diff --git a/XMonad/Actions/DynamicWorkspaceOrder.hs b/XMonad/Actions/DynamicWorkspaceOrder.hs --- a/XMonad/Actions/DynamicWorkspaceOrder.hs +++ b/XMonad/Actions/DynamicWorkspaceOrder.hs @@ -28,6 +28,8 @@ , moveToGreedy , shiftTo + , withNthWorkspace + ) where import XMonad @@ -163,3 +165,14 @@ -- given type in the given direction, using the dynamic workspace order. shiftTo :: Direction1D -> WSType -> X () shiftTo dir t = doTo dir t getSortByOrder (windows . W.shift) + +-- | Do something with the nth workspace in the dynamic order. The +-- callback is given the workspace's tag as well as the 'WindowSet' +-- of the workspace itself. +withNthWorkspace :: (String -> WindowSet -> WindowSet) -> Int -> X () +withNthWorkspace job wnum = do + sort <- getSortByOrder + ws <- gets (map W.tag . sort . W.workspaces . windowset) + case drop wnum ws of + (w:_) -> windows $ job w + [] -> return () diff --git a/XMonad/Actions/DynamicWorkspaces.hs b/XMonad/Actions/DynamicWorkspaces.hs --- a/XMonad/Actions/DynamicWorkspaces.hs +++ b/XMonad/Actions/DynamicWorkspaces.hs @@ -23,6 +23,7 @@ addHiddenWorkspace, withWorkspace, selectWorkspace, renameWorkspace, + renameWorkspaceByName, toNthWorkspace, withNthWorkspace ) where @@ -73,11 +74,13 @@ mkXPrompt (Wor "") c (mkCompl ts) job' renameWorkspace :: XPConfig -> X () -renameWorkspace conf = workspacePrompt conf $ \w -> - windows $ \s -> let sett wk = wk { tag = w } - setscr scr = scr { workspace = sett $ workspace scr } - sets q = q { current = setscr $ current q } - in sets $ removeWorkspace' w s +renameWorkspace conf = workspacePrompt conf renameWorkspaceByName + +renameWorkspaceByName :: String -> X () +renameWorkspaceByName w = windows $ \s -> let sett wk = wk { tag = w } + setscr scr = scr { workspace = sett $ workspace scr } + sets q = q { current = setscr $ current q } + in sets $ removeWorkspace' w s toNthWorkspace :: (String -> X ()) -> Int -> X () toNthWorkspace job wnum = do sort <- getSortByIndex diff --git a/XMonad/Actions/FindEmptyWorkspace.hs b/XMonad/Actions/FindEmptyWorkspace.hs --- a/XMonad/Actions/FindEmptyWorkspace.hs +++ b/XMonad/Actions/FindEmptyWorkspace.hs @@ -15,7 +15,7 @@ module XMonad.Actions.FindEmptyWorkspace ( -- * Usage -- $usage - viewEmptyWorkspace, tagToEmptyWorkspace + viewEmptyWorkspace, tagToEmptyWorkspace, sendToEmptyWorkspace ) where import Data.List @@ -65,3 +65,8 @@ -- all workspaces are in use. tagToEmptyWorkspace :: X () tagToEmptyWorkspace = withEmptyWorkspace $ \w -> windows $ view w . shift w + +-- | Send current window to an empty workspace. Do nothing if +-- all workspaces are in use. +sendToEmptyWorkspace :: X () +sendToEmptyWorkspace = withEmptyWorkspace $ \w -> windows $ shift w diff --git a/XMonad/Actions/GridSelect.hs b/XMonad/Actions/GridSelect.hs --- a/XMonad/Actions/GridSelect.hs +++ b/XMonad/Actions/GridSelect.hs @@ -74,6 +74,7 @@ import Data.Maybe import Data.Bits import Data.Char +import Data.Ord (comparing) import Control.Applicative import Control.Monad.State import Control.Arrow @@ -234,12 +235,39 @@ } td_elementmap :: TwoDState a -> [(TwoDPosition,(String,a))] -td_elementmap s = - let positions = td_availSlots s - elements = L.filter (((td_searchString s) `isSubstringOf`) . fst) (td_elements s) - in zipWith (,) positions elements - where sub `isSubstringOf` string = or [ (upper sub) `isPrefixOf` t | t <- tails (upper string) ] - upper = map toUpper +td_elementmap s = zipWith (,) positions sortedElements + where + TwoDState {td_availSlots = positions, + td_searchString = searchString} = s + -- Filter out any elements that don't contain the searchString (case insensitive) + filteredElements = L.filter ((searchString `isInfixOfI`) . fst) (td_elements s) + -- Sorts the elementmap + sortedElements = orderElementmap searchString filteredElements + -- Case Insensitive version of isInfixOf + needle `isInfixOfI` haystack = (upper needle) `isInfixOf` (upper haystack) + upper = map toUpper + + +-- | We enforce an ordering such that we will always get the same result. If the +-- elements position changes from call to call of gridselect, then the shown +-- positions will also change when you search for the same string. This is +-- especially the case when using gridselect for showing and switching between +-- workspaces, as workspaces are usually shown in order of last visited. The +-- chosen ordering is "how deep in the haystack the needle is" (number of +-- characters from the beginning of the string and the needle). +orderElementmap :: String -> [(String,a)] -> [(String,a)] +orderElementmap searchString elements = if not $ null searchString then sortedElements else elements + where + upper = map toUpper + -- Calculates a (score, element) tuple where the score is the depth of the (case insensitive) needle. + calcScore element = ( length $ takeWhile (not . isPrefixOf (upper searchString)) (tails . upper . fst $ element) + , element) + -- Use the score and then the string as the parameters for comparing, making + -- it consistent even when two strings that score the same, as it will then be + -- sorted by the strings, making it consistent. + compareScore = comparing (\(score, (str,_)) -> (score, str)) + sortedElements = map snd . sortBy compareScore $ map calcScore elements + newtype TwoD a b = TwoD { unTwoD :: StateT (TwoDState a) X b } deriving (Monad,Functor,MonadState (TwoDState a)) diff --git a/XMonad/Actions/GroupNavigation.hs b/XMonad/Actions/GroupNavigation.hs --- a/XMonad/Actions/GroupNavigation.hs +++ b/XMonad/Actions/GroupNavigation.hs @@ -20,7 +20,7 @@ -- ---------------------------------------------------------------------- -module XMonad.Actions.GroupNavigation ( -- * Usage +module XMonad.Actions.GroupNavigation ( -- * Usage -- $usage Direction (..) , nextMatch @@ -46,7 +46,7 @@ Import the module into your @~\/.xmonad\/xmonad.hs@: -> import XMonad.Actions,GroupNavigation +> import XMonad.Actions.GroupNavigation To support cycling forward and backward through all xterm windows, add something like this to your keybindings: @@ -110,13 +110,13 @@ -- | Focuses the next window that matches the given boolean query. If -- there is no such window, perform the given action instead. nextMatchOrDo :: Direction -> Query Bool -> X () -> X () -nextMatchOrDo dir qry act = orderedWindowList dir +nextMatchOrDo dir qry act = orderedWindowList dir >>= focusNextMatchOrDo qry act -- Produces the action to perform depending on whether there's a -- matching window focusNextMatchOrDo :: Query Bool -> X () -> Seq Window -> X () -focusNextMatchOrDo qry act = findM (runQuery qry) +focusNextMatchOrDo qry act = findM (runQuery qry) >=> maybe act (windows . SS.focusWindow) -- Returns the list of windows ordered by workspace as specified in @@ -126,7 +126,7 @@ orderedWindowList dir = withWindowSet $ \ss -> do wsids <- asks (Seq.fromList . workspaces . config) let wspcs = orderedWorkspaceList ss wsids - wins = dirfun dir + wins = dirfun dir $ Fold.foldl' (><) Seq.empty $ fmap (Seq.fromList . SS.integrate' . SS.stack) wspcs cur = SS.peek ss @@ -148,7 +148,7 @@ --- History navigation, requires a layout modifier ------------------- -- The state extension that holds the history information -data HistoryDB = HistoryDB (Maybe Window) -- currently focused window +data HistoryDB = HistoryDB (Maybe Window) -- currently focused window (Seq Window) -- previously focused windows deriving (Read, Show, Typeable) @@ -182,12 +182,12 @@ flt p = Fold.foldl (\xs x -> if p x then xs |> x else xs) Seq.empty brkl :: (a -> Bool) -> Seq a -> (Seq a, Seq a) -brkl p xs = flip Seq.splitAt xs - $ snd +brkl p xs = flip Seq.splitAt xs + $ snd $ Fold.foldr (\x (i, j) -> if p x then (i-1, i-1) else (i-1, j)) (l, l) xs where l = Seq.length xs - + --- Some sequence helpers -------------------------------------------- -- Rotates the sequence by one position diff --git a/XMonad/Actions/KeyRemap.hs b/XMonad/Actions/KeyRemap.hs --- a/XMonad/Actions/KeyRemap.hs +++ b/XMonad/Actions/KeyRemap.hs @@ -9,7 +9,7 @@ -- Stability : unstable -- Portability : unportable -- --- Remap Keybinding on the fly, e.g having Dvorak char, but everything with Control/Shift +-- Remap Keybinding on the fly, e.g having Dvorak char, but everything with Control/Shift -- is left us Layout -- ----------------------------------------------------------------------------- @@ -42,7 +42,7 @@ -- $usage -- Provides the possibility to remap parts of the keymap to generate different keys -- --- * E.g You want to type Programmers Dvorak, but your keybindings should be the normal us layout +-- * E.g You want to type Programmers Dvorak, but your keybindings should be the normal us layout -- after all -- -- First, you must add all possible keybindings for all layout you want to use: diff --git a/XMonad/Actions/Launcher.hs b/XMonad/Actions/Launcher.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/Launcher.hs @@ -0,0 +1,123 @@ +{- | +Module : XMonad.Actions.Launcher +Copyright : (C) 2012 Carlos López-Camey +License : None; public domain + +Maintainer : +Stability : unstable + +A set of prompts for XMonad +-} + +module XMonad.Actions.Launcher( + -- * Description and use + -- $description + defaultLauncherModes + , ExtensionActions + , LauncherConfig(..) + , launcherPrompt +) where + +import Data.List (find, findIndex, isPrefixOf, tails) +import qualified Data.Map as M +import Data.Maybe (isJust) +import XMonad hiding (config) +import XMonad.Prompt +import XMonad.Util.Run + +{- $description + This module exemplifies usage of `XMonad.Prompt.mkXPromptWithModes`. It includes two modes: + + * Hoogle mode: Search for functions using hoogle, choosing a function leads you to documentation in Haddock. + + * Calc: Uses the program calc to do calculations. + + To test it, modify your local .xmonad: + + > import XMonad.Prompt(defaultXPConfig) + > import XMonad.Actions.Launcher + + > ((modm .|. controlMask, xK_l), launcherPrompt defaultXPConfig $ defaultLauncherModes launcherConfig) + + A LauncherConfig contains settings for the default modes, modify them accordingly. + + > launcherConfig = LauncherConfig { pathToHoogle = "/home/YOU/.cabal/bin/hoogle" , browser = "firefox"} + +Restart xmonad. Press Ctrl + Your_Modkey + L and the first prompt should pop up. + + If you used 'defaultXPConfig', you can change mode with 'xK_grave'. If you are using your own 'XPConfig', define the value for 'changeModeKey'. + -} + +data HoogleMode = HMode FilePath String --path to hoogle and browser +data CalculatorMode = CalcMode + +data LauncherConfig = LauncherConfig { + browser :: String + , pathToHoogle :: String +} + +type ExtensionActions = M.Map String (String -> X()) + +-- | Uses the command `calc` to compute arithmetic expressions +instance XPrompt CalculatorMode where + showXPrompt CalcMode = "calc %s> " + commandToComplete CalcMode = id --send the whole string to `calc` + completionFunction CalcMode = \s -> if (length s == 0) then return [] else do + fmap lines $ runProcessWithInput "calc" [s] "" + modeAction CalcMode _ _ = return () -- do nothing; this might copy the result to the clipboard + +-- | Uses the program `hoogle` to search for functions +instance XPrompt HoogleMode where + showXPrompt _ = "hoogle %s> " + commandToComplete _ = id + completionFunction (HMode pathToHoogleBin' _) = \s -> completionFunctionWith pathToHoogleBin' ["--count","8",s] + -- This action calls hoogle again to find the URL corresponding to the autocompleted item + modeAction (HMode pathToHoogleBin'' browser') query result = do + completionsWithLink <- liftIO $ completionFunctionWith pathToHoogleBin'' ["--count","5","--link",query] + let link = do + s <- find (isJust . \complStr -> findSeqIndex complStr result) completionsWithLink + i <- findSeqIndex s "http://" + return $ drop i s + case link of + Just l -> spawn $ browser' ++ " " ++ l + _ -> return () + where + -- | Receives a sublist and a list. It returns the index where the sublist appears in the list. + findSeqIndex :: (Eq a) => [a] -> [a] -> Maybe Int + findSeqIndex xs xss = findIndex (isPrefixOf xss) $ tails xs + +-- | Creates an autocompletion function for a programm given the program's name and a list of args to send to the command. +completionFunctionWith :: String -> [String] -> IO [String] +completionFunctionWith cmd args = do fmap lines $ runProcessWithInput cmd args "" + +-- | Creates a prompt with the given modes +launcherPrompt :: XPConfig -> [XPMode] -> X() +launcherPrompt config modes = mkXPromptWithModes modes config + +-- | Create a list of modes based on : +-- a list of extensions mapped to actions +-- the path to hoogle +defaultLauncherModes :: LauncherConfig -> [XPMode] +defaultLauncherModes cnf = let + ph = pathToHoogle cnf + in [ hoogleMode ph $ browser cnf + , calcMode] + +hoogleMode :: FilePath -> String -> XPMode +hoogleMode pathToHoogleBin browser' = XPT $ HMode pathToHoogleBin browser' +calcMode :: XPMode +calcMode = XPT CalcMode + +{- + + -- ideas for XMonad.Prompt running on mode XPMultipleModes + * Switch to mode by name of the prompt, 1. ':' at an empty(?) buffer, 2. autocomplete name in buffer should happen, 3. switch to mode with enter (cancel switch with C-g) + + * Support for actions of type String -> X a + + -- ideas for this module + + * Hoogle mode: add a setting in the action to either go to documentation or to the source code (needs hoogle change?) + + * Hoogle mode: add setting to query hoogle at haskell.org instead (with &mode=json) +-} diff --git a/XMonad/Actions/Navigation2D.hs b/XMonad/Actions/Navigation2D.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/Navigation2D.hs @@ -0,0 +1,778 @@ +{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, PatternGuards, RankNTypes, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Navigation2D +-- Copyright : (c) 2011 Norbert Zeh +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Norbert Zeh +-- Stability : unstable +-- Portability : unportable +-- +-- Navigation2D is an xmonad extension that allows easy directional +-- navigation of windows and screens (in a multi-monitor setup). +----------------------------------------------------------------------------- + +module XMonad.Actions.Navigation2D ( -- * Usage + -- $usage + + -- * Finer points + -- $finer_points + + -- * Alternative directional navigation modules + -- $alternatives + + -- * Incompatibilities + -- $incompatibilities + + -- * Detailed technical discussion + -- $technical + + -- * Exported functions and types + -- #Exports# + + withNavigation2DConfig + , Navigation2DConfig(..) + , defaultNavigation2DConfig + , Navigation2D + , lineNavigation + , centerNavigation + , fullScreenRect + , singleWindowRect + , switchLayer + , windowGo + , windowSwap + , windowToScreen + , screenGo + , screenSwap + , Direction2D(..) + ) where + +import Control.Applicative +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import XMonad hiding (Screen) +import qualified XMonad.StackSet as W +import qualified XMonad.Util.ExtensibleState as XS +import XMonad.Util.Types + +-- $usage +-- #Usage# +-- Navigation2D provides directional navigation (go left, right, up, down) for +-- windows and screens. It treats floating and tiled windows as two separate +-- layers and provides mechanisms to navigate within each layer and to switch +-- between layers. Navigation2D provides two different navigation strategies +-- (see <#Technical_Discussion> for details): /Line navigation/ feels rather +-- natural but may make it impossible to navigate to a given window from the +-- current window, particularly in the floating layer. /Center navigation/ +-- feels less natural in certain situations but ensures that all windows can be +-- reached without the need to involve the mouse. Navigation2D allows different +-- navigation strategies to be used in the two layers and allows customization +-- of the navigation strategy for the tiled layer based on the layout currently +-- in effect. +-- +-- You can use this module with (a subset of) the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Actions.Navigation2D +-- +-- Then edit your keybindings: +-- +-- > -- Switch between layers +-- > , ((modm, xK_space), switchLayers) +-- > +-- > -- Directional navigation of windows +-- > , ((modm, xK_Right), windowGo R False) +-- > , ((modm, xK_Left ), windowGo L False) +-- > , ((modm, xK_Up ), windowGo U False) +-- > , ((modm, xK_Down ), windowGo D False) +-- > +-- > -- Swap adjacent windows +-- > , ((modm .|. controlMask, xK_Right), windowSwap R False) +-- > , ((modm .|. controlMask, xK_Left ), windowSwap L False) +-- > , ((modm .|. controlMask, xK_Up ), windowSwap U False) +-- > , ((modm .|. controlMask, xK_Down ), windowSwap D False) +-- > +-- > -- Directional navigation of screens +-- > , ((modm, xK_r ), screenGo R False) +-- > , ((modm, xK_l ), screenGo L False) +-- > , ((modm, xK_u ), screenGo U False) +-- > , ((modm, xK_d ), screenGo D False) +-- > +-- > -- Swap workspaces on adjacent screens +-- > , ((modm .|. controlMask, xK_r ), screenSwap R False) +-- > , ((modm .|. controlMask, xK_l ), screenSwap L False) +-- > , ((modm .|. controlMask, xK_u ), screenSwap U False) +-- > , ((modm .|. controlMask, xK_d ), screenSwap D False) +-- > +-- > -- Send window to adjacent screen +-- > , ((modm .|. mod1Mask, xK_r ), windowToScreen R False) +-- > , ((modm .|. mod1Mask, xK_l ), windowToScreen L False) +-- > , ((modm .|. mod1Mask, xK_u ), windowToScreen U False) +-- > , ((modm .|. mod1Mask, xK_d ), windowToScreen D False) +-- +-- and add the configuration of the module to your main function: +-- +-- > main = xmonad $ withNavigation2DConfig defaultNavigation2DConfig +-- > $ defaultConfig +-- +-- For detailed instruction on editing the key binding see: +-- +-- "XMonad.Doc.Extending#Editing_key_bindings". + +-- $finer_points +-- #Finer_Points# +-- The above should get you started. Here are some finer points: +-- +-- Navigation2D has the ability to wrap around at screen edges. For example, if +-- you navigated to the rightmost window on the rightmost screen and you +-- continued to go right, this would get you to the leftmost window on the +-- leftmost screen. This feature may be useful for switching between screens +-- that are far apart but may be confusing at least to novice users. Therefore, +-- it is disabled in the above example (e.g., navigation beyond the rightmost +-- window on the rightmost screen is not possible and trying to do so will +-- simply not do anything.) If you want this feature, change all the 'False' +-- values in the above example to 'True'. You could also decide you want +-- wrapping only for a subset of the operations and no wrapping for others. +-- +-- By default, all layouts use the 'defaultTiledNavigation' strategy specified +-- in the 'Navigation2DConfig' (by default, line navigation is used). To +-- override this behaviour for some layouts, add a pair (\"layout name\", +-- navigation strategy) to the 'layoutNavigation' list in the +-- 'Navigation2DConfig', where \"layout name\" is the string reported by the +-- layout's description method (normally what is shown as the layout name in +-- your status bar). For example, all navigation strategies normally allow only +-- navigation between mapped windows. The first step to overcome this, for +-- example, for the Full layout, is to switch to center navigation for the Full +-- layout: +-- +-- > myNavigation2DConfig = defaultNavigation2DConfig { layoutNavigation = [("Full", centerNavigation)] } +-- > +-- > main = xmonad $ withNavigation2DConfig myNavigation2DConfig +-- > $ defaultConfig +-- +-- The navigation between windows is based on their screen rectangles, which are +-- available /and meaningful/ only for mapped windows. Thus, as already said, +-- the default is to allow navigation only between mapped windows. However, +-- there are layouts that do not keep all windows mapped. One example is the +-- Full layout, which unmaps all windows except the one that has the focus, +-- thereby preventing navigation to any other window in the layout. To make +-- navigation to unmapped windows possible, unmapped windows need to be assigned +-- rectangles to pretend they are mapped, and a natural way to do this for the +-- Full layout is to pretend all windows occupy the full screen and are stacked +-- on top of each other so that only the frontmost one is visible. This can be +-- done as follows: +-- +-- > myNavigation2DConfig = defaultNavigation2DConfig { layoutNavigation = [("Full", centerNavigation)] +-- > , unmappedWindowRect = [("Full", singleWindowRect)] +-- > } +-- > +-- > main = xmonad $ withNavigation2DConfig myNavigation2DConfig +-- > $ defaultConfig +-- +-- With this setup, Left/Up navigation behaves like standard +-- 'XMonad.StackSet.focusUp' and Right/Down navigation behaves like +-- 'XMonad.StackSet.focusDown', thus allowing navigation between windows in the +-- layout. +-- +-- In general, each entry in the 'unmappedWindowRect' association list is a pair +-- (\"layout description\", function), where the function computes a rectangle +-- for each unmapped window from the screen it is on and the window ID. +-- Currently, Navigation2D provides only two functions of this type: +-- 'singleWindowRect' and 'fullScreenRect'. +-- +-- With per-layout navigation strategies, if different layouts are in effect on +-- different screens in a multi-monitor setup, and different navigation +-- strategies are defined for these active layouts, the most general of these +-- navigation strategies is used across all screens (because Navigation2D does +-- not distinguish between windows on different workspaces), where center +-- navigation is more general than line navigation, as discussed formally under +-- <#Technical_Discussion>. + +-- $alternatives +-- #Alternatives# +-- +-- There exist two alternatives to Navigation2D: +-- "XMonad.Actions.WindowNavigation" and "XMonad.Layout.WindowNavigation". +-- X.L.WindowNavigation has the advantage of colouring windows to indicate the +-- window that would receive the focus in each navigation direction, but it does +-- not support navigation across multiple monitors, does not support directional +-- navigation of floating windows, and has a very unintuitive definition of +-- which window receives the focus next in each direction. X.A.WindowNavigation +-- does support navigation across multiple monitors but does not provide window +-- colouring while retaining the unintuitive navigational semantics of +-- X.L.WindowNavigation. This makes it very difficult to predict which window +-- receives the focus next. Neither X.A.WindowNavigation nor +-- X.L.WindowNavigation supports directional navigation of screens. + +-- $technical +-- #Technical_Discussion# +-- An in-depth discussion of the navigational strategies implemented in +-- Navigation2D, including formal proofs of their properties, can be found +-- at . + +-- $incompatibilities +-- #Incompatibilities# +-- Currently Navigation2D is known not to play nicely with tabbed layouts, but +-- it should work well with any other tiled layout. My hope is to address the +-- incompatibility with tabbed layouts in a future version. The navigation to +-- unmapped windows, for example in a Full layout, by assigning rectangles to +-- unmapped windows is more a workaround than a clean solution. Figuring out +-- how to deal with tabbed layouts may also lead to a more general and cleaner +-- solution to query the layout for a window's rectangle that may make this +-- workaround unnecessary. At that point, the 'unmappedWindowRect' field of the +-- 'Navigation2DConfig' will disappear. + +-- | A rectangle paired with an object +type Rect a = (a, Rectangle) + +-- | A shorthand for window-rectangle pairs. Reduces typing. +type WinRect = Rect Window + +-- | A shorthand for workspace-rectangle pairs. Reduces typing. +type WSRect = Rect WorkspaceId + +---------------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------------- +-- -- +-- PUBLIC INTERFACE -- +-- -- +---------------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------------- + +-- | Encapsulates the navigation strategy +data Navigation2D = N Generality (forall a . Eq a => Direction2D -> Rect a -> [Rect a] -> Maybe a) + +runNav :: forall a . Eq a => Navigation2D -> (Direction2D -> Rect a -> [Rect a] -> Maybe a) +runNav (N _ nav) = nav + +-- | Score that indicates how general a navigation strategy is +type Generality = Int + +instance Eq Navigation2D where + (N x _) == (N y _) = x == y + +instance Ord Navigation2D where + (N x _) <= (N y _) = x <= y + +-- | Line navigation. To illustrate this navigation strategy, consider +-- navigating to the left from the current window. In this case, we draw a +-- horizontal line through the center of the current window and consider all +-- windows that intersect this horizontal line and whose right boundaries are to +-- the left of the left boundary of the current window. From among these +-- windows, we choose the one with the rightmost right boundary. +lineNavigation :: Navigation2D +lineNavigation = N 1 doLineNavigation + +-- | Center navigation. Again, consider navigating to the left. Then we +-- consider the cone bounded by the two rays shot at 45-degree angles in +-- north-west and south-west direction from the center of the current window. A +-- window is a candidate to receive the focus if its center lies in this cone. +-- We choose the window whose center has minimum L1-distance from the current +-- window center. The tie breaking strategy for windows with the same distance +-- is a bit complicated (see <#Technical_Discussion>) but ensures that all +-- windows can be reached and that windows with the same center are traversed in +-- their order in the window stack, that is, in the order +-- 'XMonad.StackSet.focusUp' and 'XMonad.StackSet.focusDown' would traverse +-- them. +centerNavigation :: Navigation2D +centerNavigation = N 2 doCenterNavigation + +-- | Stores the configuration of directional navigation +data Navigation2DConfig = Navigation2DConfig + { defaultTiledNavigation :: Navigation2D -- ^ default navigation strategy for the tiled layer + , floatNavigation :: Navigation2D -- ^ navigation strategy for the float layer + , screenNavigation :: Navigation2D -- ^ strategy for navigation between screens + , layoutNavigation :: [(String, Navigation2D)] -- ^ association list of customized navigation strategies + -- for different layouts in the tiled layer. Each pair + -- is of the form (\"layout description\", navigation + -- strategy). If there is no pair in this list whose first + -- component is the name of the current layout, the + -- 'defaultTiledNavigation' strategy is used. + , unmappedWindowRect :: [(String, Screen -> Window -> X (Maybe Rectangle))] + -- ^ list associating functions to calculate rectangles + -- for unmapped windows with layouts to which they are + -- to be applied. Each pair in this list is of + -- the form (\"layout description\", function), where the + -- function calculates a rectangle for a given unmapped + -- window from the screen it is on and its window ID. + -- See <#Finer_Points> for how to use this. + } deriving Typeable + +-- | Shorthand for the tedious screen type +type Screen = W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail + +-- So we can store the configuration in extensible state +instance ExtensionClass Navigation2DConfig where + initialValue = defaultNavigation2DConfig + +-- | Modifies the xmonad configuration to store the Navigation2D configuration +withNavigation2DConfig :: Navigation2DConfig -> XConfig a -> XConfig a +withNavigation2DConfig conf2d xconf = xconf { startupHook = startupHook xconf + >> XS.put conf2d + } + +-- | Default navigation configuration. It uses line navigation for the tiled +-- layer and for navigation between screens, and center navigation for the float +-- layer. No custom navigation strategies or rectangles for unmapped windows are +-- defined for individual layouts. +defaultNavigation2DConfig :: Navigation2DConfig +defaultNavigation2DConfig = Navigation2DConfig { defaultTiledNavigation = lineNavigation + , floatNavigation = centerNavigation + , screenNavigation = lineNavigation + , layoutNavigation = [] + , unmappedWindowRect = [] + } + +-- | Switches focus to the closest window in the other layer (floating if the +-- current window is tiled, tiled if the current window is floating). Closest +-- means that the L1-distance between the centers of the windows is minimized. +switchLayer :: X () +switchLayer = actOnLayer otherLayer + ( \ _ cur wins -> windows + $ doFocusClosestWindow cur wins + ) + ( \ _ cur wins -> windows + $ doFocusClosestWindow cur wins + ) + ( \ _ _ _ -> return () ) + False + +-- | Moves the focus to the next window in the given direction and in the same +-- layer as the current window. The second argument indicates whether +-- navigation should wrap around (e.g., from the left edge of the leftmost +-- screen to the right edge of the rightmost screen). +windowGo :: Direction2D -> Bool -> X () +windowGo dir wrap = actOnLayer thisLayer + ( \ conf cur wins -> windows + $ doTiledNavigation conf dir W.focusWindow cur wins + ) + ( \ conf cur wins -> windows + $ doFloatNavigation conf dir W.focusWindow cur wins + ) + ( \ conf cur wspcs -> windows + $ doScreenNavigation conf dir W.view cur wspcs + ) + wrap + +-- | Swaps the current window with the next window in the given direction and in +-- the same layer as the current window. (In the floating layer, all that +-- changes for the two windows is their stacking order if they're on the same +-- screen. If they're on different screens, each window is moved to the other +-- window's screen but retains its position and size relative to the screen.) +-- The second argument indicates wrapping (see 'windowGo'). +windowSwap :: Direction2D -> Bool -> X () +windowSwap dir wrap = actOnLayer thisLayer + ( \ conf cur wins -> windows + $ doTiledNavigation conf dir swap cur wins + ) + ( \ conf cur wins -> windows + $ doFloatNavigation conf dir swap cur wins + ) + ( \ _ _ _ -> return () ) + wrap + +-- | Moves the current window to the next screen in the given direction. The +-- second argument indicates wrapping (see 'windowGo'). +windowToScreen :: Direction2D -> Bool -> X () +windowToScreen dir wrap = actOnScreens ( \ conf cur wspcs -> windows + $ doScreenNavigation conf dir W.shift cur wspcs + ) + wrap + +-- | Moves the focus to the next screen in the given direction. The second +-- argument indicates wrapping (see 'windowGo'). +screenGo :: Direction2D -> Bool -> X () +screenGo dir wrap = actOnScreens ( \ conf cur wspcs -> windows + $ doScreenNavigation conf dir W.view cur wspcs + ) + wrap + +-- | Swaps the workspace on the current screen with the workspace on the screen +-- in the given direction. The second argument indicates wrapping (see +-- 'windowGo'). +screenSwap :: Direction2D -> Bool -> X () +screenSwap dir wrap = actOnScreens ( \ conf cur wspcs -> windows + $ doScreenNavigation conf dir W.greedyView cur wspcs + ) + wrap + +-- | Maps each window to a fullscreen rect. This may not be the same rectangle the +-- window maps to under the Full layout or a similar layout if the layout +-- respects statusbar struts. In such cases, it may be better to use +-- 'singleWindowRect'. +fullScreenRect :: Screen -> Window -> X (Maybe Rectangle) +fullScreenRect scr _ = return (Just . screenRect . W.screenDetail $ scr) + +-- | Maps each window to the rectangle it would receive if it was the only +-- window in the layout. Useful, for example, for determining the default +-- rectangle for unmapped windows in a Full layout that respects statusbar +-- struts. +singleWindowRect :: Screen -> Window -> X (Maybe Rectangle) +singleWindowRect scr win = listToMaybe + . map snd + . fst + <$> runLayout ((W.workspace scr) { W.stack = W.differentiate [win] }) + (screenRect . W.screenDetail $ scr) + +---------------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------------- +-- -- +-- PRIVATE X ACTIONS -- +-- -- +---------------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------------- + +-- | Acts on the appropriate layer using the given action functions +actOnLayer :: ([WinRect] -> [WinRect] -> [WinRect]) -- ^ Chooses which layer to operate on, relative + -- to the current window (same or other layer) + -> (Navigation2DConfig -> WinRect -> [WinRect] -> X ()) -- ^ The action for the tiled layer + -> (Navigation2DConfig -> WinRect -> [WinRect] -> X ()) -- ^ The action for the float layer + -> (Navigation2DConfig -> WSRect -> [WSRect] -> X ()) -- ^ The action if the current workspace is empty + -> Bool -- ^ Should navigation wrap around screen edges? + -> X () +actOnLayer choice tiledact floatact wsact wrap = withWindowSet $ \winset -> do + conf <- XS.get + (floating, tiled) <- navigableWindows conf wrap winset + let cur = W.peek winset + case cur of + Nothing -> actOnScreens wsact wrap + Just w | Just rect <- L.lookup w tiled -> tiledact conf (w, rect) (choice tiled floating) + | Just rect <- L.lookup w floating -> floatact conf (w, rect) (choice floating tiled) + | otherwise -> return () + +-- | Returns the list of windows on the currently visible workspaces +navigableWindows :: Navigation2DConfig -> Bool -> WindowSet -> X ([WinRect], [WinRect]) +navigableWindows conf wrap winset = L.partition (\(win, _) -> M.member win (W.floating winset)) + . addWrapping winset wrap + . catMaybes + . concat + <$> + ( mapM ( \scr -> mapM (maybeWinRect scr) + $ W.integrate' + $ W.stack + $ W.workspace scr + ) + . sortedScreens + ) winset + where + maybeWinRect scr win = do + winrect <- windowRect win + rect <- case winrect of + Just _ -> return winrect + Nothing -> maybe (return Nothing) + (\f -> f scr win) + (L.lookup (description . W.layout . W.workspace $ scr) (unmappedWindowRect conf)) + return ((,) win <$> rect) + +-- | Returns the current rectangle of the given window, Nothing if the window isn't mapped +windowRect :: Window -> X (Maybe Rectangle) +windowRect win = withDisplay $ \dpy -> do + mp <- isMapped win + if mp then do (_, x, y, w, h, bw, _) <- io $ getGeometry dpy win + return $ Just $ Rectangle x y (w + 2 * bw) (h + 2 * bw) + `catchX` return Nothing + else return Nothing + +-- | Acts on the screens using the given action function +actOnScreens :: (Navigation2DConfig -> WSRect -> [WSRect] -> X ()) + -> Bool -- ^ Should wrapping be used? + -> X () +actOnScreens act wrap = withWindowSet $ \winset -> do + conf <- XS.get + let wsrects = visibleWorkspaces winset wrap + cur = W.tag . W.workspace . W.current $ winset + rect = fromJust $ L.lookup cur wsrects + act conf (cur, rect) wsrects + +-- | Determines whether a given window is mapped +isMapped :: Window -> X Bool +isMapped win = withDisplay + $ \dpy -> io + $ (waIsUnmapped /=) + . wa_map_state + <$> getWindowAttributes dpy win + +---------------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------------- +-- -- +-- PRIVATE PURE FUNCTIONS -- +-- -- +---------------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------------- + +-- | Finds the window closest to the given window and focuses it. Ties are +-- broken by choosing the first window in the window stack among the tied +-- windows. (The stack order is the one produced by integrate'ing each visible +-- workspace's window stack and concatenating these lists for all visible +-- workspaces.) +doFocusClosestWindow :: WinRect + -> [WinRect] + -> (WindowSet -> WindowSet) +doFocusClosestWindow (cur, rect) winrects + | null winctrs = id + | otherwise = W.focusWindow . fst $ L.foldl1' closer winctrs + where + ctr = centerOf rect + winctrs = filter ((cur /=) . fst) + $ map (\(w, r) -> (w, centerOf r)) winrects + closer wc1@(_, c1) wc2@(_, c2) | lDist ctr c1 > lDist ctr c2 = wc2 + | otherwise = wc1 + +-- | Implements navigation for the tiled layer +doTiledNavigation :: Navigation2DConfig + -> Direction2D + -> (Window -> WindowSet -> WindowSet) + -> WinRect + -> [WinRect] + -> (WindowSet -> WindowSet) +doTiledNavigation conf dir act cur winrects winset + | Just win <- runNav nav dir cur winrects = act win winset + | otherwise = winset + where + layouts = map (description . W.layout . W.workspace) + $ W.screens winset + nav = maximum + $ map ( fromMaybe (defaultTiledNavigation conf) + . flip L.lookup (layoutNavigation conf) + ) + $ layouts + +-- | Implements navigation for the float layer +doFloatNavigation :: Navigation2DConfig + -> Direction2D + -> (Window -> WindowSet -> WindowSet) + -> WinRect + -> [WinRect] + -> (WindowSet -> WindowSet) +doFloatNavigation conf dir act cur winrects + | Just win <- runNav nav dir cur winrects = act win + | otherwise = id + where + nav = floatNavigation conf + +-- | Implements navigation between screens +doScreenNavigation :: Navigation2DConfig + -> Direction2D + -> (WorkspaceId -> WindowSet -> WindowSet) + -> WSRect + -> [WSRect] + -> (WindowSet -> WindowSet) +doScreenNavigation conf dir act cur wsrects + | Just ws <- runNav nav dir cur wsrects = act ws + | otherwise = id + where + nav = screenNavigation conf + +-- | Implements line navigation. For layouts without overlapping windows, there +-- is no need to break ties between equidistant windows. When windows do +-- overlap, even the best tie breaking rule cannot make line navigation feel +-- natural. Thus, we fairly arbtitrarily break ties by preferring the window +-- that comes first in the window stack. (The stack order is the one produced +-- by integrate'ing each visible workspace's window stack and concatenating +-- these lists for all visible workspaces.) +doLineNavigation :: Eq a => Direction2D -> Rect a -> [Rect a] -> Maybe a +doLineNavigation dir (cur, rect) winrects + | null winrects' = Nothing + | otherwise = Just . fst $ L.foldl1' closer winrects' + where + -- The current window's center + ctr@(xc, yc) = centerOf rect + + -- The list of windows that are candidates to receive focus. + winrects' = filter dirFilter + $ filter ((cur /=) . fst) + $ winrects + + -- Decides whether a given window matches the criteria to be a candidate to + -- receive the focus. + dirFilter (_, r) = (dir == L && leftOf r rect && intersectsY yc r) + || (dir == R && leftOf rect r && intersectsY yc r) + || (dir == U && above r rect && intersectsX xc r) + || (dir == D && above rect r && intersectsX xc r) + + -- Decide whether r1 is left of/above r2. + leftOf r1 r2 = rect_x r1 + fi (rect_width r1) <= rect_x r2 + above r1 r2 = rect_y r1 + fi (rect_height r1) <= rect_y r2 + + -- Check whether r's x-/y-range contains the given x-/y-coordinate. + intersectsX x r = rect_x r <= x && rect_x r + fi (rect_width r) >= x + intersectsY y r = rect_y r <= y && rect_y r + fi (rect_height r) >= y + + -- Decides whether r1 is closer to the current window's center than r2 + closer wr1@(_, r1) wr2@(_, r2) | dist ctr r1 > dist ctr r2 = wr2 + | otherwise = wr1 + + -- Returns the distance of r from the point (x, y) + dist (x, y) r | dir == L = x - rect_x r - fi (rect_width r) + | dir == R = rect_x r - x + | dir == U = y - rect_y r - fi (rect_height r) + | otherwise = rect_y r - y + +-- | Implements center navigation +doCenterNavigation :: Eq a => Direction2D -> Rect a -> [Rect a] -> Maybe a +doCenterNavigation dir (cur, rect) winrects + | ((w, _):_) <- onCtr' = Just w + | otherwise = closestOffCtr + where + -- The center of the current window + (xc, yc) = centerOf rect + + -- All the windows with their center points relative to the current + -- center rotated so the right cone becomes the relevant cone. + -- The windows are ordered in the order they should be preferred + -- when they are otherwise tied. + winctrs = map (\(w, r) -> (w, dirTransform . centerOf $ r)) + $ stackTransform + $ winrects + + -- Give preference to windows later in the stack for going left or up and to + -- windows earlier in the stack for going right or down. (The stack order + -- is the one produced by integrate'ing each visible workspace's window + -- stack and concatenating these lists for all visible workspaces.) + stackTransform | dir == L || dir == U = reverse + | otherwise = id + + -- Transform a point into a difference to the current window center and + -- rotate it so that the relevant cone becomes the right cone. + dirTransform (x, y) | dir == R = ( x - xc , y - yc ) + | dir == L = (-(x - xc), -(y - yc)) + | dir == D = ( y - yc , x - xc ) + | otherwise = (-(y - yc), -(x - xc)) + + -- Partition the points into points that coincide with the center + -- and points that do not. + (onCtr, offCtr) = L.partition (\(_, (x, y)) -> x == 0 && y == 0) winctrs + + -- All the points that coincide with the current center and succeed it + -- in the (appropriately ordered) window stack. + onCtr' = L.tail $ L.dropWhile ((cur /=) . fst) onCtr + -- tail should be safe here because cur should be in onCtr + + -- All the points that do not coincide with the current center and which + -- lie in the (rotated) right cone. + offCtr' = L.filter (\(_, (x, y)) -> x > 0 && y < x && y >= -x) offCtr + + -- The off-center point closest to the center and + -- closest to the bottom ray of the cone. Nothing if no off-center + -- point is in the cone + closestOffCtr = if null offCtr' then Nothing + else Just $ fst $ L.foldl1' closest offCtr' + + closest wp@(_, p@(_, yp)) wq@(_, q@(_, yq)) + | lDist (0, 0) q < lDist (0, 0) p = wq -- q is closer than p + | lDist (0, 0) p < lDist (0, 0) q = wp -- q is farther away than p + | yq < yp = wq -- q is closer to the bottom ray than p + | otherwise = wp -- q is farther away from the bottom ray than p + -- or it has the same distance but comes later + -- in the window stack + +-- | Swaps the current window with the window given as argument +swap :: Window -> WindowSet -> WindowSet +swap win winset = W.focusWindow cur + $ L.foldl' (flip W.focusWindow) newwinset newfocused + where + -- The current window + cur = fromJust $ W.peek winset + + -- All screens + scrs = W.screens winset + + -- All visible workspaces + visws = map W.workspace scrs + + -- The focused windows of the visible workspaces + focused = mapMaybe (\ws -> W.focus <$> W.stack ws) visws + + -- The window lists of the visible workspaces + wins = map (W.integrate' . W.stack) visws + + -- Update focused windows and window lists to reflect swap of windows. + newfocused = map swapWins focused + newwins = map (map swapWins) wins + + -- Replaces the current window with the argument window and vice versa. + swapWins x | x == cur = win + | x == win = cur + | otherwise = x + + -- Reconstruct the workspaces' window stacks to reflect the swap. + newvisws = zipWith (\ws wns -> ws { W.stack = W.differentiate wns }) visws newwins + newscrs = zipWith (\scr ws -> scr { W.workspace = ws }) scrs newvisws + newwinset = winset { W.current = head newscrs + , W.visible = tail newscrs + } + +-- | Calculates the center of a rectangle +centerOf :: Rectangle -> (Position, Position) +centerOf r = (rect_x r + fi (rect_width r) `div` 2, rect_y r + fi (rect_height r) `div` 2) + +-- | Shorthand for integer conversions +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +-- | Functions to choose the subset of windows to operate on +thisLayer, otherLayer :: a -> a -> a +thisLayer = curry fst +otherLayer = curry snd + +-- | Returns the list of visible workspaces and their screen rects +visibleWorkspaces :: WindowSet -> Bool -> [WSRect] +visibleWorkspaces winset wrap = addWrapping winset wrap + $ map ( \scr -> ( W.tag . W.workspace $ scr + , screenRect . W.screenDetail $ scr + ) + ) + $ sortedScreens winset + +-- | Creates five copies of each (window/workspace, rect) pair in the input: the +-- original and four offset one desktop size (desktop = collection of all +-- screens) to the left, to the right, up, and down. Wrap-around at desktop +-- edges is implemented by navigating into these displaced copies. +addWrapping :: WindowSet -- ^ The window set, used to get the desktop size + -> Bool -- ^ Should wrapping be used? Do nothing if not. + -> [Rect a] -- ^ Input set of (window/workspace, rect) pairs + -> [Rect a] +addWrapping _ False wrects = wrects +addWrapping winset True wrects = [ (w, r { rect_x = rect_x r + fi x + , rect_y = rect_y r + fi y + } + ) + | (w, r) <- wrects + , (x, y) <- [(0, 0), (-xoff, 0), (xoff, 0), (0, -yoff), (0, yoff)] + ] + where + (xoff, yoff) = wrapOffsets winset + +-- | Calculates the offsets for window/screen coordinates for the duplication +-- of windows/workspaces that implements wrap-around. +wrapOffsets :: WindowSet -> (Integer, Integer) +wrapOffsets winset = (max_x - min_x, max_y - min_y) + where + min_x = fi $ minimum $ map rect_x rects + min_y = fi $ minimum $ map rect_y rects + max_x = fi $ maximum $ map (\r -> rect_x r + (fi $ rect_width r)) rects + max_y = fi $ maximum $ map (\r -> rect_y r + (fi $ rect_height r)) rects + rects = map snd $ visibleWorkspaces winset False + + +-- | Returns the list of screens sorted primarily by their centers' +-- x-coordinates and secondarily by their y-coordinates. +sortedScreens :: WindowSet -> [Screen] +sortedScreens winset = L.sortBy cmp + $ W.screens winset + where + cmp s1 s2 | x1 < x2 = LT + | x1 > x2 = GT + | y1 < x2 = LT + | y1 > y2 = GT + | otherwise = EQ + where + (x1, y1) = centerOf (screenRect . W.screenDetail $ s1) + (x2, y2) = centerOf (screenRect . W.screenDetail $ s2) + + +-- | Calculates the L1-distance between two points. +lDist :: (Position, Position) -> (Position, Position) -> Int +lDist (x1, y1) (x2, y2) = abs (fi $ x1 - x2) + abs (fi $ y1 - y2) diff --git a/XMonad/Actions/PhysicalScreens.hs b/XMonad/Actions/PhysicalScreens.hs --- a/XMonad/Actions/PhysicalScreens.hs +++ b/XMonad/Actions/PhysicalScreens.hs @@ -41,7 +41,7 @@ Example usage in your @~\/.xmonad\/xmonad.hs@ file: -> import XMonad.Actions.PhysicalSCreens +> import XMonad.Actions.PhysicalScreens > , ((modMask, xK_a), onPrevNeighbour W.view) > , ((modMask, xK_o), onNextNeighbour W.view) @@ -112,4 +112,3 @@ -- | Apply operation on a WindowSet with the WorkspaceId of the previous screen in the physical order as parameter. onPrevNeighbour :: (WorkspaceId -> WindowSet -> WindowSet) -> X () onPrevNeighbour = neighbourWindows (-1) - diff --git a/XMonad/Actions/Plane.hs b/XMonad/Actions/Plane.hs --- a/XMonad/Actions/Plane.hs +++ b/XMonad/Actions/Plane.hs @@ -110,7 +110,7 @@ (WorkspaceId -> WindowSet -> WindowSet) -> Lines -> Limits -> Direction -> X () plane function numberLines_ limits direction = do - state <- get + st <- get xconf <- ask numberLines <- @@ -205,7 +205,7 @@ preColumns = div areas numberLines mCurrentWS :: Maybe Int - mCurrentWS = elemIndex (currentTag $ windowset state) areaNames + mCurrentWS = elemIndex (currentTag $ windowset st) areaNames areas :: Int areas = length areaNames diff --git a/XMonad/Actions/ShowText.hs b/XMonad/Actions/ShowText.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/ShowText.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.ShowText +-- Copyright : (c) Mario Pastorelli (2012) +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : pastorelli.mario@gmail.com +-- Stability : unstable +-- Portability : unportable +-- +-- ShowText displays text for sometime on the screen similar to "XMonad.Util.Dzen" +-- which offers more features (currently) +----------------------------------------------------------------------------- + +module XMonad.Actions.ShowText + ( -- * Usage + -- $usage + defaultSTConfig + , handleTimerEvent + , flashText + , ShowTextConfig(..) + ) where + +import Control.Monad (when) +import Data.Map (Map,empty,insert,lookup) +import Data.Monoid (mempty, All) +import Prelude hiding (lookup) +import XMonad +import XMonad.StackSet (current,screen) +import XMonad.Util.Font (Align(AlignCenter) + , initXMF + , releaseXMF + , textExtentsXMF + , textWidthXMF) +import XMonad.Util.Timer (startTimer) +import XMonad.Util.XUtils (createNewWindow + , deleteWindow + , fi + , showWindow + , paintAndWrite) +import qualified XMonad.Util.ExtensibleState as ES + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Actions.ShowText +-- +-- Then add the event hook handler: +-- +-- > xmonad { handleEventHook = myHandleEventHooks <+> handleTimerEvent } +-- +-- You can then use flashText in your keybindings: +-- +-- > ((modMask, xK_Right), flashText defaultSTConfig 1 "->" >> nextWS) +-- + +-- | ShowText contains the map with timers as keys and created windows as values +newtype ShowText = ShowText (Map Atom Window) + deriving (Read,Show,Typeable) + +instance ExtensionClass ShowText where + initialValue = ShowText empty + +-- | Utility to modify a ShowText +modShowText :: (Map Atom Window -> Map Atom Window) -> ShowText -> ShowText +modShowText f (ShowText m) = ShowText $ f m + +data ShowTextConfig = + STC { st_font :: String -- ^ Font name + , st_bg :: String -- ^ Background color + , st_fg :: String -- ^ Foreground color + } + +defaultSTConfig :: ShowTextConfig +defaultSTConfig = + STC { st_font = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*" + , st_bg = "black" + , st_fg = "white" + } + +-- | Handles timer events that notify when a window should be removed +handleTimerEvent :: Event -> X All +handleTimerEvent (ClientMessageEvent _ _ _ dis _ mtyp d) = do + (ShowText m) <- ES.get :: X ShowText + a <- io $ internAtom dis "XMONAD_TIMER" False + when (mtyp == a && length d >= 1) + (whenJust (lookup (fromIntegral $ d !! 0) m) deleteWindow) + mempty +handleTimerEvent _ = mempty + +-- | Shows a window in the center of the screen with the given text +flashText :: ShowTextConfig + -> Rational -- ^ number of seconds + -> String -- ^ text to display + -> X () +flashText c i s = do + f <- initXMF (st_font c) + d <- asks display + sc <- gets $ fi . screen . current . windowset + width <- textWidthXMF d f s + (as,ds) <- textExtentsXMF f s + let hight = as + ds + ht = displayHeight d sc + wh = displayWidth d sc + y = (fi ht - hight + 2) `div` 2 + x = (fi wh - width + 2) `div` 2 + w <- createNewWindow (Rectangle (fi x) (fi y) (fi width) (fi hight)) + Nothing "" True + showWindow w + paintAndWrite w f (fi width) (fi hight) 0 (st_bg c) "" + (st_fg c) (st_bg c) [AlignCenter] [s] + releaseXMF f + io $ sync d False + t <- startTimer i + ES.modify $ modShowText (insert (fromIntegral t) w) diff --git a/XMonad/Actions/TagWindows.hs b/XMonad/Actions/TagWindows.hs --- a/XMonad/Actions/TagWindows.hs +++ b/XMonad/Actions/TagWindows.hs @@ -26,10 +26,9 @@ TagPrompt, ) where -import Prelude hiding (catch) import Data.List (nub,sortBy) import Control.Monad -import Control.Exception +import Control.Exception as E import XMonad.StackSet hiding (filter) @@ -82,7 +81,7 @@ -- reads from the \"_XMONAD_TAGS\" window property getTags :: Window -> X [String] getTags w = withDisplay $ \d -> - io $ catch (internAtom d "_XMONAD_TAGS" False >>= + io $ E.catch (internAtom d "_XMONAD_TAGS" False >>= getTextProperty d w >>= wcTextPropertyToTextList d) (econst [[]]) diff --git a/XMonad/Actions/WindowGo.hs b/XMonad/Actions/WindowGo.hs --- a/XMonad/Actions/WindowGo.hs +++ b/XMonad/Actions/WindowGo.hs @@ -114,7 +114,7 @@ Mutt which you just did for Firefox - but Mutt runs inside a terminal window? No problem: you search for a terminal window calling itself \"mutt\", and if there isn't you run a terminal with a command to run Mutt! Here's an example - (borrowing 'runInTerm' from "XMonad.Utils.Run"): + (borrowing 'runInTerm' from "XMonad.Util.Run"): > , ((modm, xK_m), raiseMaybe (runInTerm "-title mutt" "mutt") (title =? "mutt")) -} diff --git a/XMonad/Actions/Workscreen.hs b/XMonad/Actions/Workscreen.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/Workscreen.hs @@ -0,0 +1,109 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.Workscreen +-- Copyright : (c) 2012 kedals0 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Dal +-- Stability : unstable +-- Portability: unportable +-- +-- A workscreen permits to display a set of workspaces on several +-- screens. In xinerama mode, when a workscreen is viewed, workspaces +-- associated to all screens are visible. +-- +-- The first workspace of a workscreen is displayed on first screen, +-- second on second screen, etc. Workspace position can be easily +-- changed. If the current workscreen is called again, workspaces are +-- shifted. +-- +-- This also permits to see all workspaces of a workscreen even if just +-- one screen is present, and to move windows from workspace to workscreen. +----------------------------------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable #-} + +module XMonad.Actions.Workscreen ( + -- * Usage + -- $usage + configWorkscreen + ,viewWorkscreen + ,Workscreen(..) + ,shiftToWorkscreen + ,fromWorkspace + ,expandWorkspace + ) where + +import XMonad hiding (workspaces) +import qualified XMonad.StackSet as W +import qualified XMonad.Util.ExtensibleState as XS +import XMonad.Actions.OnScreen + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Actions.Workscreen +-- > myWorkspaces = let myOldWorkspaces = ["adm","work","mail"] +-- > in Workscreen.expandWorkspace 2 myOldWorkspaces +-- > myStartupHook = do Workscreen.configWorkscreen (Workscreen.fromWorkspace 2 myWorkspaces) +-- > return () +-- +-- Then, replace normal workspace view and shift keybinding: +-- +-- > [((m .|. modm, k), f i) +-- > | (i, k) <- zip [0..] [1..12] +-- > , (f, m) <- [(Workscreen.viewWorkscreen, 0), (Workscreen.shiftToWorkscreen, shiftMask)]] +-- +-- For detailed instructions on editing your key bindings, see +-- "XMonad.Doc.Extending#Editing_key_bindings". + + +data Workscreen = Workscreen{workscreenId::Int,workspaces::[WorkspaceId]} deriving (Show,Typeable) +type WorkscreenId=Int + +data WorkscreenStorage = WorkscreenStorage WorkscreenId [Workscreen] deriving (Show,Typeable) +instance ExtensionClass WorkscreenStorage where + initialValue = WorkscreenStorage 0 [] + +-- | Helper to group workspaces. Multiply workspace by screens number. +expandWorkspace :: Int -> [WorkspaceId] -> [WorkspaceId] +expandWorkspace nscr ws = concat $ map expandId ws + where expandId wsId = let t = wsId ++ "_" + in map ((++) t . show ) [1..nscr] + +-- | Create workscreen list from workspace list. Group workspaces to +-- packets of screens number size. +fromWorkspace :: Int -> [WorkspaceId] -> [Workscreen] +fromWorkspace n ws = map (\(a,b) -> Workscreen a b) $ zip [0..] (fromWorkspace' n ws) +fromWorkspace' :: Int -> [WorkspaceId] -> [[WorkspaceId]] +fromWorkspace' _ [] = [] +fromWorkspace' n ws = take n ws : fromWorkspace' n (drop n ws) + +-- | Initial configuration of workscreens +configWorkscreen :: [Workscreen] -> X () +configWorkscreen wscrn = XS.put (WorkscreenStorage 0 wscrn) + +-- | View workscreen of index @WorkscreenId@. If current workscreen is asked +-- workscreen, workscreen's workspaces are shifted. +viewWorkscreen :: WorkscreenId -> X () +viewWorkscreen wscrId = do (WorkscreenStorage c a) <- XS.get + let wscr = if wscrId == c + then Workscreen wscrId $ shiftWs (workspaces $ a !! wscrId) + else a !! wscrId + (x,_:ys) = splitAt wscrId a + newWorkscreenStorage = WorkscreenStorage wscrId (x ++ [wscr] ++ ys) + windows (viewWorkscreen' wscr) + XS.put newWorkscreenStorage + +viewWorkscreen' :: Workscreen -> WindowSet -> WindowSet +viewWorkscreen' (Workscreen _ ws) = \s -> foldl wsToSc' s (zip [0..] ws) + where wsToSc' s (scr,wsId) = greedyViewOnScreen scr wsId s + +shiftWs :: [WorkspaceId] -> [WorkspaceId] +shiftWs a = drop 1 a ++ take 1 a + +-- | Shift a window on the first workspace of workscreen +-- @WorkscreenId@. +shiftToWorkscreen :: WorkscreenId -> X () +shiftToWorkscreen wscrId = do (WorkscreenStorage _ a) <- XS.get + let ws = head . workspaces $ a !! wscrId + windows $ W.shift ws diff --git a/XMonad/Doc/Extending.hs b/XMonad/Doc/Extending.hs --- a/XMonad/Doc/Extending.hs +++ b/XMonad/Doc/Extending.hs @@ -175,7 +175,7 @@ * "XMonad.Actions.FloatKeys": Move and resize floating windows. -* "XMonad.Layout.FloatSnap": +* "XMonad.Actions.FloatSnap": Move and resize floating windows using other windows and the edge of the screen as guidelines. @@ -257,7 +257,7 @@ * "XMonad.Actions.UpdateFocus": Updates the focus on mouse move in unfocused windows. -* "XMonadContrib.UpdatePointer": +* "XMonad.Actions.UpdatePointer": Causes the pointer to follow whichever window focus changes to. * "XMonad.Actions.Warp": diff --git a/XMonad/Hooks/DebugEvents.hs b/XMonad/Hooks/DebugEvents.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/DebugEvents.hs @@ -0,0 +1,1254 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.DebugEvents +-- Copyright : (c) Brandon S Allbery KF8NH, 2012 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : allbery.b@gmail.com +-- Stability : unstable +-- Portability : not portable +-- +-- Module to dump diagnostic information about X11 events received by +-- @xmonad@. This is incomplete due to 'Event' being incomplete and not +-- providing information about a number of events, and enforcing artificial +-- constraints on others (for example 'ClientMessage'); the @X11@ package +-- will require a number of changes to fix these problems. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.DebugEvents (debugEventsHook) where + +import Prelude + +import XMonad hiding (windowEvent + ,(-->) + ) + +import XMonad.Hooks.DebugKeyEvents (debugKeyEvents) +import XMonad.Util.DebugWindow (debugWindow) + +-- import Graphics.X11.Xlib.Extras.GetAtomName (getAtomName) + +import Control.Exception.Extensible as E +import Control.Monad.State +import Control.Monad.Reader +import Data.Char (isDigit) +import Data.List (genericIndex + ,genericLength + ,unfoldr + ) +import Codec.Binary.UTF8.String +import Data.Maybe (fromMaybe) +import Data.Monoid +import Foreign +import Foreign.C.String +import Foreign.C.Types +import Numeric (showHex) +import System.Exit +import System.IO +import System.Process + +-- this should move into X11 +foreign import ccall unsafe "XGetAtomName" + xGetAtomName :: Display -> Atom -> IO CString + +getAtomName :: Display -> Atom -> IO (Maybe String) +getAtomName d a = do + n <- xGetAtomName d a + if n == nullPtr + then return Nothing + else do + n' <- peekCString n + xFree n + return $ Just n' + +-- | Event hook to dump all received events. You should probably not use this +-- unconditionally; it will produce massive amounts of output. +debugEventsHook :: Event -> X All +debugEventsHook e = debugEventsHook' e >> return (All True) + +-- | Dump an X11 event. Can't be used directly as a 'handleEventHook'. +debugEventsHook' :: Event -> X () + +debugEventsHook' (ConfigureRequestEvent {ev_window = w + ,ev_parent = p + ,ev_x = x + ,ev_y = y + ,ev_width = wid + ,ev_height = ht + ,ev_border_width = bw + ,ev_above = above + ,ev_detail = place + ,ev_value_mask = msk + }) = do + windowEvent "ConfigureRequest" w + windowEvent " parent" p +-- mask <- quickFormat msk $ dumpBits wmCRMask +-- say " requested parameters" $ concat ['(':show wid +-- ,'x':show ht +-- ,')':if bw == 0 then "" else '+':show bw +-- ,'@':'(':show x +-- ,',':show y +-- ,") mask " +-- ,mask +-- ] + s <- quickFormat [x,y,wid,ht,bw,fromIntegral above,place] $ + dumpListByMask' msk [("x" ,dump32 ,cARDINAL) + ,("y" ,dump32 ,cARDINAL) + ,("width" ,dump32 ,cARDINAL) + ,("height" ,dump32 ,cARDINAL) + ,("border_width",dump32 ,cARDINAL) + ,("sibling" ,dumpWindow ,wINDOW ) + ,("detail" ,dumpEnum wmPlacement,cARDINAL) + ] + say " requested" s + +debugEventsHook' (ConfigureEvent {ev_window = w + ,ev_above = above + }) = do + windowEvent "Configure" w + -- most of the content is covered by debugWindow + when (above /= none) $ debugWindow above >>= say " above" + +debugEventsHook' (MapRequestEvent {ev_window = w + ,ev_parent = p + }) = + windowEvent "MapRequest" w >> + windowEvent " parent" p + +debugEventsHook' e@(KeyEvent {ev_event_type = t}) + | t == keyPress = + io (hPutStr stderr "KeyPress ") >> + debugKeyEvents e >> + return () + +debugEventsHook' (ButtonEvent {ev_window = w + ,ev_state = s + ,ev_button = b + }) = do + windowEvent "Button" w + nl <- gets numberlockMask + let msk | s == 0 = "" + | otherwise = "modifiers " ++ vmask nl s + say " button" $ show b ++ msk + +debugEventsHook' (DestroyWindowEvent {ev_window = w + }) = + windowEvent "DestroyWindow" w + +debugEventsHook' (UnmapEvent {ev_window = w + }) = + windowEvent "Unmap" w + +debugEventsHook' (MapNotifyEvent {ev_window = w + }) = + windowEvent "MapNotify" w + +{- way too much output; suppressed. + +debugEventsHook' (CrossingEvent {ev_window = w + ,ev_subwindow = s + }) = + windowEvent "Crossing" w >> + windowEvent " subwindow" s +-} +debugEventsHook' (CrossingEvent {}) = + return () + +debugEventsHook' (SelectionRequest {ev_requestor = rw + ,ev_owner = ow + ,ev_selection = a + }) = + windowEvent "SelectionRequest" rw >> + windowEvent " owner" ow >> + atomEvent " atom" a + +debugEventsHook' (PropertyEvent {ev_window = w + ,ev_atom = a + ,ev_propstate = s + }) = do + a' <- atomName a + -- too many of these, and they're not real useful + if a' `elem` ["_NET_WM_USER_TIME" +-- ,"_NET_WM_WINDOW_OPACITY" + ] then return () else do + windowEvent "Property on" w + s' <- case s of + 1 -> return "deleted" + 0 -> dumpProperty a a' w (7 + length a') + _ -> error "Illegal propState; Xlib corrupted?" + say " atom" $ a' ++ s' + +debugEventsHook' (ExposeEvent {ev_window = w + }) = + windowEvent "Expose" w + +debugEventsHook' (ClientMessageEvent {ev_window = w + ,ev_message_type = a + -- @@@ they did it again! no ev_format, + -- and ev_data is [CInt] + -- @@@ and get a load of the trainwreck + -- that is setClientMessageEvent! +-- ,ev_format = b + ,ev_data = vs' + }) = do + windowEvent "ClientMessage on" w + n <- atomName a + -- this is a sort of custom property + -- @@@ this likely won't work as is; type information varies, I think + (ta,b,l) <- case lookup n clientMessages of + Nothing -> return (a,32,length vs') + Just (ta',b,l) -> do + ta <- getAtom ta' + return (ta,b,l) + let wl = bytes b + vs <- io $ take (l * wl) `fmap` splitCInt vs' + s <- dumpProperty' w a n ta b vs 0 (10 + length n) + say " message" $ n ++ s + +debugEventsHook' _ = return () + +-- | Emit information about an atom. +atomName :: Atom -> X String +atomName a = withDisplay $ \d -> + io $ fromMaybe ("(unknown atom " ++ show a ++ ")") `fmap` getAtomName d a + +-- | Emit an atom with respect to the current event. +atomEvent :: String -> Atom -> X () +atomEvent l a = atomName a >>= say l + +-- | Emit a window with respect to the current event. +windowEvent :: String -> Window -> X () +windowEvent l w = debugWindow w >>= say l + +-- | Helper to emit tagged event information. +say :: String -> String -> X () +say l s = trace $ l ++ ' ':s + +-- | Deconstuct a list of 'CInt's into raw bytes +splitCInt :: [CInt] -> IO Raw +splitCInt vs = io $ withArray vs $ \p -> + peekArray (4 * length vs) (castPtr p :: Ptr CUChar) + +-- | Specify how to decode some common client messages. +clientMessages :: [(String,(String,Int,Int))] +clientMessages = [("_NET_ACTIVE_WINDOW",("_NET_ACTIVE_WINDOW",32,1)) + ,("WM_CHANGE_STATE" ,("WM_STATE" ,32,2)) + ,("WM_COMMAND" ,("STRING" , 8,0)) + ,("WM_SAVE_YOURSELF" ,("STRING" , 8,0)) + ] + +-- | Convert a modifier mask into a useful string +vmask :: KeyMask -> KeyMask -> String +vmask numLockMask msk = unwords $ + reverse $ + fst $ + foldr vmask' ([],msk) masks + where + masks = map (\m -> (m,show m)) [0..toEnum (bitSize msk - 1)] ++ + [(numLockMask,"num" ) + ,( lockMask,"lock" ) + ,(controlMask,"ctrl" ) + ,( shiftMask,"shift") + ,( mod5Mask,"mod5" ) + ,( mod4Mask,"mod4" ) + ,( mod3Mask,"mod3" ) + ,( mod2Mask,"mod2" ) + ,( mod1Mask,"mod1" ) + ] + vmask' _ a@( _,0) = a + vmask' (m,s) (ss,v) | v .&. m == m = (s : ss,v .&. complement m) + vmask' _ r = r + +-- formatting properties. ick. -- + +-- @@@ Document the parser. Someday. + +type Raw = [CUChar] + +data Decode = Decode {property :: Atom -- original property atom + ,pName :: String -- its name + ,pType :: Atom -- base property type atom + ,width :: Int -- declared data width + ,window :: Window -- source window + ,indent :: Int -- current indent (via local) + ,limit :: Int -- line length + } + +-- the result accumulates here mainly for the benefit of the indenter +data DecodeState = DecS {value :: Raw -- unconsumed raw property value + ,accum :: String -- output accumulator + ,joint :: String -- separator when adding to accumulator + } + +newtype Decoder a = Decoder (ReaderT Decode (StateT DecodeState X) a) +#ifndef __HADDOCK__ + deriving (Functor + ,Monad + ,MonadIO + ,MonadState DecodeState + ,MonadReader Decode + ) +#endif + +-- | Retrive, parse, and dump a window property. As all the high-level property +-- interfaces lose information necessary to decode properties correctly, we +-- work at the lowest level available. +dumpProperty :: Atom -> String -> Window -> Int -> X String +dumpProperty a n w i = do + prop <- withDisplay $ \d -> + io $ + alloca $ \fmtp -> + alloca $ \szp -> + alloca $ \lenp -> + alloca $ \ackp -> + alloca $ \vsp -> do + rc <- xGetWindowProperty + d + w + a + 0 + maxBound + False + anyPropertyType + fmtp + szp + lenp + ackp + vsp + case rc of + 0 -> do + fmt <- fromIntegral `fmap` peek fmtp + vs' <- peek vsp + sz <- fromIntegral `fmap` peek szp + case () of + () | fmt == none -> xFree vs' >> return (Left "(property deleted)" ) + | sz < 0 -> xFree vs' >> return (Left $ "(illegal bit size " ++ + show sz ++ + ")" ) + | sz `mod` 8 /= 0 -> xFree vs' >> return (Left $ "(illegal bit size " ++ + show sz ++ + ")" ) + | otherwise -> do + len <- fromIntegral `fmap` peek lenp + -- that's as in "ack! it's fugged!" + ack <- fromIntegral `fmap` peek ackp + vs <- peekArray (len * bytes sz) vs' + _ <- xFree vs' + return $ Right (fmt,sz,ack,vs) + e -> return $ Left $ "getWindowProperty failed: " ++ show e + case prop of + Left _ -> return "" + Right (fmt,sz,ack,vs) -> dumpProperty' w a n fmt sz vs ack i + +-- @@@ am I better off passing in the Decode and DecodeState? +-- | Parse and dump a property (or a 'ClientMessage'). +dumpProperty' :: Window -- source window + -> Atom -- property id + -> String -- property name + -> Atom -- property type + -> Int -- bit width + -> Raw -- raw value + -> CULong -- size of un-dumped content + -> Int -- indent for output formatting + -> X String +dumpProperty' w a n fmt sz vs ack i = do + ptn <- atomName fmt + let dec = Decode {property = a + ,pName = n + ,pType = fmt + ,width = sz + ,indent = i + length ptn + 6 + ,window = w + ,limit = 96 + } + dec' = dec {pType = cARDINAL + ,width = 8 + } + ds = DecS {value = vs + -- @@@ probably should push this outside, since it doesn't + -- make sense for ClientMessage + ,accum = " (" ++ ptn ++ ") " + ,joint = "= " + } + (_,ds') <- runDecode dec ds $ dumpProp a n + let fin = length (value ds') + len = length vs + lost = if ack == 0 then "" else "and " ++ show ack ++ " lost bytes" + unk = case () of + () | fin == len -> "undecodeable " + | fin == 0 -> "." + | otherwise -> "and remainder (" ++ show (len - fin) ++ '/':show len ++ ")" + (_,ds'') <- if fin == 0 + then return (True,ds') + else runDecode dec' (withJoint' unk ds' ) $ dumpArray dump8 + (_,ds''') <- if ack == 0 + then return (True,ds'') + else runDecode dec' (withJoint' " " ds'') $ propSimple lost -- @@@ + return $ accum ds''' + +-- | A simplified version of 'dumpProperty\'', to format random values from +-- events. +quickFormat :: (Storable i, Integral i) => [i] -> Decoder Bool -> X String +quickFormat v f = do + let vl = length v + vs <- io $ + allocaArray vl $ + \p -> pokeArray p (map fromIntegral v :: [CULong]) >> + peekArray (4 * vl) (castPtr p :: Ptr CUChar) + let dec = Decode {property = none + ,pName = "" + ,pType = cARDINAL + ,width = 32 + ,indent = 0 + ,window = none + ,limit = maxBound + } + ds = DecS {value = vs + ,accum = "" + ,joint = "" + } + (r,ds') <- runDecode dec ds f + return $ accum ds' ++ if r then "" else "?" + +-- | Launch a decoding parser, returning success and final state. +runDecode :: Decode -> DecodeState -> Decoder Bool -> X (Bool,DecodeState) +runDecode c s (Decoder p) = runStateT (runReaderT p c) s + +-- Coerce bit size to bytes. +bytes :: Int -> Int +bytes w = w `div` 8 + +-- | The top level property decoder, for a wide variety of standard ICCCM and +-- EWMH window properties. We pass part of the 'ReaderT' as arguments for +-- pattern matching. +dumpProp :: Atom -> String -> Decoder Bool + +dumpProp _ "CLIPBOARD" = dumpSelection +dumpProp _ "_NET_SUPPORTED" = dumpArray dumpAtom +dumpProp _ "_NET_CLIENT_LIST" = dumpArray dumpWindow +dumpProp _ "_NET_CLIENT_LIST_STACKING" = dumpArray dumpWindow +dumpProp _ "_NET_NUMBER_OF_DESKTOPS" = dump32 +dumpProp _ "_NET_VIRTUAL_ROOTS" = dumpArray dumpWindow +dumpProp _ "_NET_DESKTOP_GEOMETRY" = dumpArray dump32 +dumpProp _ "_NET_DESKTOP_VIEWPORT" = dumpList [("w",dump32) + ,("h",dump32) + ] +dumpProp _ "_NET_CURRENT_DESKTOP" = dump32 +dumpProp _ "_NET_DESKTOP_NAMES" = dumpArray dumpUTF +dumpProp _ "_NET_ACTIVE_WINDOW" = dumpActiveWindow +dumpProp _ "_NET_WORKAREA" = dumpList [("start" + ,dumpList [("x",dump32) + ,("y",dump32) + ] + ) + ,("size" + ,dumpList [("w",dump32) + ,("h",dump32) + ] + ) + ] +dumpProp _ "_NET_SUPPORTING_WM_CHECK" = dumpWindow +dumpProp _ "_NET_DESKTOP_LAYOUT" = dumpList [("orientation" + ,dumpEnum nwmOrientation + ) + ,("size" + ,dumpList [("cols",dump32) + ,("rows",dump32) + ] + ) + ,("origin" + ,dumpEnum nwmOrigin + ) + ] +dumpProp _ "_NET_SHOWING_DESKTOP" = dump32 +dumpProp _ "_NET_WM_NAME" = dumpUTF +dumpProp _ "_NET_WM_VISIBLE_NAME" = dumpUTF +dumpProp _ "_NET_WM_ICON_NAME" = dumpUTF +dumpProp _ "_NET_WM_VISIBLE_ICON_NAME" = dumpUTF +dumpProp _ "_NET_WM_DESKTOP" = dumpExcept [(0xFFFFFFFF,"all")] + dump32 +dumpProp _ "_NET_WM_WINDOW_TYPE" = dumpArray dumpAtom +dumpProp _ "_NET_WM_STATE" = dumpArray dumpAtom +dumpProp _ "_NET_WM_ALLOWED_ACTIONS" = dumpArray dumpAtom +dumpProp _ "_NET_WM_STRUT" = dumpList [("left gap" ,dump32) + ,("right gap" ,dump32) + ,("top gap" ,dump32) + ,("bottom gap",dump32) + ] +dumpProp _ "_NET_WM_STRUT_PARTIAL" = dumpList [("left gap" ,dump32) + ,("right gap" ,dump32) + ,("top gap" ,dump32) + ,("bottom gap" ,dump32) + ,("left start" ,dump32) + ,("left end" ,dump32) + ,("right start" ,dump32) + ,("right end" ,dump32) + ,("top start" ,dump32) + ,("top end" ,dump32) + ,("bottom start",dump32) + ,("bottom end" ,dump32) + ] +dumpProp _ "_NET_WM_ICON_GEOMETRY" = dumpList [("x",dump32) + ,("y",dump32) + ,("w",dump32) + ,("h",dump32) + ] +-- no, I'm not going to duplicate xprop *completely*! +dumpProp _ "_NET_WM_ICON" = propSimple "(icon)" +dumpProp _ "_NET_WM_PID" = dumpPid +dumpProp _ "_NET_WM_HANDLED_ICONS" = propSimple "(defined)" +dumpProp _ "_NET_WM_USER_TIME" = dumpExcept [(0,"do not map initially")] + dumpTime +dumpProp _ "_NET_FRAME_EXTENTS" = dumpList [("left" ,dump32) + ,("right" ,dump32) + ,("top" ,dump32) + ,("bottom",dump32) + ] +dumpProp _ "_NET_WM_SYNC_REQUEST_COUNTER" = dumpExcept [(0,"illegal value 0")] + dump64 +dumpProp _ "_NET_STARTUP_ID" = dumpUTF +dumpProp _ "WM_PROTOCOLS" = dumpArray dumpAtom +dumpProp _ "WM_COLORMAP_WINDOWS" = dumpArray dumpWindow +dumpProp _ "WM_STATE" = dumpState +dumpProp _ "WM_LOCALE_NAME" = dumpString +dumpProp _ "WM_CLIENT_LEADER" = dumpWindow +dumpProp _ "_NET_WM_WINDOW_OPACITY" = dumpPercent +dumpProp _ "XdndAware" = dumpArray dumpAtom +dumpProp _ "_XKLAVIER_TRANSPARENT" = dumpInteger 32 +dumpProp _ "_XKLAVIER_STATE" = dumpList [("state" ,dumpInteger 32) + ,("indicators",dumpXKlInds) + ] +dumpProp _ "_MOTIF_DRAG_RECEIVER_INFO" = dumpMotifDragReceiver +dumpProp _ "_OL_WIN_ATTR" = dumpOLAttrs +dumpProp _ "_OL_DECOR_ADD" = dumpArray dumpAtom +dumpProp _ "_OL_DECOR_DEL" = dumpArray dumpAtom +dumpProp _ "_MOTIF_WM_HINTS" = dumpMwmHints +dumpProp _ "_MOTIF_WM_INFO" = dumpMwmInfo +dumpProp _ "_XMONAD_DECORATED_BY" = dumpWindow +dumpProp _ "_XMONAD_DECORATION_FOR" = dumpWindow +dumpProp a _ | a == wM_NAME = dumpString + | a == pRIMARY = dumpSelection + | a == sECONDARY = dumpSelection + -- this is gross + | a == wM_TRANSIENT_FOR = do + root <- fromIntegral `fmap` inX (asks theRoot) + w <- asks window + WMHints {wmh_window_group = group} <- + inX $ asks display >>= io . flip getWMHints w + dumpExcept [(0 ,"window group " ++ show group) + ,(root,"window group " ++ show group) + ] + dumpWindow + | a == rESOURCE_MANAGER = dumpString + | a == wM_COMMAND = dumpString + | a == wM_HINTS = dumpWmHints + | a == wM_CLIENT_MACHINE = dumpString + | a == wM_ICON_NAME = dumpString + | a == wM_ICON_SIZE = dumpList [("min size" + ,dumpList [("w",dump32) + ,("h",dump32) + ] + ) + ,("max size" + ,dumpList [("w",dump32) + ,("h",dump32) + ] + ) + ,("increment" + ,dumpList [("w",dump32) + ,("h",dump32) + ] + ) + ] + | a == wM_NORMAL_HINTS = (...) + | a == wM_ZOOM_HINTS = (...) -- same as previous + | a == rGB_DEFAULT_MAP = (...) -- XStandardColormap + | a == rGB_BEST_MAP = (...) -- " + | a == rGB_RED_MAP = (...) -- " + | a == rGB_GREEN_MAP = (...) -- " + | a == rGB_BLUE_MAP = (...) -- " + | a == rGB_GRAY_MAP = (...) -- " + | a == wM_CLASS = dumpList [("name" ,dumpString) + ,("class",dumpString) + ] +dumpProp _ s | s `isCountOf` "WM_S" = dumpSelection + | s `isCountOf` "_NET_WM_CM_S" = dumpSelection + | s `isCountOf` "_NET_DESKTOP_LAYOUT_S" = dumpSelection + | s `isCountOf` "CUT_BUFFER" = dumpString + -- and dumpProperties does the rest + | otherwise = return False + +-- lower level decoders -- + +-- alter the current joint +withJoint :: String -> Decoder a -> Decoder a +withJoint j = ((modify $ withJoint' j) >>) + +withJoint' :: String -> DecodeState -> DecodeState +withJoint' j s = s {joint = j} + +-- lift an X into a Decoder +inX :: X a -> Decoder a +inX = Decoder . lift . lift + +-- flip isPrefixOf, but the remainder must be all digits +isCountOf :: String -> String -> Bool +-- note that \NUL is safe because atom names have to be C strings +s `isCountOf` pfx = null $ + dropWhile isDigit $ + map fst $ + dropWhile (uncurry (==)) $ + zip s $ + pfx ++ repeat '\NUL' + +-- localize an increased indent +withIndent :: Int -> Decoder a -> Decoder a +withIndent w = local (\r -> r {indent = indent r + w}) + +-- dump an array of items. this dumps the entire property +dumpArray :: Decoder Bool -> Decoder Bool +dumpArray item = do + withIndent 1 $ append "[" >> withJoint "" (dumpArray' item "") + +-- step through values as an array, ending on parse error or end of list +dumpArray' :: Decoder Bool -> String -> Decoder Bool +dumpArray' item pfx = do + vs <- gets value + if vs == [] + then append "]" + else append pfx >> whenD item (dumpArray' item ",") + +-- keep parsing until a parse step fails +-- @@@ which points out that all my uses of @whenX (return ...)@ are actually 'when', +-- which suggests that 'whenX' is *also* the same function... yep. ISAGN +whenD :: Monad m => m Bool -> m Bool -> m Bool +whenD p f = p >>= \b -> if b then f else return False + +-- verify a decoder parameter, else call error reporter +-- once again, it's more general than I originally wrote +guardR :: (MonadReader r m, Eq v) + => (r -> v) -- value selector + -> v -- expected value + -> (v -> v -> m a) -- error reporter + -> m a -- continuation (hush) + -> m a +guardR sel val err good = do + v <- asks sel + if v == val then good else err v val + +-- this is kinda dumb +fi :: Bool -> a -> a -> a +fi p n y = if p then y else n -- flip (if' p), if that existed + +-- verify we have the expected word size +guardSize :: Int -> Decoder Bool -> Decoder Bool +-- see XSync documentation for this insanity +guardSize 64 = guardR width 32 propSizeErr . guardSize' 8 propShortErr +guardSize w = guardR width w propSizeErr . guardSize' (bytes w) propShortErr + +guardSize' :: Int -> Decoder a -> Decoder a -> Decoder a +guardSize' l n y = gets value >>= \vs -> fi (length vs >= l) n y + +-- verify we have the expected property type +guardType :: Atom -> Decoder Bool -> Decoder Bool +guardType t = guardR pType t propTypeErr + +-- dump a structure as a named tuple +dumpList :: [(String,Decoder Bool)] -> Decoder Bool +dumpList proto = do + a <- asks pType + dumpList'' (maxBound :: CULong) (map (\(s,d) -> (s,d,a)) proto) "(" + +-- same but elements have their own distinct types +dumpList' :: [(String,Decoder Bool,Atom)] -> Decoder Bool +dumpList' proto = dumpList'' (maxBound :: CULong) proto "(" + +-- same but only dump elements identified by provided mask +dumpListByMask :: CULong -> [(String,Decoder Bool)] -> Decoder Bool +dumpListByMask m p = do + a <- asks pType + dumpList'' m (map (\(s,d) -> (s,d,a)) p) "(" + +-- and the previous two combined +dumpListByMask' :: CULong -> [(String,Decoder Bool,Atom)] -> Decoder Bool +dumpListByMask' m p = dumpList'' m p "(" + +dumpList'' :: CULong -> [(String,Decoder Bool,Atom)] -> String -> Decoder Bool +dumpList'' _ [] _ = append ")" >> return True +dumpList'' 0 _ _ = append ")" >> return True +dumpList'' m ((l,p,t):ps) sep = do + (e,sep') <- if m .&. 1 == 0 + then do + -- @@@ ew + st <- get + e <- local (\r -> r {pType = t}) p + v' <- gets value + put $ st {value = v'} + return (e,sep) + else do + let label = sep ++ l ++ " = " + append label + e <- withJoint "" $ do + local (\r -> r {pType = t + ,indent = indent r + length label + }) + p + return (e,",") + if e then dumpList'' (m `shiftR` 1) ps sep' else return e + +-- do the getTextProperty dance, the hard way. +-- @@@ @COMPOUND_TEXT@ not supported yet. +dumpString :: Decoder Bool +dumpString = do + fmt <- asks pType + [cOMPOUND_TEXT,uTF8_STRING] <- inX $ mapM getAtom ["COMPOUND_TEXT","UTF8_STRING"] + case () of + () | fmt == cOMPOUND_TEXT -> guardSize 16 (...) + | fmt == sTRING -> guardSize 8 $ do + vs <- gets value + modify (\r -> r {value = []}) + let ss = flip unfoldr (map twiddle vs) $ + \s -> if null s + then Nothing + else let (w,s'') = break (== '\NUL') s + s' = if null s'' + then s'' + else tail s'' + in Just (w,s') + case ss of + [s] -> append $ show s + ss' -> let go (s:ss'') c = append c >> + append (show s) >> + go ss'' "," + go [] _ = append "]" + in append "[" >> go ss' "" + | fmt == uTF8_STRING -> dumpUTF -- duplicate type test instead of code :) + | otherwise -> (inX $ atomName fmt) >>= + failure . ("unrecognized string type " ++) + +-- show who owns a selection +dumpSelection :: Decoder Bool +dumpSelection = do + -- system selections contain a window ID; others are random + -- note that the window ID will be the same as the owner, so + -- we don't really care anyway. we *do* want the selection owner + a <- asks property + owner <- inX $ withDisplay $ \d -> io $ xGetSelectionOwner d a + if owner == none + then append "unowned" + else do + w <- inX $ debugWindow owner + append $ "owned by " ++ w + +-- for now, not querying Xkb +dumpXKlInds :: Decoder Bool +dumpXKlInds = guardType iNTEGER $ do + n <- fmap fromIntegral `fmap` getInt' 32 + case n of + Nothing -> propShortErr + Just is -> append $ "indicators " ++ unwords (dumpInds is 1 1 []) + where + dumpInds :: Word32 -> Word32 -> Int -> [String] -> [String] + dumpInds n bt c bs | n == 0 && c == 1 = ["none"] + | n == 0 = bs + | n .&. bt /= 0 = dumpInds (n .&. complement bt) + (bt `shiftL` 1) + (c + 1) + ((show c):bs) + | otherwise = dumpInds n + (bt `shiftL` 1) + (c + 1) + bs + +-- decode an Atom +dumpAtom :: Decoder Bool +dumpAtom = + guardType aTOM $ do + a <- getInt' 32 + case a of + Nothing -> return False + Just a' -> do + an <- inX $ atomName $ fromIntegral a' + append an + +dumpWindow :: Decoder Bool +dumpWindow = guardSize 32 $ guardType wINDOW $ do + w <- getInt' 32 + case w of + Nothing -> return False + Just w' -> inX (debugWindow (fromIntegral w')) >>= append + +-- a bit of a hack; as a Property it's a wINDOW, as a ClientMessage it's a list +dumpActiveWindow :: Decoder Bool +dumpActiveWindow = guardSize 32 $ do + t <- asks pType + nAW <- inX $ getAtom "_NET_ACTIVE_WINDOW" + case () of + () | t == wINDOW -> dumpWindow + | t == nAW -> dumpList' [("source" ,dumpEnum awSource,cARDINAL) + ,("timestamp" ,dumpTime ,cARDINAL) + ,("active window",dumpWindow ,wINDOW ) + ] + _ -> do + t' <- inX $ atomName t + failure $ concat ["(bad type " + ,t' + ,"; expected WINDOW or _NET_ACTIVE_WINDOW" + ] +-- dump a generic CARDINAL value +dumpInt :: Int -> Decoder Bool +dumpInt w = guardSize w $ guardType cARDINAL $ getInt w show + +-- INTEGER is the signed version of CARDINAL +dumpInteger :: Int -> Decoder Bool +dumpInteger w = guardSize w $ guardType iNTEGER $ getInt w (show . signed w) + +-- reinterpret an unsigned as a signed +signed :: Int -> Integer -> Integer +signed w i = bit (w + 1) - i + +-- and wrappers to keep the parse list in bounds +dump64 :: Decoder Bool +dump64 = dumpInt 64 + +dump32 :: Decoder Bool +dump32 = dumpInt 32 + +{- not used in standard properties +dump16 :: Decoder Bool +dump16 = dumpInt 16 +-} + +dump8 :: Decoder Bool +dump8 = dumpInt 8 + +-- I am assuming for the moment that this is a single string. +-- This might be false; consider the way the STRING properties +-- handle lists. +dumpUTF :: Decoder Bool +dumpUTF = do + uTF8_STRING <- inX $ getAtom "UTF8_STRING" + guardType uTF8_STRING $ guardSize 8 $ do + s <- gets value + modify (\r -> r {value = []}) + append . show . decode . map fromIntegral $ s + return True + +-- dump an enumerated value using a translation table +dumpEnum' :: [String] -> Atom -> Decoder Bool +dumpEnum' ss fmt = guardType fmt $ + getInt 32 $ + \r -> case () of + () | r < 0 -> "undefined value " ++ show r + | r >= genericLength ss -> "undefined value " ++ show r + | otherwise -> genericIndex ss r + +-- we do not, unlike @xev@, try to ascii-art pixmaps. +dumpPixmap :: Decoder Bool +dumpPixmap = guardType pIXMAP $ do + p' <- getInt' 32 + case p' of + Nothing -> return False + Just p -> do + append $ "pixmap " ++ showHex p "" + g' <- inX $ withDisplay $ \d -> io $ + Just `fmap` getGeometry d (fromIntegral p) + `E.catch` + \e -> case fromException e of + Just x -> throw e `const` (x `asTypeOf` ExitSuccess) + _ -> return Nothing + case g' of + Nothing -> append " (deleted)" + Just (_,x,y,wid,ht,bw,dp) -> + append $ concat + [" (" + ,show wid + ,'x':show ht + ,'x':show dp + ,')':if bw == 0 then "" else '+':show bw + ,"@(" + ,show x + ,',':show y + ,")" + ] + +dumpOLAttrs :: Decoder Bool +dumpOLAttrs = do + pt <- inX $ getAtom "_OL_WIN_ATTR" + guardType pt $ do + msk <- getInt' 32 + case msk of + Nothing -> propShortErr + Just msk' -> dumpListByMask (fromIntegral msk') [("window type" ,dumpAtom ) + ,("menu" ,dump32 ) -- @@@ unk + ,("pushpin" ,dumpEnum bool) + ,("limited menu",dump32 ) -- @@@ unk + ] + +dumpMwmHints :: Decoder Bool +dumpMwmHints = do + ta <- asks property + guardType ta $ do + msk <- getInt' 32 + case msk of + Nothing -> propShortErr + Just msk' -> dumpListByMask (fromIntegral msk') [("functions" ,dumpBits mwmFuncs ) + ,("decorations",dumpBits mwmDecos ) + ,("input mode" ,dumpEnum mwmInputMode) + ,("status" ,dumpBits mwmState ) + ] + +dumpMwmInfo :: Decoder Bool +dumpMwmInfo = do + ta <- asks property + guardType ta $ dumpList' [("flags" ,dumpBits mwmHints,cARDINAL) + ,("window",dumpWindow ,wINDOW ) + ] + +-- the most common case +dumpEnum :: [String] -> Decoder Bool +dumpEnum ss = dumpEnum' ss cARDINAL + +-- implement exceptional cases atop a normal dumper +-- @@@ there's gotta be a better way +dumpExcept :: [(Integer,String)] -> Decoder Bool -> Decoder Bool +dumpExcept xs item = do + -- this horror brought to you by reparsing to get the right value for our use + sp <- get + rc <- item + if not rc then return False else do + that <- get -- if none match then we just restore the value parse + vs <- gets value + let w = (length (value sp) - length vs) * 8 + -- now we get to reparse again so we get our copy of it + put sp + Just v <- getInt' w + -- and after all that, we can process the exception list + dumpExcept' xs that v + +dumpExcept' :: [(Integer,String)] + -> DecodeState + -> Integer + -> Decoder Bool +dumpExcept' [] that _ = put that >> return True +dumpExcept' ((exc,str):xs) that val | exc == val = append str + | otherwise = dumpExcept' xs that val + +-- use @ps@ to get process information. +-- @@@@ assumes a POSIX @ps@, not a BSDish one. +dumpPid :: Decoder Bool +dumpPid = guardType cARDINAL $ do + n <- getInt' 32 + case n of + Nothing -> return False + Just pid' -> do + let pid = show pid' + ps = (proc "/bin/ps" ["-fp" ++ pid]) {std_out = CreatePipe} + (_,o,_,_) <- io $ createProcess ps + case o of + Nothing -> append $ "pid " ++ pid + Just p' -> do + prc <- io $ lines `fmap` hGetContents p' + -- deliberately forcing it + append $ if length prc < 2 + then "pid " ++ pid + else prc !! 1 + +dumpTime :: Decoder Bool +dumpTime = append "server event # " >> dump32 + +dumpState :: Decoder Bool +dumpState = do + wM_STATE <- inX $ getAtom "WM_STATE" + guardType wM_STATE $ dumpList' [("state" ,dumpEnum wmState,cARDINAL) + ,("icon window",dumpWindow ,wINDOW ) + ] + +dumpMotifDragReceiver :: Decoder Bool +dumpMotifDragReceiver = do + ta <- inX $ getAtom "_MOTIF_DRAG_RECEIVER_INFO" + guardType ta $ dumpList' [("endian" ,dumpMotifEndian,cARDINAL) + ,("version" ,dump8 ,cARDINAL) + ,("style" ,dumpMDropStyle ,cARDINAL) -- @@@ dummy + ] + +dumpMDropStyle :: Decoder Bool +dumpMDropStyle = do + d <- getInt' 8 + pad 1 $ case d of + Nothing -> propShortErr + Just ps | ps == 0 -> pad 12 $ append "none" + | ps == 1 -> pad 12 $ append "drop only" + | ps == 2 -> append "prefer preregister " >> dumpMDPrereg + | ps == 3 -> append "preregister " >> dumpMDPrereg + | ps == 4 -> pad 12 $ append "prefer dynamic" + | ps == 5 -> pad 12 $ append "dynamic" + | ps == 6 -> pad 12 $ append "prefer receiver" + | otherwise -> failure $ "unknown drop style " ++ show ps + +dumpMDPrereg :: Decoder Bool +dumpMDPrereg = do + -- this is a bit ugly; we pretend to be extending the above dumpList' + append "," + append "proxy window = " + withIndent 15 dumpWindow + append "," + append "drop sites = " + dsc' <- getInt' 16 + case dsc' of + Nothing -> propShortErr + Just dsc -> do + withIndent 13 $ append (show dsc) + pad 2 $ do + append "," + append "total size = " + withIndent 13 dump32 + dumpMDBlocks $ fromIntegral dsc + +dumpMDBlocks :: Int -> Decoder Bool +dumpMDBlocks _ = propSimple "(drop site info)" -- @@@ maybe later if needed + +dumpMotifEndian :: Decoder Bool +dumpMotifEndian = guardType cARDINAL $ guardSize 8 $ do + c <- map twiddle `fmap` eat 1 + case c of + ['l'] -> append "little" + ['B'] -> append "big" + _ -> failure "bad endian flag" + +pad :: Int -> Decoder Bool -> Decoder Bool +pad n p = do + vs <- gets value + if length vs < n + then propShortErr + else modify (\r -> r {value = drop n vs}) >> p + +dumpPercent :: Decoder Bool +dumpPercent = guardType cARDINAL $ do + n <- getInt' 32 + case n of + Nothing -> return False + Just n' -> + let pct = 100 * fromIntegral n' / fromIntegral (maxBound :: Word32) + pct :: Double + in append $ show (round pct :: Integer) ++ "%" + +dumpWmHints :: Decoder Bool +dumpWmHints = + guardType wM_HINTS $ do + msk <- getInt' 32 + case msk of + Nothing -> return False + Just msk' -> dumpListByMask' (fromIntegral msk') + [("input" ,dumpEnum bool ,cARDINAL) + ,("initial_state",dumpEnum wmState,cARDINAL) + ,("icon_pixmap" ,dumpPixmap ,pIXMAP ) + ,("icon_window" ,dumpWindow ,wINDOW ) + ,("icon_x" ,dump32 ,cARDINAL) + ,("icon_y" ,dump32 ,cARDINAL) + ,("icon_mask" ,dumpPixmap ,pIXMAP ) + ,("window_group" ,dumpWindow ,wINDOW ) + ] + +dumpBits :: [String] -> Decoder Bool +dumpBits bs = guardType cARDINAL $ do + n <- getInt' 32 + case n of + Nothing -> return False + Just n' -> dumpBits' bs 1 (fromIntegral n') "" + +dumpBits' :: [String] -> Int -> Int -> String -> Decoder Bool +dumpBits' [] _ n p = if n == 0 then return True else append (p ++ show n) +dumpBits' (s:ss) b n p = do + p' <- if n .&. b /= 0 + then append (p ++ s) >> return "|" + else return p + dumpBits' ss (b `shiftL` 1) (n .&. complement b) p' + +-- enum definitions -- + +mwmFuncs :: [String] +mwmFuncs = ["all except" + ,"resize" + ,"move" + ,"minimize" + ,"maximize" + ,"close" + ] + +mwmDecos :: [String] +mwmDecos = ["all except" + ,"border" + ,"resize handle" + ,"title" + ,"menu button" + ,"maximize button" + ,"minimize button" + ] + +mwmInputMode :: [String] +mwmInputMode = ["modeless" + ,"application modal" + ,"system model" + ,"full application modal" + ] + +mwmState :: [String] +mwmState = ["tearoff window" + ] + +mwmHints :: [String] +mwmHints = ["standard startup" + ,"custom startup" + ] + +awSource :: [String] +awSource = ["unspecified" + ,"application" + ,"pager/task list" + ] + +{- eventually... +wmHintsFlags :: [String] +wmHintsFlags = ["Input" + ,"State" + ,"IconPixmap" + ,"IconWindow" + ,"IconX" + ,"IconY" + ,"IconMask" + ,"WindowGroup" + ] + +wmCRMask :: [String] +wmCRMask = ["X" + ,"Y" + ,"Width" + ,"Height" + ,"BorderWidth" + ,"Sibling" + ,"StackMode" + ] +-} + +wmPlacement :: [String] +wmPlacement = ["Above" + ,"Below" + ,"TopIf" + ,"BottomIf" + ,"Opposite" + ] + +bool :: [String] +bool = ["False","True"] + +nwmOrientation :: [String] +nwmOrientation = nwmEnum (Just "ORIENTATION") ["HORZ","VERT"] + +nwmOrigin :: [String] +nwmOrigin = nwmEnum Nothing ["TOPLEFT","TOPRIGHT","BOTTOMRIGHT","BOTTOMLEFT"] + +wmState :: [String] +wmState = ["Withdrawn","Normal","Zoomed (obsolete)","Iconified","Inactive"] + +nwmEnum :: Maybe String + -> [String] + -> [String] +nwmEnum Nothing vs = map ( "_NET_WM_" ++) vs +nwmEnum (Just prefix) vs = map (("_NET_WM_" ++ prefix ++ "_") ++) vs + +-- and the lowest level coercions -- + +-- parse and return an integral value +getInt' :: Int -> Decoder (Maybe Integer) +-- see XSync documentation for this insanity +getInt' 64 = guardR width 32 (\a e -> propSizeErr a e >> return Nothing) $ + guardSize' 8 (propShortErr >> return Nothing) $ do + lo <- inhale 32 + hi <- inhale 32 + return $ Just $ lo + hi * (fromIntegral (maxBound :: Word32) + 1) +getInt' w = guardR width w (\a e -> propSizeErr a e >> return Nothing) $ + guardSize' (bytes w) (propShortErr >> return Nothing) $ + Just `fmap` inhale w + +-- parse an integral value and feed it to a show-er of some kind +getInt :: Int -> (Integer -> String) -> Decoder Bool +getInt w f = getInt' w >>= maybe (return False) (append . f) + +-- bottommost level: parse an integral value out of the stream. +-- Not much in the way of error checking; it is assumed you used +-- the appropriate guards. +-- @@@@@@@@@ evil beyond evil. there *has* to be a better way +inhale :: Int -> Decoder Integer +inhale 8 = do + [b] <- eat 1 + return $ fromIntegral b +inhale 16 = do + [b0,b1] <- eat 2 + io $ allocaArray 2 $ \p -> do + pokeArray p [b0,b1] + [v] <- peekArray 1 (castPtr p :: Ptr Word16) + return $ fromIntegral v +inhale 32 = do + [b0,b1,b2,b3] <- eat 4 + io $ allocaArray 4 $ \p -> do + pokeArray p [b0,b1,b2,b3] + [v] <- peekArray 1 (castPtr p :: Ptr Word32) + return $ fromIntegral v +inhale b = error $ "inhale " ++ show b + +eat :: Int -> Decoder Raw +eat n = do + (bs,rest) <- splitAt n `fmap` gets value + modify (\r -> r {value = rest}) + return bs + +-- actually do formatting type stuffs +-- sorta stubbed for the moment +-- eventually we should do indentation foo here +append :: String -> Decoder Bool +append = append' True + +-- and the same but for errors +failure :: String -> Decoder Bool +failure = append' False + +-- common appender +append' :: Bool -> String -> Decoder Bool +append' b s = do + j <- gets joint + modify (\r -> r {accum = accum r ++ j ++ s}) + return b + +-- consume all and output a constant string +propSimple :: String -> Decoder Bool +propSimple s = modify (\r -> r {value = []}) >> append s + +-- report various errors +propShortErr :: Decoder Bool +propShortErr = failure "(property ended prematurely)" + +propSizeErr :: Int -> Int -> Decoder Bool +propSizeErr e a = failure $ "(bad bit width " ++ + show a ++ + "; expected " ++ + show e ++ + ")" + +propTypeErr :: Atom -> Atom -> Decoder Bool +propTypeErr a e = do + e' <- inX $ atomName e + a' <- inX $ atomName a + failure $ "(bad type " ++ a' ++"; expected " ++ e' ++ ")" + +-- for stubs +(...) :: Decoder Bool +(...) = do + fmt <- asks pType >>= inX . atomName + propSimple $ "(unimplemented type " ++ fmt ++ ")" + +-- you like fi, I like this +twiddle :: (Enum a, Enum b) => a -> b +twiddle = toEnum . fromEnum diff --git a/XMonad/Hooks/DebugKeyEvents.hs b/XMonad/Hooks/DebugKeyEvents.hs --- a/XMonad/Hooks/DebugKeyEvents.hs +++ b/XMonad/Hooks/DebugKeyEvents.hs @@ -45,7 +45,7 @@ -- Logged key events look like: -- -- @keycode 53 sym 120 (0x78, "x") mask 0x0 () clean 0x0 ()@ --- +-- -- The @mask@ and @clean@ indicate the modifiers pressed along with -- the key; @mask@ is raw, and @clean@ is what @xmonad@ sees after -- sanitizing it (removing @numberLockMask@, etc.) diff --git a/XMonad/Hooks/DebugStack.hs b/XMonad/Hooks/DebugStack.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/DebugStack.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.DebugStack +-- Copyright : (c) Brandon S Allbery KF8NH, 2012 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : allbery.b@gmail.com +-- Stability : unstable +-- Portability : not portable +-- +-- Dump the state of the 'StackSet'. A @logHook@ and @handleEventHook@ are +-- also provided. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.DebugStack (debugStack + ,debugStackString + ,debugStackLogHook + ,debugStackEventHook + ) where + +import XMonad.Core +import qualified XMonad.StackSet as W + +import XMonad.Util.DebugWindow + +import Graphics.X11.Types (Window) +import Graphics.X11.Xlib.Extras (Event) + +import Control.Monad (foldM) +import Data.Map (toList) +import Data.Monoid (All(..)) + +-- | Print the state of the current window stack to @stderr@, which for most +-- installations goes to @~/.xsession-errors@. "XMonad.Util.DebugWindow" +-- is used to display the individual windows. +debugStack :: X () +debugStack = debugStackString >>= trace + +-- | The above packaged as a 'logHook'. (Currently this is identical.) +debugStackLogHook :: X () +debugStackLogHook = debugStack + +-- | The above packaged as a 'handleEventHook'. You almost certainly do not +-- want to use this unconditionally, as it will cause massive amounts of +-- output and possibly slow @xmonad@ down severely. + +debugStackEventHook :: Event -> X All +debugStackEventHook _ = debugStack >> return (All True) + +-- | Dump the state of the current 'StackSet' as a multiline 'String'. +-- @ +-- stack [ mm +-- ,(*) ww +-- , ww +-- ] +-- float { ww +-- , ww +-- } +-- @ +-- +-- One thing I'm not sure of is where the zipper is when focus is on a +-- floating window. +debugStackString :: X String +debugStackString = withWindowSet $ \ws -> do + s <- emit "stack" ("[","]") (W.peek ws) $ W.index ws + f <- emit "float" ("{","}") (W.peek ws) $ map fst $ toList $ W.floating ws + return $ s ++ f + where + emit :: String -> (String,String) -> Maybe Window -> [Window] -> X String + emit title (lb,rb) _ [] = return $ title ++ " " ++ lb ++ rb ++ "]\n" + emit title (lb,rb) focused ws = do + (_,_,_,_,ss) <- foldM emit' (title,lb,rb,focused,"") ws + return $ ss ++ + replicate (length title + 1) ' ' ++ + rb ++ + "\n" + + emit' :: (String,String,String,Maybe Window,String) + -> Window + -> X (String,String,String,Maybe Window,String) + emit' (t,l,r,f,a) w = do + w' <- emit'' f w + return (replicate (length t) ' ' + ,',' : replicate (length l - 1) ' ' + ,r + ,f + ,a ++ t ++ " " ++ l ++ w' ++ "\n" + ) + emit'' :: Maybe Window -> Window -> X String + emit'' focus win = + let fi f = if win == f then "(*) " else " " + in (maybe " " fi focus ++) `fmap` debugWindow win diff --git a/XMonad/Hooks/DynamicBars.hs b/XMonad/Hooks/DynamicBars.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/DynamicBars.hs @@ -0,0 +1,136 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.DynamicBars +-- Copyright : (c) Ben Boeckel 2012 +-- License : BSD-style (as xmonad) +-- +-- Maintainer : mathstuf@gmail.com +-- Stability : unstable +-- Portability : unportable +-- +-- Manage per-screen status bars. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.DynamicBars ( + -- * Usage + -- $usage + DynamicStatusBar + , DynamicStatusBarCleanup + , dynStatusBarStartup + , dynStatusBarEventHook + , multiPP + ) where + +import Prelude + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans (lift) +import Control.Monad.Writer (WriterT, execWriterT, tell) + +import Data.Maybe +import Data.Monoid +import Data.Traversable (traverse) + +import Graphics.X11.Xinerama +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xrandr + +import System.IO +import System.IO.Unsafe + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Hooks.DynamicLog + +-- $usage +-- Provides a few helper functions to manage per-screen status bars while +-- dynamically responding to screen changes. A startup action, event hook, and +-- a way to separate PP styles based on the screen's focus are provided: +-- +-- * The 'dynStatusBarStartup' hook which initializes the status bars. +-- +-- * The 'dynStatusBarEventHook' hook which respawns status bars when the +-- number of screens changes. +-- +-- * The 'multiPP' function which allows for different output based on whether +-- the screen for the status bar has focus. +-- +-- The hooks take a 'DynamicStatusBar' function which is given the id of the +-- screen to start up and returns the 'Handle' to the pipe to write to. The +-- 'DynamicStatusBarCleanup' argument should tear down previous instances. It +-- is called when the number of screens changes and on startup. +-- + +data DynStatusBarInfo = DynStatusBarInfo + { dsbInfoScreens :: [ScreenId] + , dsbInfoHandles :: [Handle] + } + +type DynamicStatusBar = ScreenId -> IO Handle +type DynamicStatusBarCleanup = IO () + +-- Global state +statusBarInfo :: MVar DynStatusBarInfo +statusBarInfo = unsafePerformIO $ newMVar (DynStatusBarInfo [] []) + +dynStatusBarStartup :: DynamicStatusBar -> DynamicStatusBarCleanup -> X () +dynStatusBarStartup sb cleanup = liftIO $ do + dpy <- openDisplay "" + xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask + closeDisplay dpy + updateStatusBars sb cleanup + +dynStatusBarEventHook :: DynamicStatusBar -> DynamicStatusBarCleanup -> Event -> X All +dynStatusBarEventHook sb cleanup (RRScreenChangeNotifyEvent {}) = liftIO (updateStatusBars sb cleanup) >> return (All True) +dynStatusBarEventHook _ _ _ = return (All True) + +updateStatusBars :: DynamicStatusBar -> DynamicStatusBarCleanup -> IO () +updateStatusBars sb cleanup = liftIO $ do + dsbInfo <- takeMVar statusBarInfo + screens <- getScreens + if (screens /= (dsbInfoScreens dsbInfo)) + then do + mapM hClose (dsbInfoHandles dsbInfo) + cleanup + newHandles <- mapM sb screens + putMVar statusBarInfo (DynStatusBarInfo screens newHandles) + else putMVar statusBarInfo dsbInfo + +----------------------------------------------------------------------------- +-- The following code is from adamvo's xmonad.hs file. +-- http://www.haskell.org/haskellwiki/Xmonad/Config_archive/adamvo%27s_xmonad.hs + +multiPP :: PP -- ^ The PP to use if the screen is focused + -> PP -- ^ The PP to use otherwise + -> X () +multiPP focusPP unfocusPP = do + dsbInfo <- liftIO $ readMVar statusBarInfo + multiPP' dynamicLogString focusPP unfocusPP (dsbInfoHandles dsbInfo) + +multiPP' :: (PP -> X String) -> PP -> PP -> [Handle] -> X () +multiPP' dynlStr focusPP unfocusPP handles = do + st <- get + let pickPP :: WorkspaceId -> WriterT (Last XState) X String + pickPP ws = do + let isFoc = (ws ==) . W.tag . W.workspace . W.current $ windowset st + put st{ windowset = W.view ws $ windowset st } + out <- lift $ dynlStr $ if isFoc then focusPP else unfocusPP + when isFoc $ get >>= tell . Last . Just + return out + traverse put . getLast + =<< execWriterT . (io . zipWithM_ hPutStrLn handles <=< mapM pickPP) . catMaybes + =<< mapM screenWorkspace (zipWith const [0 .. ] handles) + return () + +getScreens :: IO [ScreenId] +getScreens = do + screens <- do + dpy <- openDisplay "" + rects <- getScreenInfo dpy + closeDisplay dpy + return rects + let ids = zip [0 .. ] screens + return $ map fst ids diff --git a/XMonad/Hooks/EwmhDesktops.hs b/XMonad/Hooks/EwmhDesktops.hs --- a/XMonad/Hooks/EwmhDesktops.hs +++ b/XMonad/Hooks/EwmhDesktops.hs @@ -20,6 +20,7 @@ ewmhDesktopsLogHook, ewmhDesktopsLogHookCustom, ewmhDesktopsEventHook, + ewmhDesktopsEventHookCustom, fullscreenEventHook ) where @@ -43,9 +44,10 @@ -- > import XMonad -- > import XMonad.Hooks.EwmhDesktops -- > --- > main = xmonad $ ewmh defaultConfig +-- > main = xmonad $ ewmh defaultConfig{ handleEventHook = +-- > handleEventHook defaultConfig <+> fullscreenEventHook } -- --- You may also be interested in 'avoidStruts' from XMonad.Hooks.ManageDocks. +-- You may also be interested in 'avoidStruts' from "XMonad.Hooks.ManageDocks". -- | Add EWMH functionality to the given config. See above for an example. @@ -116,18 +118,23 @@ -- * _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) +ewmhDesktopsEventHook = ewmhDesktopsEventHookCustom id -handle :: Event -> X () -handle ClientMessageEvent { +-- | +-- Generalized version of ewmhDesktopsEventHook that allows an arbitrary +-- user-specified function to transform the workspace list (post-sorting) +ewmhDesktopsEventHookCustom :: ([WindowSpace] -> [WindowSpace]) -> Event -> X All +ewmhDesktopsEventHookCustom f e = handle f e >> return (All True) + +handle :: ([WindowSpace] -> [WindowSpace]) -> Event -> X () +handle f (ClientMessageEvent { ev_window = w, ev_message_type = mt, ev_data = d - } = withWindowSet $ \s -> do + }) = withWindowSet $ \s -> do sort' <- getSortByIndex - let ws = sort' $ W.workspaces s + let ws = f $ sort' $ W.workspaces s a_cd <- getAtom "_NET_CURRENT_DESKTOP" a_d <- getAtom "_NET_WM_DESKTOP" @@ -154,17 +161,19 @@ -- The Message is unknown to us, but that is ok, not all are meant -- to be handled by the window manager return () -handle _ = 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. +-- +-- Note this is not included in 'ewmh'. fullscreenEventHook :: Event -> X All fullscreenEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do - state <- getAtom "_NET_WM_STATE" + wmstate <- getAtom "_NET_WM_STATE" fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN" - wstate <- fromMaybe [] `fmap` getProp32 state win + wstate <- fromMaybe [] `fmap` getProp32 wmstate win let isFull = fromIntegral fullsc `elem` wstate @@ -173,9 +182,9 @@ add = 1 toggle = 2 ptype = 4 -- The atom property type for changeProperty - chWstate f = io $ changeProperty32 dpy win state ptype propModeReplace (f wstate) + chWstate f = io $ changeProperty32 dpy win wmstate ptype propModeReplace (f wstate) - when (typ == state && fi fullsc `elem` dats) $ do + when (typ == wmstate && 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 diff --git a/XMonad/Hooks/FadeInactive.hs b/XMonad/Hooks/FadeInactive.hs --- a/XMonad/Hooks/FadeInactive.hs +++ b/XMonad/Hooks/FadeInactive.hs @@ -17,10 +17,12 @@ -- $usage setOpacity, isUnfocused, + isUnfocusedOnCurrentWS, fadeIn, fadeOut, fadeIf, fadeInactiveLogHook, + fadeInactiveCurrentWSLogHook, fadeOutLogHook ) where @@ -58,18 +60,18 @@ | perc < 0 || perc > 1 = round perc -- to maintain backwards-compatability | otherwise = round $ perc * 0xffffffff --- | sets the opacity of a window +-- | Sets the opacity of a window setOpacity :: Window -> Rational -> X () setOpacity w t = withDisplay $ \dpy -> do a <- getAtom "_NET_WM_WINDOW_OPACITY" c <- getAtom "CARDINAL" io $ changeProperty32 dpy w a c propModeReplace [rationalToOpacity t] --- | fades a window out by setting the opacity +-- | Fades a window out by setting the opacity fadeOut :: Rational -> Window -> X () fadeOut = flip setOpacity --- | makes a window completely opaque +-- | Makes a window completely opaque fadeIn :: Window -> X () fadeIn = fadeOut 1 @@ -78,15 +80,34 @@ fadeIf :: Query Bool -> Rational -> Query Rational fadeIf qry amt = qry >>= \b -> return $ if b then amt else 1 --- | sets the opacity of inactive windows to the specified amount +-- | Sets the opacity of inactive windows to the specified amount fadeInactiveLogHook :: Rational -> X () fadeInactiveLogHook = fadeOutLogHook . fadeIf isUnfocused --- | returns True if the window doesn't have the focus. +-- | Set the opacity of inactive windows, on the current workspace, to the +-- specified amount. This is specifically usefull in a multi monitor setup. See +-- 'isUnfocusedOnCurrentWS'. +fadeInactiveCurrentWSLogHook :: Rational -> X () +fadeInactiveCurrentWSLogHook = fadeOutLogHook . fadeIf isUnfocusedOnCurrentWS + +-- | Returns True if the window doesn't have the focus. isUnfocused :: Query Bool isUnfocused = ask >>= \w -> liftX . gets $ maybe True (w /=) . W.peek . windowset --- | fades out every window by the amount returned by the query. +-- | Returns True if the window doesn't have the focus, and the window is on the +-- current workspace. This is specifically handy in a multi monitor setup +-- (xinerama) where multiple workspaces are visible. Using this, non-focused +-- workspaces are are not faded out making it easier to look and read the +-- content on them. +isUnfocusedOnCurrentWS :: Query Bool +isUnfocusedOnCurrentWS = do + w <- ask + ws <- liftX $ gets windowset + let thisWS = w `elem` W.index ws + unfocused = maybe True (w /=) $ W.peek ws + return $ thisWS && unfocused + +-- | Fades out every window by the amount returned by the query. fadeOutLogHook :: Query Rational -> X () fadeOutLogHook qry = withWindowSet $ \s -> do let visibleWins = (W.integrate' . W.stack . W.workspace . W.current $ s) ++ diff --git a/XMonad/Hooks/FadeWindows.hs b/XMonad/Hooks/FadeWindows.hs --- a/XMonad/Hooks/FadeWindows.hs +++ b/XMonad/Hooks/FadeWindows.hs @@ -105,7 +105,7 @@ -- -- "XMonad.Doc.Extending#Editing_the_event_hook" -- (which sadly doesnt exist at the time of writing...) --- +-- -- /WARNING:/ This module is very good at triggering bugs in -- compositing managers. Symptoms range from windows not being -- repainted until the compositing manager is restarted or the diff --git a/XMonad/Hooks/ICCCMFocus.hs b/XMonad/Hooks/ICCCMFocus.hs --- a/XMonad/Hooks/ICCCMFocus.hs +++ b/XMonad/Hooks/ICCCMFocus.hs @@ -18,8 +18,9 @@ -- @ ----------------------------------------------------------------------------- module XMonad.Hooks.ICCCMFocus +{-# DEPRECATED "XMonad.Hooks.ICCCMFocus: xmonad>0.10 core merged issue 177" #-} ( - atom_WM_TAKE_FOCUS + atom_WM_TAKE_FOCUS , takeFocusX , takeTopFocus ) where @@ -27,31 +28,15 @@ import XMonad import XMonad.Hooks.SetWMName import qualified XMonad.StackSet as W -import Control.Monad -atom_WM_TAKE_FOCUS :: - X Atom -atom_WM_TAKE_FOCUS = - getAtom "WM_TAKE_FOCUS" - takeFocusX :: Window -> X () -takeFocusX w = - withWindowSet . const $ do - dpy <- asks display - wmtakef <- atom_WM_TAKE_FOCUS - wmprot <- atom_WM_PROTOCOLS - protocols <- io $ getWMProtocols dpy w - when (wmtakef `elem` protocols) $ - io . allocaXEvent $ \ev -> do - setEventType ev clientMessage - setClientMessageEvent ev w wmprot 32 wmtakef currentTime - sendEvent dpy w False noEventMask ev +takeFocusX _w = return () -- | The value to add to your log hook configuration. takeTopFocus :: X () takeTopFocus = - (withWindowSet $ maybe (setFocusX =<< asks theRoot) takeFocusX . W.peek) >> setWMName "LG3D" + (withWindowSet $ maybe (setFocusX =<< asks theRoot) takeFocusX . W.peek) >> setWMName "LG3D" diff --git a/XMonad/Hooks/ManageDocks.hs b/XMonad/Hooks/ManageDocks.hs --- a/XMonad/Hooks/ManageDocks.hs +++ b/XMonad/Hooks/ManageDocks.hs @@ -111,8 +111,8 @@ desk <- getAtom "_NET_WM_WINDOW_TYPE_DESKTOP" mbr <- getProp32s "_NET_WM_WINDOW_TYPE" w case mbr of - Just [r] -> return $ elem (fromIntegral r) [dock, desk] - _ -> return False + Just rs -> return $ any (`elem` [dock,desk]) (map fromIntegral rs) + _ -> return False -- | Whenever a new dock appears, refresh the layout immediately to avoid the -- new dock. diff --git a/XMonad/Hooks/Script.hs b/XMonad/Hooks/Script.hs --- a/XMonad/Hooks/Script.hs +++ b/XMonad/Hooks/Script.hs @@ -26,8 +26,6 @@ -- import XMonad -import System.Directory - -- $usage -- -- This module allows you to run a centrally located script with the text @@ -47,7 +45,7 @@ -- | Execute a named script hook execScriptHook :: MonadIO m => String -> m () -execScriptHook hook = io $ do - home <- getHomeDirectory - let script = home ++ "/.xmonad/hooks " +execScriptHook hook = do + xmonadDir <- getXMonadDir + let script = xmonadDir ++ "/hooks " spawn (script ++ hook) diff --git a/XMonad/Hooks/ToggleHook.hs b/XMonad/Hooks/ToggleHook.hs --- a/XMonad/Hooks/ToggleHook.hs +++ b/XMonad/Hooks/ToggleHook.hs @@ -63,10 +63,11 @@ {- The current state is kept here -} -data HookState = HookState { hooks :: Map String (Bool, Bool) } deriving (Typeable) +data HookState = HookState { hooks :: Map String (Bool, Bool) } deriving (Typeable, Read, Show) instance ExtensionClass HookState where initialValue = HookState empty + extensionType = PersistentExtension modify' :: String -> ((Bool, Bool) -> (Bool, Bool)) -> X () modify' n f = XS.modify (HookState . setter . hooks) diff --git a/XMonad/Hooks/UrgencyHook.hs b/XMonad/Hooks/UrgencyHook.hs --- a/XMonad/Hooks/UrgencyHook.hs +++ b/XMonad/Hooks/UrgencyHook.hs @@ -59,6 +59,7 @@ dzenUrgencyHook, DzenUrgencyHook(..), NoUrgencyHook(..), + BorderUrgencyHook(..), FocusHook(..), minutes, seconds, -- * Stuff for developers: @@ -67,6 +68,7 @@ SpawnUrgencyHook(..), UrgencyHook(urgencyHook), Interval, + borderUrgencyHook, focusHook, spawnUrgencyHook, stdoutUrgencyHook ) where import XMonad @@ -83,6 +85,7 @@ import Data.List (delete, (\\)) import Data.Maybe (listToMaybe, maybeToList) import qualified Data.Set as S +import System.IO (hPutStrLn, stderr) -- $usage -- @@ -388,9 +391,12 @@ -- | The class definition, and some pre-defined instances. -class (Read h, Show h) => UrgencyHook h where +class UrgencyHook h where urgencyHook :: h -> Window -> X () +instance UrgencyHook (Window -> X ()) where + urgencyHook = id + data NoUrgencyHook = NoUrgencyHook deriving (Read, Show) instance UrgencyHook NoUrgencyHook where @@ -418,11 +424,40 @@ > withUrgencyHook FocusHook $ myconfig { ... -} +focusHook :: Window -> X () +focusHook = urgencyHook FocusHook data FocusHook = FocusHook deriving (Read, Show) instance UrgencyHook FocusHook where urgencyHook _ _ = focusUrgent +-- | A hook that sets the border color of an urgent window. The color +-- will remain until the next time the window gains or loses focus, at +-- which point the standard border color from the XConfig will be applied. +-- You may want to use suppressWhen = Never with this: +-- +-- > withUrgencyHookC BorderUrgencyHook { urgencyBorderColor = "#ff0000" } urgencyConfig { suppressWhen = Never } ... +-- +-- (This should be @urgentBorderColor@ but that breaks "XMonad.Layout.Decoration". +-- @borderColor@ breaks anyone using 'XPConfig' from "XMonad.Prompt". We need to +-- think a bit more about namespacing issues, maybe.) + +borderUrgencyHook :: String -> Window -> X () +borderUrgencyHook = urgencyHook . BorderUrgencyHook +data BorderUrgencyHook = BorderUrgencyHook { urgencyBorderColor :: !String } + deriving (Read, Show) + +instance UrgencyHook BorderUrgencyHook where + urgencyHook BorderUrgencyHook { urgencyBorderColor = cs } w = + withDisplay $ \dpy -> io $ do + c' <- initColor dpy cs + case c' of + Just c -> setWindowBorder dpy w c + _ -> hPutStrLn stderr $ concat ["Warning: bad urgentBorderColor " + ,show cs + ," in BorderUrgencyHook" + ] + -- | Flashes when a window requests your attention and you can't see it. -- Defaults to a duration of five seconds, and no extra args to dzen. -- See 'DzenUrgencyHook'. @@ -432,12 +467,16 @@ -- | Spawn a commandline thing, appending the window id to the prefix string -- you provide. (Make sure to add a space if you need it.) Do your crazy -- xcompmgr thing. +spawnUrgencyHook :: String -> Window -> X () +spawnUrgencyHook = urgencyHook . SpawnUrgencyHook newtype SpawnUrgencyHook = SpawnUrgencyHook String deriving (Read, Show) instance UrgencyHook SpawnUrgencyHook where urgencyHook (SpawnUrgencyHook prefix) w = spawn $ prefix ++ show w -- | For debugging purposes, really. +stdoutUrgencyHook :: Window -> X () +stdoutUrgencyHook = urgencyHook StdoutUrgencyHook data StdoutUrgencyHook = StdoutUrgencyHook deriving (Read, Show) instance UrgencyHook StdoutUrgencyHook where diff --git a/XMonad/Hooks/XPropManage.hs b/XMonad/Hooks/XPropManage.hs --- a/XMonad/Hooks/XPropManage.hs +++ b/XMonad/Hooks/XPropManage.hs @@ -18,8 +18,7 @@ xPropManageHook, XPropMatch, pmX, pmP ) where -import Prelude hiding (catch) -import Control.Exception +import Control.Exception as E import Data.Char (chr) import Data.Monoid (mconcat, Endo(..)) @@ -76,7 +75,7 @@ getProp :: Display -> Window -> Atom -> X ([String]) getProp d w p = do - prop <- io $ catch (getTextProperty d w p >>= wcTextPropertyToTextList d) (\(_ :: IOException) -> return [[]]) + prop <- io $ E.catch (getTextProperty d w p >>= wcTextPropertyToTextList d) (\(_ :: IOException) -> return [[]]) let filt q | q == wM_COMMAND = concat . map splitAtNull | otherwise = id return (filt p prop) diff --git a/XMonad/Layout/BorderResize.hs b/XMonad/Layout/BorderResize.hs --- a/XMonad/Layout/BorderResize.hs +++ b/XMonad/Layout/BorderResize.hs @@ -59,10 +59,8 @@ data BorderResize a = BR (M.Map Window RectWithBorders) deriving (Show, Read) -brBorderOffset :: Position -brBorderOffset = 5 brBorderSize :: Dimension -brBorderSize = 10 +brBorderSize = 2 borderResize :: l a -> ModifiedLayout BorderResize l a borderResize = ModifiedLayout (BR M.empty) @@ -147,10 +145,10 @@ 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) + [((Rectangle (x + fi wh - fi brBorderSize) y brBorderSize ht), xC_right_side , RightSideBorder), + ((Rectangle x y brBorderSize ht) , xC_left_side , LeftSideBorder), + ((Rectangle x y wh brBorderSize) , xC_top_side , TopSideBorder), + ((Rectangle x (y + fi ht - fi brBorderSize) wh brBorderSize), xC_bottom_side, BottomSideBorder) ] handleResize :: [(Window, (BorderType, Window, Rectangle))] -> Event -> X () diff --git a/XMonad/Layout/Fullscreen.hs b/XMonad/Layout/Fullscreen.hs --- a/XMonad/Layout/Fullscreen.hs +++ b/XMonad/Layout/Fullscreen.hs @@ -53,7 +53,7 @@ -- To use this module, add 'fullscreenEventHook' and 'fullscreenManageHook' -- to your config, i.e. -- --- > xmonad defaultconfig { eventHook = fullscreenEventHook, +-- > xmonad defaultconfig { handleEventHook = fullscreenEventHook, -- > manageHook = fullscreenManageHook, -- > layoutHook = myLayouts } -- @@ -124,11 +124,11 @@ -- Modify the floating member of the stack set directly; this is the hackish part. Just FullscreenChanged -> do - state <- get - let ws = windowset state + st <- get + let ws = windowset st flt = W.floating ws flt' = M.intersectionWith doFull fulls flt - put state {windowset = ws {W.floating = M.union flt' flt}} + put st {windowset = ws {W.floating = M.union flt' flt}} return $ Just $ FullscreenFloat frect $ M.filter snd fulls where doFull (_, True) _ = frect doFull (rect, False) _ = rect @@ -174,9 +174,9 @@ -- | The event hook required for the layout modifiers to work fullscreenEventHook :: Event -> X All fullscreenEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do - state <- getAtom "_NET_WM_STATE" + wmstate <- getAtom "_NET_WM_STATE" fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN" - wstate <- fromMaybe [] `fmap` getProp32 state win + wstate <- fromMaybe [] `fmap` getProp32 wmstate win let fi :: (Integral i, Num n) => i -> n fi = fromIntegral isFull = fi fullsc `elem` wstate @@ -184,8 +184,8 @@ add = 1 toggle = 2 ptype = 4 - chWState f = io $ changeProperty32 dpy win state ptype propModeReplace (f wstate) - when (typ == state && fi fullsc `elem` dats) $ do + chWState f = io $ changeProperty32 dpy win wmstate ptype propModeReplace (f wstate) + when (typ == wmstate && fi fullsc `elem` dats) $ do when (action == add || (action == toggle && not isFull)) $ do chWState (fi fullsc:) broadcastMessage $ AddFullscreen win diff --git a/XMonad/Layout/Groups.hs b/XMonad/Layout/Groups.hs --- a/XMonad/Layout/Groups.hs +++ b/XMonad/Layout/Groups.hs @@ -70,9 +70,9 @@ -- group, and the layout with which the groups themselves will -- be arranged on the screen. -- --- The "XMonad.Layout.Groups.Examples" and "XMonad.Layout.Groups.Wmii" --- modules contain examples of layouts that can be defined with this --- combinator. They're also the recommended starting point +-- The "XMonad.Layout.Groups.Examples" and "XMonad.Layout.Groups.Wmii" +-- modules contain examples of layouts that can be defined with this +-- combinator. They're also the recommended starting point -- if you are a beginner and looking for something you can use easily. -- -- One thing to note is that 'Groups'-based layout have their own @@ -81,7 +81,7 @@ -- will have no visible effect, and those like 'XMonad.StackSet.focusUp' -- will focus the windows in an unpredictable order. For a better way of -- rearranging windows and moving focus in such a layout, see the --- example 'ModifySpec's (to be passed to the 'Modify' message) provided +-- example 'ModifySpec's (to be passed to the 'Modify' message) provided -- by this module. -- -- If you use both 'Groups'-based and other layouts, The "XMonad.Layout.Groups.Helpers" @@ -105,7 +105,7 @@ data Uniq = U Integer Integer deriving (Eq, Show, Read) --- | From a seed, generate an infinite list of keys and a new +-- | From a seed, generate an infinite list of keys and a new -- seed. All keys generated with this method will be different -- provided you don't use 'gen' again with a key from the list. -- (if you need to do that, see 'split' instead) @@ -121,7 +121,7 @@ -- | Add a unique identity to a layout so we can -- follow it around. -data WithID l a = ID { getID :: Uniq +data WithID l a = ID { getID :: Uniq , unID :: (l a)} deriving (Show, Read) @@ -133,16 +133,16 @@ ID id1 _ == ID id2 _ = id1 == id2 instance LayoutClass l a => LayoutClass (WithID l) a where - runLayout ws@W.Workspace { W.layout = ID id l } r - = do (placements, ml') <- flip runLayout r + runLayout ws@W.Workspace { W.layout = ID id l } r + = do (placements, ml') <- flip runLayout r ws { W.layout = l} return (placements, ID id <$> ml') handleMessage (ID id l) sm = do ml' <- handleMessage l sm return $ ID id <$> ml' description (ID _ l) = description l - + -- * The 'Groups' layout @@ -211,7 +211,7 @@ -- | Adapt our groups to a new stack. -- This algorithm handles window additions and deletions correctly, --- ignores changes in window ordering, and tries to react to any +-- ignores changes in window ordering, and tries to react to any -- other stack changes as gracefully as possible. readapt :: Eq a => Zipper a -> Groups l l2 a -> Groups l l2 a readapt z g = let mf = getFocusZ z @@ -233,7 +233,7 @@ removeDeleted z = filterZ_ (flip elemZ z) -- | Identify the windows not already in a group. -findNewWindows :: Eq a => [a] -> Zipper (Group l a) +findNewWindows :: Eq a => [a] -> Zipper (Group l a) -> (Zipper (Group l a), [a]) findNewWindows as gs = (gs, foldrZ_ removePresent as gs) where removePresent g as' = filter (not . flip elemZ (gZipper g)) as' @@ -279,10 +279,10 @@ let placements = concatMap fst results newL = justMakeNew l mpart' (map snd results ++ hidden') - + return $ (placements, newL) - handleMessage l@(Groups _ p _ _) sm | Just (ToEnclosing sm') <- fromMessage sm + handleMessage l@(Groups _ p _ _) sm | Just (ToEnclosing sm') <- fromMessage sm = do mp' <- handleMessage p sm' return $ maybeMakeNew l mp' [] @@ -316,7 +316,7 @@ step _ = return Nothing -justMakeNew :: Groups l l2 a -> Maybe (l2 (Group l a)) -> [Maybe (WithID l a)] +justMakeNew :: Groups l l2 a -> Maybe (l2 (Group l a)) -> [Maybe (WithID l a)] -> Maybe (Groups l l2 a) justMakeNew g mpart' ml's = Just g { partitioner = fromMaybe (partitioner g) mpart' , groups = combine (groups g) ml's } @@ -339,7 +339,7 @@ -- ** ModifySpec type --- | Type of functions describing modifications to a 'Groups' layout. They +-- | Type of functions describing modifications to a 'Groups' layout. They -- are transformations on 'Zipper's of groups. -- -- Things you shouldn't do: @@ -358,8 +358,8 @@ -- 'ModifySpec's as arguments, or returning them, you'll need to write a type -- signature and add @{-# LANGUAGE Rank2Types #-}@ at the beginning type ModifySpec = forall l. WithID l Window - -> Zipper (Group l Window) -> Zipper (Group l Window) + -> Zipper (Group l Window) -- | Apply a ModifySpec. applySpec :: ModifySpec -> Groups l l2 Window -> Maybe (Groups l l2 Window) @@ -367,7 +367,7 @@ g' = flip modifyGroups g $ f (ID id $ baseLayout g) >>> toTags >>> foldr reID ((ids, []), []) - >>> snd + >>> snd >>> fromTags in case groups g == groups g' of True -> Nothing @@ -448,7 +448,7 @@ -- helper _moveToNewGroup :: WithID l Window -> W.Stack (Group l Window) - -> (Group l Window -> Zipper (Group l Window) + -> (Group l Window -> Zipper (Group l Window) -> Zipper (Group l Window)) -> Zipper (Group l Window) _moveToNewGroup l0 s insertX | G l (Just f) <- W.focus s @@ -456,7 +456,7 @@ s' = s { W.focus = G l f' } in insertX (G l0 $ singletonZ w) $ Just s' _moveToNewGroup _ s _ = Just s - + -- | Move the focused window to a new group before the current one. moveToNewGroupUp :: ModifySpec moveToNewGroupUp _ Nothing = Nothing diff --git a/XMonad/Layout/Groups/Examples.hs b/XMonad/Layout/Groups/Examples.hs --- a/XMonad/Layout/Groups/Examples.hs +++ b/XMonad/Layout/Groups/Examples.hs @@ -67,12 +67,12 @@ -- $usage --- This module contains example 'G.Groups'-based layouts. +-- This module contains example 'G.Groups'-based layouts. -- You can either import this module directly, or look at its source -- for ideas of how "XMonad.Layout.Groups" may be used. -- -- You can use the contents of this module by adding --- +-- -- > import XMonad.Layout.Groups.Examples -- -- to the top of your @.\/.xmonad\/xmonad.hs@. @@ -80,10 +80,10 @@ -- For more information on using any of the layouts, jump directly -- to its \"Example\" section. -- --- Whichever layout you choose to use, you will probably want to be +-- Whichever layout you choose to use, you will probably want to be -- able to move focus and windows between groups in a consistent -- manner. For this, you should take a look at the functions from --- the "XMonad.Layout.Groups.Helpers" module, which are all +-- the "XMonad.Layout.Groups.Helpers" module, which are all -- re-exported by this module. -- -- For more information on how to extend your layour hook and key bindings, see @@ -99,7 +99,7 @@ instance Eq a => EQF GroupEQ (G.Group l a) where eq _ (G.G l1 _) (G.G l2 _) = G.sameID l1 l2 -zoomRowG :: (Eq a, Show a, Read a, Show (l a), Read (l a)) +zoomRowG :: (Eq a, Show a, Read a, Show (l a), Read (l a)) => ZoomRow GroupEQ (G.Group l a) zoomRowG = zoomRowWith GroupEQ @@ -171,10 +171,10 @@ -- $example2 -- A layout which arranges windows into tabbed groups, and the groups --- themselves according to XMonad's default algorithm +-- themselves according to XMonad's default algorithm -- (@'Tall' ||| 'Mirror' 'Tall' ||| 'Full'@). As their names --- indicate, 'tallTabs' starts as 'Tall', 'mirrorTallTabs' starts --- as 'Mirror' 'Tall' and 'fullTabs' starts as 'Full', but in any +-- indicate, 'tallTabs' starts as 'Tall', 'mirrorTallTabs' starts +-- as 'Mirror' 'Tall' and 'fullTabs' starts as 'Full', but in any -- case you can freely switch between the three afterwards. -- -- You can use any of these three layouts by including it in your layout hook. @@ -204,7 +204,7 @@ defaultTiledTabsConfig :: TiledTabsConfig DefaultShrinker defaultTiledTabsConfig = TTC 1 0.5 (3/100) 1 0.5 (3/100) shrinkText defaultTheme -fullTabs c = _tab c $ G.group _tabs $ Full ||| _vert c ||| _horiz c +fullTabs c = _tab c $ G.group _tabs $ Full ||| _vert c ||| _horiz c tallTabs c = _tab c $ G.group _tabs $ _vert c ||| _horiz c ||| Full diff --git a/XMonad/Layout/Groups/Helpers.hs b/XMonad/Layout/Groups/Helpers.hs --- a/XMonad/Layout/Groups/Helpers.hs +++ b/XMonad/Layout/Groups/Helpers.hs @@ -69,7 +69,7 @@ -- This module provides actions that try to send 'G.GroupsMessage's, and -- fall back to the classic way if the current layout doesn't hande them. -- They are in the section called \"Layout-generic actions\". --- +-- -- The sections \"Groups-specific actions\" contains actions that don't make -- sense for non-'G.Groups'-based layouts. These are simply wrappers around -- the equivalent 'G.GroupsMessage's, but are included so you don't have to @@ -139,7 +139,7 @@ focusNonFloat :: X () focusNonFloat = alt2 G.Refocus helper - where helper = withFocused $ \w -> do + where helper = withFocused $ \w -> do ws <- getWindows floats <- getFloats let (before, after) = span (/=w) ws @@ -170,7 +170,7 @@ focusFloatUp :: X () focusFloatUp = focusHelper id reverse - + focusFloatDown :: X () focusFloatDown = focusHelper id id diff --git a/XMonad/Layout/Groups/Wmii.hs b/XMonad/Layout/Groups/Wmii.hs --- a/XMonad/Layout/Groups/Wmii.hs +++ b/XMonad/Layout/Groups/Wmii.hs @@ -17,7 +17,7 @@ module XMonad.Layout.Groups.Wmii ( -- * Usage -- $usage - + wmii , zoomGroupIn , zoomGroupOut @@ -48,9 +48,9 @@ -- $usage --- This module provides a layout inspired by the one used by the wmii +-- This module provides a layout inspired by the one used by the wmii -- () window manager. --- Windows are arranged into groups in a horizontal row, and each group can lay out +-- Windows are arranged into groups in a horizontal row, and each group can lay out -- its windows -- -- * by maximizing the focused one @@ -59,16 +59,16 @@ -- -- * by arranging them in a column. -- --- As the groups are arranged in a 'ZoomRow', the relative width of each group can be --- increased or decreased at will. Groups can also be set to use the whole screen +-- As the groups are arranged in a 'ZoomRow', the relative width of each group can be +-- increased or decreased at will. Groups can also be set to use the whole screen -- whenever they have focus. -- -- You can use the contents of this module by adding --- +-- -- > import XMonad.Layout.Groups.Wmii -- --- to the top of your @.\/.xmonad\/xmonad.hs@, and adding 'wmii' --- (with a 'Shrinker' and decoration 'Theme' as +-- to the top of your @.\/.xmonad\/xmonad.hs@, and adding 'wmii' +-- (with a 'Shrinker' and decoration 'Theme' as -- parameters) to your layout hook, for example: -- -- > myLayout = wmii shrinkText defaultTheme @@ -92,10 +92,10 @@ wmii s t = G.group innerLayout zoomRowG where column = named "Column" $ Tall 0 (3/100) (1/2) tabs = named "Tabs" $ Simplest - innerLayout = renamed [CutWordsLeft 3] + innerLayout = renamed [CutWordsLeft 3] $ addTabs s t - $ ignore NextLayout - $ ignore (JumpToLayout "") $ unEscape + $ ignore NextLayout + $ ignore (JumpToLayout "") $ unEscape $ column ||| tabs ||| Full -- | Increase the width of the focused group diff --git a/XMonad/Layout/ImageButtonDecoration.hs b/XMonad/Layout/ImageButtonDecoration.hs --- a/XMonad/Layout/ImageButtonDecoration.hs +++ b/XMonad/Layout/ImageButtonDecoration.hs @@ -140,7 +140,7 @@ closeButton :: [[Bool]] -closeButton = convertToBool closeButton' +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. diff --git a/XMonad/Layout/LayoutBuilderP.hs b/XMonad/Layout/LayoutBuilderP.hs --- a/XMonad/Layout/LayoutBuilderP.hs +++ b/XMonad/Layout/LayoutBuilderP.hs @@ -40,7 +40,7 @@ -- -- compare "XMonad.Util.Invisible" --- | Type class for predicates. This enables us to manage not only Windows, +-- | Type class for predicates. This enables us to manage not only Windows, -- but any objects, for which instance Predicate is defined. -- -- Another instance exists in XMonad.Util.WindowPropertiesRE in xmonad-extras diff --git a/XMonad/Layout/Minimize.hs b/XMonad/Layout/Minimize.hs --- a/XMonad/Layout/Minimize.hs +++ b/XMonad/Layout/Minimize.hs @@ -84,12 +84,12 @@ setMinimizedState win st f = do setWMState win st withDisplay $ \dpy -> do - state <- getAtom "_NET_WM_STATE" + wm_state <- getAtom "_NET_WM_STATE" mini <- getAtom "_NET_WM_STATE_HIDDEN" - wstate <- fromMaybe [] `fmap` getProp32 state win + wstate <- fromMaybe [] `fmap` getProp32 wm_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) + io $ changeProperty32 dpy win wm_state ptype propModeReplace (f fi_mini wstate) setMinimized :: Window -> X () setMinimized win = setMinimizedState win iconicState (:) diff --git a/XMonad/Layout/MouseResizableTile.hs b/XMonad/Layout/MouseResizableTile.hs --- a/XMonad/Layout/MouseResizableTile.hs +++ b/XMonad/Layout/MouseResizableTile.hs @@ -136,55 +136,55 @@ mouseResizableTileMirrored = mouseResizableTile { isMirrored = True } instance LayoutClass MouseResizableTile Window where - doLayout state sr (W.Stack w l r) = do - drg <- draggerGeometry $ draggerType state + doLayout st sr (W.Stack w l r) = do + drg <- draggerGeometry $ draggerType st 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, preparedDraggers) = tile (nmaster st) (masterFrac st) + (leftFracs st ++ repeat (slaveFrac st)) + (rightFracs st ++ repeat (slaveFrac st)) sr' num drg rects' = map (mirrorAdjust id mirrorRect . sanitizeRectangle sr') rects - mapM_ deleteDragger $ draggers state + mapM_ deleteDragger $ draggers st (draggerWrs, newDraggers) <- unzip <$> mapM - (createDragger sr . adjustForMirror (isMirrored state)) + (createDragger sr . adjustForMirror (isMirrored st)) preparedDraggers - return (draggerWrs ++ zip wins rects', Just $ state { draggers = newDraggers, + return (draggerWrs ++ zip wins rects', Just $ st { draggers = newDraggers, focusPos = length l, numWindows = length wins }) where - mirrorAdjust a b = if (isMirrored state) + mirrorAdjust a b = if (isMirrored st) then b else a - handleMessage state m + handleMessage st m | Just (IncMasterN d) <- fromMessage m = - return $ Just $ state { nmaster = max 0 (nmaster state + d) } + return $ Just $ st { nmaster = max 0 (nmaster st + d) } | Just Shrink <- fromMessage m = - return $ Just $ state { masterFrac = max 0 (masterFrac state - fracIncrement state) } + return $ Just $ st { masterFrac = max 0 (masterFrac st - fracIncrement st) } | Just Expand <- fromMessage m = - return $ Just $ state { masterFrac = min 1 (masterFrac state + fracIncrement state) } + return $ Just $ st { masterFrac = min 1 (masterFrac st + fracIncrement st) } | Just ShrinkSlave <- fromMessage m = - return $ Just $ modifySlave state (- fracIncrement state) + return $ Just $ modifySlave st (- fracIncrement st) | Just ExpandSlave <- fromMessage m = - return $ Just $ modifySlave state (fracIncrement state) + return $ Just $ modifySlave st (fracIncrement st) | Just (SetMasterFraction f) <- fromMessage m = - return $ Just $ state { masterFrac = max 0 (min 1 f) } + return $ Just $ st { 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)) } + return $ Just $ st { leftFracs = replaceAtPos (slaveFrac st) + (leftFracs st) 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)) } + return $ Just $ st { rightFracs = replaceAtPos (slaveFrac st) + (rightFracs st) 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 + | Just e <- fromMessage m :: Maybe Event = handleResize (draggers st) (isMirrored st) e >> return Nothing + | Just Hide <- fromMessage m = releaseResources >> return (Just $ st { draggers = [] }) + | Just ReleaseResources <- fromMessage m = releaseResources >> return (Just $ st { draggers = [] }) + where releaseResources = mapM_ deleteDragger $ draggers st handleMessage _ _ = return Nothing - description state = mirror "MouseResizableTile" - where mirror = if isMirrored state then ("Mirror " ++) else id + description st = mirror "MouseResizableTile" + where mirror = if isMirrored st then ("Mirror " ++) else id draggerGeometry :: DraggerType -> X DraggerGeometry draggerGeometry (FixedDragger g d) = @@ -203,28 +203,28 @@ 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 +modifySlave st delta = + let pos = focusPos st + num = numWindows st + nmaster' = nmaster st + leftFracs' = leftFracs st + rightFracs' = rightFracs st + slFrac = slaveFrac st 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 + in st { leftFracs = replaceAtPos slFrac leftFracs' draggerPos (max 0 (min 1 (oldFraction + delta))) } - else state + else st else if draggersRight > 0 then let draggerPos = min (draggersRight - 1) (pos - nmaster') oldFraction = (rightFracs' ++ repeat slFrac) !! draggerPos - in state { rightFracs = replaceAtPos slFrac rightFracs' draggerPos + in st { rightFracs = replaceAtPos slFrac rightFracs' draggerPos (max 0 (min 1 (oldFraction + delta))) } - else state + else st replaceAtPos :: (Num t, Eq t) => Rational -> [Rational] -> t -> Rational -> [Rational] replaceAtPos _ [] 0 x' = [x'] diff --git a/XMonad/Layout/OnHost.hs b/XMonad/Layout/OnHost.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/OnHost.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.OnHost +-- Copyright : (c) Brandon S Allbery, Brent Yorgey +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : +-- Stability : unstable +-- Portability : unportable +-- +-- Configure layouts on a per-host basis: use layouts and apply +-- layout modifiers selectively, depending on the host. Heavily based on +-- "XMonad.Layout.PerWorkspace" by Brent Yorgey. +----------------------------------------------------------------------------- + +module XMonad.Layout.OnHost (-- * Usage + -- $usage + OnHost + ,onHost + ,onHosts + ,modHost + ,modHosts + ) where + +import XMonad +import qualified XMonad.StackSet as W + +import XMonad.Layout.LayoutModifier + +import Data.Maybe (fromMaybe) +import System.Posix.Env (getEnv) + +-- $usage +-- You can use this module by importing it into your ~\/.xmonad\/xmonad.hs file: +-- +-- > import XMonad.Layout.OnHost +-- +-- and modifying your 'layoutHook' as follows (for example): +-- +-- > layoutHook = modHost "baz" m1 $ -- apply layout modifier m1 to all layouts on host "baz" +-- > onHost "foo" l1 $ -- layout l1 will be used on host "foo". +-- > onHosts ["bar","quux"] l2 $ -- layout l2 will be used on hosts "bar" and "quux". +-- > l3 -- layout l3 will be used on all other hosts. +-- +-- Note that @l1@, @l2@, and @l3@ can be arbitrarily complicated +-- layouts, e.g. @(Full ||| smartBorders $ tabbed shrinkText +-- defaultTConf ||| ...)@, and @m1@ can be any layout modifier, i.e. a +-- function of type @(l a -> ModifiedLayout lm l a)@. +-- +-- In another scenario, suppose you wanted to have layouts A, B, and C +-- available on all hosts, except that on host foo you want +-- layout D instead of C. You could do that as follows: +-- +-- > layoutHook = A ||| B ||| onHost "foo" D C +-- +-- Note that we rely on '$HOST' being set in the environment, as is true on most +-- modern systems; if it's not, you may want to use a wrapper around xmonad or +-- perhaps use 'System.Posix.Env.setEnv' (or 'putEnv') to set it in 'main'. +-- This is to avoid dragging in the network package as an xmonad dependency. +-- If '$HOST' is not defined, it will behave as if the host name never matches. +-- +-- Also note that '$HOST' is usually a fully qualified domain name, not a short name. +-- If you use a short name, this code will try to truncate $HOST to match; this may +-- prove too magical, though, and may change in the future. + +-- | Specify one layout to use on a particular host, and another +-- to use on all others. The second layout can be another call to +-- 'onHost', and so on. +onHost :: (LayoutClass l1 a, LayoutClass l2 a) + => String -- ^ the name of the host to match + -> (l1 a) -- ^ layout to use on the matched host + -> (l2 a) -- ^ layout to use everywhere else + -> OnHost l1 l2 a +onHost host = onHosts [host] + +-- | Specify one layout to use on a particular set of hosts, and +-- another to use on all other hosts. +onHosts :: (LayoutClass l1 a, LayoutClass l2 a) + => [String] -- ^ names of hosts to match + -> (l1 a) -- ^ layout to use on matched hosts + -> (l2 a) -- ^ layout to use everywhere else + -> OnHost l1 l2 a +onHosts hosts l1 l2 = OnHost hosts False l1 l2 + +-- | Specify a layout modifier to apply on a particular host; layouts +-- on all other hosts will remain unmodified. +modHost :: (LayoutClass l a) + => String -- ^ name of the host to match + -> (l a -> ModifiedLayout lm l a) -- ^ the modifier to apply on the matching host + -> l a -- ^ the base layout + -> OnHost (ModifiedLayout lm l) l a +modHost host = modHosts [host] + +-- | Specify a layout modifier to apply on a particular set of +-- hosts; layouts on all other hosts will remain +-- unmodified. +modHosts :: (LayoutClass l a) + => [String] -- ^ names of the hosts to match + -> (l a -> ModifiedLayout lm l a) -- ^ the modifier to apply on the matching hosts + -> l a -- ^ the base layout + -> OnHost (ModifiedLayout lm l) l a +modHosts hosts f l = OnHost hosts False (f l) l + +-- | Structure for representing a host-specific layout along with +-- a layout for all other hosts. We store the names of hosts +-- to be matched, and the two layouts. We save the layout choice in +-- the Bool, to be used to implement description. +data OnHost l1 l2 a = OnHost [String] + Bool + (l1 a) + (l2 a) + deriving (Read, Show) + +instance (LayoutClass l1 a, LayoutClass l2 a, Show a) => LayoutClass (OnHost l1 l2) a where + runLayout (W.Workspace i p@(OnHost hosts _ lt lf) ms) r = do + h <- io $ getEnv "HOST" + if maybe False (`elemFQDN` hosts) h + then do (wrs, mlt') <- runLayout (W.Workspace i lt ms) r + return (wrs, Just $ mkNewOnHostT p mlt') + else do (wrs, mlt') <- runLayout (W.Workspace i lf ms) r + return (wrs, Just $ mkNewOnHostF p mlt') + + handleMessage (OnHost hosts bool lt lf) m + | bool = handleMessage lt m >>= maybe (return Nothing) (\nt -> return . Just $ OnHost hosts bool nt lf) + | otherwise = handleMessage lf m >>= maybe (return Nothing) (\nf -> return . Just $ OnHost hosts bool lt nf) + + description (OnHost _ True l1 _) = description l1 + description (OnHost _ _ _ l2) = description l2 + +-- | Construct new OnHost values with possibly modified layouts. +mkNewOnHostT :: OnHost l1 l2 a -> Maybe (l1 a) -> OnHost l1 l2 a +mkNewOnHostT (OnHost hosts _ lt lf) mlt' = + (\lt' -> OnHost hosts True lt' lf) $ fromMaybe lt mlt' + +mkNewOnHostF :: OnHost l1 l2 a -> Maybe (l2 a) -> OnHost l1 l2 a +mkNewOnHostF (OnHost hosts _ lt lf) mlf' = + (\lf' -> OnHost hosts False lt lf') $ fromMaybe lf mlf' + +-- | 'Data.List.elem' except that if one side has a dot and the other doesn't, we truncate +-- the one that does at the dot. +elemFQDN :: String -> [String] -> Bool +elemFQDN _ [] = False +elemFQDN h0 (h:hs) + | h0 `eqFQDN` h = True + | otherwise = elemFQDN h0 hs + +-- | String equality, possibly truncating one side at a dot. +eqFQDN :: String -> String -> Bool +eqFQDN a b + | '.' `elem` a && '.' `elem` b = a == b + | '.' `elem` a = takeWhile (/= '.') a == b + | '.' `elem` b = a == takeWhile (/= '.') b + | otherwise = a == b diff --git a/XMonad/Layout/Renamed.hs b/XMonad/Layout/Renamed.hs --- a/XMonad/Layout/Renamed.hs +++ b/XMonad/Layout/Renamed.hs @@ -24,7 +24,7 @@ import XMonad.Layout.LayoutModifier -- $usage --- You can use this module by adding +-- You can use this module by adding -- -- > import XMonad.Layout.Renamed -- diff --git a/XMonad/Layout/ShowWName.hs b/XMonad/Layout/ShowWName.hs --- a/XMonad/Layout/ShowWName.hs +++ b/XMonad/Layout/ShowWName.hs @@ -86,18 +86,18 @@ doShow (SWN False _ _ ) _ wrs = return (wrs, Nothing) flashName :: SWNConfig -> Rectangle -> [(a, Rectangle)] -> X ([(a, Rectangle)], Maybe (ShowWName a)) -flashName c (Rectangle _ _ wh ht) wrs = do +flashName c (Rectangle sx sy wh ht) wrs = do d <- asks display n <- withWindowSet (return . S.currentTag) f <- initXMF (swn_font c) - width <- textWidthXMF d f n + width <- fmap (\w -> w + w `div` length n) $ textWidthXMF d f n (as,ds) <- textExtentsXMF f n let hight = as + ds - y = (fi ht - hight + 2) `div` 2 - x = (fi wh - width + 2) `div` 2 + y = fi sy + (fi ht - hight + 2) `div` 2 + x = fi sx + (fi wh - width + 2) `div` 2 w <- createNewWindow (Rectangle (fi x) (fi y) (fi width) (fi hight)) Nothing "" True showWindow w - paintAndWrite w f (fi width) (fi hight) 0 "" "" (swn_color c) (swn_bgcolor c) [AlignCenter] [n] + paintAndWrite w f (fi width) (fi hight) 0 (swn_bgcolor c) "" (swn_color c) (swn_bgcolor c) [AlignCenter] [n] releaseXMF f io $ sync d False i <- startTimer (swn_fade c) diff --git a/XMonad/Layout/Spacing.hs b/XMonad/Layout/Spacing.hs --- a/XMonad/Layout/Spacing.hs +++ b/XMonad/Layout/Spacing.hs @@ -18,6 +18,7 @@ -- $usage spacing, Spacing, + smartSpacing, SmartSpacing, ) where @@ -52,3 +53,17 @@ shrinkRect :: Int -> Rectangle -> Rectangle shrinkRect p (Rectangle x y w h) = Rectangle (x+fi p) (y+fi p) (w-2*fi p) (h-2*fi p) + +-- | Surrounds all windows with blank space, except when the window is the only +-- visible window on the current workspace. +smartSpacing :: Int -> l a -> ModifiedLayout SmartSpacing l a +smartSpacing p = ModifiedLayout (SmartSpacing p) + +data SmartSpacing a = SmartSpacing Int deriving (Show, Read) + +instance LayoutModifier SmartSpacing a where + + pureModifier _ _ _ [x] = ([x], Nothing) + pureModifier (SmartSpacing p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing) + + modifierDescription (SmartSpacing p) = "SmartSpacing " ++ show p diff --git a/XMonad/Layout/Spiral.hs b/XMonad/Layout/Spiral.hs --- a/XMonad/Layout/Spiral.hs +++ b/XMonad/Layout/Spiral.hs @@ -26,7 +26,7 @@ ) where import Data.Ratio -import XMonad +import XMonad hiding ( Rotation ) import XMonad.StackSet ( integrate ) -- $usage diff --git a/XMonad/Layout/TrackFloating.hs b/XMonad/Layout/TrackFloating.hs --- a/XMonad/Layout/TrackFloating.hs +++ b/XMonad/Layout/TrackFloating.hs @@ -45,7 +45,7 @@ instance LayoutModifier TrackFloating Window where - modifyLayoutWithUpdate os@(TrackFloating wasF mw) ws@(W.Workspace{ W.stack = ms }) r + modifyLayoutWithUpdate os@(TrackFloating _wasF mw) ws@(W.Workspace{ W.stack = ms }) r = do winset <- gets windowset let xCur = fmap W.focus xStack @@ -57,7 +57,7 @@ newStack -- focus is floating, so use the remembered focus point | Just isF' <- isF, - isF' || wasF, + isF', Just w <- mw, Just s <- ms, Just ns <- find ((==) w . W.focus) diff --git a/XMonad/Layout/WindowNavigation.hs b/XMonad/Layout/WindowNavigation.hs --- a/XMonad/Layout/WindowNavigation.hs +++ b/XMonad/Layout/WindowNavigation.hs @@ -105,7 +105,7 @@ configurableNavigation conf = ModifiedLayout (WindowNavigation conf (I Nothing)) instance LayoutModifier WindowNavigation Window where - redoLayout (WindowNavigation conf (I state)) rscr (Just s) origwrs = + redoLayout (WindowNavigation conf (I st)) rscr (Just s) origwrs = do XConf { normalBorder = nbc, focusedBorder = fbc, display = dpy } <- ask [uc,dc,lc,rc] <- case brightness conf of @@ -120,8 +120,8 @@ let w = W.focus s r = case filter ((==w).fst) origwrs of ((_,x):_) -> x [] -> rscr - pt = case state of Just (NS ptold _) | ptold `inrect` r -> ptold - _ -> center r + pt = case st of Just (NS ptold _) | ptold `inrect` r -> ptold + _ -> center r existing_wins = W.integrate s wrs = filter ((`elem` existing_wins) . fst) $ filter ((/=r) . snd) $ filter ((/=w) . fst) origwrs @@ -130,8 +130,8 @@ wnavigablec = nub $ concatMap (\d -> map (\(win,_) -> (win,dirc d)) $ take 1 $ navigable d pt wrs) [U,D,R,L] - wothers = case state of Just (NS _ wo) -> map fst wo - _ -> [] + wothers = case st of Just (NS _ wo) -> map fst wo + _ -> [] mapM_ (sc nbc) (wothers \\ map fst wnavigable) mapM_ (\(win,c) -> sc c win) wnavigablec return (origwrs, Just $ WindowNavigation conf $ I $ Just $ NS pt wnavigable) diff --git a/XMonad/Layout/WorkspaceDir.hs b/XMonad/Layout/WorkspaceDir.hs --- a/XMonad/Layout/WorkspaceDir.hs +++ b/XMonad/Layout/WorkspaceDir.hs @@ -29,21 +29,15 @@ WorkspaceDir, ) where -import Prelude hiding (catch) -import Control.Exception import System.Directory ( setCurrentDirectory, getCurrentDirectory ) import Control.Monad ( when ) import XMonad hiding ( focus ) -import XMonad.Util.Run ( runProcessWithInput ) import XMonad.Prompt ( XPConfig ) import XMonad.Prompt.Directory ( directoryPrompt ) import XMonad.Layout.LayoutModifier import XMonad.StackSet ( tag, currentTag ) -econst :: Monad m => a -> IOException -> m a -econst = const . return - -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: -- @@ -90,8 +84,7 @@ cleanDir x = scd x >> io getCurrentDirectory scd :: String -> X () -scd x = do x' <- io (runProcessWithInput "bash" [] ("echo -n " ++ x) `catch` econst x) - catchIO $ setCurrentDirectory x' +scd x = catchIO $ setCurrentDirectory x changeDir :: XPConfig -> X () changeDir c = directoryPrompt c "Set working directory: " (sendMessage . Chdir) diff --git a/XMonad/Layout/ZoomRow.hs b/XMonad/Layout/ZoomRow.hs --- a/XMonad/Layout/ZoomRow.hs +++ b/XMonad/Layout/ZoomRow.hs @@ -42,7 +42,7 @@ import Data.Maybe (fromMaybe) import Control.Arrow (second) - + -- $usage -- This module provides a layout which places all windows in a single -- row; the size occupied by each individual window can be increased @@ -80,9 +80,9 @@ zoomRow = ZC ClassEQ emptyZ -- $noneq --- Haskell's 'Eq' class is usually concerned with structural equality, whereas +-- Haskell's 'Eq' class is usually concerned with structural equality, whereas -- what this layout really wants is for its elements to have a unique identity, --- even across changes. There are cases (such as, importantly, 'Window's) where +-- even across changes. There are cases (such as, importantly, 'Window's) where -- the 'Eq' instance for a type actually does that, but if you want to lay -- out something more exotic than windows and your 'Eq' means something else, -- you can use the following. @@ -92,7 +92,7 @@ -- sure that the layout never has to handle two \"equal\" elements -- at the same time (it won't do any huge damage, but might behave -- a bit strangely). -zoomRowWith :: (EQF f a, Show (f a), Read (f a), Show a, Read a) +zoomRowWith :: (EQF f a, Show (f a), Read (f a), Show a, Read a) => f a -> ZoomRow f a zoomRowWith f = ZC f emptyZ @@ -185,7 +185,7 @@ -- * LayoutClass instance -instance (EQF f a, Show a, Read a, Show (f a), Read (f a)) +instance (EQF f a, Show a, Read a, Show (f a), Read (f a)) => LayoutClass (ZoomRow f) a where description (ZC _ Nothing) = "ZoomRow" description (ZC _ (Just s)) = "ZoomRow" ++ if full $ W.focus s @@ -197,7 +197,7 @@ doLayout (ZC f zelts) r@(Rectangle _ _ w _) s = let elts = W.integrate' zelts - zelts' = mapZ_ (\a -> fromMaybe (E a 1 False) + zelts' = mapZ_ (\a -> fromMaybe (E a 1 False) $ lookupBy (eq f) a elts) $ Just s elts' = W.integrate' zelts' @@ -251,7 +251,7 @@ = case fromMessage sm of Just (Zoom r') -> Just $ ZC f $ setFocus zelts $ E a (r*r') b Just (ZoomTo r') -> Just $ ZC f $ setFocus zelts $ E a r' b - Just ZoomFullToggle -> pureMessage (ZC f zelts) + Just ZoomFullToggle -> pureMessage (ZC f zelts) $ SomeMessage $ ZoomFull $ not b _ -> Nothing diff --git a/XMonad/Prompt.hs b/XMonad/Prompt.hs --- a/XMonad/Prompt.hs +++ b/XMonad/Prompt.hs @@ -18,20 +18,23 @@ -- $usage mkXPrompt , mkXPromptWithReturn + , mkXPromptWithModes , amberXPConfig , defaultXPConfig , greenXPConfig + , XPMode , XPType (..) , XPPosition (..) , XPConfig (..) , XPrompt (..) , XP - , defaultXPKeymap + , defaultXPKeymap, defaultXPKeymap' + , emacsLikeXPKeymap, emacsLikeXPKeymap' , quit , killBefore, killAfter, startOfLine, endOfLine , pasteString, moveCursor , setInput, getInput - , moveWord, killWord, deleteString + , moveWord, moveWord', killWord, killWord', deleteString , moveHistory, setSuccess, setDone , Direction1D(..) , ComplFunction @@ -65,31 +68,29 @@ , XPState ) where -import Prelude hiding (catch) - -import XMonad hiding (config, cleanMask) -import qualified XMonad as X (numberlockMask) -import qualified XMonad.StackSet as W -import XMonad.Util.Font -import XMonad.Util.Types -import XMonad.Util.XSelection (getSelection) +import XMonad hiding (cleanMask, config) +import qualified XMonad as X (numberlockMask) +import qualified XMonad.StackSet as W +import XMonad.Util.Font +import XMonad.Util.Types +import XMonad.Util.XSelection (getSelection) -import Codec.Binary.UTF8.String (decodeString) -import Control.Applicative ((<$>)) -import Control.Arrow ((&&&),first) -import Control.Concurrent (threadDelay) -import Control.Exception.Extensible hiding (handle) -import Control.Monad.State -import Data.Bits -import Data.Char (isSpace) -import Data.IORef -import Data.List -import Data.Maybe (fromMaybe) -import Data.Set (fromList, toList) -import System.Directory (getAppUserDataDirectory) -import System.IO -import System.Posix.Files -import qualified Data.Map as M +import Codec.Binary.UTF8.String (decodeString,isUTF8Encoded) +import Control.Applicative ((<$>)) +import Control.Arrow (first, (&&&), (***)) +import Control.Concurrent (threadDelay) +import Control.Exception.Extensible as E hiding (handle) +import Control.Monad.State +import Data.Bits +import Data.Char (isSpace) +import Data.IORef +import Data.List +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Set (fromList, toList) +import System.Directory (getAppUserDataDirectory) +import System.IO +import System.Posix.Files -- $usage -- For usage examples see "XMonad.Prompt.Shell", @@ -108,11 +109,12 @@ , screen :: !Rectangle , complWin :: Maybe Window , complWinDim :: Maybe ComplWindowDim - , completionFunction :: String -> IO [String] + , complIndex :: !(Int,Int) , showComplWin :: Bool + , operationMode :: XPOperationMode + , highlightedCompl :: Maybe String , gcon :: !GC , fontS :: !XMonadFont - , xptype :: !XPType , commandHistory :: W.Stack String , offset :: !Int , config :: XPConfig @@ -130,6 +132,7 @@ , borderColor :: String -- ^ Border color , promptBorderWidth :: !Dimension -- ^ Border width , position :: XPPosition -- ^ Position: 'Top' or 'Bottom' + , alwaysHighlight :: !Bool -- ^ Always highlight an item, overriden to True with multiple modes. This implies having *one* column of autocompletions only. , height :: !Dimension -- ^ Window height , historySize :: !Int -- ^ The number of history entries to be saved , historyFilter :: [String] -> [String] @@ -138,6 +141,7 @@ , promptKeymap :: M.Map (KeyMask,KeySym) (XP ()) -- ^ Mapping from key combinations to actions , completionKey :: KeySym -- ^ Key that should trigger completion + , changeModeKey :: KeySym -- ^ Key to change mode (when the prompt has multiple modes) , defaultText :: String -- ^ The text by default in the prompt line , autoComplete :: Maybe Int -- ^ Just x: if only one completion remains, auto-select it, , showCompletionOnTab :: Bool -- ^ Only show list of completions when Tab was pressed @@ -148,6 +152,9 @@ } data XPType = forall p . XPrompt p => XPT p +type ComplFunction = String -> IO [String] +type XPMode = XPType +data XPOperationMode = XPSingleMode ComplFunction XPType | XPMultipleModes (W.Stack XPType) instance Show XPType where show (XPT p) = showXPrompt p @@ -157,6 +164,8 @@ nextCompletion (XPT t) = nextCompletion t commandToComplete (XPT t) = commandToComplete t completionToCommand (XPT t) = completionToCommand t + completionFunction (XPT t) = completionFunction t + modeAction (XPT t) = modeAction t -- | The class prompt types must be an instance of. In order to -- create a prompt you need to create a data type, without parameters, @@ -178,11 +187,13 @@ -- printed in the command line when tab is pressed, given the -- string presently in the command line and the list of -- completion. + -- This function is not used when in multiple modes (because alwaysHighlight in XPConfig is True) nextCompletion :: t -> String -> [String] -> String nextCompletion = getNextOfLastWord -- | This method is used to generate the string to be passed to -- the completion function. + -- This function is not used when in multiple modes (because alwaysHighlight in XPConfig is True) commandToComplete :: t -> String -> String commandToComplete _ = getLastWord @@ -196,6 +207,22 @@ completionToCommand :: t -> String -> String completionToCommand _ c = c + -- | When the prompt has multiple modes, this is the function + -- used to generate the autocompletion list. + -- The argument passed to this function is given by `commandToComplete` + -- The default implementation shows an error message. + completionFunction :: t -> ComplFunction + completionFunction t = \_ -> return ["Completions for " ++ (showXPrompt t) ++ " could not be loaded"] + + -- | When the prompt has multiple modes (created with mkXPromptWithModes), this function is called + -- when the user picks an item from the autocompletion list. + -- The first argument is the prompt (or mode) on which the item was picked + -- The first string argument is the autocompleted item's text. + -- The second string argument is the query made by the user (written in the prompt's buffer). + -- See XMonad/Actions/Launcher.hs for a usage example. + modeAction :: t -> String -> String -> X () + modeAction _ _ _ = return () + data XPPosition = Top | Bottom deriving (Show,Read) @@ -212,6 +239,7 @@ , promptBorderWidth = 1 , promptKeymap = defaultXPKeymap , completionKey = xK_Tab + , changeModeKey = xK_grave , position = Bottom , height = 18 , historySize = 256 @@ -220,29 +248,29 @@ , autoComplete = Nothing , showCompletionOnTab = False , searchPredicate = isPrefixOf + , alwaysHighlight = False } greenXPConfig = defaultXPConfig { fgColor = "green", bgColor = "black", promptBorderWidth = 0 } amberXPConfig = defaultXPConfig { fgColor = "#ca8f2d", bgColor = "black", fgHLight = "#eaaf4c" } -type ComplFunction = String -> IO [String] - -initState :: XPrompt p => Display -> Window -> Window -> Rectangle -> ComplFunction - -> GC -> XMonadFont -> p -> [String] -> XPConfig -> KeyMask -> XPState -initState d rw w s compl gc fonts pt h c nm = +initState :: Display -> Window -> Window -> Rectangle -> XPOperationMode + -> GC -> XMonadFont -> [String] -> XPConfig -> KeyMask -> XPState +initState d rw w s opMode gc fonts h c nm = XPS { dpy = d , rootw = rw , win = w , screen = s , complWin = Nothing , complWinDim = Nothing - , completionFunction = compl , showComplWin = not (showCompletionOnTab c) + , operationMode = opMode + , highlightedCompl = Nothing , gcon = gc , fontS = fonts - , xptype = XPT pt , commandHistory = W.Stack { W.focus = defaultText c , W.up = [] , W.down = h } + , complIndex = (0,0) --(column index, row index), used when `alwaysHighlight` in XPConfig is True , offset = length (defaultText c) , config = c , successful = False @@ -250,6 +278,36 @@ , numlockMask = nm } +-- Returns the current XPType +currentXPMode :: XPState -> XPType +currentXPMode st = case operationMode st of + XPMultipleModes modes -> W.focus modes + XPSingleMode _ xptype -> xptype + +-- When in multiple modes, this function sets the next mode +-- in the list of modes as active +setNextMode :: XPState -> XPState +setNextMode st = case operationMode st of + XPMultipleModes modes -> case W.down modes of + [] -> st -- there is no next mode, return same state + (m:ms) -> let + currentMode = W.focus modes + in st { operationMode = XPMultipleModes W.Stack { W.up = [], W.focus = m, W.down = ms ++ [currentMode]}} --set next and move previous current mode to the of the stack + _ -> st --nothing to do, the prompt's operation has only one mode + +-- Returns the highlighted item +highlightedItem :: XPState -> [String] -> Maybe String +highlightedItem st' completions = case complWinDim st' of + Nothing -> Nothing -- when there isn't any compl win, we can't say how many cols,rows there are + Just winDim -> + let + (_,_,_,_,xx,yy) = winDim + complMatrix = splitInSubListsAt (length yy) (take (length xx * length yy) completions) + (col_index,row_index) = (complIndex st') + in case completions of + [] -> Nothing + _ -> Just $ complMatrix !! col_index !! row_index + -- this would be much easier with functional references command :: XPState -> String command = W.focus . commandHistory @@ -257,6 +315,9 @@ setCommand :: String -> XPState -> XPState setCommand xs s = s { commandHistory = (commandHistory s) { W.focus = xs }} +setHighlightedCompl :: Maybe String -> XPState -> XPState +setHighlightedCompl hc st = st { highlightedCompl = hc} + -- | Sets the input string to the given value. setInput :: String -> XP () setInput = modify . setCommand @@ -284,23 +345,30 @@ fs <- initXMF (font conf) numlock <- gets $ X.numberlockMask let hs = fromMaybe [] $ M.lookup (showXPrompt t) hist - st = initState d rw w s compl gc fs (XPT t) hs conf numlock + om = (XPSingleMode compl (XPT t)) --operation mode + st = initState d rw w s om gc fs hs conf numlock st' <- io $ execStateT runXP st releaseXMF fs io $ freeGC d gc - if successful st' - then do - let prune = take (historySize conf) - io $ writeHistory $ M.insertWith - (\xs ys -> prune . historyFilter conf $ xs ++ ys) - (showXPrompt t) - (prune $ historyFilter conf [command st']) - hist + if successful st' then do + let + prune = take (historySize conf) + + io $ writeHistory $ M.insertWith + (\xs ys -> prune . historyFilter conf $ xs ++ ys) + (showXPrompt t) + (prune $ historyFilter conf [command st']) + hist -- we need to apply historyFilter before as well, since -- otherwise the filter would not be applied if -- there is no history - Just <$> action (command st') + --When alwaysHighlight is True, autocompletion is handled with indexes. + --When it is false, it is handled depending on the prompt buffer's value + let selectedCompletion = case alwaysHighlight (config st') of + False -> command st' + True -> fromMaybe "" $ highlightedCompl st' + Just <$> action selectedCompletion else return Nothing -- | Creates a prompt given: @@ -317,6 +385,60 @@ mkXPrompt :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X ()) -> X () mkXPrompt t conf compl action = mkXPromptWithReturn t conf compl action >> return () +-- | Creates a prompt with multiple modes given: +-- +-- * A non-empty list of modes +-- * A prompt configuration +-- +-- The created prompt allows to switch between modes with `changeModeKey` in `conf`. The modes are +-- instances of XPrompt. See XMonad.Actions.Launcher for more details +-- +-- The argument supplied to the action to execute is always the current highlighted item, +-- that means that this prompt overrides the value `alwaysHighlight` for its configuration to True. +mkXPromptWithModes :: [XPType] -> XPConfig -> X () +mkXPromptWithModes modes conf = do + XConf { display = d, theRoot = rw } <- ask + s <- gets $ screenRect . W.screenDetail . W.current . windowset + hist <- io readHistory + w <- io $ createWin d rw conf s + io $ selectInput d w $ exposureMask .|. keyPressMask + gc <- io $ createGC d w + io $ setGraphicsExposures d gc False + fs <- initXMF (font conf) + numlock <- gets $ X.numberlockMask + let + defaultMode = head modes + hs = fromMaybe [] $ M.lookup (showXPrompt defaultMode) hist + modeStack = W.Stack{ W.focus = defaultMode --current mode + , W.up = [] + , W.down = tail modes --other modes + } + st = initState d rw w s (XPMultipleModes modeStack) gc fs hs conf { alwaysHighlight = True} numlock + st' <- io $ execStateT runXP st + + releaseXMF fs + io $ freeGC d gc + + if successful st' then do + let + prune = take (historySize conf) + + -- insert into history the buffers value + io $ writeHistory $ M.insertWith + (\xs ys -> prune . historyFilter conf $ xs ++ ys) + (showXPrompt defaultMode) + (prune $ historyFilter conf [command st']) + hist + + case operationMode st' of + XPMultipleModes ms -> let + action = modeAction $ W.focus ms + in action (command st') $ (fromMaybe "" $ highlightedCompl st') + _ -> error "The impossible occurred: This prompt runs with multiple modes but they could not be found." --we are creating a prompt with multiple modes, so its operationMode should have been constructed with XPMultipleMode + else + return () + + runXP :: XP () runXP = do (d,w) <- gets (dpy &&& win) @@ -358,11 +480,16 @@ handle :: KeyStroke -> Event -> XP () handle ks@(sym,_) e@(KeyEvent {ev_event_type = t, ev_state = m}) = do complKey <- gets $ completionKey . config + chgModeKey <- gets $ changeModeKey . config c <- getCompletions when (length c > 1) $ modify (\s -> s { showComplWin = True }) if complKey == sym then completionHandle c ks e - else when (t == keyPress) $ keyPressHandle m ks + else if (sym == chgModeKey) then + do + modify setNextMode + updateWindows + else when (t == keyPress) $ keyPressHandle m ks handle _ (ExposeEvent {ev_window = w}) = do st <- get when (win st == w) updateWindows @@ -372,15 +499,20 @@ completionHandle :: [String] -> KeyStroke -> Event -> XP () completionHandle c ks@(sym,_) (KeyEvent { ev_event_type = t, ev_state = m }) = do complKey <- gets $ completionKey . config + alwaysHlight <- gets $ alwaysHighlight . config case () of () | t == keyPress && sym == complKey -> do st <- get - let updateState l = - let new_command = nextCompletion (xptype st) (command st) l - in modify $ \s -> setCommand new_command $ s { offset = length new_command } - updateWins l = redrawWindows l >> - eventLoop (completionHandle l) + let updateState l = case alwaysHlight of + -- modify the buffer's value + False -> let newCommand = nextCompletion (currentXPMode st) (command st) l + in modify $ \s -> setCommand newCommand $ s { offset = length newCommand, highlightedCompl = Just newCommand} + --TODO: Scroll or paginate results + True -> let complIndex' = nextComplIndex st (length l) + highlightedCompl' = highlightedItem st { complIndex = complIndex'} c + in modify $ \s -> setHighlightedCompl highlightedCompl' $ s { complIndex = complIndex' } + updateWins l = redrawWindows l >> eventLoop (completionHandle l) case c of [] -> updateWindows >> eventLoop handle [x] -> updateState [x] >> getCompletions >>= updateWins @@ -390,6 +522,23 @@ -- some other event: go back to main loop completionHandle _ k e = handle k e +--Receives an state of the prompt, the size of the autocompletion list and returns the column,row +--which should be highlighted next +nextComplIndex :: XPState -> Int -> (Int,Int) +nextComplIndex st nitems = case complWinDim st of + Nothing -> (0,0) --no window dims (just destroyed or not created) + Just (_,_,_,_,_,yy) -> let + (ncols,nrows) = (nitems `div` length yy + if (nitems `mod` length yy > 0) then 1 else 0, length yy) + (currentcol,currentrow) = complIndex st + in if (currentcol + 1 >= ncols) then --hlight is in the last column + if (currentrow + 1 < nrows ) then --hlight is still not at the last row + (currentcol, currentrow + 1) + else + (0,0) + else if(currentrow + 1 < nrows) then --hlight not at the last row + (currentcol, currentrow + 1) + else + (currentcol + 1, 0) tryAutoComplete :: XP Bool tryAutoComplete = do @@ -402,7 +551,7 @@ Nothing -> return False where runCompleted cmd delay = do st <- get - let new_command = nextCompletion (xptype st) (command st) [cmd] + let new_command = nextCompletion (currentXPMode st) (command st) [cmd] modify $ setCommand "autocompleting..." updateWindows io $ threadDelay delay @@ -411,19 +560,31 @@ -- KeyPresses +-- | Default key bindings for prompts. Click on the \"Source\" link +-- to the right to see the complete list. See also 'defaultXPKeymap''. defaultXPKeymap :: M.Map (KeyMask,KeySym) (XP ()) -defaultXPKeymap = M.fromList $ +defaultXPKeymap = defaultXPKeymap' isSpace + +-- | A variant of 'defaultXPKeymap' which lets you specify a custom +-- predicate for identifying non-word characters, which affects all +-- the word-oriented commands (move\/kill word). The default is +-- 'isSpace'. For example, by default a path like @foo\/bar\/baz@ +-- would be considered as a single word. You could use a predicate +-- like @(\\c -> isSpace c || c == \'\/\')@ to move through or +-- delete components of the path one at a time. +defaultXPKeymap' :: (Char -> Bool) -> M.Map (KeyMask,KeySym) (XP ()) +defaultXPKeymap' p = M.fromList $ map (first $ (,) controlMask) -- control + [ (xK_u, killBefore) , (xK_k, killAfter) , (xK_a, startOfLine) , (xK_e, endOfLine) , (xK_y, pasteString) - , (xK_Right, moveWord Next) - , (xK_Left, moveWord Prev) - , (xK_Delete, killWord Next) - , (xK_BackSpace, killWord Prev) - , (xK_w, killWord Prev) + , (xK_Right, moveWord' p Next) + , (xK_Left, moveWord' p Prev) + , (xK_Delete, killWord' p Next) + , (xK_BackSpace, killWord' p Prev) + , (xK_w, killWord' p Prev) , (xK_g, quit) , (xK_bracketleft, quit) ] ++ @@ -441,6 +602,57 @@ , (xK_Escape, quit) ] +-- | A keymap with many emacs-like key bindings. Click on the +-- \"Source\" link to the right to see the complete list. +-- See also 'emacsLikeXPKeymap''. +emacsLikeXPKeymap :: M.Map (KeyMask,KeySym) (XP ()) +emacsLikeXPKeymap = emacsLikeXPKeymap' isSpace + +-- | A variant of 'emacsLikeXPKeymap' which lets you specify a custom +-- predicate for identifying non-word characters, which affects all +-- the word-oriented commands (move\/kill word). The default is +-- 'isSpace'. For example, by default a path like @foo\/bar\/baz@ +-- would be considered as a single word. You could use a predicate +-- like @(\\c -> isSpace c || c == \'\/\')@ to move through or +-- delete components of the path one at a time. +emacsLikeXPKeymap' :: (Char -> Bool) -> M.Map (KeyMask,KeySym) (XP ()) +emacsLikeXPKeymap' p = M.fromList $ + map (first $ (,) controlMask) -- control + + [ (xK_z, killBefore) --kill line backwards + , (xK_k, killAfter) -- kill line fowards + , (xK_a, startOfLine) --move to the beginning of the line + , (xK_e, endOfLine) -- move to the end of the line + , (xK_d, deleteString Next) -- delete a character foward + , (xK_b, moveCursor Prev) -- move cursor forward + , (xK_f, moveCursor Next) -- move cursor backward + , (xK_BackSpace, killWord' p Prev) -- kill the previous word + , (xK_y, pasteString) + , (xK_g, quit) + , (xK_bracketleft, quit) + ] ++ + map (first $ (,) mod1Mask) -- meta key + + [ (xK_BackSpace, killWord' p Prev) + , (xK_f, moveWord' p Next) -- move a word forward + , (xK_b, moveWord' p Prev) -- move a word backward + , (xK_d, killWord' p Next) -- kill the next word + , (xK_n, moveHistory W.focusUp') + , (xK_p, moveHistory W.focusDown') + ] + ++ + map (first $ (,) 0) -- + [ (xK_Return, setSuccess True >> setDone True) + , (xK_KP_Enter, setSuccess True >> setDone True) + , (xK_BackSpace, deleteString Prev) + , (xK_Delete, deleteString Next) + , (xK_Left, moveCursor Prev) + , (xK_Right, moveCursor Next) + , (xK_Home, startOfLine) + , (xK_End, endOfLine) + , (xK_Down, moveHistory W.focusUp') + , (xK_Up, moveHistory W.focusDown') + , (xK_Escape, quit) + ] + keyPressHandle :: KeyMask -> KeyStroke -> XP () keyPressHandle m (ks,str) = do km <- gets (promptKeymap . config) @@ -450,8 +662,12 @@ Nothing -> case str of "" -> eventLoop handle _ -> when (kmask .&. controlMask == 0) $ do - insertString (decodeString str) + let str' = if isUTF8Encoded str + then decodeString str + else str + insertString str' updateWindows + updateHighlightedCompl completed <- tryAutoComplete when completed $ setSuccess True >> setDone True @@ -477,16 +693,26 @@ killAfter = modify $ \s -> setCommand (take (offset s) (command s)) s --- | Kill the next\/previous word +-- | Kill the next\/previous word, using 'isSpace' as the default +-- predicate for non-word characters. See 'killWord''. killWord :: Direction1D -> XP () -killWord d = do +killWord = killWord' isSpace + +-- | Kill the next\/previous word, given a predicate to identify +-- non-word characters. First delete any consecutive non-word +-- characters; then delete consecutive word characters, stopping +-- just before the next non-word character. +-- +-- For example, by default (using 'killWord') a path like +-- @foo\/bar\/baz@ would be deleted in its entirety. Instead you can +-- use something like @killWord' (\\c -> isSpace c || c == \'\/\')@ to +-- delete the path one component at a time. +killWord' :: (Char -> Bool) -> Direction1D -> XP () +killWord' p d = do o <- gets offset c <- gets command let (f,ss) = splitAt o c - delNextWord w = - case w of - ' ':x -> x - word -> snd . break isSpace $ word + delNextWord = snd . break p . dropWhile p delPrevWord = reverse . delNextWord . reverse (ncom,noff) = case d of @@ -508,10 +734,18 @@ flushString :: XP () flushString = modify $ \s -> setCommand "" $ s { offset = 0} +--reset index if config has `alwaysHighlight`. The inserted char could imply fewer autocompletions. +--If the current index was column 2, row 1 and now there are only 4 autocompletion rows with 1 column, what should we highlight? Set it to the first and start navigation again +resetComplIndex :: XPState -> XPState +resetComplIndex st = if (alwaysHighlight $ config st) then st { complIndex = (0,0) } else st + -- | Insert a character at the cursor position insertString :: String -> XP () insertString str = - modify $ \s -> setCommand (c (command s) (offset s)) $ s { offset = o (offset s)} + modify $ \s -> let + cmd = (c (command s) (offset s)) + st = resetComplIndex $ s { offset = o (offset s)} + in setCommand cmd st where o oo = oo + length str c oc oo | oo >= length oc = oc ++ str | otherwise = f ++ str ++ ss @@ -539,19 +773,25 @@ modify $ \s -> s { offset = o (offset s) (command s)} where o oo c = if d == Prev then max 0 (oo - 1) else min (length c) (oo + 1) --- | move the cursor one word +-- | Move the cursor one word, using 'isSpace' as the default +-- predicate for non-word characters. See 'moveWord''. moveWord :: Direction1D -> XP () -moveWord d = do +moveWord = moveWord' isSpace + +-- | Move the cursor one word, given a predicate to identify non-word +-- characters. First move past any consecutive non-word characters; +-- then move to just before the next non-word character. +moveWord' :: (Char -> Bool) -> Direction1D -> XP () +moveWord' p d = do c <- gets command o <- gets offset let (f,ss) = splitAt o c - lenToS = length . fst . break isSpace - ln p s = case p s of - ' ':x -> 1 + lenToS x - x -> lenToS x + len = uncurry (+) + . (length *** (length . fst . break p)) + . break (not . p) newoff = case d of - Prev -> o - ln reverse f - Next -> o + ln id ss + Prev -> o - len (reverse f) + Next -> o + len ss modify $ \s -> s { offset = newoff } moveHistory :: (W.Stack String -> W.Stack String) -> XP () @@ -559,6 +799,13 @@ in s { commandHistory = ch , offset = length $ W.focus ch } +updateHighlightedCompl :: XP () +updateHighlightedCompl = do + st <- get + cs <- getCompletions + alwaysHighlight' <- gets $ alwaysHighlight . config + when (alwaysHighlight') $ modify $ \s -> s {highlightedCompl = highlightedItem st cs} + -- X Stuff updateWindows :: XP () @@ -611,7 +858,7 @@ printPrompt drw = do st <- get let (gc,(c,(d,fs))) = (gcon &&& config &&& dpy &&& fontS) st - (prt,(com,off)) = (show . xptype &&& command &&& offset) st + (prt,(com,off)) = (show . currentXPMode &&& command &&& offset) st str = prt ++ com -- break the string in 3 parts: till the cursor, the cursor and the rest (f,p,ss) = if off >= length com @@ -633,13 +880,18 @@ -- reverse the colors and print the rest of the string draw (fgColor c) (bgColor c) (x + fromIntegral (fsl + psl)) y ss --- Completions +-- get the current completion function depending on the active mode +getCompletionFunction :: XPState -> ComplFunction +getCompletionFunction st = case operationMode st of + XPSingleMode compl _ -> compl + XPMultipleModes modes -> completionFunction $ W.focus modes +-- Completions getCompletions :: XP [String] getCompletions = do s <- get - io $ completionFunction s (commandToComplete (xptype s) (command s)) - `catch` \(SomeException _) -> return [] + io $ getCompletionFunction s (commandToComplete (currentXPMode s) (command s)) + `E.catch` \(SomeException _) -> return [] setComplWin :: Window -> ComplWindowDim -> XP () setComplWin w wi = @@ -713,7 +965,9 @@ (defaultDepthOfScreen scr) io $ fillDrawable d p gc border bgcolor (fi bw) wh ht let ac = splitInSubListsAt (length yy) (take (length xx * length yy) compl) + printComplList d p gc (fgColor c) (bgColor c) xx yy ac + --lift $ spawn $ "xmessage " ++ " ac: " ++ show ac ++ " xx: " ++ show xx ++ " length xx: " ++ show (length xx) ++ " yy: " ++ show (length yy) io $ copyArea d p w gc 0 0 wh ht 0 0 io $ freePixmap d p @@ -734,16 +988,34 @@ Nothing -> recreate else destroyComplWin +-- Finds the column and row indexes in which a string appears. +-- if the string is not in the matrix, the indexes default to (0,0) +findComplIndex :: String -> [[String]] -> (Int,Int) +findComplIndex x xss = let + colIndex = fromMaybe 0 $ findIndex (\cols -> x `elem` cols) xss + rowIndex = fromMaybe 0 $ elemIndex x $ (!!) xss colIndex + in (colIndex,rowIndex) + printComplList :: Display -> Drawable -> GC -> String -> String -> [Position] -> [Position] -> [[String]] -> XP () printComplList d drw gc fc bc xs ys sss = zipWithM_ (\x ss -> - zipWithM_ (\y s -> do + zipWithM_ (\y item -> do st <- get - let (f,b) = if completionToCommand (xptype st) s == commandToComplete (xptype st) (command st) - then (fgHLight $ config st,bgHLight $ config st) - else (fc,bc) - printStringXMF d drw (fontS st) gc f b x y s) + alwaysHlight <- gets $ alwaysHighlight . config + let (f,b) = case alwaysHlight of + True -> -- default to the first item, the one in (0,0) + let + (colIndex,rowIndex) = findComplIndex item sss + in -- assign some colors + if ((complIndex st) == (colIndex,rowIndex)) then (fgHLight $ config st,bgHLight $ config st) + else (fc,bc) + False -> + -- compare item with buffer's value + if completionToCommand (currentXPMode st) item == commandToComplete (currentXPMode st) (command st) + then (fgHLight $ config st,bgHLight $ config st) + else (fc,bc) + printStringXMF d drw (fontS st) gc f b x y item) ys ss) xs sss -- History @@ -757,7 +1029,7 @@ getHistoryFile = fmap (++ "/history") $ getAppUserDataDirectory "xmonad" readHistory :: IO History -readHistory = readHist `catch` \(SomeException _) -> return emptyHistory +readHistory = readHist `E.catch` \(SomeException _) -> return emptyHistory where readHist = do path <- getHistoryFile @@ -768,7 +1040,7 @@ writeHistory hist = do path <- getHistoryFile let filtered = M.filter (not . null) hist - writeFile path (show filtered) `catch` \(SomeException e) -> + writeFile path (show filtered) `E.catch` \(SomeException e) -> hPutStrLn stderr ("error writing history: "++show e) setFileMode path mode where mode = ownerReadMode .|. ownerWriteMode diff --git a/XMonad/Prompt/DirExec.hs b/XMonad/Prompt/DirExec.hs --- a/XMonad/Prompt/DirExec.hs +++ b/XMonad/Prompt/DirExec.hs @@ -24,8 +24,7 @@ , DirExec ) where -import Prelude hiding (catch) -import Control.Exception +import Control.Exception as E import System.Directory import Control.Monad import Data.List @@ -104,4 +103,4 @@ liftM2 (&&) (doesFileExist x') (liftM executable (getPermissions x')))) - `catch` econst [] + `E.catch` econst [] diff --git a/XMonad/Prompt/RunOrRaise.hs b/XMonad/Prompt/RunOrRaise.hs --- a/XMonad/Prompt/RunOrRaise.hs +++ b/XMonad/Prompt/RunOrRaise.hs @@ -26,8 +26,7 @@ import XMonad.Actions.WindowGo (runOrRaise) import XMonad.Util.Run (runProcessWithInput) -import Prelude hiding (catch) -import Control.Exception +import Control.Exception as E import Control.Monad (liftM, liftM2) import System.Directory (doesDirectoryExist, doesFileExist, executable, getPermissions) @@ -71,7 +70,7 @@ isApp x = liftM2 (==) pid $ pidof x pidof :: String -> Query Int -pidof x = io $ (runProcessWithInput "pidof" [x] [] >>= readIO) `catch` econst 0 +pidof x = io $ (runProcessWithInput "pidof" [x] [] >>= readIO) `E.catch` econst 0 pid :: Query Int pid = ask >>= (\w -> liftX $ withDisplay $ \d -> getPID d w) diff --git a/XMonad/Prompt/Shell.hs b/XMonad/Prompt/Shell.hs --- a/XMonad/Prompt/Shell.hs +++ b/XMonad/Prompt/Shell.hs @@ -15,27 +15,31 @@ -- $usage Shell (..) , shellPrompt + -- ** Variations on shellPrompt + -- $spawns + , prompt + , safePrompt + , unsafePrompt + + -- * Utility functions , getCommands , getBrowser , getEditor , getShellCompl , split - , prompt - , safePrompt ) where -import Codec.Binary.UTF8.String (encodeString) -import Control.Exception -import Control.Monad (forM) -import Data.List (isPrefixOf) -import Prelude hiding (catch) -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.Environment (getEnv) -import System.Posix.Files (getFileStatus, isDirectory) +import Codec.Binary.UTF8.String (encodeString) +import Control.Exception as E +import Control.Monad (forM) +import Data.List (isPrefixOf) +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.Environment (getEnv) +import System.Posix.Files (getFileStatus, isDirectory) -import XMonad.Util.Run -import XMonad hiding (config) -import XMonad.Prompt +import XMonad hiding (config) +import XMonad.Prompt +import XMonad.Util.Run econst :: Monad m => a -> IOException -> m a econst = const . return @@ -64,7 +68,9 @@ cmds <- io getCommands mkXPrompt Shell c (getShellCompl cmds) spawn -{- | See safe and unsafeSpawn. prompt is an alias for safePrompt; +{- $spawns + See safe and unsafeSpawn in "XMonad.Util.Run". + prompt is an alias for safePrompt; safePrompt and unsafePrompt work on the same principles, but will use XPrompt to interactively query the user for input; the appearance is set by passing an XPConfig as the second argument. The first argument @@ -78,6 +84,7 @@ wants URLs, and unsafePrompt for the XTerm example because this allows you to easily start a terminal executing an arbitrary command, like 'top'. -} + prompt, unsafePrompt, safePrompt :: FilePath -> XPConfig -> X () prompt = unsafePrompt safePrompt c config = mkXPrompt Shell config (getShellCompl [c]) run @@ -103,7 +110,7 @@ getCommands :: IO [String] getCommands = do - p <- getEnv "PATH" `catch` econst [] + p <- getEnv "PATH" `E.catch` econst [] let ds = filter (/= "") $ split ':' p es <- forM ds $ \d -> do exists <- doesDirectoryExist d @@ -130,9 +137,11 @@ isSpecialChar :: Char -> Bool isSpecialChar = flip elem " &\\@\"'#?$*()[]{};" --- | Ask the shell environment for +-- | Ask the shell environment for the value of a variable in XMonad's environment, with a default value. +-- In order to /set/ an environment variable (eg. combine with a prompt so you can modify @$HTTP_PROXY@ dynamically), +-- you need to use 'System.Posix.putEnv'. env :: String -> String -> IO String -env variable fallthrough = getEnv variable `catch` econst fallthrough +env variable fallthrough = getEnv variable `E.catch` econst fallthrough {- | Ask the shell what browser the user likes. If the user hasn't defined any $BROWSER, defaults to returning \"firefox\", since that seems to be the most diff --git a/XMonad/Prompt/Ssh.hs b/XMonad/Prompt/Ssh.hs --- a/XMonad/Prompt/Ssh.hs +++ b/XMonad/Prompt/Ssh.hs @@ -19,15 +19,13 @@ Ssh, ) where -import Prelude hiding (catch) - import XMonad import XMonad.Util.Run import XMonad.Prompt import System.Directory import System.Environment -import Control.Exception +import Control.Exception as E import Control.Monad import Data.Maybe @@ -78,7 +76,7 @@ sshComplListGlobal :: IO [String] sshComplListGlobal = do - env <- getEnv "SSH_KNOWN_HOSTS" `catch` econst "/nonexistent" + env <- getEnv "SSH_KNOWN_HOSTS" `E.catch` econst "/nonexistent" fs <- mapM fileExists [ env , "/usr/local/etc/ssh/ssh_known_hosts" , "/usr/local/etc/ssh_known_hosts" diff --git a/XMonad/Util/DebugWindow.hs b/XMonad/Util/DebugWindow.hs new file mode 100644 --- /dev/null +++ b/XMonad/Util/DebugWindow.hs @@ -0,0 +1,140 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.DebugWindow +-- Copyright : (c) Brandon S Allbery KF8NH, 2012 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : allbery.b@gmail.com +-- Stability : unstable +-- Portability : not portable +-- +-- Module to dump window information for diagnostic/debugging purposes. See +-- "XMonad.Hooks.DebugEvents" and "XMonad.Hooks.DebugStack" for practical uses. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.DebugWindow (debugWindow) where + +import Prelude + +import XMonad + +import Codec.Binary.UTF8.String (decodeString) +import Control.Exception.Extensible as E +import Control.Monad (when) +import Data.List (unfoldr + ,intercalate + ) +import Foreign +import Foreign.C.String +import Numeric (showHex) +import System.Exit + +-- | Output a window by ID in hex, decimal, its ICCCM resource name and class, +-- and its title if available. Also indicate override_redirect with an +-- exclamation mark, and wrap in brackets if it is unmapped or withdrawn. +debugWindow :: Window -> X String +debugWindow 0 = return "None" +debugWindow w = do + let wx = pad 8 '0' $ showHex w "" + w' <- withDisplay $ \d -> io (safeGetWindowAttributes d w) + case w' of + Nothing -> + return $ "(deleted window " ++ wx ++ ")" + Just (WindowAttributes x y wid ht bw m o) -> do + c' <- withDisplay $ \d -> + io (getWindowProperty8 d wM_CLASS w) + let c = case c' of + Nothing -> "" + Just c'' -> intercalate "/" $ + flip unfoldr (map (toEnum . fromEnum) c'') $ + \s -> if null s + then Nothing + else let (w'',s'') = break (== '\NUL') s + s' = if null s'' + then s'' + else tail s'' + in Just (w'',s') + t <- catchX' (wrap `fmap` getEWMHTitle "VISIBLE" w) $ + catchX' (wrap `fmap` getEWMHTitle "" w) $ + catchX' (wrap `fmap` getICCCMTitle w) $ + return "" + let (lb,rb) = case () of + () | m == waIsViewable -> ("","") + | otherwise -> ("[","]") + o' = if o then "!" else "" + return $ concat [lb + ,o' + ,"window " + ,wx + ,t + ," (" + ,show wid + ,',':show ht + ,')':if bw == 0 then "" else '+':show bw + ,"@(" + ,show x + ,',':show y + ,')':if null c then "" else ' ':c + ,rb + ] + +getEWMHTitle :: String -> Window -> X String +getEWMHTitle sub w = do + a <- getAtom $ "_NET_WM_" ++ (if null sub then "" else '_':sub) ++ "_NAME" + (Just t) <- withDisplay $ \d -> io $ getWindowProperty32 d a w + return $ map (toEnum . fromEnum) t + +getICCCMTitle :: Window -> X String +getICCCMTitle w = do + t@(TextProperty t' _ 8 _) <- withDisplay $ \d -> io $ getTextProperty d w wM_NAME + [s] <- catchX' (tryUTF8 t) $ + catchX' (tryCompound t) $ + io ((:[]) `fmap` peekCString t') + return s + +tryUTF8 :: TextProperty -> X [String] +tryUTF8 (TextProperty s enc _ _) = do + uTF8_STRING <- getAtom "UTF8_STRING" + when (enc == uTF8_STRING) $ error "String is not UTF8_STRING" + (map decodeString . splitNul) `fmap` io (peekCString s) + +tryCompound :: TextProperty -> X [String] +tryCompound t@(TextProperty _ enc _ _) = do + cOMPOUND_TEXT <- getAtom "COMPOUND_TEXT" + when (enc == cOMPOUND_TEXT) $ error "String is not COMPOUND_TEXT" + withDisplay $ \d -> io $ wcTextPropertyToTextList d t + +splitNul :: String -> [String] +splitNul "" = [] +splitNul s = let (s',ss') = break (== '\NUL') s in s' : splitNul ss' + +pad :: Int -> Char -> String -> String +pad w c s = replicate (w - length s) c ++ s + +-- modified 'catchX' without the print to 'stderr' +catchX' :: X a -> X a -> X a +catchX' job errcase = do + st <- get + c <- ask + (a, s') <- io $ runX c st job `E.catch` \e -> case fromException e of + Just x -> throw e `const` (x `asTypeOf` ExitSuccess) + _ -> runX c st errcase + put s' + return a + +wrap :: String -> String +wrap s = ' ' : '"' : wrap' s ++ "\"" + where + wrap' (s':ss) | s' == '"' = '\\' : s' : wrap' ss + | s' == '\\' = '\\' : s' : wrap' ss + | otherwise = s' : wrap' ss + wrap' "" = "" + +-- Graphics.X11.Extras.getWindowAttributes is bugggggggy +safeGetWindowAttributes :: Display -> Window -> IO (Maybe WindowAttributes) +safeGetWindowAttributes d w = alloca $ \p -> do + s <- xGetWindowAttributes d w p + case s of + 0 -> return Nothing + _ -> Just `fmap` peek p diff --git a/XMonad/Util/Dmenu.hs b/XMonad/Util/Dmenu.hs --- a/XMonad/Util/Dmenu.hs +++ b/XMonad/Util/Dmenu.hs @@ -55,7 +55,7 @@ -- | Like 'menu' but also takes a list of command line arguments. menuArgs :: String -> [String] -> [String] -> X String -menuArgs menuCmd args opts = runProcessWithInput menuCmd args (unlines opts) +menuArgs menuCmd args opts = fmap (filter (/='\n')) $ runProcessWithInput menuCmd args (unlines opts) -- | Like 'dmenuMap' but also takes the command to run. menuMap :: String -> M.Map String a -> X (Maybe a) diff --git a/XMonad/Util/Font.hs b/XMonad/Util/Font.hs --- a/XMonad/Util/Font.hs +++ b/XMonad/Util/Font.hs @@ -32,11 +32,10 @@ , fi ) where -import Prelude hiding (catch) import XMonad import Foreign import Control.Applicative -import Control.Exception +import Control.Exception as E import Data.Maybe #ifdef XFT @@ -53,7 +52,7 @@ #endif -- $usage --- See "Xmonad.Layout.Tabbed" or "XMonad.Prompt" for usage examples +-- 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. @@ -70,7 +69,7 @@ initCoreFont :: String -> X FontStruct initCoreFont s = do d <- asks display - io $ catch (getIt d) (fallBack d) + io $ E.catch (getIt d) (fallBack d) where getIt d = loadQueryFont d s fallBack d = econst $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" @@ -82,7 +81,7 @@ initUtf8Font :: String -> X FontSet initUtf8Font s = do d <- asks display - (_,_,fs) <- io $ catch (getIt d) (fallBack d) + (_,_,fs) <- io $ E.catch (getIt d) (fallBack d) return fs where getIt d = createFontSet d s fallBack d = econst $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" diff --git a/XMonad/Util/Image.hs b/XMonad/Util/Image.hs --- a/XMonad/Util/Image.hs +++ b/XMonad/Util/Image.hs @@ -29,7 +29,7 @@ | 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 diff --git a/XMonad/Util/Loggers.hs b/XMonad/Util/Loggers.hs --- a/XMonad/Util/Loggers.hs +++ b/XMonad/Util/Loggers.hs @@ -52,9 +52,8 @@ import XMonad.Util.Font (Align (..)) import XMonad.Util.NamedWindows (getName) -import Prelude hiding (catch) import Control.Applicative ((<$>)) -import Control.Exception +import Control.Exception as E import Data.List (isPrefixOf, isSuffixOf) import Data.Maybe (fromMaybe) import Data.Traversable (traverse) @@ -143,7 +142,7 @@ -- | Create a 'Logger' from an arbitrary shell command. logCmd :: String -> Logger logCmd c = io $ do (_, out, _, _) <- runInteractiveCommand c - fmap Just (hGetLine out) `catch` econst Nothing + fmap Just (hGetLine out) `E.catch` econst Nothing -- no need to waitForProcess, we ignore SIGCHLD -- | Get a count of filtered files in a directory. diff --git a/XMonad/Util/NamedScratchpad.hs b/XMonad/Util/NamedScratchpad.hs --- a/XMonad/Util/NamedScratchpad.hs +++ b/XMonad/Util/NamedScratchpad.hs @@ -24,12 +24,14 @@ namedScratchpadAction, allNamedScratchpadAction, namedScratchpadManageHook, - namedScratchpadFilterOutWorkspace + namedScratchpadFilterOutWorkspace, + namedScratchpadFilterOutWorkspacePP ) where import XMonad import XMonad.Hooks.ManageHelpers (doRectFloat) import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace) +import XMonad.Hooks.DynamicLog (PP, ppSort) import Control.Monad (filterM) import Data.Maybe (listToMaybe) @@ -159,5 +161,21 @@ -- doesn't contain it. Intended for use with logHooks. namedScratchpadFilterOutWorkspace :: [WindowSpace] -> [WindowSpace] namedScratchpadFilterOutWorkspace = filter (\(W.Workspace tag _ _) -> tag /= scratchpadWorkspaceTag) + +-- | Transforms a pretty-printer into one not displaying the NSP workspace. +-- +-- A simple use could be: +-- +-- > logHook = dynamicLogWithPP . namedScratchpadFilterOutWorkspace $ defaultPP +-- +-- Here is another example, when using "XMonad.Layout.IndependentScreens". +-- If you have handles @hLeft@ and @hRight@ for bars on the left and right screens, respectively, and @pp@ is a pretty-printer function that takes a handle, you could write +-- +-- > logHook = let log screen handle = dynamicLogWithPP . namedScratchpadFilterOutWorkspacePP . marshallPP screen . pp $ handle +-- > in log 0 hLeft >> log 1 hRight +namedScratchpadFilterOutWorkspacePP :: PP -> PP +namedScratchpadFilterOutWorkspacePP pp = pp { + ppSort = fmap (. namedScratchpadFilterOutWorkspace) (ppSort pp) + } -- vim:ts=4:shiftwidth=4:softtabstop=4:expandtab:foldlevel=20: diff --git a/XMonad/Util/NamedWindows.hs b/XMonad/Util/NamedWindows.hs --- a/XMonad/Util/NamedWindows.hs +++ b/XMonad/Util/NamedWindows.hs @@ -22,9 +22,8 @@ unName ) where -import Prelude hiding ( catch ) import Control.Applicative ( (<$>) ) -import Control.Exception.Extensible ( bracket, catch, SomeException(..) ) +import Control.Exception.Extensible as E import Data.Maybe ( fromMaybe, listToMaybe ) import qualified XMonad.StackSet as W ( peek ) @@ -50,11 +49,11 @@ let getIt = bracket getProp (xFree . tp_value) (fmap (`NW` w) . copy) getProp = (internAtom d "_NET_WM_NAME" False >>= getTextProperty d w) - `catch` \(SomeException _) -> getTextProperty d w wM_NAME + `E.catch` \(SomeException _) -> getTextProperty d w wM_NAME copy prop = fromMaybe "" . listToMaybe <$> wcTextPropertyToTextList d prop - io $ getIt `catch` \(SomeException _) -> ((`NW` w) . resName) `fmap` getClassHint d w + io $ getIt `E.catch` \(SomeException _) -> ((`NW` w) . resName) `fmap` getClassHint d w unName :: NamedWindow -> Window unName (NW _ w) = w diff --git a/XMonad/Util/Paste.hs b/XMonad/Util/Paste.hs --- a/XMonad/Util/Paste.hs +++ b/XMonad/Util/Paste.hs @@ -3,7 +3,7 @@ Copyright : (C) 2008 Jérémy Bobbio, gwern License : BSD3 -Maintainer : gwern +Maintainer : none Stability : unstable Portability : unportable @@ -54,9 +54,9 @@ pasteSelection = getSelection >>= pasteString -- | Send a string to the window which is currently focused. This function correctly --- handles capitalization. +-- handles capitalization. Warning: in dealing with capitalized characters, this assumes a QWERTY layout. pasteString :: String -> X () -pasteString = mapM_ (\x -> if isUpper x then pasteChar shiftMask x else pasteChar noModMask x) +pasteString = mapM_ (\x -> if isUpper x || x `elem` "~!@#$%^&*()_+{}|:\"<>?" then pasteChar shiftMask x else pasteChar noModMask x) {- | Send a character to the current window. This is more low-level. Remember that you must handle the case of capitalization appropriately. @@ -89,9 +89,3 @@ sendEvent d w True keyPressMask ev setEventType ev keyRelease sendEvent d w True keyReleaseMask ev - --- | A null 'KeyMask'. Used when you don't want a character or string shifted, control'd, or what. --- --- TODO: This really should be a function in the X11 binding. When noModMask shows up there, remove. -noModMask :: KeyMask -noModMask = 0 diff --git a/XMonad/Util/Run.hs b/XMonad/Util/Run.hs --- a/XMonad/Util/Run.hs +++ b/XMonad/Util/Run.hs @@ -86,6 +86,15 @@ -- Use like: -- -- > (5.5 `seconds`) +-- +-- In GHC 7 and later, you must either enable the PostfixOperators extension +-- (by adding +-- +-- > {-# LANGUAGE PostfixOperators #-} +-- +-- to the top of your file) or use seconds in prefix form: +-- +-- > 5.5 seconds seconds :: Rational -> Int seconds = fromEnum . (* 1000000) diff --git a/XMonad/Util/Stack.hs b/XMonad/Util/Stack.hs --- a/XMonad/Util/Stack.hs +++ b/XMonad/Util/Stack.hs @@ -145,7 +145,7 @@ swapDownZ :: Zipper a -> Zipper a swapDownZ Nothing = Nothing swapDownZ (Just s) | d:down <- W.down s = Just s { W.down = down, W.up = d:W.up s } -swapDownZ (Just s) = Just s { W.up = [], W.down = reverse (W.up s) } +swapDownZ (Just s) = Just s { W.up = [], W.down = reverse (W.up s) } -- | Swap the focused element with the first one swapMasterZ :: Zipper a -> Zipper a @@ -197,7 +197,7 @@ where adapt g e1 e2 = g (fromE e1) (fromE e2) -- ** Maps - + -- | Map a function over a stack. The boolean argument indcates whether -- the current element is the focused one mapZ :: (Bool -> a -> b) -> Zipper a -> Zipper b diff --git a/XMonad/Util/Themes.hs b/XMonad/Util/Themes.hs --- a/XMonad/Util/Themes.hs +++ b/XMonad/Util/Themes.hs @@ -131,12 +131,12 @@ } } --- | Don's prefered colors - from DynamicLog...;) +-- | Don's preferred colors - from DynamicLog...;) donaldTheme :: ThemeInfo donaldTheme = newTheme { themeName = "donaldTheme" , themeAuthor = "Andrea Rossato" - , themeDescription = "Don's prefered colors - from DynamicLog...;)" + , themeDescription = "Don's preferred colors - from DynamicLog...;)" , theme = defaultTheme { activeColor = "#2b4f98" , inactiveColor = "#cccccc" , activeBorderColor = "#2b4f98" diff --git a/XMonad/Util/XSelection.hs b/XMonad/Util/XSelection.hs --- a/XMonad/Util/XSelection.hs +++ b/XMonad/Util/XSelection.hs @@ -82,7 +82,7 @@ safePromptSelection app = join $ io $ liftM (safeSpawn app . return) getSelection unsafePromptSelection app = join $ io $ liftM unsafeSpawn $ fmap (\x -> app ++ " " ++ x) getSelection -{- | A wrapper around 'promptSelection' and its safe variant. They take two parameters, the +{- | A wrapper around 'promptSelection' and its safe variant. They take two parameters, the first is a function that transforms strings, and the second is the application to run. The transformer essentially transforms the selection in X. One example is to wrap code, such as a command line action copied out of the browser diff --git a/XMonad/Util/XUtils.hs b/XMonad/Util/XUtils.hs --- a/XMonad/Util/XUtils.hs +++ b/XMonad/Util/XUtils.hs @@ -38,7 +38,7 @@ import Control.Monad -- $usage --- See "XMonad.Layout.Tabbed" or "XMonad.Layout.DragPane" or +-- 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. @@ -163,7 +163,7 @@ -- drawn inside it. -- Not exported. paintWindow' :: Window -> Rectangle -> Dimension -> String -> String - -> Maybe (XMonadFont,String,String,[(String, (Position, Position))]) + -> 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 diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -1,5 +1,5 @@ name: xmonad-contrib -version: 0.10 +version: 0.11 homepage: http://xmonad.org/ synopsis: Third party extensions for xmonad description: @@ -30,9 +30,20 @@ tests/Selective.hs tests/SwapWorkspaces.hs tests/XPrompt.hs -cabal-version: >= 1.2.1 +cabal-version: >= 1.6 build-type: Simple +bug-reports: http://code.google.com/p/xmonad/issues/list +tested-with: GHC==7.6.1, + GHC==7.4.1, + GHC==7.2.1, + GHC==6.12.3, + GHC==6.10.4 +source-repository head + type: darcs + location: http://code.haskell.org/XMonadContrib + + flag small_base description: Choose the new smaller, split-up base package. @@ -61,7 +72,7 @@ extensions: ForeignFunctionInterface cpp-options: -DXFT - build-depends: mtl >= 1 && < 3, unix, X11>=1.5.0.0 && < 1.6, xmonad>=0.10, xmonad<0.11, utf8-string + build-depends: mtl >= 1 && < 3, unix, X11>=1.6 && < 1.7, xmonad>=0.11 && < 0.12, utf8-string if true ghc-options: -fwarn-tabs -Wall @@ -102,9 +113,11 @@ XMonad.Actions.FocusNth XMonad.Actions.GridSelect XMonad.Actions.GroupNavigation + XMonad.Actions.Launcher XMonad.Actions.MessageFeedback XMonad.Actions.MouseGestures XMonad.Actions.MouseResize + XMonad.Actions.Navigation2D XMonad.Actions.NoBorders XMonad.Actions.OnScreen XMonad.Actions.PerWorkspaceKeys @@ -115,6 +128,7 @@ XMonad.Actions.KeyRemap XMonad.Actions.RotSlaves XMonad.Actions.Search + XMonad.Actions.ShowText XMonad.Actions.SimpleDate XMonad.Actions.SinkAll XMonad.Actions.SpawnOn @@ -132,6 +146,7 @@ XMonad.Actions.WithAll XMonad.Actions.WorkspaceCursors XMonad.Actions.WorkspaceNames + XMonad.Actions.Workscreen XMonad.Config.Arossato XMonad.Config.Azerty XMonad.Config.Bluetile @@ -142,9 +157,12 @@ XMonad.Config.Sjanssen XMonad.Config.Xfce XMonad.Hooks.CurrentWorkspaceOnTop + XMonad.Hooks.DebugEvents XMonad.Hooks.DebugKeyEvents + XMonad.Hooks.DynamicBars XMonad.Hooks.DynamicHooks XMonad.Hooks.DynamicLog + XMonad.Hooks.DebugStack XMonad.Hooks.EwmhDesktops XMonad.Hooks.FadeInactive XMonad.Hooks.FadeWindows @@ -221,6 +239,7 @@ XMonad.Layout.Named XMonad.Layout.NoBorders XMonad.Layout.NoFrillsDecoration + XMonad.Layout.OnHost XMonad.Layout.OneBig XMonad.Layout.PerWorkspace XMonad.Layout.PositionStoreFloat @@ -268,6 +287,7 @@ XMonad.Prompt.XMonad XMonad.Util.Cursor XMonad.Util.CustomKeys + XMonad.Util.DebugWindow XMonad.Util.Dmenu XMonad.Util.Dzen XMonad.Util.ExtensibleState