diff --git a/XMonad/Actions/BluetileCommands.hs b/XMonad/Actions/BluetileCommands.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/BluetileCommands.hs @@ -0,0 +1,83 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.BluetileCommands +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- This is a list of selected commands that can be made available using +-- "XMonad.Hooks.ServerMode" to allow external programs to control +-- the window manager. Bluetile () +-- uses this to enable its dock application to do things like changing +-- workspaces and layouts. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.BluetileCommands ( + -- * Usage + -- $usage + bluetileCommands + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Layout.LayoutCombinators +import System.Exit + +-- $usage +-- +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Hooks.ServerMode +-- > import XMonad.Actions.BluetileCommands +-- +-- Then edit your @handleEventHook@: +-- +-- > main = xmonad defaultConfig { handleEventHook = serverModeEventHook' bluetileCommands } +-- +-- See the documentation of "XMonad.Hooks.ServerMode" for details on +-- how to actually invoke the commands from external programs. + +workspaceCommands :: Int -> X [(String, X ())] +workspaceCommands sid = asks (workspaces . config) >>= \spaces -> return + [(("greedyView" ++ show i), + activateScreen sid >> windows (W.greedyView i)) + | i <- spaces ] + +layoutCommands :: Int -> [(String, X ())] +layoutCommands sid = [ ("layout floating" , activateScreen sid >> + sendMessage (JumpToLayout "Floating")) + , ("layout tiled1" , activateScreen sid >> + sendMessage (JumpToLayout "Tiled1")) + , ("layout tiled2" , activateScreen sid >> + sendMessage (JumpToLayout "Tiled2")) + , ("layout fullscreen" , activateScreen sid >> + sendMessage (JumpToLayout "Fullscreen")) + ] + +masterAreaCommands :: Int -> [(String, X ())] +masterAreaCommands sid = [ ("increase master n", activateScreen sid >> + sendMessage (IncMasterN 1)) + , ("decrease master n", activateScreen sid >> + sendMessage (IncMasterN (-1))) + ] + +quitCommands :: [(String, X ())] +quitCommands = [ ("quit bluetile", io (exitWith ExitSuccess)) + , ("quit bluetile and start metacity", restart "metacity" False) + ] + +bluetileCommands :: X [(String, X ())] +bluetileCommands = do + let restartCommand = [ ("restart bluetile", restart "bluetile" True) ] + wscmds0 <- workspaceCommands 0 + wscmds1 <- workspaceCommands 1 + return $ restartCommand + ++ wscmds0 ++ layoutCommands 0 ++ masterAreaCommands 0 ++ quitCommands + ++ wscmds1 ++ layoutCommands 1 ++ masterAreaCommands 1 ++ quitCommands + +activateScreen :: Int -> X () +activateScreen sid = screenWorkspace (S sid) >>= flip whenJust (windows . W.view) diff --git a/XMonad/Actions/CopyWindow.hs b/XMonad/Actions/CopyWindow.hs --- a/XMonad/Actions/CopyWindow.hs +++ b/XMonad/Actions/CopyWindow.hs @@ -26,7 +26,6 @@ import XMonad import Control.Arrow ((&&&)) -import Control.Monad import qualified Data.List as L import XMonad.Actions.WindowGo @@ -146,7 +145,9 @@ delFromAllButCurrent w ss = foldr ($) ss $ map (delWinFromWorkspace w . W.tag) $ W.hidden ss ++ map W.workspace (W.visible ss) - delWinFromWorkspace w wid = W.modify Nothing (W.filter (/= w)) . W.view wid + delWinFromWorkspace w wid = viewing wid $ W.modify Nothing (W.filter (/= w)) + + viewing wis f ss = W.view (W.currentTag ss) $ f $ W.view wis ss -- | A list of hidden workspaces containing a copy of the focused window. wsContainingCopies :: X [WorkspaceId] diff --git a/XMonad/Actions/CycleWS.hs b/XMonad/Actions/CycleWS.hs --- a/XMonad/Actions/CycleWS.hs +++ b/XMonad/Actions/CycleWS.hs @@ -46,6 +46,7 @@ -- * Toggling the previous workspace -- $toggling , toggleWS + , toggleWS' , toggleOrView -- * Moving between screens (xinerama) @@ -65,6 +66,7 @@ , shiftTo , moveTo + , doTo -- * The mother-combinator @@ -72,6 +74,8 @@ , toggleOrDoSkip , skipTags + , screenBy + ) where import Control.Monad ( unless ) @@ -147,10 +151,17 @@ -- | Toggle to the workspace displayed previously. toggleWS :: X () -toggleWS = do - hs <- gets (hidden . windowset) - unless (null hs) (windows . view . tag $ head hs) +toggleWS = toggleWS' [] +-- | Toggle to the previous workspace while excluding some workspaces. +-- +-- > -- Ignore the scratchpad workspace while toggling: +-- > ("M-b", toggleWS' ["NSP"]) +toggleWS' :: [WorkspaceId] -> X () +toggleWS' skips = do + hs' <- cleanHiddens skips + unless (null hs') (windows . view . tag $ head hs') + -- | 'XMonad.StackSet.greedyView' a workspace, or if already there, view -- the previously displayed workspace ala weechat. Change @greedyView@ to -- @toggleOrView@ in your workspace bindings as in the 'XMonad.StackSet.view' @@ -159,9 +170,8 @@ toggleOrView :: WorkspaceId -> X () toggleOrView = toggleOrDoSkip [] greedyView --- | Allows ignoring listed workspace tags (such as scratchpad's \"NSP\") while --- finding the previously displayed workspace, or choice of different actions, --- like view, shift, etc. For example: +-- | Allows ignoring listed workspace tags (such as scratchpad's \"NSP\"), and +-- running other actions such as view, shift, etc. For example: -- -- > import qualified XMonad.StackSet as W -- > import XMonad.Actions.CycleWS @@ -174,9 +184,9 @@ toggleOrDoSkip :: [WorkspaceId] -> (WorkspaceId -> WindowSet -> WindowSet) -> WorkspaceId -> X () toggleOrDoSkip skips f toWS = do - ws <- gets windowset - let hs' = hidden ws `skipTags` skips - if toWS == (tag . workspace $ current ws) + hs' <- cleanHiddens skips + cur <- gets (currentTag . windowset) + if toWS == cur then unless (null hs') (windows . f . tag $ head hs') else windows (f toWS) @@ -185,6 +195,9 @@ skipTags :: (Eq i) => [Workspace i l a] -> [i] -> [Workspace i l a] skipTags wss ids = filter ((`notElem` ids) . tag) wss +cleanHiddens :: [WorkspaceId] -> X [WindowSpace] +cleanHiddens skips = gets $ (flip skipTags) skips . hidden . windowset + switchWorkspace :: Int -> X () switchWorkspace d = wsBy d >>= windows . greedyView @@ -218,6 +231,10 @@ | HiddenWS -- ^ cycle through non-visible workspaces | HiddenNonEmptyWS -- ^ cycle through non-empty non-visible workspaces | AnyWS -- ^ cycle through all workspaces + | WSTagGroup Char + -- ^ cycle through workspaces in the same group, the + -- group name is all characters up to the first + -- separator character or the end of the tag | WSIs (X (WindowSpace -> Bool)) -- ^ cycle through workspaces satisfying -- an arbitrary predicate @@ -232,18 +249,26 @@ hi <- wsTypeToPred HiddenWS return (\w -> hi w && ne w) wsTypeToPred AnyWS = return (const True) +wsTypeToPred (WSTagGroup sep) = do cur <- (groupName.workspace.current) `fmap` gets windowset + return $ (cur ==).groupName + where groupName = takeWhile (/=sep).tag wsTypeToPred (WSIs p) = p -- | View the next workspace in the given direction that satisfies -- the given condition. moveTo :: Direction1D -> WSType -> X () -moveTo dir t = findWorkspace getSortByIndex dir t 1 >>= windows . greedyView +moveTo dir t = doTo dir t getSortByIndex (windows . greedyView) -- | Move the currently focused window to the next workspace in the -- given direction that satisfies the given condition. shiftTo :: Direction1D -> WSType -> X () -shiftTo dir t = findWorkspace getSortByIndex dir t 1 >>= windows . shift +shiftTo dir t = doTo dir t getSortByIndex (windows . shift) +-- | Using the given sort, find the next workspace in the given +-- direction of the given type, and perform the given action on it. +doTo :: Direction1D -> WSType -> X WorkspaceSort -> (WorkspaceId -> X ()) -> X () +doTo dir t srt act = findWorkspace srt dir t 1 >>= act + -- | Given a function @s@ to sort workspaces, a direction @dir@, a -- predicate @p@ on workspaces, and an integer @n@, find the tag of -- the workspace which is @n@ away from the current workspace in @@ -300,6 +325,17 @@ Nothing -> return () Just ws -> windows (view ws) +{- | Get the 'ScreenId' /d/ places over. Example usage is a variation of the +the default screen keybindings: + +> -- mod-{w,e}, Switch to previous/next Xinerama screen +> -- mod-shift-{w,e}, Move client to previous/next Xinerama screen +> -- +> [((m .|. modm, key), sc >>= screenWorkspace >>= flip whenJust (windows . f)) +> | (key, sc) <- zip [xK_w, xK_e] [(screenBy (-1)),(screenBy 1)] +> , (f, m) <- [(W.view, 0), (W.shift, shiftMask)]] + +-} screenBy :: Int -> X (ScreenId) screenBy d = do ws <- gets windowset --let ss = sortBy screen (screens ws) diff --git a/XMonad/Actions/CycleWindows.hs b/XMonad/Actions/CycleWindows.hs --- a/XMonad/Actions/CycleWindows.hs +++ b/XMonad/Actions/CycleWindows.hs @@ -226,8 +226,10 @@ (revls',rs') = splitAt (length ls) (f $ master:revls ++ rs) -- $generic --- Generic list rotations +-- Generic list rotations such that @rotUp [1..4]@ is equivalent to +-- @[2,3,4,1]@ and @rotDown [1..4]@ to @[4,1,2,3]@. They both are +-- @id@ for null or singleton lists. rotUp :: [a] -> [a] -rotUp l = tail l ++ [head l] +rotUp l = drop 1 l ++ take 1 l rotDown :: [a] -> [a] -rotDown l = last l : init l +rotDown = reverse . rotUp . reverse diff --git a/XMonad/Actions/DynamicWorkspaceGroups.hs b/XMonad/Actions/DynamicWorkspaceGroups.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/DynamicWorkspaceGroups.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.DynamicWorkspaceGroups +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : +-- Stability : experimental +-- Portability : unportable +-- +-- Dynamically manage \"workspace groups\", sets of workspaces being +-- used together for some common task or purpose, to allow switching +-- between workspace groups in a single action. Note that this only +-- makes sense for multi-head setups. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.DynamicWorkspaceGroups + ( -- * Usage + -- $usage + + WSGroupId + + , addWSGroup + , addCurrentWSGroup + , forgetWSGroup + , viewWSGroup + + , promptWSGroupView + , promptWSGroupAdd + , promptWSGroupForget + + , WSGPrompt + ) where + +import Data.List (find) +import Control.Arrow ((&&&)) +import qualified Data.Map as M + +import XMonad +import qualified XMonad.StackSet as W + +import XMonad.Prompt +import qualified XMonad.Util.ExtensibleState as XS + +-- $usage +-- You can use this module by importing it into your ~\/.xmonad\/xmonad.hs file: +-- +-- > import XMonad.Actions.DynamicWorkspaceGroups +-- +-- Then add keybindings like the following (this example uses +-- "XMonad.Util.EZConfig"-style keybindings, but this is not necessary): +-- +-- > , ("M-y n", promptWSGroupAdd myXPConfig "Name this group: ") +-- > , ("M-y g", promptWSGroupView myXPConfig "Go to group: ") +-- > , ("M-y d", promptWSGroupForget myXPConfig "Forget group: ") +-- + +type WSGroup = [(ScreenId,WorkspaceId)] + +type WSGroupId = String + +data WSGroupStorage = WSG { unWSG :: M.Map WSGroupId WSGroup } + deriving (Typeable, Read, Show) + +withWSG :: (M.Map WSGroupId WSGroup -> M.Map WSGroupId WSGroup) -> WSGroupStorage -> WSGroupStorage +withWSG f = WSG . f . unWSG + +instance ExtensionClass WSGroupStorage where + initialValue = WSG $ M.empty + extensionType = PersistentExtension + +-- | Add a new workspace group with the given name. +addWSGroup :: WSGroupId -> [WorkspaceId] -> X () +addWSGroup name wids = withWindowSet $ \w -> do + let wss = map ((W.tag . W.workspace) &&& W.screen) $ W.screens w + wmap = mapM (strength . (flip lookup wss &&& id)) wids + case wmap of + Just ps -> XS.modify . withWSG . M.insert name $ ps + Nothing -> return () + where strength (ma, b) = ma >>= \a -> return (a,b) + +-- | Give a name to the current workspace group. +addCurrentWSGroup :: WSGroupId -> X () +addCurrentWSGroup name = withWindowSet $ \w -> + addWSGroup name $ map (W.tag . W.workspace) (W.current w : W.visible w) + +-- | Delete the named workspace group from the list of workspace +-- groups. Note that this has no effect on the workspaces involved; +-- it simply forgets the given name. +forgetWSGroup :: WSGroupId -> X () +forgetWSGroup = XS.modify . withWSG . M.delete + +-- | View the workspace group with the given name. +viewWSGroup :: WSGroupId -> X () +viewWSGroup name = do + WSG m <- XS.get + case M.lookup name m of + Just grp -> mapM_ (uncurry viewWS) grp + Nothing -> return () + +-- | View the given workspace on the given screen. +viewWS :: ScreenId -> WorkspaceId -> X () +viewWS sid wid = do + mw <- findScreenWS sid + case mw of + Just w -> do + windows $ W.view w + windows $ W.greedyView wid + Nothing -> return () + +-- | Find the workspace which is currently on the given screen. +findScreenWS :: ScreenId -> X (Maybe WorkspaceId) +findScreenWS sid = withWindowSet $ + return . fmap (W.tag . W.workspace) . find ((==sid) . W.screen) . W.screens + +data WSGPrompt = WSGPrompt String + +instance XPrompt WSGPrompt where + showXPrompt (WSGPrompt s) = s + +-- | Prompt for a workspace group to view. +promptWSGroupView :: XPConfig -> String -> X () +promptWSGroupView xp s = do + gs <- fmap (M.keys . unWSG) XS.get + mkXPrompt (WSGPrompt s) xp (mkComplFunFromList' gs) viewWSGroup + +-- | Prompt for a name for the current workspace group. +promptWSGroupAdd :: XPConfig -> String -> X () +promptWSGroupAdd xp s = + mkXPrompt (WSGPrompt s) xp (const $ return []) addCurrentWSGroup + +-- | Prompt for a workspace group to forget. +promptWSGroupForget :: XPConfig -> String -> X () +promptWSGroupForget xp s = do + gs <- fmap (M.keys . unWSG) XS.get + mkXPrompt (WSGPrompt s) xp (mkComplFunFromList' gs) forgetWSGroup diff --git a/XMonad/Actions/DynamicWorkspaceOrder.hs b/XMonad/Actions/DynamicWorkspaceOrder.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/DynamicWorkspaceOrder.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.DynamicWorkspaceOrder +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : +-- Stability : experimental +-- Portability : unportable +-- +-- Remember a dynamically updateable ordering on workspaces, together +-- with tools for using this ordering with "XMonad.Actions.CycleWS" +-- and "XMonad.Hooks.DynamicLog". +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.DynamicWorkspaceOrder + ( -- * Usage + -- $usage + + getWsCompareByOrder + , getSortByOrder + , swapWith + + , moveTo + , moveToGreedy + , shiftTo + + ) where + +import XMonad +import qualified XMonad.StackSet as W +import qualified XMonad.Util.ExtensibleState as XS + +import XMonad.Util.WorkspaceCompare (WorkspaceCompare, WorkspaceSort, mkWsSort) +import XMonad.Actions.CycleWS (findWorkspace, WSType(..), Direction1D(..), doTo) + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Maybe (fromJust, fromMaybe) +import Data.Ord (comparing) + +-- $usage +-- You can use this module by importing it into your ~\/.xmonad\/xmonad.hs file: +-- +-- > import qualified XMonad.Actions.DynamicWorkspaceOrder as DO +-- +-- Then add keybindings to swap the order of workspaces (these +-- examples use "XMonad.Util.EZConfig" emacs-style keybindings): +-- +-- > , ("M-C-", DO.swapWith Next NonEmptyWS) +-- > , ("M-C-", DO.swapWith Prev NonEmptyWS) +-- +-- See "XMonad.Actions.CycleWS" for information on the possible +-- arguments to 'swapWith'. +-- +-- However, by itself this will do nothing; 'swapWith' does not change +-- the actual workspaces in any way. It simply keeps track of an +-- auxiliary ordering on workspaces. Anything which cares about the +-- order of workspaces must be updated to use the auxiliary ordering. +-- +-- To change the order in which workspaces are displayed by +-- "XMonad.Hooks.DynamicLog", use 'getSortByOrder' in your +-- 'XMonad.Hooks.DynamicLog.ppSort' field, for example: +-- +-- > ... dynamicLogWithPP $ byorgeyPP { +-- > ... +-- > , ppSort = DO.getSortByOrder +-- > ... +-- > } +-- +-- To use workspace cycling commands like those from +-- "XMonad.Actions.CycleWS", use the versions of 'moveTo', +-- 'moveToGreedy', and 'shiftTo' exported by this module. For example: +-- +-- > , ("M-S-", DO.shiftTo Next HiddenNonEmptyWS) +-- > , ("M-S-", DO.shiftTo Prev HiddenNonEmptyWS) +-- > , ("M-", DO.moveTo Next HiddenNonEmptyWS) +-- > , ("M-", DO.moveTo Prev HiddenNonEmptyWS) +-- +-- For slight variations on these, use the source for examples and +-- tweak as desired. + +-- | Extensible state storage for the workspace order. +data WSOrderStorage = WSO { unWSO :: Maybe (M.Map WorkspaceId Int) } + deriving (Typeable, Read, Show) + +instance ExtensionClass WSOrderStorage where + initialValue = WSO Nothing + extensionType = PersistentExtension + +-- | Lift a Map function to a function on WSOrderStorage. +withWSO :: (M.Map WorkspaceId Int -> M.Map WorkspaceId Int) + -> (WSOrderStorage -> WSOrderStorage) +withWSO f = WSO . fmap f . unWSO + +-- | Update the ordering storage: initialize if it doesn't yet exist; +-- add newly created workspaces at the end as necessary. +updateOrder :: X () +updateOrder = do + WSO mm <- XS.get + case mm of + Nothing -> do + -- initialize using ordering of workspaces from the user's config + ws <- asks (workspaces . config) + XS.put . WSO . Just . M.fromList $ zip ws [0..] + Just m -> do + -- check for new workspaces and add them at the end + curWs <- gets (S.fromList . map W.tag . W.workspaces . windowset) + let mappedWs = M.keysSet m + newWs = curWs `S.difference` mappedWs + nextIndex = 1 + maximum (-1 : M.elems m) + newWsIxs = zip (S.toAscList newWs) [nextIndex..] + XS.modify . withWSO . M.union . M.fromList $ newWsIxs + +-- | A comparison function which orders workspaces according to the +-- stored dynamic ordering. +getWsCompareByOrder :: X WorkspaceCompare +getWsCompareByOrder = do + updateOrder + -- after the call to updateOrder we are guaranteed that the dynamic + -- workspace order is initialized and contains all existing + -- workspaces. + WSO (Just m) <- XS.get + return $ comparing (fromMaybe 1000 . flip M.lookup m) + +-- | Sort workspaces according to the stored dynamic ordering. +getSortByOrder :: X WorkspaceSort +getSortByOrder = mkWsSort getWsCompareByOrder + +-- | Swap the current workspace with another workspace in the stored +-- dynamic order. +swapWith :: Direction1D -> WSType -> X () +swapWith dir which = findWorkspace getSortByOrder dir which 1 >>= swapWithCurrent + +-- | Swap the given workspace with the current one. +swapWithCurrent :: WorkspaceId -> X () +swapWithCurrent w = do + cur <- gets (W.currentTag . windowset) + swapOrder w cur + +-- | Swap the two given workspaces in the dynamic order. +swapOrder :: WorkspaceId -> WorkspaceId -> X () +swapOrder w1 w2 = do + io $ print (w1,w2) + WSO (Just m) <- XS.get + let [i1,i2] = map (fromJust . flip M.lookup m) [w1,w2] + XS.modify (withWSO (M.insert w1 i2 . M.insert w2 i1)) + windows id -- force a status bar update + +-- | View the next workspace of the given type in the given direction, +-- where \"next\" is determined using the dynamic workspace order. +moveTo :: Direction1D -> WSType -> X () +moveTo dir t = doTo dir t getSortByOrder (windows . W.view) + +-- | Same as 'moveTo', but using 'greedyView' instead of 'view'. +moveToGreedy :: Direction1D -> WSType -> X () +moveToGreedy dir t = doTo dir t getSortByOrder (windows . W.greedyView) + +-- | Shift the currently focused window to the next workspace of the +-- 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) diff --git a/XMonad/Actions/DynamicWorkspaces.hs b/XMonad/Actions/DynamicWorkspaces.hs --- a/XMonad/Actions/DynamicWorkspaces.hs +++ b/XMonad/Actions/DynamicWorkspaces.hs @@ -8,15 +8,18 @@ -- Stability : unstable -- Portability : unportable -- --- Provides bindings to add and delete workspaces. Note that you may only --- delete a workspace that is already empty. +-- Provides bindings to add and delete workspaces. -- ----------------------------------------------------------------------------- module XMonad.Actions.DynamicWorkspaces ( -- * Usage -- $usage - addWorkspace, removeWorkspace, + addWorkspace, addWorkspacePrompt, + removeWorkspace, + removeEmptyWorkspace, + removeEmptyWorkspaceAfter, + removeEmptyWorkspaceAfterExcept, addHiddenWorkspace, withWorkspace, selectWorkspace, renameWorkspace, @@ -25,14 +28,18 @@ import XMonad hiding (workspaces) import XMonad.StackSet hiding (filter, modify, delete) -import XMonad.Prompt.Workspace -import XMonad.Prompt ( XPConfig, mkXPrompt, XPrompt(..) ) +import XMonad.Prompt.Workspace ( Wor(Wor), workspacePrompt ) +import XMonad.Prompt ( XPConfig, mkXPrompt ) import XMonad.Util.WorkspaceCompare ( getSortByIndex ) +import Data.List (find) +import Data.Maybe (isNothing) +import Control.Monad (when) -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file: -- -- > import XMonad.Actions.DynamicWorkspaces +-- > import XMonad.Actions.CopyWindow(copy) -- -- Then add keybindings like the following: -- @@ -50,14 +57,10 @@ -- > zip (zip (repeat (modm .|. shiftMask)) [xK_1..xK_9]) (map (withNthWorkspace W.shift) [0..]) -- -- For detailed instructions on editing your key bindings, see --- "XMonad.Doc.Extending#Editing_key_bindings". +-- "XMonad.Doc.Extending#Editing_key_bindings". See also the documentation for +-- "XMonad.Actions.CopyWindow", 'windows', 'shift', and 'defaultXPConfig'. -data Wor = Wor String - -instance XPrompt Wor where - showXPrompt (Wor x) = x - mkCompl :: [String] -> String -> IO [String] mkCompl l s = return $ filter (\x -> take (length s) x == s) l @@ -97,25 +100,68 @@ then windows $ greedyView w else addWorkspace w --- | Add a new workspace with the given name. +-- | Add a new workspace with the given name, or do nothing if a +-- workspace with the given name already exists; then switch to the +-- newly created workspace. addWorkspace :: String -> X () addWorkspace newtag = addHiddenWorkspace newtag >> windows (greedyView newtag) +-- | Prompt for the name of a new workspace, add it if it does not +-- already exist, and switch to it. +addWorkspacePrompt :: XPConfig -> X () +addWorkspacePrompt conf = mkXPrompt (Wor "New workspace name: ") conf (const (return [])) addWorkspace --- | Add a new hidden workspace with the given name. +-- | Add a new hidden workspace with the given name, or do nothing if +-- a workspace with the given name already exists. addHiddenWorkspace :: String -> X () -addHiddenWorkspace newtag = do l <- asks (layoutHook . config) - windows (addHiddenWorkspace' newtag l) +addHiddenWorkspace newtag = + whenX (gets (not . tagMember newtag . windowset)) $ do + l <- asks (layoutHook . config) + windows (addHiddenWorkspace' newtag l) -- | Remove the current workspace if it contains no windows. +removeEmptyWorkspace :: X () +removeEmptyWorkspace = gets (currentTag . windowset) >>= removeEmptyWorkspaceByTag + +-- | Remove the current workspace. removeWorkspace :: X () -removeWorkspace = do s <- gets windowset - case s of - StackSet { current = Screen { workspace = torem } - , hidden = (w:_) } - -> do windows $ view (tag w) - windows (removeWorkspace' (tag torem)) - _ -> return () +removeWorkspace = gets (currentTag . windowset) >>= removeWorkspaceByTag + +-- | Remove workspace with specific tag if it contains no windows. Only works +-- on the current or the last workspace. +removeEmptyWorkspaceByTag :: String -> X () +removeEmptyWorkspaceByTag t = whenX (isEmpty t) $ removeWorkspaceByTag t + +-- | Remove workspace with specific tag. Only works on the current or the last workspace. +removeWorkspaceByTag :: String -> X () +removeWorkspaceByTag torem = do + s <- gets windowset + case s of + StackSet { current = Screen { workspace = cur }, hidden = (w:_) } -> do + when (torem==tag cur) $ windows $ view $ tag w + windows $ removeWorkspace' torem + _ -> return () + +-- | Remove the current workspace after an operation if it is empty and hidden. +-- Can be used to remove a workspace if it is empty when leaving it. The +-- operation may only change workspace once, otherwise the workspace will not +-- be removed. +removeEmptyWorkspaceAfter :: X () -> X () +removeEmptyWorkspaceAfter = removeEmptyWorkspaceAfterExcept [] + +-- | Like 'removeEmptyWorkspaceAfter' but use a list of sticky workspaces, +-- whose entries will never be removed. +removeEmptyWorkspaceAfterExcept :: [String] -> X () -> X () +removeEmptyWorkspaceAfterExcept sticky f = do + before <- gets (currentTag . windowset) + f + after <- gets (currentTag . windowset) + when (before/=after && before `notElem` sticky) $ removeEmptyWorkspaceByTag before + +isEmpty :: String -> X Bool +isEmpty t = do wsl <- gets $ workspaces . windowset + let mws = find (\ws -> tag ws == t) wsl + return $ maybe True (isNothing . stack) mws addHiddenWorkspace' :: i -> l -> StackSet i l a sid sd -> StackSet i l a sid sd addHiddenWorkspace' newtag l s@(StackSet { hidden = ws }) = s { hidden = Workspace newtag l Nothing:ws } diff --git a/XMonad/Actions/FlexibleManipulate.hs b/XMonad/Actions/FlexibleManipulate.hs --- a/XMonad/Actions/FlexibleManipulate.hs +++ b/XMonad/Actions/FlexibleManipulate.hs @@ -23,6 +23,8 @@ ) where import XMonad +import qualified Prelude as P +import Prelude (($), (.), fst, snd, uncurry, const, id, Ord(..), Monad(..), fromIntegral, Double, Integer, map, round, otherwise) -- $usage -- First, add this import to your @~\/.xmonad\/xmonad.hs@: @@ -84,7 +86,7 @@ let uv = (pointer - wpos) / wsize fc = mapP f uv - mul = mapP (\x -> 2 - 2 * abs(x - 0.5)) fc --Fudge factors: interpolation between 1 when on edge, 2 in middle + mul = mapP (\x -> 2 P.- 2 P.* P.abs(x P.- 0.5)) fc --Fudge factors: interpolation between 1 when on edge, 2 in middle atl = ((1, 1) - fc) * mul abr = fc * mul mouseDrag (\ex ey -> io $ do @@ -121,14 +123,13 @@ minP :: Ord a => (a,a) -> (a,a) -> (a,a) minP = zipP min -instance Num Pnt where - (+) = zipP (+) - (-) = zipP (-) - (*) = zipP (*) - abs = mapP abs - signum = mapP signum - fromInteger = const undefined +infixl 6 +, - +infixl 7 *, / -instance Fractional Pnt where - fromRational = const undefined - recip = mapP recip +(+), (-), (*) :: (P.Num a) => (a,a) -> (a,a) -> (a,a) +(+) = zipP (P.+) +(-) = zipP (P.-) +(*) = zipP (P.*) +(/) :: (P.Fractional a) => (a,a) -> (a,a) -> (a,a) +(/) = zipP (P./) + diff --git a/XMonad/Actions/FlexibleResize.hs b/XMonad/Actions/FlexibleResize.hs --- a/XMonad/Actions/FlexibleResize.hs +++ b/XMonad/Actions/FlexibleResize.hs @@ -20,6 +20,7 @@ ) where import XMonad +import XMonad.Util.XUtils (fi) import Foreign.C.Types -- $usage @@ -76,6 +77,3 @@ Just True -> (0, (fi k + fi p -).fi, (fi k + fi p -).fi) Nothing -> (k `div` 2, const p, const $ fi k) Just False -> (k, const p, subtract (fi p) . fi) - -fi :: (Num b, Integral a) => a -> b -fi = fromIntegral diff --git a/XMonad/Actions/FloatKeys.hs b/XMonad/Actions/FloatKeys.hs --- a/XMonad/Actions/FloatKeys.hs +++ b/XMonad/Actions/FloatKeys.hs @@ -17,7 +17,9 @@ keysMoveWindow, keysMoveWindowTo, keysResizeWindow, - keysAbsResizeWindow) where + keysAbsResizeWindow, + P, G, + ) where import XMonad diff --git a/XMonad/Actions/GridSelect.hs b/XMonad/Actions/GridSelect.hs --- a/XMonad/Actions/GridSelect.hs +++ b/XMonad/Actions/GridSelect.hs @@ -28,7 +28,6 @@ -- * Configuration GSConfig(..), defaultGSConfig, - NavigateMap, TwoDPosition, buildDefaultGSConfig, @@ -38,6 +37,7 @@ withSelectedWindow, bringSelected, goToSelected, + gridselectWorkspace, spawnSelected, runSelectedAction, @@ -45,13 +45,35 @@ HasColorizer(defaultColorizer), fromClassName, stringColorizer, - colorRangeFromClassName + colorRangeFromClassName, + -- * Navigation Mode assembly + TwoD, + makeXEventhandler, + shadowWithKeymap, + + -- * Built-in Navigation Mode + defaultNavigation, + substringSearch, + navNSearch, + + -- * Navigation Components + setPos, + move, + moveNext, movePrev, + select, + cancel, + transformSearchString, + -- * Screenshots -- $screenshots + + -- * Types + TwoDState, ) where import Data.Maybe import Data.Bits +import Data.Char import Control.Applicative import Control.Monad.State import Control.Arrow @@ -92,13 +114,13 @@ -- > {-# LANGUAGE NoMonomorphismRestriction #-} -- > import XMonad -- > ... --- > gsconfig1 = defaultGSConfig { gs_cellheight = 30, gs_cellWidth = 100 } +-- > gsconfig1 = defaultGSConfig { gs_cellheight = 30, gs_cellwidth = 100 } -- -- An example where 'buildDefaultGSConfig' is used instead of 'defaultGSConfig' -- in order to specify a custom colorizer is @gsconfig2@ (found in -- "XMonad.Actions.GridSelect#Colorizers"): -- --- > gsconfig2 colorizer = (buildDefaultGSConfig colorizer) { gs_cellheight = 30, gs_cellWidth = 100 } +-- > gsconfig2 colorizer = (buildDefaultGSConfig colorizer) { gs_cellheight = 30, gs_cellwidth = 100 } -- -- > -- | A green monochrome colorizer based on window class -- > greenColorizer = colorRangeFromClassName @@ -117,45 +139,48 @@ -- $keybindings -- --- Adding more keybindings for gridselect to listen to is similar: --- --- At the top of your config: +-- You can build you own navigation mode and submodes by combining the +-- exported action ingredients and assembling them using 'makeXEventhandler' and 'shadowWithKeymap'. -- --- > {-# LANGAUGE NoMonomorphismRestriction #-} --- > import XMonad --- > import qualified Data.Map as M +-- > myNavigation :: TwoD a (Maybe a) +-- > myNavigation = makeXEventhandler $ shadowWithKeymap navKeyMap navDefaultHandler +-- > where navKeyMap = M.fromList [ +-- > ((0,xK_Escape), cancel) +-- > ,((0,xK_Return), select) +-- > ,((0,xK_slash) , substringSearch myNavigation) +-- > ,((0,xK_Left) , move (-1,0) >> myNavigation) +-- > ,((0,xK_h) , move (-1,0) >> myNavigation) +-- > ,((0,xK_Right) , move (1,0) >> myNavigation) +-- > ,((0,xK_l) , move (1,0) >> myNavigation) +-- > ,((0,xK_Down) , move (0,1) >> myNavigation) +-- > ,((0,xK_j) , move (0,1) >> myNavigation) +-- > ,((0,xK_Up) , move (0,-1) >> myNavigation) +-- > ,((0,xK_y) , move (-1,-1) >> myNavigation) +-- > ,((0,xK_i) , move (1,-1) >> myNavigation) +-- > ,((0,xK_n) , move (-1,1) >> myNavigation) +-- > ,((0,xK_m) , move (1,-1) >> myNavigation) +-- > ,((0,xK_space) , setPos (0,0) >> myNavigation) +-- > ] +-- > -- The navigation handler ignores unknown key symbols +-- > navDefaultHandler = const myNavigation -- --- Then define @gsconfig3@ which may be used in exactly the same manner as @gsconfig1@: +-- You can then define @gsconfig3@ which may be used in exactly the same manner as @gsconfig1@: -- -- > gsconfig3 = defaultGSConfig -- > { gs_cellheight = 30 -- > , gs_cellwidth = 100 --- > , gs_navigate = M.unions --- > [reset --- > ,nethackKeys --- > ,gs_navigate -- get the default navigation bindings --- > $ defaultGSConfig `asTypeOf` gsconfig3 -- needed to fix an ambiguous type variable --- > ] +-- > , gs_navigate = myNavigation -- > } --- > where addPair (a,b) (x,y) = (a+x,b+y) --- > nethackKeys = M.map addPair $ M.fromList --- > [((0,xK_y),(-1,-1)) --- > ,((0,xK_i),(1,-1)) --- > ,((0,xK_n),(-1,1)) --- > ,((0,xK_m),(1,1)) --- > ] --- > -- jump back to the center with the spacebar, regardless of the current position. --- > reset = M.singleton (0,xK_space) (const (0,0)) -- $screenshots -- -- Selecting a workspace: -- --- <> +-- <> -- -- Selecting a window by title: -- --- <> +-- <> data GSConfig a = GSConfig { gs_cellheight :: Integer, @@ -163,7 +188,7 @@ gs_cellpadding :: Integer, gs_colorizer :: a -> Bool -> X (String, String), gs_font :: String, - gs_navigate :: NavigateMap, + gs_navigate :: TwoD a (Maybe a), gs_originFractX :: Double, gs_originFractY :: Double } @@ -193,21 +218,29 @@ defaultGSConfig :: HasColorizer a => GSConfig a defaultGSConfig = buildDefaultGSConfig defaultColorizer -type NavigateMap = M.Map (KeyMask,KeySym) (TwoDPosition -> TwoDPosition) - type TwoDPosition = (Integer, Integer) type TwoDElementMap a = [(TwoDPosition,(String,a))] data TwoDState a = TwoDState { td_curpos :: TwoDPosition - , td_elementmap :: TwoDElementMap a + , td_availSlots :: [TwoDPosition] + , td_elements :: [(String,a)] , td_gsconfig :: GSConfig a , td_font :: XMonadFont , td_paneX :: Integer , td_paneY :: Integer , td_drawingWin :: Window + , td_searchString :: String } +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 + newtype TwoD a b = TwoD { unTwoD :: StateT (TwoDState a) X b } deriving (Monad,Functor,MonadState (TwoDState a)) @@ -221,14 +254,16 @@ evalTwoD :: TwoD a1 a -> TwoDState a1 -> X a evalTwoD m s = flip evalStateT s $ unTwoD m -diamondLayer :: (Enum b', Num b') => b' -> [(b', b')] --- FIXME remove nub -diamondLayer n = let ul = [ (x,n-x) | x <- [0..n] ] - in nub $ ul ++ (map (negate *** id) ul) ++ - (map (negate *** negate) ul) ++ - (map (id *** negate) ul) +diamondLayer :: (Enum a, Num a, Eq a) => a -> [(a, a)] +diamondLayer 0 = [(0,0)] +diamondLayer n = + -- tr = top right + -- r = ur ++ 90 degree clock-wise rotation of ur + let tr = [ (x,n-x) | x <- [0..n-1] ] + r = tr ++ (map (\(x,y) -> (y,-x)) tr) + in r ++ (map (negate *** negate) r) -diamond :: (Enum a, Num a) => [(a, a)] +diamond :: (Enum a, Num a, Eq a) => [(a, a)] diamond = concatMap diamondLayer [0..] diamondRestrict :: Integer -> Integer -> Integer -> Integer -> [(Integer, Integer)] @@ -237,9 +272,6 @@ map (\(x', y') -> (x' + fromInteger originX, y' + fromInteger originY)) . take 1000 $ diamond -tupadd :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1) -tupadd (a,b) (c,d) = (a+c,b+d) - findInElementMap :: (Eq a) => a -> [(a, b)] -> Maybe (a, b) findInElementMap pos = find ((== pos) . fst) @@ -268,11 +300,23 @@ updateAllElements :: TwoD a () updateAllElements = do - TwoDState { td_elementmap = els } <- get - updateElements els + s <- get + updateElements (td_elementmap s) +grayoutAllElements :: TwoD a () +grayoutAllElements = + do + s <- get + updateElementsWithColorizer grayOnly (td_elementmap s) + where grayOnly _ _ = return ("#808080", "#808080") + updateElements :: TwoDElementMap a -> TwoD a () updateElements elementmap = do + s <- get + updateElementsWithColorizer (gs_colorizer (td_gsconfig s)) elementmap + +updateElementsWithColorizer :: (a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a () +updateElementsWithColorizer colorizer elementmap = do TwoDState { td_curpos = curpos, td_drawingWin = win, td_gsconfig = gsconfig, @@ -284,7 +328,7 @@ paneX' = div (paneX-cellwidth) 2 paneY' = div (paneY-cellheight) 2 updateElement (pos@(x,y),(text, element)) = liftX $ do - colors <- gs_colorizer gsconfig element (pos == curpos) + colors <- colorizer element (pos == curpos) drawWinBox win font colors cellheight @@ -295,53 +339,181 @@ (gs_cellpadding gsconfig) mapM_ updateElement elementmap -eventLoop :: TwoD a (Maybe a) -eventLoop = do - (keysym,string,event) <- liftX $ withDisplay $ \d -> liftIO $ allocaXEvent $ \e -> do - maskEvent d (exposureMask .|. keyPressMask .|. buttonReleaseMask) e - ev <- getEvent e - (ks,s) <- if ev_event_type ev == keyPress - then lookupString $ asKeyEvent e - else return (Nothing, "") - return (ks,s,ev) - handle (fromMaybe xK_VoidSymbol keysym,string) event - -handle :: (KeySym, t) -> Event -> TwoD a (Maybe a) -handle (ks,_) (KeyEvent {ev_event_type = t, ev_state = m }) - | t == keyPress && ks == xK_Escape = return Nothing - | t == keyPress && ks == xK_Return = do - (TwoDState { td_curpos = pos, td_elementmap = elmap }) <- get - return $ fmap (snd . snd) $ findInElementMap pos elmap - | t == keyPress = do - m' <- liftX (cleanMask m) - keymap <- gets (gs_navigate . td_gsconfig) - maybe eventLoop diffAndRefresh . M.lookup (m',ks) $ keymap - where diffAndRefresh diff = do - state <- get - let elmap = td_elementmap state - oldPos = td_curpos state - newPos = diff oldPos - newSelectedEl = findInElementMap newPos elmap - when (isJust newSelectedEl) $ do - put state { td_curpos = newPos } - updateElements (catMaybes [(findInElementMap oldPos elmap), newSelectedEl]) - eventLoop - -handle _ (ButtonEvent { ev_event_type = t, ev_x = x, ev_y = y }) +stdHandle :: Event -> TwoD a (Maybe a) -> TwoD a (Maybe a) +stdHandle (ButtonEvent { ev_event_type = t, ev_x = x, ev_y = y }) contEventloop | t == buttonRelease = do - (TwoDState { td_elementmap = elmap, td_paneX = px, td_paneY = py, - td_gsconfig = (GSConfig ch cw _ _ _ _ _ _) }) <- get + s @ TwoDState { td_paneX = px, td_paneY = py, + td_gsconfig = (GSConfig ch cw _ _ _ _ _ _) } <- get let gridX = (fi x - (px - cw) `div` 2) `div` cw gridY = (fi y - (py - ch) `div` 2) `div` ch - case lookup (gridX,gridY) elmap of + case lookup (gridX,gridY) (td_elementmap s) of Just (_,el) -> return (Just el) - Nothing -> eventLoop - | otherwise = eventLoop + Nothing -> contEventloop + | otherwise = contEventloop -handle _ (ExposeEvent { }) = updateAllElements >> eventLoop +stdHandle (ExposeEvent { }) contEventloop = updateAllElements >> contEventloop -handle _ _ = eventLoop +stdHandle _ contEventloop = contEventloop +-- | Embeds a key handler into the X event handler that dispatches key +-- events to the key handler, while non-key event go to the standard +-- handler. +makeXEventhandler :: ((KeySym, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a) +makeXEventhandler keyhandler = fix $ \me -> join $ liftX $ withDisplay $ \d -> liftIO $ allocaXEvent $ \e -> do + maskEvent d (exposureMask .|. keyPressMask .|. buttonReleaseMask) e + ev <- getEvent e + if ev_event_type ev == keyPress + then do + (ks,s) <- lookupString $ asKeyEvent e + return $ do + mask <- liftX $ cleanMask (ev_state ev) + keyhandler (fromMaybe xK_VoidSymbol ks, s, mask) + else + return $ stdHandle ev me + +-- | When the map contains (KeySym,KeyMask) tuple for the given event, +-- the associated action in the map associated shadows the default key +-- handler +shadowWithKeymap :: M.Map (KeyMask, KeySym) a -> ((KeySym, String, KeyMask) -> a) -> (KeySym, String, KeyMask) -> a +shadowWithKeymap keymap dflt keyEvent@(ks,_,m') = fromMaybe (dflt keyEvent) (M.lookup (m',ks) keymap) + +-- Helper functions to use for key handler functions + +-- | Closes gridselect returning the element under the cursor +select :: TwoD a (Maybe a) +select = do + s <- get + return $ fmap (snd . snd) $ findInElementMap (td_curpos s) (td_elementmap s) + +-- | Closes gridselect returning no element. +cancel :: TwoD a (Maybe a) +cancel = return Nothing + +-- | Sets the absolute position of the cursor. +setPos :: (Integer, Integer) -> TwoD a () +setPos newPos = do + s <- get + let elmap = td_elementmap s + newSelectedEl = findInElementMap newPos (td_elementmap s) + oldPos = td_curpos s + when (isJust newSelectedEl && newPos /= oldPos) $ do + put s { td_curpos = newPos } + updateElements (catMaybes [(findInElementMap oldPos elmap), newSelectedEl]) + +-- | Moves the cursor by the offsets specified +move :: (Integer, Integer) -> TwoD a () +move (dx,dy) = do + s <- get + let (x,y) = td_curpos s + newPos = (x+dx,y+dy) + setPos newPos + +moveNext :: TwoD a () +moveNext = do + position <- gets td_curpos + elems <- gets td_elementmap + let n = length elems + m = case findIndex (\p -> fst p == position) elems of + Nothing -> Nothing + Just k | k == n-1 -> Just 0 + | otherwise -> Just (k+1) + whenJust m $ \i -> + setPos (fst $ elems !! i) + +movePrev :: TwoD a () +movePrev = do + position <- gets td_curpos + elems <- gets td_elementmap + let n = length elems + m = case findIndex (\p -> fst p == position) elems of + Nothing -> Nothing + Just 0 -> Just (n-1) + Just k -> Just (k-1) + whenJust m $ \i -> + setPos (fst $ elems !! i) + +-- | Apply a transformation function the current search string +transformSearchString :: (String -> String) -> TwoD a () +transformSearchString f = do + s <- get + let oldSearchString = td_searchString s + newSearchString = f oldSearchString + when (newSearchString /= oldSearchString) $ do + -- FIXME: grayoutAllElements + updateAllElements paint some fields twice causing flickering + -- we would need a much smarter update strategy to fix that + when (length newSearchString > length oldSearchString) grayoutAllElements + -- FIXME curpos might end up outside new bounds + put s { td_searchString = newSearchString } + updateAllElements + +-- | By default gridselect used the defaultNavigation action, which +-- binds left,right,up,down and vi-style h,l,j,k navigation. Return +-- quits gridselect, returning the selected element, while Escape +-- cancels the selection. Slash enters the substring search mode. In +-- substring search mode, every string-associated keystroke is +-- added to a search string, which narrows down the object +-- selection. Substring search mode comes back to regular navigation +-- via Return, while Escape cancels the search. If you want that +-- navigation style, add 'defaultNavigation' as 'gs_navigate' to your +-- 'GSConfig' object. This is done by 'buildDefaultGSConfig' automatically. +defaultNavigation :: TwoD a (Maybe a) +defaultNavigation = makeXEventhandler $ shadowWithKeymap navKeyMap navDefaultHandler + where navKeyMap = M.fromList [ + ((0,xK_Escape) , cancel) + ,((0,xK_Return) , select) + ,((0,xK_slash) , substringSearch defaultNavigation) + ,((0,xK_Left) , move (-1,0) >> defaultNavigation) + ,((0,xK_h) , move (-1,0) >> defaultNavigation) + ,((0,xK_Right) , move (1,0) >> defaultNavigation) + ,((0,xK_l) , move (1,0) >> defaultNavigation) + ,((0,xK_Down) , move (0,1) >> defaultNavigation) + ,((0,xK_j) , move (0,1) >> defaultNavigation) + ,((0,xK_Up) , move (0,-1) >> defaultNavigation) + ,((0,xK_k) , move (0,-1) >> defaultNavigation) + ,((0,xK_Tab) , moveNext >> defaultNavigation) + ,((0,xK_n) , moveNext >> defaultNavigation) + ,((shiftMask,xK_Tab), movePrev >> defaultNavigation) + ,((0,xK_p) , movePrev >> defaultNavigation) + ] + -- The navigation handler ignores unknown key symbols, therefore we const + navDefaultHandler = const defaultNavigation + +-- | This navigation style combines navigation and search into one mode at the cost of losing vi style +-- navigation. With this style, there is no substring search submode, +-- but every typed character is added to the substring search. +navNSearch :: TwoD a (Maybe a) +navNSearch = makeXEventhandler $ shadowWithKeymap navNSearchKeyMap navNSearchDefaultHandler + where navNSearchKeyMap = M.fromList [ + ((0,xK_Escape) , cancel) + ,((0,xK_Return) , select) + ,((0,xK_Left) , move (-1,0) >> navNSearch) + ,((0,xK_Right) , move (1,0) >> navNSearch) + ,((0,xK_Down) , move (0,1) >> navNSearch) + ,((0,xK_Up) , move (0,-1) >> navNSearch) + ,((0,xK_Tab) , moveNext >> navNSearch) + ,((shiftMask,xK_Tab), movePrev >> navNSearch) + ,((0,xK_BackSpace), transformSearchString (\s -> if (s == "") then "" else init s) >> navNSearch) + ] + -- The navigation handler ignores unknown key symbols, therefore we const + navNSearchDefaultHandler (_,s,_) = do + transformSearchString (++ s) + navNSearch + +-- | Navigation submode used for substring search. It returns to the +-- first argument navigation style when the user hits Return. +substringSearch :: TwoD a (Maybe a) -> TwoD a (Maybe a) +substringSearch returnNavigation = fix $ \me -> + let searchKeyMap = M.fromList [ + ((0,xK_Escape) , transformSearchString (const "") >> returnNavigation) + ,((0,xK_Return) , returnNavigation) + ,((0,xK_BackSpace), transformSearchString (\s -> if (s == "") then "" else init s) >> me) + ] + searchDefaultHandler (_,s,_) = do + transformSearchString (++ s) + me + in makeXEventhandler $ shadowWithKeymap searchKeyMap searchDefaultHandler + + -- FIXME probably move that into Utils? -- Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space hsv2rgb :: Fractional a => (Integer,a,a) -> (a,a,a) @@ -418,7 +590,8 @@ -- | Brings up a 2D grid of elements in the center of the screen, and one can -- select an element with cursors keys. The selected element is returned. gridselect :: GSConfig a -> [(String,a)] -> X (Maybe a) -gridselect gsconfig elmap = +gridselect _ [] = return Nothing +gridselect gsconfig elements = withDisplay $ \dpy -> do rootw <- asks theRoot s <- gets $ screenRect . W.screenDetail . W.current . windowset @@ -438,16 +611,16 @@ originPosX = floor $ ((gs_originFractX gsconfig) - (1/2)) * 2 * fromIntegral restrictX originPosY = floor $ ((gs_originFractY gsconfig) - (1/2)) * 2 * fromIntegral restrictY coords = diamondRestrict restrictX restrictY originPosX originPosY - elmap' = zip coords elmap - evalTwoD (updateAllElements >> eventLoop) - (TwoDState (head coords) - elmap' - gsconfig - font - screenWidth - screenHeight - win) + evalTwoD (updateAllElements >> (gs_navigate gsconfig)) TwoDState { td_curpos = (head coords), + td_availSlots = coords, + td_elements = elements, + td_gsconfig = gsconfig, + td_font = font, + td_paneX = screenWidth, + td_paneY = screenHeight, + td_drawingWin = win, + td_searchString = "" } else return Nothing liftIO $ do @@ -484,19 +657,7 @@ -- | Builds a default gs config from a colorizer function. buildDefaultGSConfig :: (a -> Bool -> X (String,String)) -> GSConfig a -buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultGSNav (1/2) (1/2) - -defaultGSNav :: NavigateMap -defaultGSNav = M.map tupadd $ M.fromList - [((0,xK_Left) ,(-1,0)) - ,((0,xK_h) ,(-1,0)) - ,((0,xK_Right),(1,0)) - ,((0,xK_l) ,(1,0)) - ,((0,xK_Down) ,(0,1)) - ,((0,xK_j) ,(0,1)) - ,((0,xK_Up) ,(0,-1)) - ,((0,xK_k) ,(0,-1)) - ] +buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultNavigation (1/2) (1/2) borderColor :: String borderColor = "white" @@ -523,3 +684,15 @@ case selectedActionM of Just selectedAction -> selectedAction Nothing -> return () + +-- | Select a workspace and view it using the given function +-- (normally 'W.view' or 'W.greedyView') +-- +-- Another option is to shift the current window to the selected workspace: +-- +-- > gridselectWorkspace (\ws -> W.greedyView ws . W.shift ws) +gridselectWorkspace :: GSConfig WorkspaceId -> + (WorkspaceId -> WindowSet -> WindowSet) -> X () +gridselectWorkspace conf viewFunc = withWindowSet $ \ws -> do + let wss = map W.tag $ W.hidden ws ++ map W.workspace (W.current ws : W.visible ws) + gridselect conf (zip wss wss) >>= flip whenJust (windows . viewFunc) diff --git a/XMonad/Actions/GroupNavigation.hs b/XMonad/Actions/GroupNavigation.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/GroupNavigation.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +---------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.GroupNavigation +-- Copyright : (c) nzeh@cs.dal.ca +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : nzeh@cs.dal.ca +-- Stability : unstable +-- Portability : unportable +-- +-- Provides methods for cycling through groups of windows across +-- workspaces, ignoring windows that do not belong to this group. A +-- group consists of all windows matching a user-provided boolean +-- query. +-- +-- Also provides a method for jumping back to the most recently used +-- window in any given group. +-- +---------------------------------------------------------------------- + +module XMonad.Actions.GroupNavigation ( -- * Usage + -- $usage + Direction (..) + , nextMatch + , nextMatchOrDo + , nextMatchWithThis + , historyHook + ) where + +import Control.Monad.Reader +import Data.Foldable as Fold +import Data.Map as Map +import Data.Sequence as Seq +import Data.Set as Set +import Graphics.X11.Types +import Prelude hiding (concatMap, drop, elem, filter, null, reverse) +import XMonad.Core +import XMonad.ManageHook +import XMonad.Operations (windows, withFocused) +import qualified XMonad.StackSet as SS +import qualified XMonad.Util.ExtensibleState as XS + +{- $usage + +Import the module into your @~\/.xmonad\/xmonad.hs@: + +> import XMonad.Actions,GroupNavigation + +To support cycling forward and backward through all xterm windows, add +something like this to your keybindings: + +> , ((modm , xK_t), nextMatch Forward (className =? "XTerm")) +> , ((modm .|. shiftMask, xK_t), nextMatch Backward (className =? "XTerm")) + +These key combinations do nothing if there is no xterm window open. +If you rather want to open a new xterm window if there is no open +xterm window, use 'nextMatchOrDo' instead: + +> , ((modm , xK_t), nextMatchOrDo Forward (className =? "XTerm") (spawn "xterm")) +> , ((modm .|. shiftMask, xK_t), nextMatchOrDo Backward (className =? "XTerm") (spawn "xterm")) + +You can use 'nextMatchWithThis' with an arbitrary query to cycle +through all windows for which this query returns the same value as the +current window. For example, to cycle through all windows in the same +window class as the current window use: + +> , ((modm , xK_f), nextMatchWithThis Forward className) +> , ((modm , xK_b), nextMatchWithThis Backward className) + +Finally, you can define keybindings to jump to the most recent window +matching a certain Boolean query. To do this, you need to add +'historyHook' to your logHook: + +> main = xmonad $ defaultConfig { logHook = historyHook } + +Then the following keybindings, for example, allow you to return to +the most recent xterm or emacs window or to simply to the most recent +window: + +> , ((modm .|. controlMask, xK_e), nextMatch History (className =? "Emacs")) +> , ((modm .|. controlMask, xK_t), nextMatch History (className =? "XTerm")) +> , ((modm , xK_BackSpace), nextMatch History (return True)) + +Again, you can use 'nextMatchOrDo' instead of 'nextMatch' if you want +to execute an action if no window matching the query exists. -} + +--- Basic cyclic navigation based on queries ------------------------- + +-- | The direction in which to look for the next match +data Direction = Forward -- ^ Forward from current window or workspace + | Backward -- ^ Backward from current window or workspace + | History -- ^ Backward in history + +-- | Focuses the next window for which the given query produces the +-- same result as the currently focused window. Does nothing if there +-- is no focused window (i.e., the current workspace is empty). +nextMatchWithThis :: Eq a => Direction -> Query a -> X () +nextMatchWithThis dir qry = withFocused $ \win -> do + prop <- runQuery qry win + nextMatch dir (qry =? prop) + +-- | Focuses the next window that matches the given boolean query. +-- Does nothing if there is no such window. This is the same as +-- 'nextMatchOrDo' with alternate action @return ()@. +nextMatch :: Direction -> Query Bool -> X () +nextMatch dir qry = nextMatchOrDo dir qry (return ()) + +-- | 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 + >>= 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) + >=> maybe act (windows . SS.focusWindow) + +-- Returns the list of windows ordered by workspace as specified in +-- ~/.xmonad/xmonad.hs +orderedWindowList :: Direction -> X (Seq Window) +orderedWindowList History = liftM (\(HistoryDB w ws) -> maybe ws (ws |>) w) XS.get +orderedWindowList dir = withWindowSet $ \ss -> do + wsids <- asks (Seq.fromList . workspaces . config) + let wspcs = orderedWorkspaceList ss wsids + wins = dirfun dir + $ Fold.foldl' (><) Seq.empty + $ fmap (Seq.fromList . SS.integrate' . SS.stack) wspcs + cur = SS.peek ss + return $ maybe wins (rotfun wins) cur + where + dirfun Backward = Seq.reverse + dirfun _ = id + rotfun wins x = rotate $ rotateTo (== x) wins + +-- Returns the ordered workspace list as specified in ~/.xmonad/xmonad.hs +orderedWorkspaceList :: WindowSet -> Seq String -> Seq WindowSpace +orderedWorkspaceList ss wsids = rotateTo isCurWS wspcs' + where + wspcs = SS.workspaces ss + wspcsMap = Fold.foldl' (\m ws -> Map.insert (SS.tag ws) ws m) Map.empty wspcs + wspcs' = fmap (\wsid -> wspcsMap ! wsid) wsids + isCurWS ws = SS.tag ws == SS.tag (SS.workspace $ SS.current ss) + +--- History navigation, requires a layout modifier ------------------- + +-- The state extension that holds the history information +data HistoryDB = HistoryDB (Maybe Window) -- currently focused window + (Seq Window) -- previously focused windows + deriving (Read, Show, Typeable) + +instance ExtensionClass HistoryDB where + + initialValue = HistoryDB Nothing Seq.empty + extensionType = PersistentExtension + +-- | Action that needs to be executed as a logHook to maintain the +-- focus history of all windows as the WindowSet changes. +historyHook :: X () +historyHook = XS.get >>= updateHistory >>= XS.put + +-- Updates the history in response to a WindowSet change +updateHistory :: HistoryDB -> X HistoryDB +updateHistory (HistoryDB oldcur oldhist) = withWindowSet $ \ss -> do + let newcur = SS.peek ss + wins = Set.fromList $ SS.allWindows ss + newhist = flt (flip Set.member wins) (ins oldcur oldhist) + return $ HistoryDB newcur (del newcur newhist) + where + ins x xs = maybe xs (<| xs) x + del x xs = maybe xs (\x' -> flt (/= x') xs) x + +--- Two replacements for Seq.filter and Seq.breakl available only in +--- containers-0.3.0.0, which only ships with ghc 6.12. Once we +--- decide to no longer support ghc < 6.12, these should be replaced +--- with Seq.filter and Seq.breakl. + +flt :: (a -> Bool) -> Seq a -> Seq a +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 + $ 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 +rotate :: Seq a -> Seq a +rotate xs = rotate' (viewl xs) + where + rotate' EmptyL = Seq.empty + rotate' (x' :< xs') = xs' |> x' + +-- Rotates the sequence until an element matching the given condition +-- is at the beginning of the sequence. +rotateTo :: (a -> Bool) -> Seq a -> Seq a +rotateTo cond xs = let (lxs, rxs) = brkl cond xs in rxs >< lxs + +--- A monadic find --------------------------------------------------- + +-- Applies the given action to every sequence element in turn until +-- the first element is found for which the action returns true. The +-- remaining elements in the sequence are ignored. +findM :: Monad m => (a -> m Bool) -> Seq a -> m (Maybe a) +findM cond xs = findM' cond (viewl xs) + where + findM' _ EmptyL = return Nothing + findM' qry (x' :< xs') = do + isMatch <- qry x' + if isMatch + then return (Just x') + else findM qry xs' diff --git a/XMonad/Actions/KeyRemap.hs b/XMonad/Actions/KeyRemap.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/KeyRemap.hs @@ -0,0 +1,156 @@ + {-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.KeyRemap +-- Copyright : (c) Christian Dietrich +-- License : BSD-style (as xmonad) +-- +-- Maintainer : stettberger@dokucde.de +-- Stability : unstable +-- Portability : unportable +-- +-- Remap Keybinding on the fly, e.g having Dvorak char, but everything with Control/Shift +-- is left us Layout +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.KeyRemap ( + -- * Usage + -- $usage + setKeyRemap, + buildKeyRemapBindings, + setDefaultKeyRemap, + + KeymapTable (KeymapTable), + emptyKeyRemap, + dvorakProgrammerKeyRemap + ) where + +import XMonad +import XMonad.Util.Paste +import Data.List + +import qualified XMonad.Util.ExtensibleState as XS +import Control.Monad + + +data KeymapTable = KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))] deriving (Typeable, Show) + +instance ExtensionClass KeymapTable where + initialValue = KeymapTable [] + +-- $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 +-- after all +-- +-- First, you must add all possible keybindings for all layout you want to use: +-- +-- > keys = myKeys ++ buildKeyRemapBindings [dvorakProgrammerKeyRemap,emptyKeyRemap] +-- +-- Then you must add setDefaultKeyRemap to your startup hook (e.g. you want to set the +-- empty keyremap (no remapping is done) as default after startup): +-- +-- > myStartupHook :: X() +-- > myStartupHook = do +-- > setWMName "LG3D" +-- > setDefaultKeyRemap emptyKeyRemap [dvorakProgrammerKeyRemap, emptyKeyRemap] +-- +-- Then you add keybindings for changing keyboard layouts; +-- +-- > , ((0 , xK_F1 ), setKeyRemap emptyKeyRemap) +-- > , ((0 , xK_F2 ), setKeyRemap dvorakProgrammerKeyRemap) +-- +-- When defining your own keymappings, please be aware of: +-- +-- * If you want to emulate a key that is shifted on us you must emulate that keypress: +-- +-- > KeymapTable [((0, xK_a), (shiftMask, xK_5))] -- would bind 'a' to '%' +-- > KeymapTable [((shiftMask, xK_a), (0, xK_5))] -- would bind 'A' to '5' +-- +-- * the dvorakProgrammerKeyRemap uses the original us layout as lookuptable to generate +-- the KeymapTable +-- +-- * KeySym and (ord Char) are incompatible, therefore the magic numbers in dvorakProgrammerKeyRemap +-- are nessesary + +doKeyRemap :: KeyMask -> KeySym -> X() +doKeyRemap mask sym = do + table <- XS.get + let (insertMask, insertSym) = extractKeyMapping table mask sym + sendKey insertMask insertSym + +-- | Using this in the keybindings to set the actual Key Translation table +setKeyRemap :: KeymapTable -> X() +setKeyRemap table = do + let KeymapTable newtable = table + KeymapTable oldtable <- XS.get + XConf { display = dpy, theRoot = rootw } <- ask + + let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync + let ungrab kc m = io $ ungrabKey dpy kc m rootw + + forM_ oldtable $ \((mask, sym), _) -> do + kc <- io $ keysymToKeycode dpy sym + -- "If the specified KeySym is not defined for any KeyCode, + -- XKeysymToKeycode() returns zero." + when (kc /= 0) $ ungrab kc mask + + forM_ newtable $ \((mask, sym), _) -> do + kc <- io $ keysymToKeycode dpy sym + -- "If the specified KeySym is not defined for any KeyCode, + -- XKeysymToKeycode() returns zero." + when (kc /= 0) $ grab kc mask + + XS.put table + +-- | Adding this to your startupHook, to select your default Key Translation table. +-- You also must give it all the KeymapTables you are willing to use +setDefaultKeyRemap :: KeymapTable -> [KeymapTable] -> X() +setDefaultKeyRemap dflt keyremaps = do + XS.put (KeymapTable mappings) + setKeyRemap dflt + where + mappings = nub (keyremaps >>= \(KeymapTable table) -> table) + +extractKeyMapping :: KeymapTable -> KeyMask -> KeySym -> (KeyMask, KeySym) +extractKeyMapping (KeymapTable table) mask sym = + insertKey filtered + where filtered = filter (\((m, s),_) -> m == mask && s == sym) table + insertKey [] = (mask, sym) + insertKey ((_, to):_) = to + +-- | Append the output of this function to your keybindings with ++ +buildKeyRemapBindings :: [KeymapTable] -> [((KeyMask, KeySym), X ())] +buildKeyRemapBindings keyremaps = + [((mask, sym), doKeyRemap mask sym) | (mask, sym) <- bindings] + where mappings = concat (map (\(KeymapTable table) -> table) keyremaps) + bindings = nub (map (\binding -> fst binding) mappings) + + +-- Here come the Keymappings +-- | The empty KeymapTable, does no translation +emptyKeyRemap :: KeymapTable +emptyKeyRemap = KeymapTable [] + +-- | The dvorak Programmers keymap, translates from us keybindings to dvorak programmers +dvorakProgrammerKeyRemap :: KeymapTable +dvorakProgrammerKeyRemap = + KeymapTable [((charToMask maskFrom, from), (charToMask maskTo, to)) | + (maskFrom, from, maskTo, to) <- (zip4 layoutUsShift layoutUsKey layoutDvorakShift layoutDvorakKey)] + where + + layoutUs = map (fromIntegral . fromEnum) "`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./~!@#$%^&*()_+QWERTYUIOP{}|ASDFGHJKL:\"ZXCVBNM<>?" :: [KeySym] + layoutUsKey = map (fromIntegral . fromEnum) "`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./" :: [KeySym] + layoutUsShift = "0000000000000000000000000000000000000000000000011111111111111111111111111111111111111111111111" + + layoutDvorak = map (fromIntegral . fromEnum) "$&[{}(=*)+]!#;,.pyfgcrl/@\\aoeuidhtns-'qjkxbmwvz~%7531902468`:<>PYFGCRL?^|AOEUIDHTNS_\"QJKXBMWVZ" :: [KeySym] + + layoutDvorakShift = map getShift layoutDvorak + layoutDvorakKey = map getKey layoutDvorak + getKey char = let Just index = elemIndex char layoutUs + in layoutUsKey !! index + getShift char = let Just index = elemIndex char layoutUs + in layoutUsShift !! index + charToMask char = if [char] == "0" then 0 else shiftMask diff --git a/XMonad/Actions/MessageFeedback.hs b/XMonad/Actions/MessageFeedback.hs --- a/XMonad/Actions/MessageFeedback.hs +++ b/XMonad/Actions/MessageFeedback.hs @@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : XMonad.Actions.MessageFeedback --- Copyright : (c) Quentin Moser +-- Copyright : (c) Quentin Moser -- License : BSD3 -- --- Maintainer : None +-- Maintainer : orphaned -- Stability : unstable -- Portability : unportable -- diff --git a/XMonad/Actions/MouseResize.hs b/XMonad/Actions/MouseResize.hs --- a/XMonad/Actions/MouseResize.hs +++ b/XMonad/Actions/MouseResize.hs @@ -23,12 +23,8 @@ , MouseResize (..) ) where -import Control.Monad -import Data.Maybe - import XMonad import XMonad.Layout.Decoration -import XMonad.Layout.LayoutModifier import XMonad.Layout.WindowArranger import XMonad.Util.XUtils @@ -114,6 +110,11 @@ Just tr -> withDisplay $ \d -> do tw <- mkInputWindow d tr io $ selectInput d tw (exposureMask .|. buttonPressMask) + + cursor <- io $ createFontCursor d xC_bottom_right_corner + io $ defineCursor d tw cursor + io $ freeCursor d cursor + showWindow tw return ((w,r), Just tw) Nothing -> return ((w,r), Nothing) diff --git a/XMonad/Actions/OnScreen.hs b/XMonad/Actions/OnScreen.hs --- a/XMonad/Actions/OnScreen.hs +++ b/XMonad/Actions/OnScreen.hs @@ -15,18 +15,138 @@ module XMonad.Actions.OnScreen ( -- * Usage -- $usage - onScreen + onScreen + , onScreen' + , Focus(..) , viewOnScreen , greedyViewOnScreen , onlyOnScreen + , toggleOnScreen + , toggleGreedyOnScreen ) where -import XMonad.StackSet -import Control.Monad(guard) -import Data.List -import Data.Maybe(fromMaybe) -import Data.Function(on) +import XMonad +import XMonad.StackSet hiding (new) +import Control.Monad (guard) +-- import Control.Monad.State.Class (gets) +import Data.Maybe (fromMaybe) + + +-- | Focus data definitions +data Focus = FocusNew -- ^ always focus the new screen + | FocusCurrent -- ^ always keep the focus on the current screen + | FocusTag WorkspaceId -- ^ always focus tag i on the new stack + | FocusTagVisible WorkspaceId -- ^ focus tag i only if workspace with tag i is visible on the old stack + + +-- | Run any function that modifies the stack on a given screen. This function +-- will also need to know which Screen to focus after the function has been +-- run. +onScreen :: (WindowSet -> WindowSet) -- ^ function to run + -> Focus -- ^ what to do with the focus + -> ScreenId -- ^ screen id + -> WindowSet -- ^ current stack + -> WindowSet +onScreen f foc sc st = fromMaybe st $ do + ws <- lookupWorkspace sc st + + let fStack = f $ view ws st + + return $ setFocus foc st fStack + + +-- set focus for new stack +setFocus :: Focus + -> WindowSet -- ^ old stack + -> WindowSet -- ^ new stack + -> WindowSet +setFocus FocusNew _ new = new +setFocus FocusCurrent old new = + case lookupWorkspace (screen $ current old) new of + Nothing -> new + Just i -> view i new +setFocus (FocusTag i) _ new = view i new +setFocus (FocusTagVisible i) old new = + if i `elem` map (tag . workspace) (visible old) + then setFocus (FocusTag i) old new + else setFocus FocusCurrent old new + +-- | A variation of @onScreen@ which will take any @X ()@ function and run it +-- on the given screen. +-- Warning: This function will change focus even if the function it's supposed +-- to run doesn't succeed. +onScreen' :: X () -- ^ X function to run + -> Focus -- ^ focus + -> ScreenId -- ^ screen id + -> X () +onScreen' x foc sc = do + st <- gets windowset + case lookupWorkspace sc st of + Nothing -> return () + Just ws -> do + windows $ view ws + x + windows $ setFocus foc st + + +-- | Switch to workspace @i@ on screen @sc@. If @i@ is visible use @view@ to +-- switch focus to the workspace @i@. +viewOnScreen :: ScreenId -- ^ screen id + -> WorkspaceId -- ^ index of the workspace + -> WindowSet -- ^ current stack + -> WindowSet +viewOnScreen sid i = + onScreen (view i) (FocusTag i) sid + +-- | Switch to workspace @i@ on screen @sc@. If @i@ is visible use @greedyView@ +-- to switch the current workspace with workspace @i@. +greedyViewOnScreen :: ScreenId -- ^ screen id + -> WorkspaceId -- ^ index of the workspace + -> WindowSet -- ^ current stack + -> WindowSet +greedyViewOnScreen sid i = + onScreen (greedyView i) (FocusTagVisible i) sid + +-- | Switch to workspace @i@ on screen @sc@. If @i@ is visible do nothing. +onlyOnScreen :: ScreenId -- ^ screen id + -> WorkspaceId -- ^ index of the workspace + -> WindowSet -- ^ current stack + -> WindowSet +onlyOnScreen sid i = + onScreen (view i) FocusCurrent sid + +-- | @toggleOrView@ as in "XMonad.Actions.CycleWS" for @onScreen@ with view +toggleOnScreen :: ScreenId -- ^ screen id + -> WorkspaceId -- ^ index of the workspace + -> WindowSet -- ^ current stack + -> WindowSet +toggleOnScreen sid i = + onScreen (toggleOrView' view i) FocusCurrent sid + +-- | @toggleOrView@ from "XMonad.Actions.CycleWS" for @onScreen@ with greedyView +toggleGreedyOnScreen :: ScreenId -- ^ screen id + -> WorkspaceId -- ^ index of the workspace + -> WindowSet -- ^ current stack + -> WindowSet +toggleGreedyOnScreen sid i = + onScreen (toggleOrView' greedyView i) FocusCurrent sid + + +-- a \"pure\" version of X.A.CycleWS.toggleOrDoSkip +toggleOrView' :: (WorkspaceId -> WindowSet -> WindowSet) -- ^ function to run + -> WorkspaceId -- ^ tag to look for + -> WindowSet -- ^ current stackset + -> WindowSet +toggleOrView' f i st = fromMaybe (f i st) $ do + let st' = hidden st + -- make sure we actually have to do something + guard $ i == (tag . workspace $ current st) + guard $ not (null st') + -- finally, toggle! + return $ f (tag . head $ st') st + + -- $usage -- -- This module provides an easy way to control, what you see on other screens in @@ -60,56 +180,9 @@ -- -- A more basic version inside the default keybindings would be: -- --- > , ((modm .|. controlMask, xK_1) windows (viewOnScreen 0 "1")) +-- > , ((modm .|. controlMask, xK_1), windows (viewOnScreen 0 "1")) -- --- where 0 is the first screen and "1" the workspace with the tag "1". +-- where 0 is the first screen and \"1\" the workspace with the tag \"1\". -- -- For detailed instructions on editing your key bindings, see -- "XMonad.Doc.Extending#Editing_key_bindings". - --- | Switch to the (hidden) workspace with index 'i' on the screen 'sc'. --- A default function (for example 'view' or 'greedyView') will be run if 'sc' is --- the current screen, no valid screen id or workspace 'i' is already visible. -onScreen :: (Eq sid, Eq i) - => (i -> StackSet i l a sid sd -> StackSet i l a sid sd) -- ^ default action - -> sid -- ^ screen id - -> i -- ^ index of the workspace - -> StackSet i l a sid sd -- ^ current stack - -> StackSet i l a sid sd -onScreen defFunc sc i st = fromMaybe (defFunc i st) $ do - -- on unfocused current screen - guard $ screen (current st) /= sc - x <- find ((i==) . tag ) (hidden st) - s <- find ((sc==) . screen) (screens st) - o <- find ((sc==) . screen) (visible st) - let newScreen = s { workspace = x } - return st { visible = newScreen : deleteBy ((==) `on` screen) newScreen (visible st) - , hidden = workspace o : deleteBy ((==) `on` tag) x (hidden st) - } - --- | Switch to workspace 'i' on screen 'sc'. If 'i' is visible use 'greedyView' --- to switch the current workspace with workspace 'i'. -greedyViewOnScreen :: (Eq sid, Eq i) - => sid -- ^ screen id - -> i -- ^ index of the workspace - -> StackSet i l a sid sd -- ^ current stack - -> StackSet i l a sid sd -greedyViewOnScreen = onScreen greedyView - --- | Switch to workspace 'i' on screen 'sc'. If 'i' is visible use 'view' to --- switch focus to the workspace 'i'. -viewOnScreen :: (Eq sid, Eq i) - => sid -- ^ screen id - -> i -- ^ index of the workspace - -> StackSet i l a sid sd -- ^ current stack - -> StackSet i l a sid sd -viewOnScreen = onScreen view - --- | Switch to workspace 'i' on screen 'sc'. If 'i' is visible do nothing. -onlyOnScreen :: (Eq sid, Eq i) - => sid -- ^ screen id - -> i -- ^ index of the workspace - -> StackSet i l a sid sd -- ^ current stack - -> StackSet i l a sid sd -onlyOnScreen = onScreen doNothing - where doNothing _ st = st diff --git a/XMonad/Actions/PerWorkspaceKeys.hs b/XMonad/Actions/PerWorkspaceKeys.hs --- a/XMonad/Actions/PerWorkspaceKeys.hs +++ b/XMonad/Actions/PerWorkspaceKeys.hs @@ -21,7 +21,6 @@ import XMonad import XMonad.StackSet as S -import Data.List (find) -- $usage -- @@ -42,9 +41,9 @@ -- If it isn't listed, then run default action (marked with empty string, \"\"), or do nothing if default isn't supplied. bindOn :: [(String, X())] -> X() bindOn bindings = chooseAction chooser where - chooser ws = case find ((ws==).fst) bindings of - Just (_, action) -> action - Nothing -> case find ((""==).fst) bindings of - Just (_, action) -> action + chooser ws = case lookup ws bindings of + Just action -> action + Nothing -> case lookup "" bindings of + Just action -> action Nothing -> return () diff --git a/XMonad/Actions/PhysicalScreens.hs b/XMonad/Actions/PhysicalScreens.hs --- a/XMonad/Actions/PhysicalScreens.hs +++ b/XMonad/Actions/PhysicalScreens.hs @@ -19,15 +19,14 @@ , getScreen , viewScreen , sendToScreen + , onNextNeighbour + , onPrevNeighbour ) where import XMonad import qualified XMonad.StackSet as W -import qualified Graphics.X11.Xlib as X -import Graphics.X11.Xinerama - -import Data.List (sortBy) +import Data.List (sortBy,findIndex) import Data.Function (on) {- $usage @@ -44,6 +43,11 @@ > import XMonad.Actions.PhysicalSCreens +> , ((modMask, xK_a), onPrevNeighbour W.view) +> , ((modMask, xK_o), onNextNeighbour W.view) +> , ((modMask .|. shiftMask, xK_a), onPrevNeighbour W.shift) +> , ((modMask .|. shiftMask, xK_o), onNextNeighbour W.shift) + > -- > -- mod-{w,e,r}, Switch to physical/Xinerama screens 1, 2, or 3 > -- mod-shift-{w,e,r}, Move client to screen 1, 2, or 3 @@ -61,12 +65,12 @@ -- | Translate a physical screen index to a "ScreenId" getScreen :: PhysicalScreen -> X (Maybe ScreenId) -getScreen (P i) = withDisplay $ \dpy -> do - screens <- io $ getScreenInfo dpy - if i >= length screens - then return Nothing - else let ss = sortBy (cmpScreen `on` fst) $ zip screens [0..] - in return $ Just $ snd $ ss !! i +getScreen (P i) = do w <- gets windowset + let screens = W.current w : W.visible w + if i<0 || i >= length screens + then return Nothing + else let ss = sortBy (cmpScreen `on` (screenRect . W.screenDetail)) screens + in return $ Just $ W.screen $ ss !! i -- | Switch to a given physical screen viewScreen :: PhysicalScreen -> X () @@ -85,4 +89,27 @@ -- | Compare two screens by their top-left corners, ordering -- | top-to-bottom and then left-to-right. cmpScreen :: Rectangle -> Rectangle -> Ordering -cmpScreen (Rectangle x1 y1 _ _) (Rectangle x2 y2 _ _) = compare (y1,x1) (y2,x2) +cmpScreen (Rectangle x1 y1 _ _) (Rectangle x2 y2 _ _) = compare (y1,x1) (y2,x2) + + +-- | Get ScreenId for neighbours of the current screen based on position offset. +getNeighbour :: Int -> X ScreenId +getNeighbour d = do w <- gets windowset + let ss = map W.screen $ sortBy (cmpScreen `on` (screenRect . W.screenDetail)) $ W.current w : W.visible w + curPos = maybe 0 id $ findIndex (== W.screen (W.current w)) ss + pos = (curPos + d) `mod` length ss + return $ ss !! pos + +neighbourWindows :: Int -> (WorkspaceId -> WindowSet -> WindowSet) -> X () +neighbourWindows d f = do s <- getNeighbour d + w <- screenWorkspace s + whenJust w $ windows . f + +-- | Apply operation on a WindowSet with the WorkspaceId of the next screen in the physical order as parameter. +onNextNeighbour :: (WorkspaceId -> WindowSet -> WindowSet) -> X () +onNextNeighbour = neighbourWindows 1 + +-- | 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/Search.hs b/XMonad/Actions/Search.hs --- a/XMonad/Actions/Search.hs +++ b/XMonad/Actions/Search.hs @@ -44,26 +44,32 @@ lucky, maps, mathworld, + openstreetmap, scholar, thesaurus, wayback, wikipedia, wiktionary, youtube, - multi + multi, -- * Use case: searching with a submap -- $tip + + -- * Types + Browser, Site, Query, Name, Search ) where -import Data.Char (chr, ord, isAlpha, isMark, isDigit) +import Codec.Binary.UTF8.String (encode) +import Data.Char (isAlphaNum, isAscii) import Data.List (isPrefixOf) -import Numeric (showIntAtBase) +import Text.Printf import XMonad (X(), MonadIO, liftIO) -import XMonad.Prompt (XPrompt(showXPrompt), mkXPrompt, XPConfig(), historyCompletionP) +import XMonad.Prompt (XPrompt(showXPrompt, nextCompletion, commandToComplete), mkXPrompt, XPConfig(), historyCompletionP, getNextCompletion) import XMonad.Prompt.Shell (getBrowser) import XMonad.Util.Run (safeSpawn) import XMonad.Util.XSelection (getSelection) + {- $usage This module is intended to allow easy access to databases on the @@ -120,6 +126,8 @@ * 'mathworld' -- Wolfram MathWorld search. +* 'openstreetmap' -- OpenStreetMap free wiki world map. + * 'scholar' -- Google scholar academic search. * 'thesaurus' -- thesaurus.reference.com search. @@ -194,32 +202,19 @@ data Search = Search Name instance XPrompt Search where showXPrompt (Search name)= "Search [" ++ name ++ "]: " + nextCompletion _ = getNextCompletion + commandToComplete _ c = c --- | Escape the search string so search engines understand it. --- Note that everything is escaped; we could be smarter and use 'isAllowedInURI' --- but then that'd be hard enough to copy-and-paste we'd need to depend on @network@. +-- | Escape the search string so search engines understand it. Only +-- digits and ASCII letters are not encoded. All non ASCII characters +-- which are encoded as UTF8 escape :: String -> String -escape = escapeURIString (\c -> isAlpha c || isDigit c || isMark c) - where -- Copied from Network.URI. - escapeURIString :: - (Char -> Bool) -- a predicate which returns 'False' if should escape - -> String -- the string to process - -> String -- the resulting URI string - escapeURIString = concatMap . escapeURIChar - escapeURIChar :: (Char->Bool) -> Char -> String - escapeURIChar p c - | p c = [c] - | otherwise = '%' : myShowHex (ord c) "" - where - myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 toChrHex n r of - [] -> "00" - [ch] -> ['0',ch] - cs -> cs - toChrHex d - | d < 10 = chr (ord '0' + fromIntegral d) - | otherwise = chr (ord 'A' + fromIntegral (d - 10)) +escape = concatMap escapeURIChar +escapeURIChar :: Char -> String +escapeURIChar c | isAscii c && isAlphaNum c = [c] + | otherwise = concatMap (printf "%%%02X") $ encode [c] + type Browser = FilePath type Query = String type Site = String -> String @@ -258,8 +253,8 @@ inside of a URL instead of in the end) you can use the alternative 'searchEngineF' function. > searchFunc :: String -> String -> searchFunc s | s `isPrefixOf` "wiki:" = "http://en.wikipedia.org/wiki/" ++ (escape $ tail $ snd $ break (==':') s) -> | s `isPrefixOf` "http://" = s +> searchFunc s | "wiki:" `isPrefixOf` s = "http://en.wikipedia.org/wiki/" ++ (escape $ tail $ snd $ break (==':') s) +> | "http://" `isPrefixOf` s = s > | otherwise = (use google) s > myNewEngine = searchEngineF "mymulti" searchFunc @@ -276,36 +271,34 @@ -- The engines. amazon, alpha, codesearch, deb, debbts, debpts, dictionary, google, hackage, hoogle, - images, imdb, isohunt, lucky, maps, mathworld, scholar, thesaurus, wayback, wikipedia, wiktionary, + images, imdb, isohunt, lucky, maps, mathworld, openstreetmap, scholar, thesaurus, wayback, wikipedia, wiktionary, youtube :: SearchEngine -amazon = searchEngine "amazon" "http://www.amazon.com/exec/obidos/external-search?index=all&keyword=" -alpha = searchEngine "alpha" "http://www.wolframalpha.com/input/?i=" -codesearch = searchEngine "codesearch" "http://www.google.com/codesearch?q=" -deb = searchEngine "deb" "http://packages.debian.org/" -debbts = searchEngine "debbts" "http://bugs.debian.org/" -debpts = searchEngine "debpts" "http://packages.qa.debian.org/" -dictionary = searchEngine "dict" "http://dictionary.reference.com/browse/" -google = searchEngine "google" "http://www.google.com/search?num=100&q=" -hackage = searchEngine "hackage" "http://hackage.haskell.org/package/" -hoogle = searchEngine "hoogle" "http://www.haskell.org/hoogle/?q=" -images = searchEngine "images" "http://images.google.fr/images?q=" -imdb = searchEngine "imdb" "http://www.imdb.com/Find?select=all&for=" -isohunt = searchEngine "isohunt" "http://isohunt.com/torrents/?ihq=" -lucky = searchEngine "lucky" "http://www.google.com/search?btnI&q=" -maps = searchEngine "maps" "http://maps.google.com/maps?q=" -mathworld = searchEngine "mathworld" "http://mathworld.wolfram.com/search/?query=" -scholar = searchEngine "scholar" "http://scholar.google.com/scholar?q=" -thesaurus = searchEngine "thesaurus" "http://thesaurus.reference.com/search?q=" -wikipedia = searchEngine "wiki" "https://secure.wikimedia.org/wikipedia/en/wiki/Special:Search?go=Go&search=" -wiktionary = searchEngine "wikt" "http://en.wiktionary.org/wiki/Special:Search?go=Go&search=" -youtube = searchEngine "youtube" "http://www.youtube.com/results?search_type=search_videos&search_query=" -{- This doesn't seem to work, but nevertheless, it seems to be the official - method at to get the - latest backup. -} -wayback = searchEngine "wayback" "http://web.archive.org/" +amazon = searchEngine "amazon" "http://www.amazon.com/exec/obidos/external-search?index=all&keyword=" +alpha = searchEngine "alpha" "http://www.wolframalpha.com/input/?i=" +codesearch = searchEngine "codesearch" "http://www.google.com/codesearch?q=" +deb = searchEngine "deb" "http://packages.debian.org/" +debbts = searchEngine "debbts" "http://bugs.debian.org/" +debpts = searchEngine "debpts" "http://packages.qa.debian.org/" +dictionary = searchEngine "dict" "http://dictionary.reference.com/browse/" +google = searchEngine "google" "http://www.google.com/search?num=100&q=" +hackage = searchEngine "hackage" "http://hackage.haskell.org/package/" +hoogle = searchEngine "hoogle" "http://www.haskell.org/hoogle/?q=" +images = searchEngine "images" "http://images.google.fr/images?q=" +imdb = searchEngine "imdb" "http://www.imdb.com/find?s=all&q=" +isohunt = searchEngine "isohunt" "http://isohunt.com/torrents/?ihq=" +lucky = searchEngine "lucky" "http://www.google.com/search?btnI&q=" +maps = searchEngine "maps" "http://maps.google.com/maps?q=" +mathworld = searchEngine "mathworld" "http://mathworld.wolfram.com/search/?query=" +openstreetmap = searchEngine "openstreetmap" "http://gazetteer.openstreetmap.org/namefinder/?find=" +scholar = searchEngine "scholar" "http://scholar.google.com/scholar?q=" +thesaurus = searchEngine "thesaurus" "http://thesaurus.reference.com/search?q=" +wikipedia = searchEngine "wiki" "http://en.wikipedia.org/wiki/Special:Search?go=Go&search=" +wiktionary = searchEngine "wikt" "http://en.wiktionary.org/wiki/Special:Search?go=Go&search=" +youtube = searchEngine "youtube" "http://www.youtube.com/results?search_type=search_videos&search_query=" +wayback = searchEngineF "wayback" ("http://web.archive.org/web/*/"++) multi :: SearchEngine -multi = namedEngine "multi" $ foldr1 (!>) [amazon, alpha, codesearch, deb, debbts, debpts, dictionary, google, hackage, hoogle, images, imdb, isohunt, lucky, maps, mathworld, scholar, thesaurus, wayback, wikipedia, wiktionary, (prefixAware google)] +multi = namedEngine "multi" $ foldr1 (!>) [amazon, alpha, codesearch, deb, debbts, debpts, dictionary, google, hackage, hoogle, images, imdb, isohunt, lucky, maps, mathworld, openstreetmap, scholar, thesaurus, wayback, wikipedia, wiktionary, (prefixAware google)] {- | This function wraps up a search engine and creates a new one, which works like the argument, but goes directly to a URL if one is given rather than @@ -334,14 +327,14 @@ \"mathworld:integral\" will search mathworld, and everything else will fall back to google. The use of intelligent will make sure that URLs are opened directly. -} (!>) :: SearchEngine -> SearchEngine -> SearchEngine -(SearchEngine name1 site1) !> (SearchEngine name2 site2) = searchEngineF (name1 ++ "/" ++ name2) (\s -> if s `isPrefixOf` (name1++":") then site1 (removeColonPrefix s) else site2 s) +(SearchEngine name1 site1) !> (SearchEngine name2 site2) = searchEngineF (name1 ++ "/" ++ name2) (\s -> if (name1++":") `isPrefixOf` s then site1 (removeColonPrefix s) else site2 s) {- | Makes a search engine prefix-aware. Especially useful together with '!>'. It will automatically remove the prefix from a query so that you don\'t end up searching for google:xmonad if google is your fallback engine and you explicitly add the prefix. -} prefixAware :: SearchEngine -> SearchEngine -prefixAware (SearchEngine name site) = SearchEngine name (\s -> if s `isPrefixOf` (name++":") then site $ removeColonPrefix s else site s) +prefixAware (SearchEngine name site) = SearchEngine name (\s -> if (name++":") `isPrefixOf` s then site $ removeColonPrefix s else site s) {- | Changes search engine's name -} namedEngine :: Name -> SearchEngine -> SearchEngine diff --git a/XMonad/Actions/SpawnOn.hs b/XMonad/Actions/SpawnOn.hs --- a/XMonad/Actions/SpawnOn.hs +++ b/XMonad/Actions/SpawnOn.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.Actions.SpawnOn @@ -18,7 +19,6 @@ -- * Usage -- $usage Spawner, - mkSpawner, manageSpawn, spawnHere, spawnOn, @@ -28,7 +28,6 @@ ) where import Data.List (isInfixOf) -import Data.IORef import System.Posix.Types (ProcessID) import XMonad @@ -37,6 +36,7 @@ import XMonad.Hooks.ManageHelpers import XMonad.Prompt import XMonad.Prompt.Shell +import qualified XMonad.Util.ExtensibleState as XS -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -44,17 +44,16 @@ -- > import XMonad.Actions.SpawnOn -- -- > main = do --- > sp <- mkSpawner -- > xmonad defaultConfig { -- > ... --- > manageHook = manageSpawn sp <+> manageHook defaultConfig +-- > manageHook = manageSpawn <+> manageHook defaultConfig -- > ... -- > } -- -- To ensure that application appears on a workspace it was launched at, add keybindings like: -- --- > , ((mod1Mask,xK_o), spawnHere sp "urxvt") --- > , ((mod1Mask,xK_s), shellPromptHere sp defaultXPConfig) +-- > , ((mod1Mask,xK_o), spawnHere "urxvt") +-- > , ((mod1Mask,xK_s), shellPromptHere defaultXPConfig) -- -- The module can also be used to apply other manage hooks to the window of -- the spawned application(e.g. float or resize it). @@ -62,26 +61,29 @@ -- For detailed instructions on editing your key bindings, see -- "XMonad.Doc.Extending#Editing_key_bindings". -newtype Spawner = Spawner {pidsRef :: IORef [(ProcessID, ManageHook)]} +newtype Spawner = Spawner {pidsRef :: [(ProcessID, ManageHook)]} deriving Typeable +instance ExtensionClass Spawner where + initialValue = Spawner [] + maxPids :: Int maxPids = 5 --- | Create 'Spawner' which then has to be passed to other functions. -mkSpawner :: (Functor m, MonadIO m) => m Spawner -mkSpawner = io . fmap Spawner $ newIORef [] +-- | Get the current Spawner or create one if it doesn't exist. +modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X () +modifySpawner f = XS.modify (Spawner . f . pidsRef) -- | Provides a manage hook to react on process spawned with -- 'spawnOn', 'spawnHere' etc. -manageSpawn :: Spawner -> ManageHook -manageSpawn sp = do - pids <- io . readIORef $ pidsRef sp +manageSpawn :: ManageHook +manageSpawn = do + Spawner pids <- liftX XS.get mp <- pid case flip lookup pids =<< mp of - Nothing -> doF id + Nothing -> idHook Just mh -> do whenJust mp $ \p -> - io . modifyIORef (pidsRef sp) $ filter ((/= p) . fst) + liftX . modifySpawner $ filter ((/= p) . fst) mh mkPrompt :: (String -> X ()) -> XPConfig -> X () @@ -91,32 +93,31 @@ -- | Replacement for Shell prompt ("XMonad.Prompt.Shell") which launches -- application on current workspace. -shellPromptHere :: Spawner -> XPConfig -> X () -shellPromptHere sp = mkPrompt (spawnHere sp) +shellPromptHere :: XPConfig -> X () +shellPromptHere = mkPrompt spawnHere -- | Replacement for Shell prompt ("XMonad.Prompt.Shell") which launches -- application on given workspace. -shellPromptOn :: Spawner -> WorkspaceId -> XPConfig -> X () -shellPromptOn sp ws = mkPrompt (spawnOn sp ws) +shellPromptOn :: WorkspaceId -> XPConfig -> X () +shellPromptOn ws = mkPrompt (spawnOn ws) -- | Replacement for 'spawn' which launches -- application on current workspace. -spawnHere :: Spawner -> String -> X () -spawnHere sp cmd = withWindowSet $ \ws -> spawnOn sp (W.currentTag ws) cmd +spawnHere :: String -> X () +spawnHere cmd = withWindowSet $ \ws -> spawnOn (W.currentTag ws) cmd -- | Replacement for 'spawn' which launches -- application on given workspace. -spawnOn :: Spawner -> WorkspaceId -> String -> X () -spawnOn sp ws cmd = spawnAndDo sp (doShift ws) cmd +spawnOn :: WorkspaceId -> String -> X () +spawnOn ws cmd = spawnAndDo (doShift ws) cmd -- | Spawn an application and apply the manage hook when it opens. -spawnAndDo :: Spawner -> ManageHook -> String -> X () -spawnAndDo sp mh cmd = do +spawnAndDo :: ManageHook -> String -> X () +spawnAndDo mh cmd = do p <- spawnPID $ mangle cmd - io $ modifyIORef (pidsRef sp) (take maxPids . ((p,mh) :)) + modifySpawner $ (take maxPids . ((p,mh) :)) where -- TODO this is silly, search for a better solution mangle xs | any (`elem` metaChars) xs || "exec" `isInfixOf` xs = xs | otherwise = "exec " ++ xs metaChars = "&|;" - diff --git a/XMonad/Actions/Submap.hs b/XMonad/Actions/Submap.hs --- a/XMonad/Actions/Submap.hs +++ b/XMonad/Actions/Submap.hs @@ -76,6 +76,7 @@ else return (m, keysym) -- Remove num lock mask and Xkb group state bits m' <- cleanMask $ m .&. ((1 `shiftL` 12) - 1) - maybe def id (M.lookup (m', s) keys) io $ ungrabKeyboard d currentTime + + maybe def id (M.lookup (m', s) keys) diff --git a/XMonad/Actions/SwapWorkspaces.hs b/XMonad/Actions/SwapWorkspaces.hs --- a/XMonad/Actions/SwapWorkspaces.hs +++ b/XMonad/Actions/SwapWorkspaces.hs @@ -25,7 +25,6 @@ import XMonad (windows, X()) import XMonad.StackSet import XMonad.Actions.CycleWS -import XMonad.Util.Types import XMonad.Util.WorkspaceCompare diff --git a/XMonad/Actions/TagWindows.hs b/XMonad/Actions/TagWindows.hs --- a/XMonad/Actions/TagWindows.hs +++ b/XMonad/Actions/TagWindows.hs @@ -22,17 +22,23 @@ focusDownTagged, focusDownTaggedGlobal, shiftHere, shiftToScreen, tagPrompt, - tagDelPrompt + tagDelPrompt, + TagPrompt, ) where -import Data.List (nub,concat,sortBy) +import Prelude hiding (catch) +import Data.List (nub,sortBy) import Control.Monad +import Control.Exception import XMonad.StackSet hiding (filter) import XMonad.Prompt import XMonad hiding (workspaces) +econst :: Monad m => a -> IOException -> m a +econst = const . return + -- $usage -- -- To use window tags, import this module into your @~\/.xmonad\/xmonad.hs@: @@ -79,7 +85,7 @@ io $ catch (internAtom d "_XMONAD_TAGS" False >>= getTextProperty d w >>= wcTextPropertyToTextList d) - (\_ -> return [[]]) + (econst [[]]) >>= return . words . unwords -- | check a window for the given tag diff --git a/XMonad/Actions/TopicSpace.hs b/XMonad/Actions/TopicSpace.hs --- a/XMonad/Actions/TopicSpace.hs +++ b/XMonad/Actions/TopicSpace.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.Actions.TopicSpace @@ -21,8 +22,10 @@ Topic , Dir , TopicConfig(..) + , defaultTopicConfig , getLastFocusedTopics , setLastFocusedTopic + , reverseLastFocusedTopics , pprWindowSet , topicActionWithPrompt , topicAction @@ -39,13 +42,12 @@ import XMonad import Data.List -import Data.Maybe (fromMaybe, isNothing, listToMaybe) +import Data.Maybe (fromMaybe, isNothing, listToMaybe, fromJust) import Data.Ord import qualified Data.Map as M -import Control.Monad ((=<<),liftM2,when,unless,replicateM_) +import Control.Monad (liftM2,when,unless,replicateM_) import System.IO -import XMonad.Operations import qualified XMonad.StackSet as W import XMonad.Prompt @@ -56,7 +58,7 @@ import qualified XMonad.Hooks.DynamicLog as DL import XMonad.Util.Run (spawnPipe) -import XMonad.Util.StringProp(getStringListProp,setStringListProp) +import qualified XMonad.Util.ExtensibleState as XS -- $overview -- This module allows to organize your workspaces on a precise topic basis. So @@ -204,20 +206,38 @@ -- numeric keypad. } +defaultTopicConfig :: TopicConfig +defaultTopicConfig = TopicConfig { topicDirs = M.empty + , topicActions = M.empty + , defaultTopicAction = const (ask >>= spawn . terminal . config) + , defaultTopic = "1" + , maxTopicHistory = 10 + } + +newtype PrevTopics = PrevTopics { getPrevTopics :: [String] } deriving (Read,Show,Typeable) +instance ExtensionClass PrevTopics where + initialValue = PrevTopics [] + extensionType = PersistentExtension + -- | Returns the list of last focused workspaces the empty list otherwise. --- This function rely on a reserved property namely _XMONAD_LAST_FOCUSED_WORKSPACES. getLastFocusedTopics :: X [String] -getLastFocusedTopics = asks display >>= flip getStringListProp "_XMONAD_LAST_FOCUSED_WORKSPACES" +getLastFocusedTopics = XS.gets getPrevTopics -- | Given a 'TopicConfig', the last focused topic, and a predicate that will -- select topics that one want to keep, this function will set the property -- of last focused topics. -setLastFocusedTopic :: TopicConfig -> Topic -> (Topic -> Bool) -> X () -setLastFocusedTopic tg w predicate = do - disp <- asks display - setStringListProp disp "_XMONAD_LAST_FOCUSED_WORKSPACES" - . take (maxTopicHistory tg) . nub . (w:) . filter predicate =<< getLastFocusedTopics +setLastFocusedTopic :: Topic -> (Topic -> Bool) -> X () +setLastFocusedTopic w predicate = + XS.modify $ PrevTopics + . seqList . nub . (w:) . filter predicate + . getPrevTopics + where seqList xs = length xs `seq` xs +-- | Reverse the list of "last focused topics" +reverseLastFocusedTopics :: X () +reverseLastFocusedTopics = + XS.modify $ PrevTopics . reverse . getPrevTopics + -- | This function is a variant of 'DL.pprWindowSet' which takes a topic configuration -- and a pretty-printing record 'PP'. It will show the list of topics sorted historically -- and highlighting topics with urgent windows. @@ -227,13 +247,13 @@ urgents <- readUrgents let empty_workspaces = map W.tag $ filter (isNothing . W.stack) $ W.workspaces winset maxDepth = maxTopicHistory tg - setLastFocusedTopic tg (W.tag . W.workspace . W.current $ winset) - (`notElem` empty_workspaces) + setLastFocusedTopic (W.tag . W.workspace . W.current $ winset) + (`notElem` empty_workspaces) lastWs <- getLastFocusedTopics - let depth topic = elemIndex topic lastWs - add_depth proj topic = proj pp $ maybe topic (((topic++":")++) . show) $ depth topic + let depth topic = fromJust $ elemIndex topic (lastWs ++ [topic]) + add_depth proj topic = proj pp . (((topic++":")++) . show) . depth $ topic pp' = pp { ppHidden = add_depth ppHidden, ppVisible = add_depth ppVisible } - sortWindows = take (maxDepth - 1) . sortBy (comparing $ fromMaybe maxDepth . depth . W.tag) + sortWindows = take maxDepth . sortBy (comparing $ depth . W.tag) return $ DL.pprWindowSet sortWindows urgents pp' winset -- | Given a prompt configuration and a topic configuration, triggers the action associated with @@ -257,7 +277,7 @@ when (null wins) $ topicAction tg topic -- | Switch to the Nth last focused topic or failback to the 'defaultTopic'. -switchNthLastFocused ::TopicConfig -> Int -> X () +switchNthLastFocused :: TopicConfig -> Int -> X () switchNthLastFocused tg depth = do lastWs <- getLastFocusedTopics switchTopic tg $ (lastWs ++ repeat (defaultTopic tg)) !! depth diff --git a/XMonad/Actions/UpdateFocus.hs b/XMonad/Actions/UpdateFocus.hs --- a/XMonad/Actions/UpdateFocus.hs +++ b/XMonad/Actions/UpdateFocus.hs @@ -21,7 +21,6 @@ import XMonad import qualified XMonad.StackSet as W -import Graphics.X11.Xlib.Extras import Control.Monad (when) import Data.Monoid @@ -45,10 +44,10 @@ -- check only every 15 px to avoid excessive calls to translateCoordinates when (x `mod` 15 == 0 || y `mod` 15 == 0) $ do dpy <- asks display - Just foc <- withWindowSet $ return . W.peek + foc <- withWindowSet $ return . W.peek -- get the window under the pointer: (_,_,_,w) <- io $ translateCoordinates dpy root root (fromIntegral x) (fromIntegral y) - when (foc /= w) $ focus w + when (foc /= Just w) $ focus w return (All True) focusOnMouseMove _ = return (All True) diff --git a/XMonad/Actions/UpdatePointer.hs b/XMonad/Actions/UpdatePointer.hs --- a/XMonad/Actions/UpdatePointer.hs +++ b/XMonad/Actions/UpdatePointer.hs @@ -24,6 +24,7 @@ where import XMonad +import XMonad.Util.XUtils (fi) import Control.Monad import XMonad.StackSet (member, peek, screenDetail, current) import Data.Maybe @@ -91,8 +92,10 @@ where fraction x y = floor (x * fromIntegral y) windowAttributesToRectangle :: WindowAttributes -> Rectangle -windowAttributesToRectangle wa = Rectangle (fi (wa_x wa)) (fi (wa_y wa)) - (fi (wa_width wa)) (fi (wa_height wa)) +windowAttributesToRectangle wa = Rectangle (fi (wa_x wa)) + (fi (wa_y wa)) + (fi (wa_width wa + 2 * wa_border_width wa)) + (fi (wa_height wa + 2 * wa_border_width wa)) moveWithin :: Ord a => a -> a -> a -> a moveWithin now lower upper = if now < lower @@ -100,6 +103,3 @@ else if now > upper then upper else now - -fi :: (Num b, Integral a) => a -> b -fi = fromIntegral diff --git a/XMonad/Actions/Warp.hs b/XMonad/Actions/Warp.hs --- a/XMonad/Actions/Warp.hs +++ b/XMonad/Actions/Warp.hs @@ -22,7 +22,6 @@ warpToWindow ) where -import Data.Ratio import Data.List import XMonad import XMonad.StackSet as W diff --git a/XMonad/Actions/WindowBringer.hs b/XMonad/Actions/WindowBringer.hs --- a/XMonad/Actions/WindowBringer.hs +++ b/XMonad/Actions/WindowBringer.hs @@ -17,7 +17,9 @@ module XMonad.Actions.WindowBringer ( -- * Usage -- $usage - gotoMenu, gotoMenu', bringMenu, windowMap, + gotoMenu, gotoMenu', gotoMenuArgs, gotoMenuArgs', + bringMenu, bringMenu', bringMenuArgs, bringMenuArgs', + windowMap, bringWindow ) where @@ -27,7 +29,7 @@ import qualified XMonad.StackSet as W import XMonad import qualified XMonad as X -import XMonad.Util.Dmenu (menuMap) +import XMonad.Util.Dmenu (menuMapArgs) import XMonad.Util.NamedWindows (getName) -- $usage @@ -44,34 +46,66 @@ -- For detailed instructions on editing your key bindings, see -- "XMonad.Doc.Extending#Editing_key_bindings". +-- | Default menu command +defaultCmd :: String +defaultCmd = "dmenu" -- | Pops open a dmenu with window titles. Choose one, and you will be -- taken to the corresponding workspace. gotoMenu :: X () -gotoMenu = actionMenu W.focusWindow +gotoMenu = gotoMenuArgs [] +-- | Pops open a dmenu with window titles. Choose one, and you will be +-- taken to the corresponding workspace. This version takes a list of +-- arguments to pass to dmenu. +gotoMenuArgs :: [String] -> X () +gotoMenuArgs menuArgs = gotoMenuArgs' defaultCmd menuArgs + +-- | Pops open an application with window titles given over stdin. Choose one, +-- and you will be taken to the corresponding workspace. gotoMenu' :: String -> X () -gotoMenu' menuCmd = actionMenu' menuCmd W.focusWindow +gotoMenu' menuCmd = gotoMenuArgs' menuCmd [] +-- | Pops open an application with window titles given over stdin. Choose one, +-- and you will be taken to the corresponding workspace. This version takes a +-- list of arguments to pass to dmenu. +gotoMenuArgs' :: String -> [String] -> X () +gotoMenuArgs' menuCmd menuArgs = actionMenu menuCmd menuArgs W.focusWindow + -- | Pops open a dmenu with window titles. Choose one, and it will be -- dragged, kicking and screaming, into your current workspace. bringMenu :: X () -bringMenu = actionMenu bringWindow +bringMenu = bringMenuArgs [] +-- | Pops open a dmenu with window titles. Choose one, and it will be +-- dragged, kicking and screaming, into your current workspace. This version +-- takes a list of arguments to pass to dmenu. +bringMenuArgs :: [String] -> X () +bringMenuArgs menuArgs = bringMenuArgs' defaultCmd menuArgs + +-- | Pops open an application with window titles given over stdin. Choose one, +-- and it will be dragged, kicking and screaming, into your current +-- workspace. +bringMenu' :: String -> X () +bringMenu' menuCmd = bringMenuArgs' menuCmd [] + +-- | Pops open an application with window titles given over stdin. Choose one, +-- and it will be dragged, kicking and screaming, into your current +-- workspace. This version allows arguments to the chooser to be specified. +bringMenuArgs' :: String -> [String] -> X () +bringMenuArgs' menuCmd menuArgs = actionMenu menuCmd menuArgs bringWindow + -- | Brings the specified window into the current workspace. bringWindow :: Window -> X.WindowSet -> X.WindowSet bringWindow w ws = W.shiftWin (W.currentTag ws) w ws -- | Calls dmenuMap to grab the appropriate Window, and hands it off to action -- if found. -actionMenu :: (Window -> X.WindowSet -> X.WindowSet) -> X() -actionMenu action = actionMenu' "dmenu" action - -actionMenu' :: String -> (Window -> X.WindowSet -> X.WindowSet) -> X() -actionMenu' menuCmd action = windowMap >>= menuMapFunction >>= flip X.whenJust (windows . action) +actionMenu :: String -> [String] -> (Window -> X.WindowSet -> X.WindowSet) -> X () +actionMenu menuCmd menuArgs action = windowMap >>= menuMapFunction >>= flip X.whenJust (windows . action) where menuMapFunction :: M.Map String a -> X (Maybe a) - menuMapFunction selectionMap = menuMap menuCmd selectionMap + menuMapFunction selectionMap = menuMapArgs menuCmd menuArgs selectionMap -- | A map from window names to Windows. windowMap :: X (M.Map String Window) diff --git a/XMonad/Actions/WindowGo.hs b/XMonad/Actions/WindowGo.hs --- a/XMonad/Actions/WindowGo.hs +++ b/XMonad/Actions/WindowGo.hs @@ -80,8 +80,11 @@ ifWindow :: Query Bool -> ManageHook -> X () -> X () ifWindow qry mh = ifWindows qry (windows . appEndo <=< runQuery mh . head) --- | 'action' is an executable to be run via 'safeSpawnProg' (of "XMonad.Util.Run") if the Window cannot be found. --- Presumably this executable is the same one that you were looking for. +{- | 'action' is an executable to be run via 'safeSpawnProg' (of "XMonad.Util.Run") if the Window cannot be found. + Presumably this executable is the same one that you were looking for. + Note that this does not go through the shell. If you wish to run an arbitrary IO action + (such as 'spawn', which will run its String argument through the shell), then you will want to use + 'raiseMaybe' directly. -} runOrRaise :: String -> Query Bool -> X () runOrRaise = raiseMaybe . safeSpawnProg @@ -160,11 +163,11 @@ {- | If the window is found the window is focused and the third argument is called otherwise, the first argument is called See 'raiseMaster' for an example. -} -raiseAndDo :: X () -> Query Bool -> (Window -> X ())-> X () +raiseAndDo :: X () -> Query Bool -> (Window -> X ()) -> X () raiseAndDo f qry after = ifWindow qry (afterRaise `mappend` raiseHook) f where afterRaise = ask >>= (>> idHook) . liftX . after -{- | If a window matching the second arugment is found, the window is focused and the third argument is called; +{- | If a window matching the second argument is found, the window is focused and the third argument is called; otherwise, the first argument is called. -} runOrRaiseAndDo :: String -> Query Bool -> (Window -> X ()) -> X () runOrRaiseAndDo = raiseAndDo . safeSpawnProg diff --git a/XMonad/Actions/WindowMenu.hs b/XMonad/Actions/WindowMenu.hs --- a/XMonad/Actions/WindowMenu.hs +++ b/XMonad/Actions/WindowMenu.hs @@ -41,6 +41,14 @@ -- -- > , ((modm, xK_o ), windowMenu) +colorizer :: a -> Bool -> X (String, String) +colorizer _ isFg = do + fBC <- asks (focusedBorderColor . config) + nBC <- asks (normalBorderColor . config) + return $ if isFg + then (fBC, nBC) + else (nBC, fBC) + windowMenu :: X () windowMenu = withFocused $ \w -> do tags <- asks (workspaces . config) @@ -48,13 +56,13 @@ Rectangle sx sy swh sht <- gets $ screenRect . W.screenDetail . W.current . windowset let originFractX = (fi x - fi sx + fi wh / 2) / fi swh originFractY = (fi y - fi sy + fi ht / 2) / fi sht - gsConfig = defaultGSConfig + gsConfig = (buildDefaultGSConfig colorizer) { gs_originFractX = originFractX , gs_originFractY = originFractY } actions = [ ("Cancel menu", return ()) , ("Close" , kill) , ("Maximize" , sendMessage $ maximizeRestore w) - , ("Minimize" , sendMessage $ MinimizeWin w) + , ("Minimize" , minimizeWindow w) ] ++ [ ("Move to " ++ tag, windows $ W.shift tag) | tag <- tags ] diff --git a/XMonad/Actions/WindowNavigation.hs b/XMonad/Actions/WindowNavigation.hs --- a/XMonad/Actions/WindowNavigation.hs +++ b/XMonad/Actions/WindowNavigation.hs @@ -36,7 +36,7 @@ withWindowNavigationKeys, WNAction(..), go, swap, - Direction2D(..) + Direction2D(..), WNState, ) where import XMonad @@ -52,7 +52,6 @@ import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Ord (comparing) import qualified Data.Set as S -import Graphics.X11.Xlib -- $usage -- diff --git a/XMonad/Actions/WithAll.hs b/XMonad/Actions/WithAll.hs --- a/XMonad/Actions/WithAll.hs +++ b/XMonad/Actions/WithAll.hs @@ -18,8 +18,6 @@ import Data.Foldable hiding (foldr) import XMonad -import XMonad.Core -import XMonad.Operations import XMonad.StackSet -- $usage diff --git a/XMonad/Actions/WorkspaceCursors.hs b/XMonad/Actions/WorkspaceCursors.hs --- a/XMonad/Actions/WorkspaceCursors.hs +++ b/XMonad/Actions/WorkspaceCursors.hs @@ -32,10 +32,13 @@ -- * Functions to pass to 'modifyLayer' ,focusNth' - ,noWrapUp,noWrapDown + ,noWrapUp,noWrapDown, -- * Todo -- $todo + + -- * Types + Cursors, ) where import qualified XMonad.StackSet as W diff --git a/XMonad/Actions/WorkspaceNames.hs b/XMonad/Actions/WorkspaceNames.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/WorkspaceNames.hs @@ -0,0 +1,152 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.WorkspaceNames +-- Copyright : (c) Tomas Janousek +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Tomas Janousek +-- Stability : experimental +-- Portability : unportable +-- +-- Provides bindings to rename workspaces, show these names in DynamicLog and +-- swap workspaces along with their names. These names survive restart. +-- Together with "XMonad.Layout.WorkspaceDir" this provides for a fully +-- dynamic topic space workflow. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE DeriveDataTypeable #-} + +module XMonad.Actions.WorkspaceNames ( + -- * Usage + -- $usage + + -- * Workspace naming + renameWorkspace, + workspaceNamesPP, + getWorkspaceNames, + setWorkspaceName, + setCurrentWorkspaceName, + + -- * Workspace swapping + swapTo, + swapTo', + swapWithCurrent, + ) where + +import XMonad +import qualified XMonad.StackSet as W +import qualified XMonad.Util.ExtensibleState as XS + +import XMonad.Actions.CycleWS (findWorkspace, WSType(..), Direction1D(..)) +import qualified XMonad.Actions.SwapWorkspaces as Swap +import XMonad.Hooks.DynamicLog (PP(..)) +import XMonad.Prompt (mkXPrompt, XPConfig) +import XMonad.Prompt.Workspace (Wor(Wor)) +import XMonad.Util.WorkspaceCompare (getSortByIndex) + +import qualified Data.Map as M +import Data.Maybe (fromMaybe) + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file: +-- +-- > import XMonad.Actions.WorkspaceNames +-- +-- Then add keybindings like the following: +-- +-- > , ((modm .|. shiftMask, xK_r ), renameWorkspace defaultXPConfig) +-- +-- and apply workspaceNamesPP to your DynamicLog pretty-printer: +-- +-- > myLogHook = +-- > workspaceNamesPP xmobarPP >>= dynamicLogString >>= xmonadPropLog +-- +-- We also provide a modification of "XMonad.Actions.SwapWorkspaces"\'s +-- functionality, which may be used this way: +-- +-- > , ((modMask .|. shiftMask, xK_Left ), swapTo Prev) +-- > , ((modMask .|. shiftMask, xK_Right ), swapTo Next) +-- +-- > [((modm .|. controlMask, k), swapWithCurrent i) +-- > | (i, k) <- zip workspaces [xK_1 ..]] +-- +-- For detailed instructions on editing your key bindings, see +-- "XMonad.Doc.Extending#Editing_key_bindings". + + + +-- | Workspace names container. +newtype WorkspaceNames = WorkspaceNames (M.Map WorkspaceId String) + deriving (Typeable, Read, Show) + +instance ExtensionClass WorkspaceNames where + initialValue = WorkspaceNames M.empty + extensionType = PersistentExtension + +-- | Returns a function that maps workspace tag @\"t\"@ to @\"t:name\"@ for +-- workspaces with a name, and to @\"t\"@ otherwise. +getWorkspaceNames :: X (WorkspaceId -> String) +getWorkspaceNames = do + WorkspaceNames m <- XS.get + return $ \wks -> case M.lookup wks m of + Nothing -> wks + Just s -> wks ++ ":" ++ s + +-- | Sets the name of a workspace. Empty string makes the workspace unnamed +-- again. +setWorkspaceName :: WorkspaceId -> String -> X () +setWorkspaceName w name = do + WorkspaceNames m <- XS.get + XS.put $ WorkspaceNames $ if null name then M.delete w m else M.insert w name m + refresh + +-- | Sets the name of the current workspace. See 'setWorkspaceName'. +setCurrentWorkspaceName :: String -> X () +setCurrentWorkspaceName name = do + current <- gets (W.currentTag . windowset) + setWorkspaceName current name + +-- | Prompt for a new name for the current workspace and set it. +renameWorkspace :: XPConfig -> X () +renameWorkspace conf = do + mkXPrompt pr conf (const (return [])) setCurrentWorkspaceName + where pr = Wor "Workspace name: " + +-- | Modify "XMonad.Hooks.DynamicLog"\'s pretty-printing format to show +-- workspace names as well. +workspaceNamesPP :: PP -> X PP +workspaceNamesPP pp = do + names <- getWorkspaceNames + return $ + pp { + ppCurrent = ppCurrent pp . names, + ppVisible = ppVisible pp . names, + ppHidden = ppHidden pp . names, + ppHiddenNoWindows = ppHiddenNoWindows pp . names, + ppUrgent = ppUrgent pp . names + } + +-- | See 'XMonad.Actions.SwapWorkspaces.swapTo'. This is the same with names. +swapTo :: Direction1D -> X () +swapTo dir = swapTo' dir AnyWS + +-- | Swap with the previous or next workspace of the given type. +swapTo' :: Direction1D -> WSType -> X () +swapTo' dir which = findWorkspace getSortByIndex dir which 1 >>= swapWithCurrent + +-- | See 'XMonad.Actions.SwapWorkspaces.swapWithCurrent'. This is almost the +-- same with names. +swapWithCurrent :: WorkspaceId -> X () +swapWithCurrent t = do + current <- gets (W.currentTag . windowset) + swapNames t current + windows $ Swap.swapWorkspaces t current + +-- | Swap names of the two workspaces. +swapNames :: WorkspaceId -> WorkspaceId -> X () +swapNames w1 w2 = do + WorkspaceNames m <- XS.get + let getname w = fromMaybe "" $ M.lookup w m + set w name m' = if null name then M.delete w m' else M.insert w name m' + XS.put $ WorkspaceNames $ set w1 (getname w2) $ set w2 (getname w1) $ m diff --git a/XMonad/Config/Arossato.hs b/XMonad/Config/Arossato.hs --- a/XMonad/Config/Arossato.hs +++ b/XMonad/Config/Arossato.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -fglasgow-exts -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE NoMonomorphismRestriction #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.Config.Arossato diff --git a/XMonad/Config/Azerty.hs b/XMonad/Config/Azerty.hs --- a/XMonad/Config/Azerty.hs +++ b/XMonad/Config/Azerty.hs @@ -38,7 +38,7 @@ -- > import qualified Data.Map as M -- > main = xmonad someConfig { keys = \c -> azertyKeys c `M.union` keys someConfig c } -azertyConfig = defaultConfig { keys = \c -> azertyKeys c `M.union` keys defaultConfig c } +azertyConfig = defaultConfig { keys = azertyKeys <+> keys defaultConfig } azertyKeys conf@(XConfig {modMask = modm}) = M.fromList $ [((modm, xK_semicolon), sendMessage (IncMasterN (-1)))] diff --git a/XMonad/Config/Bluetile.hs b/XMonad/Config/Bluetile.hs new file mode 100644 --- /dev/null +++ b/XMonad/Config/Bluetile.hs @@ -0,0 +1,217 @@ +{-# OPTIONS -fno-warn-missing-signatures #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Config.Bluetile +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- This is the default configuration of Bluetile +-- (). If you +-- are migrating from Bluetile to xmonad or want to create +-- a similar setup, then this will give you pretty much +-- the same thing, except for Bluetile's helper applications +-- such as the dock. +-- +----------------------------------------------------------------------------- + +module XMonad.Config.Bluetile ( + -- * Usage + -- $usage + bluetileConfig + ) where + +import XMonad hiding ( (|||) ) + +import XMonad.Layout.BorderResize +import XMonad.Layout.BoringWindows +import XMonad.Layout.ButtonDecoration +import XMonad.Layout.Decoration +import XMonad.Layout.DecorationAddons +import XMonad.Layout.DraggingVisualizer +import XMonad.Layout.LayoutCombinators +import XMonad.Layout.Maximize +import XMonad.Layout.Minimize +import XMonad.Layout.MouseResizableTile +import XMonad.Layout.Named +import XMonad.Layout.NoBorders +import XMonad.Layout.PositionStoreFloat +import XMonad.Layout.WindowSwitcherDecoration + +import XMonad.Actions.BluetileCommands +import XMonad.Actions.CycleWS +import XMonad.Actions.WindowMenu + +import XMonad.Hooks.CurrentWorkspaceOnTop +import XMonad.Hooks.EwmhDesktops +import XMonad.Hooks.ManageDocks +import XMonad.Hooks.ManageHelpers +import XMonad.Hooks.PositionStoreHooks +import XMonad.Hooks.Minimize +import XMonad.Hooks.ServerMode +import XMonad.Hooks.WorkspaceByPos + +import XMonad.Config.Gnome + +import qualified XMonad.StackSet as W +import qualified Data.Map as M + +import System.Exit +import Data.Monoid +import Control.Monad(when) + +-- $usage +-- To use this module, start with the following @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad +-- > import XMonad.Config.Bluetile +-- > import XMonad.Util.Replace +-- > +-- > main = replace >> xmonad bluetileConfig +-- +-- The invocation of 'replace' will replace a currently running +-- window manager. This is the default behaviour of Bluetile as well. +-- See "XMonad.Util.Replace" for more information. + +bluetileWorkspaces :: [String] +bluetileWorkspaces = ["1","2","3","4","5","6","7","8","9","0"] + +bluetileKeys :: XConfig Layout -> M.Map (KeyMask, KeySym) (X ()) +bluetileKeys conf@(XConfig {XMonad.modMask = modMask'}) = M.fromList $ + -- launching and killing programs + [ ((modMask' , xK_Return), spawn $ XMonad.terminal conf) -- %! Launch terminal + , ((modMask', xK_p ), gnomeRun) -- %! Launch Gnome "Run application" dialog + , ((modMask' .|. shiftMask, xK_c ), kill) -- %! Close the focused window + + , ((modMask', xK_F5 ), refresh) -- %! Resize viewed windows to the correct size + , ((modMask' .|. shiftMask, xK_F5 ), setLayout $ XMonad.layoutHook conf) -- %! Reset the layouts on the current workspace to default + + , ((modMask', xK_o ), windowMenu) + + -- move focus up or down the window stack + , ((modMask', xK_Tab ), focusDown) -- %! Move focus to the next window + , ((modMask' .|. shiftMask, xK_Tab ), focusUp) -- %! Move focus to the previous window + , ((modMask', xK_j ), focusDown) -- %! Move focus to the next window + , ((modMask', xK_k ), focusUp) -- %! Move focus to the previous window + , ((modMask', xK_space ), focusMaster) -- %! Move focus to the master window + + -- modifying the window order + , ((modMask' .|. shiftMask, xK_space ), windows W.swapMaster) -- %! Swap the focused window and the master window + , ((modMask' .|. shiftMask, xK_j ), windows W.swapDown ) -- %! Swap the focused window with the next window + , ((modMask' .|. shiftMask, xK_k ), windows W.swapUp ) -- %! Swap the focused window with the previous window + + -- resizing the master/slave ratio + , ((modMask', xK_h ), sendMessage Shrink) -- %! Shrink the master area + , ((modMask', xK_l ), sendMessage Expand) -- %! Expand the master area + , ((modMask', xK_u ), sendMessage ShrinkSlave) -- %! Shrink a slave area + , ((modMask', xK_i ), sendMessage ExpandSlave) -- %! Expand a slave area + + -- floating layer support + , ((modMask', xK_t ), withFocused $ windows . W.sink) -- %! Push window back into tiling + , ((modMask' .|. shiftMask, xK_t ), withFocused $ float ) -- %! Float window + + -- increase or decrease number of windows in the master area + , ((modMask' , xK_comma ), sendMessage (IncMasterN 1)) -- %! Increment the number of windows in the master area + , ((modMask' , xK_period), sendMessage (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area + + -- quit, or restart + , ((modMask' .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- %! Quit + , ((modMask' , xK_q ), restart "xmonad" True) -- %! Restart + + -- Metacity-like workspace switching + , ((mod1Mask .|. controlMask, xK_Left), prevWS) + , ((mod1Mask .|. controlMask, xK_Right), nextWS) + , ((mod1Mask .|. controlMask .|. shiftMask, xK_Left), shiftToPrev >> prevWS) + , ((mod1Mask .|. controlMask .|. shiftMask, xK_Right), shiftToNext >> nextWS) + + -- more Metacity keys + , ((mod1Mask , xK_F2), gnomeRun) + , ((mod1Mask , xK_F4), kill) + + -- Switching to layouts + , ((modMask' , xK_a), sendMessage $ JumpToLayout "Floating") + , ((modMask' , xK_s), sendMessage $ JumpToLayout "Tiled1") + , ((modMask' , xK_d), sendMessage $ JumpToLayout "Tiled2") + , ((modMask' , xK_f), sendMessage $ JumpToLayout "Fullscreen") + + -- Maximizing + , ((modMask' , xK_z), withFocused (sendMessage . maximizeRestore)) + + -- Minimizing + , ((modMask', xK_m ), withFocused minimizeWindow) + , ((modMask' .|. shiftMask, xK_m ), sendMessage RestoreNextMinimizedWin) + ] + ++ + -- mod-[1..9] ++ [0] %! Switch to workspace N + -- mod-shift-[1..9] ++ [0] %! Move client to workspace N + [((m .|. modMask', k), windows $ f i) + | (i, k) <- zip (XMonad.workspaces conf) ([xK_1 .. xK_9] ++ [xK_0]) + , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]] + ++ + -- mod-{w,e,r} %! Switch to physical/Xinerama screens 1, 2, or 3 + -- mod-shift-{w,e,r} %! Move client to screen 1, 2, or 3 + [((m .|. modMask', key), screenWorkspace sc >>= flip whenJust (windows . f)) + | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..] + , (f, m) <- [(W.view, 0), (W.shift, shiftMask)]] + +bluetileMouseBindings :: XConfig Layout -> M.Map (KeyMask, Button) (Window -> X ()) +bluetileMouseBindings (XConfig {XMonad.modMask = modMask'}) = M.fromList $ + -- mod-button1 %! Move a floated window by dragging + [ ((modMask', button1), (\w -> isFloating w >>= \isF -> when (isF) $ + focus w >> mouseMoveWindow w >> windows W.shiftMaster)) + -- mod-button2 %! Switch to next and first layout + , ((modMask', button2), (\_ -> sendMessage NextLayout)) + , ((modMask' .|. shiftMask, button2), (\_ -> sendMessage $ JumpToLayout "Floating")) + -- mod-button3 %! Resize a floated window by dragging + , ((modMask', button3), (\w -> isFloating w >>= \isF -> when (isF) $ + focus w >> mouseResizeWindow w >> windows W.shiftMaster)) + ] + +isFloating :: Window -> X (Bool) +isFloating w = do + ws <- gets windowset + return $ M.member w (W.floating ws) + +bluetileManageHook :: ManageHook +bluetileManageHook = composeAll + [ workspaceByPos, positionStoreManageHook (Just defaultThemeWithButtons) + , className =? "MPlayer" --> doFloat + , isFullscreen --> doFullFloat + , manageDocks] + +bluetileLayoutHook = avoidStruts $ minimize $ boringWindows $ ( + named "Floating" floating ||| + named "Tiled1" tiled1 ||| + named "Tiled2" tiled2 ||| + named "Fullscreen" fullscreen + ) + where + floating = floatingDeco $ maximize $ borderResize $ positionStoreFloat + tiled1 = tilingDeco $ maximize $ mouseResizableTileMirrored + tiled2 = tilingDeco $ maximize $ mouseResizableTile + fullscreen = tilingDeco $ maximize $ smartBorders Full + + tilingDeco l = windowSwitcherDecorationWithButtons shrinkText defaultThemeWithButtons (draggingVisualizer l) + floatingDeco l = buttonDeco shrinkText defaultThemeWithButtons l + +bluetileConfig = + defaultConfig + { modMask = mod4Mask, -- logo key + manageHook = bluetileManageHook, + layoutHook = bluetileLayoutHook, + logHook = currentWorkspaceOnTop >> ewmhDesktopsLogHook, + handleEventHook = ewmhDesktopsEventHook + `mappend` fullscreenEventHook + `mappend` minimizeEventHook + `mappend` serverModeEventHook' bluetileCommands + `mappend` positionStoreEventHook, + workspaces = bluetileWorkspaces, + keys = bluetileKeys, + mouseBindings = bluetileMouseBindings, + focusFollowsMouse = False, + focusedBorderColor = "#000000", + terminal = "gnome-terminal" + } diff --git a/XMonad/Config/Desktop.hs b/XMonad/Config/Desktop.hs --- a/XMonad/Config/Desktop.hs +++ b/XMonad/Config/Desktop.hs @@ -54,7 +54,6 @@ ) where import XMonad -import XMonad.Config (defaultConfig) import XMonad.Hooks.ManageDocks import XMonad.Hooks.EwmhDesktops import XMonad.Util.Cursor @@ -127,7 +126,7 @@ -- To add to the logHook while still sending workspace and window information -- to DE apps use something like: -- --- > , logHook = myLogHook >> logHook desktopConfig +-- > , logHook = myLogHook <+> logHook desktopConfig -- -- Or for more elaborate logHooks you can use @do@: -- @@ -139,25 +138,23 @@ -- $eventHook -- To customize xmonad's event handling while still having it respond --- to EWMH events from pagers, task bars, etc. add to your imports: --- --- > import Data.Monoid --- --- and use 'Data.Monoid.mappend' to combine event hooks (right to left application like @\<+\>@) +-- to EWMH events from pagers, task bars: -- --- > , handleEventHook = mappend myEventHooks (handleEventHook desktopConfig) +-- > , handleEventHook = myEventHooks <+> handleEventHook desktopConfig -- --- or 'Data.Monoid.mconcat' (like @composeAll@) +-- or 'mconcat' if you write a list event of event hooks -- -- > , handleEventHook = mconcat -- > [ myMouseHandler -- > , myMessageHandler -- > , handleEventHook desktopConfig ] -- +-- Note that the event hooks are run left to right (in contrast to +-- 'ManageHook'S which are right to left) -- $startupHook -- To run the desktop startupHook, plus add further actions to be run each --- time xmonad starts or restarts, use '>>' to combine actions as in the +-- time xmonad starts or restarts, use '<+>' to combine actions as in the -- logHook example, or something like: -- -- > , startupHook = do @@ -170,7 +167,7 @@ { startupHook = setDefaultCursor xC_left_ptr , layoutHook = desktopLayoutModifiers $ layoutHook defaultConfig , manageHook = manageHook defaultConfig <+> manageDocks - , keys = \c -> desktopKeys c `M.union` keys defaultConfig c } + , keys = desktopKeys <+> keys defaultConfig } desktopKeys (XConfig {modMask = modm}) = M.fromList $ [ ((modm, xK_b), sendMessage ToggleStruts) ] diff --git a/XMonad/Config/Droundy.hs b/XMonad/Config/Droundy.hs --- a/XMonad/Config/Droundy.hs +++ b/XMonad/Config/Droundy.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures -fglasgow-exts -fno-warn-orphans #-} +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Copyright : (c) Spencer Janssen 2007 @@ -10,7 +11,6 @@ import XMonad hiding (keys, config, (|||)) import qualified XMonad (keys) -import XMonad.Config ( defaultConfig ) import qualified XMonad.StackSet as W import qualified Data.Map as M diff --git a/XMonad/Config/Gnome.hs b/XMonad/Config/Gnome.hs --- a/XMonad/Config/Gnome.hs +++ b/XMonad/Config/Gnome.hs @@ -41,7 +41,7 @@ gnomeConfig = desktopConfig { terminal = "gnome-terminal" - , keys = \c -> gnomeKeys c `M.union` keys desktopConfig c + , keys = gnomeKeys <+> keys desktopConfig , startupHook = gnomeRegister >> startupHook desktopConfig } gnomeKeys (XConfig {modMask = modm}) = M.fromList $ diff --git a/XMonad/Config/Kde.hs b/XMonad/Config/Kde.hs --- a/XMonad/Config/Kde.hs +++ b/XMonad/Config/Kde.hs @@ -40,11 +40,11 @@ kdeConfig = desktopConfig { terminal = "konsole" - , keys = \c -> kdeKeys c `M.union` keys desktopConfig c } + , keys = kdeKeys <+> keys desktopConfig } kde4Config = desktopConfig { terminal = "konsole" - , keys = \c -> kde4Keys c `M.union` keys desktopConfig c } + , keys = kde4Keys <+> keys desktopConfig } kdeKeys (XConfig {modMask = modm}) = M.fromList $ [ ((modm, xK_p), spawn "dcop kdesktop default popupExecuteCommand") diff --git a/XMonad/Config/Sjanssen.hs b/XMonad/Config/Sjanssen.hs --- a/XMonad/Config/Sjanssen.hs +++ b/XMonad/Config/Sjanssen.hs @@ -1,60 +1,64 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module XMonad.Config.Sjanssen (sjanssenConfig, sjanssenConfigXmobar) where +module XMonad.Config.Sjanssen (sjanssenConfig) where import XMonad hiding (Tall(..)) import qualified XMonad.StackSet as W import XMonad.Actions.CopyWindow import XMonad.Layout.Tabbed import XMonad.Layout.HintedTile -import XMonad.Config (defaultConfig) import XMonad.Layout.NoBorders -import XMonad.Hooks.DynamicLog hiding (xmobar) +import XMonad.Hooks.DynamicLog import XMonad.Hooks.ManageDocks import XMonad.Hooks.ManageHelpers (isFullscreen, doFullFloat) import XMonad.Hooks.EwmhDesktops import XMonad.Prompt import XMonad.Actions.SpawnOn +import XMonad.Util.SpawnOnce import XMonad.Layout.LayoutScreens import XMonad.Layout.TwoPane import qualified Data.Map as M -sjanssenConfigXmobar = statusBar "exec xmobar" sjanssenPP strutkey =<< sjanssenConfig - where - strutkey (XConfig {modMask = modm}) = (modm, xK_b) - -sjanssenConfig = do - sp <- mkSpawner - return . ewmh $ defaultConfig +sjanssenConfig = + ewmh $ defaultConfig { terminal = "exec urxvt" , workspaces = ["irc", "web"] ++ map show [3 .. 9 :: Int] , mouseBindings = \(XConfig {modMask = modm}) -> M.fromList $ [ ((modm, button1), (\w -> focus w >> mouseMoveWindow w)) , ((modm, button2), (\w -> focus w >> windows W.swapMaster)) , ((modm.|. shiftMask, button1), (\w -> focus w >> mouseResizeWindow w)) ] - , keys = \c -> mykeys sp c `M.union` keys defaultConfig c + , keys = \c -> mykeys c `M.union` keys defaultConfig c + , logHook = dynamicLogString sjanssenPP >>= xmonadPropLog , layoutHook = modifiers layouts , manageHook = composeAll [className =? x --> doShift w | (x, w) <- [ ("Firefox", "web") , ("Ktorrent", "7") , ("Amarokapp", "7")]] - <+> manageHook defaultConfig <+> manageDocks <+> manageSpawn sp + <+> manageHook defaultConfig <+> manageDocks <+> manageSpawn <+> (isFullscreen --> doFullFloat) + , startupHook = mapM_ spawnOnce spawns } where tiled = HintedTile 1 0.03 0.5 TopLeft layouts = (tiled Tall ||| (tiled Wide ||| Full)) ||| tabbed shrinkText myTheme - modifiers = smartBorders + modifiers = avoidStruts . smartBorders - mykeys sp (XConfig {modMask = modm}) = M.fromList $ - [((modm, xK_p ), shellPromptHere sp myPromptConfig) - ,((modm .|. shiftMask, xK_Return), spawnHere sp =<< asks (terminal . config)) + spawns = [ "xmobar" + , "xset -b", "xset s off", "xset dpms 0 600 1200" + , "nitrogen --set-tiled wallpaper/wallpaper.jpg" + , "trayer --transparent true --expand true --align right " + ++ "--edge bottom --widthtype request" ] + + mykeys (XConfig {modMask = modm}) = M.fromList $ + [((modm, xK_p ), shellPromptHere myPromptConfig) + ,((modm .|. shiftMask, xK_Return), spawnHere =<< asks (terminal . config)) ,((modm .|. shiftMask, xK_c ), kill1) ,((modm .|. shiftMask .|. controlMask, xK_c ), kill) ,((modm .|. shiftMask, xK_0 ), windows $ copyToAll) ,((modm, xK_z ), layoutScreens 2 $ TwoPane 0.5 0.5) ,((modm .|. shiftMask, xK_z ), rescreen) + , ((modm , xK_b ), sendMessage ToggleStruts) ] myFont = "xft:Bitstream Vera Sans Mono:pixelsize=10" diff --git a/XMonad/Config/Xfce.hs b/XMonad/Config/Xfce.hs --- a/XMonad/Config/Xfce.hs +++ b/XMonad/Config/Xfce.hs @@ -36,7 +36,7 @@ xfceConfig = desktopConfig { terminal = "Terminal" - , keys = \c -> xfceKeys c `M.union` keys desktopConfig c } + , keys = xfceKeys <+> keys desktopConfig } xfceKeys (XConfig {modMask = modm}) = M.fromList $ [ ((modm, xK_p), spawn "xfrun4") diff --git a/XMonad/Doc/Developing.hs b/XMonad/Doc/Developing.hs --- a/XMonad/Doc/Developing.hs +++ b/XMonad/Doc/Developing.hs @@ -256,6 +256,9 @@ * Code should be compilable with "ghc-options: -Wall -Werror" set in the xmonad-contrib.cabal file. There should be no warnings. +* Code should be free of any warnings or errors from the Hlint tool; use your + best judgement on some warnings like eta-reduction or bracket removal, though. + * Partial functions should be avoided: the window manager should not crash, so never call 'error' or 'undefined'. diff --git a/XMonad/Doc/Extending.hs b/XMonad/Doc/Extending.hs --- a/XMonad/Doc/Extending.hs +++ b/XMonad/Doc/Extending.hs @@ -382,13 +382,17 @@ * "XMonad.Hooks.ManageHelpers": provide helper functions to be used in @manageHook@. +* "XMonad.Hooks.Minimize": + Handles window manager hints to minimize and restore windows. Use + this with XMonad.Layout.Minimize. + * "XMonad.Hooks.Place": Automatic placement of floating windows. * "XMonad.Hooks.RestoreMinimized": - Lets you restore minimized windows (see "XMonad.Layout.Minimize") - by selecting them on a taskbar (listens for _NET_ACTIVE_WINDOW - and WM_CHANGE_STATE). + (Deprecated: Use XMonad.Hooks.Minimize) Lets you restore minimized + windows (see "XMonad.Layout.Minimize") by selecting them on a + taskbar (listens for _NET_ACTIVE_WINDOW and WM_CHANGE_STATE). * "XMonad.Hooks.Script": Provides a simple interface for running a ~\/.xmonad\/hooks script with the @@ -932,16 +936,18 @@ and provide an appropriate definition of @myKeys@, such as: -> myKeys conf@(XConfig {XMonad.modMask = modm}) = +> myKeys conf@(XConfig {XMonad.modMask = modm}) = M.fromList > [ ((modm, xK_F12), xmonadPrompt defaultXPConfig) > , ((modm, xK_F3 ), shellPrompt defaultXPConfig) > ] This particular definition also requires importing "XMonad.Prompt", -"XMonad.Prompt.Shell", and "XMonad.Prompt.XMonad": +"XMonad.Prompt.Shell", "XMonad.Prompt.XMonad", and "Data.Map": -> import XMonadPrompt -> import ... -- and so on +> import qualified Data.Map as M +> import XMonad.Prompt +> import XMonad.Prompt.Shell +> import XMonad.Prompt.XMonad For a list of the names of particular keys (such as xK_F12, and so on), see @@ -977,7 +983,7 @@ For instance, if you have defined some additional key bindings like these: -> myKeys conf@(XConfig {XMonad.modMask = modm}) = +> myKeys conf@(XConfig {XMonad.modMask = modm}) = M.fromList > [ ((modm, xK_F12), xmonadPrompt defaultXPConfig) > , ((modm, xK_F3 ), shellPrompt defaultXPConfig) > ] @@ -985,13 +991,19 @@ then you can create a new key bindings map by joining the default one with yours: -> newKeys x = M.union (keys defaultConfig x) (M.fromList (myKeys x)) +> newKeys x = myKeys x `M.union` keys defaultConfig x Finally, you can use @newKeys@ in the 'XMonad.Core.XConfig.keys' field of the configuration: > main = xmonad $ defaultConfig { keys = newKeys } +Alternatively, the '<+>' operator can be used which in this usage does exactly +the same as the explicit usage of 'M.union' and propagation of the config +argument, thanks to appropriate instances in "Data.Monoid". + +> main = xmonad $ defaultConfig { keys = myKeys <+> keys defaultConfig } + All together, your @~\/.xmonad\/xmonad.hs@ would now look like this: @@ -1006,11 +1018,9 @@ > import XMonad.Prompt.XMonad > > main :: IO () -> main = xmonad $ defaultConfig { keys = newKeys } -> -> newKeys x = M.union (keys defaultConfig x) (M.fromList (myKeys x)) +> main = xmonad $ defaultConfig { keys = myKeys <+> keys defaultConfig } > -> myKeys conf@(XConfig {XMonad.modMask = modm}) = +> myKeys conf@(XConfig {XMonad.modMask = modm}) = M.fromList > [ ((modm, xK_F12), xmonadPrompt defaultXPConfig) > , ((modm, xK_F3 ), shellPrompt defaultXPConfig) > ] @@ -1034,10 +1044,10 @@ to define @newKeys@ as a 'Data.Map.difference' between the default map and the map of the key bindings you want to remove. Like so: -> newKeys x = M.difference (keys defaultConfig x) (M.fromList $ keysToRemove x) +> newKeys x = keys defaultConfig x `M.difference` keysToRemove x > -> keysToRemove :: XConfig Layout -> [((KeyMask, KeySym),X ())] -> keysToRemove x = +> keysToRemove :: XConfig Layout -> M.Map (KeyMask, KeySym) (X ()) +> keysToRemove x = M.fromList > [ ((modm , xK_q ), return ()) > , ((modm .|. shiftMask, xK_q ), return ()) > ] @@ -1164,7 +1174,7 @@ Then we create the combination of layouts we need: -> mylayoutHook = Full ||| tabbed shrinkText defaultTConf ||| Accordion +> mylayoutHook = Full ||| tabbed shrinkText defaultTheme ||| Accordion Now, all we need to do is change the 'XMonad.Core.layoutHook' @@ -1178,11 +1188,11 @@ 'XMonad.Layout.NoBorders.noBorders' layout modifier, from the "XMonad.Layout.NoBorders" module (which must be imported): -> mylayoutHook = noBorders (Full ||| tabbed shrinkText defaultTConf ||| Accordion) +> mylayoutHook = noBorders (Full ||| tabbed shrinkText defaultTheme ||| Accordion) If we want only the tabbed layout without borders, then we may write: -> mylayoutHook = Full ||| noBorders (tabbed shrinkText defaultTConf) ||| Accordion +> mylayoutHook = Full ||| noBorders (tabbed shrinkText defaultTheme) ||| Accordion Our @~\/.xmonad\/xmonad.hs@ will now look like this: @@ -1192,7 +1202,7 @@ > import XMonad.Layout.Accordion > import XMonad.Layout.NoBorders > -> mylayoutHook = Full ||| noBorders (tabbed shrinkText defaultTConf) ||| Accordion +> mylayoutHook = Full ||| noBorders (tabbed shrinkText defaultTheme) ||| Accordion > > main = xmonad $ defaultConfig { layoutHook = mylayoutHook } diff --git a/XMonad/Hooks/CurrentWorkspaceOnTop.hs b/XMonad/Hooks/CurrentWorkspaceOnTop.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/CurrentWorkspaceOnTop.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveDataTypeable #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.CurrentWorkspaceOnTop +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- Ensures that the windows of the current workspace are always in front +-- of windows that are located on other visible screens. This becomes important +-- if you use decoration and drag windows from one screen to another. Using this +-- module, the dragged window will always be in front of other windows. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.CurrentWorkspaceOnTop ( + -- * Usage + -- $usage + currentWorkspaceOnTop + ) where + +import XMonad +import qualified XMonad.StackSet as S +import qualified XMonad.Util.ExtensibleState as XS +import Control.Monad(when) +import qualified Data.Map as M + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Hooks.CurrentWorkspaceOnTop +-- > +-- > main = xmonad $ defaultConfig { +-- > ... +-- > logHook = currentWorkspaceOnTop +-- > ... +-- > } +-- + +data CWOTState = CWOTS String deriving Typeable + +instance ExtensionClass CWOTState where + initialValue = CWOTS "" + +currentWorkspaceOnTop :: X () +currentWorkspaceOnTop = withDisplay $ \d -> do + ws <- gets windowset + (CWOTS lastTag) <- XS.get + let curTag = S.tag . S.workspace . S.current $ ws + when (curTag /= lastTag) $ do + -- the following is more or less a reimplementation of what's happening in "XMonad.Operation" + let s = S.current ws + wsp = S.workspace s + viewrect = screenRect $ S.screenDetail s + tmpStack = (S.stack wsp) >>= S.filter (`M.notMember` S.floating ws) + (rs, ml') <- runLayout wsp { S.stack = tmpStack } viewrect + updateLayout curTag ml' + let this = S.view curTag ws + fltWins = filter (flip M.member (S.floating ws)) $ S.index this + wins = fltWins ++ (map fst rs) -- order: first all floating windows, then the order the layout returned + -- end of reimplementation + + when (not . null $ wins) $ do + io $ raiseWindow d (head wins) -- raise first window of current workspace to the very top, + io $ restackWindows d wins -- then use restackWindows to let all other windows from the workspace follow + XS.put(CWOTS curTag) diff --git a/XMonad/Hooks/DebugKeyEvents.hs b/XMonad/Hooks/DebugKeyEvents.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/DebugKeyEvents.hs @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.DebugKeyEvents +-- Copyright : (c) 2011 Brandon S Allbery +-- License : BSD +-- +-- Maintainer : Brandon S Allbery +-- Stability : unstable +-- Portability : unportable +-- +-- A debugging module to track key events, useful when you can't tell whether +-- xmonad is processing some or all key events. +----------------------------------------------------------------------------- + +module XMonad.Hooks.DebugKeyEvents (-- * Usage + -- $usage + debugKeyEvents + ) where + +import XMonad.Core +import XMonad.Operations (cleanMask) + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import Control.Monad.State (gets) +import Data.Bits +import Data.List (intercalate) +import Data.Monoid +import Numeric (showHex) +import System.IO (hPutStrLn + ,stderr) + +-- $usage +-- Add this to your handleEventHook to print received key events to the +-- log (the console if you use @startx@/@xinit@, otherwise usually +-- @~/.xsession-errors@). +-- +-- > , handleEventHook = debugKeyEvents +-- +-- If you already have a handleEventHook then you should append it: +-- +-- > , handleEventHook = ... <+> debugKeyEvents +-- +-- 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.) +-- +-- For more detailed instructions on editing the logHook see: +-- +-- "XMonad.Doc.Extending#The_log_hook_and_external_status_bars" + +-- | Print key events to stderr for debugging +debugKeyEvents :: Event -> X All +debugKeyEvents (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) + | t == keyPress = + withDisplay $ \dpy -> do + sym <- io $ keycodeToKeysym dpy code 0 + msk <- cleanMask m + nl <- gets numberlockMask + io $ hPutStrLn stderr $ intercalate " " ["keycode" + ,show code + ,"sym" + ,show sym + ," (" + ,hex sym + ," \"" + ,keysymToString sym + ,"\") mask" + ,hex m + ,"(" ++ vmask nl m ++ ")" + ,"clean" + ,hex msk + ,"(" ++ vmask nl msk ++ ")" + ] + return (All True) +debugKeyEvents _ = return (All True) + +-- | Convenient showHex variant +hex :: (Integral n, Show n) => n -> String +hex v = "0x" ++ showHex v "" + +-- | Convert a modifier mask into a useful string +vmask :: KeyMask -> KeyMask -> String +vmask numLockMask msk = intercalate " " $ + 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 diff --git a/XMonad/Hooks/DynamicHooks.hs b/XMonad/Hooks/DynamicHooks.hs --- a/XMonad/Hooks/DynamicHooks.hs +++ b/XMonad/Hooks/DynamicHooks.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.Hooks.DynamicHooks @@ -15,20 +16,18 @@ module XMonad.Hooks.DynamicHooks ( -- * Usage -- $usage - initDynamicHooks - ,dynamicMasterHook + dynamicMasterHook ,addDynamicHook ,updateDynamicHook ,oneShotHook ) where import XMonad -import System.IO +import qualified XMonad.Util.ExtensibleState as XS import Data.List import Data.Maybe (listToMaybe) import Data.Monoid -import Data.IORef -- $usage -- Provides two new kinds of 'ManageHooks' that can be defined at runtime. @@ -40,68 +39,46 @@ -- Note that you will lose all dynamically defined 'ManageHook's when you @mod+q@! -- If you want them to last, you should create them as normal in your @xmonad.hs@. -- --- First, you must execute 'initDynamicHooks' from 'main' in your @xmonad.hs@: --- --- > dynHooksRef <- initDynamicHooks --- --- and then pass this value to the other functions in this module. --- --- You also need to add the base 'ManageHook': +-- To use this module, add 'dynamicMasterHook' to your 'manageHook': -- --- > xmonad { manageHook = myManageHook <+> dynamicMasterHook dynHooksRef } +-- > xmonad { manageHook = myManageHook <+> dynamicMasterHook } -- --- You must include this @dynHooksRef@ value when using the functions in this --- module: +-- You can then use the supplied functions in your keybindings: -- --- > xmonad { keys = myKeys `Data.Map.union` Data.Map.fromList --- > [((modm, xK_i), oneShotHook dynHooksRef --- > "FFlaunchHook" (className =? "firefox") (doShift "3") --- > >> spawn "firefox") --- > ,((modm, xK_u), addDynamicHook dynHooksRef --- > (className =? "example" --> doFloat)) --- > ,((modm, xK_y), updatePermanentHook dynHooksRef --- > (const idHook))) ] -- resets the permanent hook. +-- > ((modMask,xK_a), oneShotHook (className =? "example") doFloat) -- data DynamicHooks = DynamicHooks { transients :: [(Query Bool, ManageHook)] , permanent :: ManageHook } - - --- | Creates the 'IORef' that stores the dynamically created 'ManageHook's. -initDynamicHooks :: IO (IORef DynamicHooks) -initDynamicHooks = newIORef (DynamicHooks { transients = [], - permanent = idHook }) + deriving Typeable +instance ExtensionClass DynamicHooks where + initialValue = DynamicHooks [] idHook --- this hook is always executed, and the IORef's contents checked. +-- this hook is always executed, and the contents of the stored hooks checked. -- note that transient hooks are run second, therefore taking precedence -- over permanent ones on matters such as which workspace to shift to. -- doFloat and doIgnore are idempotent. -- | Master 'ManageHook' that must be in your @xmonad.hs@ 'ManageHook'. -dynamicMasterHook :: IORef DynamicHooks -> ManageHook -dynamicMasterHook ref = return True --> - (ask >>= \w -> liftX (do - dh <- io $ readIORef ref +dynamicMasterHook :: ManageHook +dynamicMasterHook = (ask >>= \w -> liftX (do + dh <- XS.get (Endo f) <- runQuery (permanent dh) w ts <- mapM (\(q,a) -> runQuery q w >>= \x -> return (x,(q, a))) (transients dh) let (ts',nts) = partition fst ts gs <- mapM (flip runQuery w . snd . snd) ts' let (Endo g) = maybe (Endo id) id $ listToMaybe gs - io $ writeIORef ref $ dh { transients = map snd nts } + XS.put $ dh { transients = map snd nts } return $ Endo $ f . g )) - -- | Appends the given 'ManageHook' to the permanent dynamic 'ManageHook'. -addDynamicHook :: IORef DynamicHooks -> ManageHook -> X () -addDynamicHook ref m = updateDynamicHook ref (<+> m) - +addDynamicHook :: ManageHook -> X () +addDynamicHook m = updateDynamicHook (<+> m) -- | Modifies the permanent 'ManageHook' with an arbitrary function. -updateDynamicHook :: IORef DynamicHooks -> (ManageHook -> ManageHook) -> X () -updateDynamicHook ref f = - io $ modifyIORef ref $ \dh -> dh { permanent = f (permanent dh) } - +updateDynamicHook :: (ManageHook -> ManageHook) -> X () +updateDynamicHook f = XS.modify $ \dh -> dh { permanent = f (permanent dh) } -- | Creates a one-shot 'ManageHook'. Note that you have to specify the two -- parts of the 'ManageHook' separately. Where you would usually write: @@ -112,11 +89,5 @@ -- -- > oneShotHook dynHooksRef (className =? "example) doFloat -- -oneShotHook :: IORef DynamicHooks -> Query Bool -> ManageHook -> X () -oneShotHook ref q a = - io $ modifyIORef ref - $ \dh -> dh { transients = (q,a):(transients dh) } - - - - +oneShotHook :: Query Bool -> ManageHook -> X () +oneShotHook q a = XS.modify $ \dh -> dh { transients = (q,a):(transients dh) } diff --git a/XMonad/Hooks/DynamicLog.hs b/XMonad/Hooks/DynamicLog.hs --- a/XMonad/Hooks/DynamicLog.hs +++ b/XMonad/Hooks/DynamicLog.hs @@ -29,6 +29,9 @@ dynamicLog, dynamicLogXinerama, + xmonadPropLog', + xmonadPropLog, + -- * Build your own formatter dynamicLogWithPP, dynamicLogString, @@ -51,24 +54,26 @@ ) where --- -- Useful imports --- -import XMonad -import Control.Monad -import Data.Char ( isSpace ) + +import Codec.Binary.UTF8.String (encodeString) +import Control.Monad (liftM2) +import Data.Char ( isSpace, ord ) +import Data.List (intersperse, isPrefixOf, sortBy) import Data.Maybe ( isJust, catMaybes ) -import Data.List -import qualified Data.Map as M import Data.Ord ( comparing ) +import qualified Data.Map as M import qualified XMonad.StackSet as S -import System.IO + +import Foreign.C (CChar) + +import XMonad + import XMonad.Util.WorkspaceCompare import XMonad.Util.NamedWindows import XMonad.Util.Run import XMonad.Layout.LayoutModifier -import XMonad.Util.Font import XMonad.Hooks.UrgencyHook import XMonad.Hooks.ManageDocks @@ -204,6 +209,24 @@ where keys' = (`M.singleton` sendMessage ToggleStruts) . k +-- | Write a string to a property on the root window. This property is of +-- type UTF8_STRING. The string must have been processed by encodeString +-- (dynamicLogString does this). +xmonadPropLog' :: String -> String -> X () +xmonadPropLog' prop msg = do + d <- asks display + r <- asks theRoot + xlog <- getAtom prop + ustring <- getAtom "UTF8_STRING" + io $ changeProperty8 d r xlog ustring propModeReplace (encodeCChar msg) + where + encodeCChar :: String -> [CChar] + encodeCChar = map (fromIntegral . ord) + +-- | Write a string to the _XMONAD_LOG property on the root window. +xmonadPropLog :: String -> X () +xmonadPropLog = xmonadPropLog' "_XMONAD_LOG" + -- | -- Helper function which provides ToggleStruts keybinding -- @@ -251,9 +274,9 @@ wt <- maybe (return "") (fmap show . getName) . S.peek $ winset -- run extra loggers, ignoring any that generate errors. - extras <- sequence $ map (flip catchX (return Nothing)) $ ppExtras pp + extras <- mapM (flip catchX (return Nothing)) $ ppExtras pp - return $ encodeOutput . sepBy (ppSep pp) . ppOrder pp $ + return $ encodeString . sepBy (ppSep pp) . ppOrder pp $ [ ws , ppLayout pp ld , ppTitle pp wt @@ -270,9 +293,9 @@ visibles = map (S.tag . S.workspace) (S.visible s) fmt w = printer pp (S.tag w) - where printer | S.tag w == this = ppCurrent + where printer | any (\x -> maybe False (== S.tag w) (S.findTag x s)) urgents = ppUrgent + | S.tag w == this = ppCurrent | S.tag w `elem` visibles = ppVisible - | any (\x -> maybe False (== S.tag w) (S.findTag x s)) urgents = \ppC -> ppUrgent ppC . ppHidden ppC | isJust (S.stack w) = ppHidden | otherwise = ppHiddenNoWindows @@ -284,10 +307,15 @@ -- where 1, 9, and 3 are the workspaces on screens 1, 2 and 3, respectively, -- and 2 and 7 are non-visible, non-empty workspaces. -- --- Unfortunately, at the present time, the current layout and window title --- are not shown, and there is no way to incorporate the xinerama --- workspace format shown above with 'dynamicLogWithPP'. Hopefully this --- will change soon. +-- At the present time, the current layout and window title +-- are not shown. The xinerama workspace format shown above can be (mostly) replicated +-- using 'dynamicLogWithPP' by setting 'ppSort' to /getSortByXineramaRule/ from +-- "XMonad.Util.WorkspaceCompare". For example, +-- +-- > defaultPP { ppCurrent = dzenColor "red" "#efebe7" +-- > , ppVisible = wrap "[" "]" +-- > , ppSort = getSortByXineramaRule +-- > } dynamicLogXinerama :: X () dynamicLogXinerama = withWindowSet $ io . putStrLn . pprWindowSetXinerama @@ -318,7 +346,7 @@ -- | Limit a string to a certain length, adding "..." if truncated. shorten :: Int -> String -> String shorten n xs | length xs < n = xs - | otherwise = (take (n - length end) xs) ++ end + | otherwise = take (n - length end) xs ++ end where end = "..." @@ -345,11 +373,7 @@ dzenEscape :: String -> String dzenEscape = concatMap (\x -> if x == '^' then "^^" else [x]) --- | Strip dzen formatting or commands. Useful to remove ppHidden --- formatting in ppUrgent field. For example: --- --- > , ppHidden = dzenColor "gray20" "" . wrap "(" ")" --- > , ppUrgent = dzenColor "dark orange" "" . dzenStrip +-- | Strip dzen formatting or commands. dzenStrip :: String -> String dzenStrip = strip [] where strip keep x @@ -370,11 +394,7 @@ -- ??? add an xmobarEscape function? --- | Strip xmobar markup. Useful to remove ppHidden color from ppUrgent --- field. For example: --- --- > , ppHidden = xmobarColor "gray20" "" . wrap "<" ">" --- > , ppUrgent = xmobarColor "dark orange" "" . xmobarStrip +-- | Strip xmobar markup. xmobarStrip :: String -> String xmobarStrip = strip [] where strip keep x @@ -400,8 +420,6 @@ -- ^ how to print tags of empty hidden workspaces , ppUrgent :: WorkspaceId -> String -- ^ format to be applied to tags of urgent workspaces. - -- NOTE that 'ppUrgent' is applied /in addition to/ - -- 'ppHidden'! , ppSep :: String -- ^ separator to use between different log sections -- (window name, layout, workspaces) @@ -457,32 +475,31 @@ , ppExtras = [] } --- | Settings to emulate dwm's statusbar, dzen only. Uses dzenStrip in --- ppUrgent. +-- | Settings to emulate dwm's statusbar, dzen only. dzenPP :: PP dzenPP = defaultPP { ppCurrent = dzenColor "white" "#2b4f98" . pad - , ppVisible = dzenColor "black" "#999999" . pad - , ppHidden = dzenColor "black" "#cccccc" . pad - , ppHiddenNoWindows = const "" - , ppUrgent = dzenColor "red" "yellow" . dzenStrip - , ppWsSep = "" - , ppSep = "" - , ppLayout = dzenColor "black" "#cccccc" . - (\ x -> case x of - "TilePrime Horizontal" -> " TTT " - "TilePrime Vertical" -> " []= " - "Hinted Full" -> " [ ] " - _ -> pad x - ) - , ppTitle = ("^bg(#324c80) " ++) . dzenEscape - } + , ppVisible = dzenColor "black" "#999999" . pad + , ppHidden = dzenColor "black" "#cccccc" . pad + , ppHiddenNoWindows = const "" + , ppUrgent = dzenColor "red" "yellow" . pad + , ppWsSep = "" + , ppSep = "" + , ppLayout = dzenColor "black" "#cccccc" . + (\ x -> pad $ case x of + "TilePrime Horizontal" -> "TTT" + "TilePrime Vertical" -> "[]=" + "Hinted Full" -> "[ ]" + _ -> x + ) + , ppTitle = ("^bg(#324c80) " ++) . dzenEscape + } -- | Some nice xmobar defaults. xmobarPP :: PP xmobarPP = defaultPP { ppCurrent = xmobarColor "yellow" "" . wrap "[" "]" , ppTitle = xmobarColor "green" "" . shorten 40 , ppVisible = wrap "(" ")" - , ppUrgent = xmobarColor "red" "yellow" + , ppUrgent = xmobarColor "red" "yellow" } -- | The options that sjanssen likes to use with xmobar, as an @@ -498,7 +515,7 @@ byorgeyPP = defaultPP { ppHiddenNoWindows = showNamedWorkspaces , ppHidden = dzenColor "black" "#a8a3f7" . pad , ppCurrent = dzenColor "yellow" "#a8a3f7" . pad - , ppUrgent = dzenColor "red" "yellow" + , ppUrgent = dzenColor "red" "yellow" . pad , ppSep = " | " , ppWsSep = "" , ppTitle = shorten 70 @@ -507,4 +524,3 @@ where showNamedWorkspaces wsId = if any (`elem` wsId) ['a'..'z'] then pad wsId else "" - diff --git a/XMonad/Hooks/EwmhDesktops.hs b/XMonad/Hooks/EwmhDesktops.hs --- a/XMonad/Hooks/EwmhDesktops.hs +++ b/XMonad/Hooks/EwmhDesktops.hs @@ -19,7 +19,8 @@ ewmhDesktopsStartup, ewmhDesktopsLogHook, ewmhDesktopsLogHookCustom, - ewmhDesktopsEventHook + ewmhDesktopsEventHook, + fullscreenEventHook ) where import Codec.Binary.UTF8.String (encode) @@ -32,7 +33,9 @@ import qualified XMonad.StackSet as W import XMonad.Hooks.SetWMName +import XMonad.Util.XUtils (fi) import XMonad.Util.WorkspaceCompare +import XMonad.Util.WindowProperties (getProp32) -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -132,14 +135,14 @@ a_cw <- getAtom "_NET_CLOSE_WINDOW" a_ignore <- mapM getAtom ["XMONAD_TIMER"] if mt == a_cd then do - let n = fromIntegral (head d) - if 0 <= n && n < length ws then - windows $ W.view (W.tag (ws !! n)) + let n = head d + if 0 <= n && fi n < length ws then + windows $ W.view (W.tag (ws !! fi n)) else trace $ "Bad _NET_CURRENT_DESKTOP with data[0]="++show n else if mt == a_d then do - let n = fromIntegral (head d) - if 0 <= n && n < length ws then - windows $ W.shiftWin (W.tag (ws !! n)) w + let n = head d + if 0 <= n && fi n < length ws then + windows $ W.shiftWin (W.tag (ws !! fi n)) w else trace $ "Bad _NET_DESKTOP with data[0]="++show n else if mt == a_aw then do windows $ W.focusWindow w @@ -153,6 +156,36 @@ return () handle _ = return () +-- | +-- An event hook to handle applications that wish to fullscreen using the +-- _NET_WM_STATE protocol. This includes users of the gtk_window_fullscreen() +-- function, such as Totem, Evince and OpenOffice.org. +fullscreenEventHook :: Event -> X All +fullscreenEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do + state <- getAtom "_NET_WM_STATE" + fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN" + wstate <- fromMaybe [] `fmap` getProp32 state win + + let isFull = fromIntegral fullsc `elem` wstate + + -- Constants for the _NET_WM_STATE protocol: + remove = 0 + add = 1 + toggle = 2 + ptype = 4 -- The atom property type for changeProperty + chWstate f = io $ changeProperty32 dpy win state ptype propModeReplace (f wstate) + + when (typ == state && fi fullsc `elem` dats) $ do + when (action == add || (action == toggle && not isFull)) $ do + chWstate (fi fullsc:) + windows $ W.float win $ W.RationalRect 0 0 1 1 + when (action == remove || (action == toggle && isFull)) $ do + chWstate $ delete (fi fullsc) + windows $ W.sink win + + return $ All True + +fullscreenEventHook _ = return $ All True setNumberOfDesktops :: (Integral a) => a -> X () setNumberOfDesktops n = withDisplay $ \dpy -> do diff --git a/XMonad/Hooks/FadeInactive.hs b/XMonad/Hooks/FadeInactive.hs --- a/XMonad/Hooks/FadeInactive.hs +++ b/XMonad/Hooks/FadeInactive.hs @@ -44,7 +44,7 @@ -- you will need to have xcompmgr -- or something similar for this to do anything -- --- For more detailed instructions on editing the layoutHook see: +-- For more detailed instructions on editing the logHook see: -- -- "XMonad.Doc.Extending#The_log_hook_and_external_status_bars" -- diff --git a/XMonad/Hooks/FadeWindows.hs b/XMonad/Hooks/FadeWindows.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/FadeWindows.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.FadeWindows +-- Copyright : Brandon S Allbery KF8NH +-- License : BSD +-- +-- Maintainer : Brandon S Allbery KF8NH +-- Stability : unstable +-- Portability : unportable +-- +-- A more flexible and general compositing interface than FadeInactive. +-- Windows can be selected and opacity specified by means of FadeHooks, +-- which are very similar to ManageHooks and use the same machinery. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.FadeWindows (-- * Usage + -- $usage + + -- * The 'logHook' for window fading + fadeWindowsLogHook + + -- * The 'FadeHook' + ,FadeHook + ,Opacity + ,idFadeHook + + -- * Predefined 'FadeHook's + ,opaque + ,solid + ,transparent + ,invisible + ,transparency + ,translucence + ,fadeBy + ,opacity + ,fadeTo + + -- * 'handleEventHook' for mapped/unmapped windows + ,fadeWindowsEventHook + + -- * 'doF' for simple hooks + ,doS + + -- * Useful 'Query's for 'FadeHook's + ,isFloating + ,isUnfocused + ) where + +import XMonad.Core +import XMonad.ManageHook (liftX) +import qualified XMonad.StackSet as W + +import XMonad.Hooks.FadeInactive (setOpacity + ,isUnfocused + ) + +import Control.Monad (forM_) +import Control.Monad.Reader (ask + ,asks) +import Control.Monad.State (gets) +import qualified Data.Map as M +import Data.Monoid + +import Graphics.X11.Xlib.Extras (Event(..)) + +-- $usage +-- To use this module, make sure your @xmonad@ core supports generalized +-- 'ManageHook's (check the type of 'idHook'; if it's @ManageHook@ then +-- your @xmonad@ is too old) and then add @fadeWindowsLogHook@ to your +-- 'logHook' and @fadeWindowsEventHook@ to your 'handleEventHook': +-- +-- > , logHook = fadeWindowsLogHook myFadeHook +-- > , handleEventHook = fadeWindowsEventHook +-- > {- ... -} +-- > +-- > myFadeHook = composeAll [isUnfocused --> transparency 0.2 +-- > , opaque +-- > ] +-- +-- The above is like FadeInactive with a fade value of 0.2. +-- +-- FadeHooks do not accumulate; instead, they compose from right to +-- left like 'ManageHook's, so the above example @myFadeHook@ will +-- render unfocused windows at 4/5 opacity and the focused window +-- as opaque. The 'opaque' hook above is optional, by the way, as any +-- unmatched window will be opaque by default. +-- +-- This module is best used with "XMonad.Hooks.MoreManageHelpers", which +-- exports a number of Queries that can be used in either @ManageHook@ +-- or @FadeHook@. +-- +-- Note that you need a compositing manager such as @xcompmgr@, +-- @dcompmgr@, or @cairo-compmgr@ for window fading to work. If you +-- aren't running a compositing manager, the opacity will be recorded +-- but won't take effect until a compositing manager is started. +-- +-- For more detailed instructions on editing the 'logHook' see: +-- +-- "XMonad.Doc.Extending#The_log_hook_and_external_status_bars" +-- +-- For more detailed instructions on editing the 'handleEventHook', +-- see: +-- +-- "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 +-- window is unmapped and remapped, to the machine becoming sluggish +-- until the compositing manager is restarted (at which point a +-- popup/dialog will suddenly appear; apparently it's getting into +-- a tight loop trying to fade the popup in). I find it useful to +-- have a key binding to restart the compositing manager; for example, +-- +-- main = xmonad $ defaultConfig { +-- {- ... -} +-- } +-- `additionalKeysP` +-- [("M-S-4",spawn "killall xcompmgr; sleep 1; xcompmgr -cCfF &")] +-- {- ... -} +-- ] +-- +-- (See "XMonad.Util.EZConfig" for 'additionalKeysP'.) + +-- a window opacity to be carried in a Query. OEmpty is sort of a hack +-- to make it obay the monoid laws +data Opacity = Opacity Rational | OEmpty + +instance Monoid Opacity where + mempty = OEmpty + r `mappend` OEmpty = r + _ `mappend` r = r + +-- | A FadeHook is similar to a ManageHook, but records window opacity. +type FadeHook = Query Opacity + +-- | Render a window fully opaque. +opaque :: FadeHook +opaque = doS (Opacity 1) + +-- | Render a window fully transparent. +transparent :: FadeHook +transparent = doS (Opacity 0) + +-- | Specify a window's transparency. +transparency :: Rational -- ^ The window's transparency as a fraction. + -- @transparency 1@ is the same as 'transparent', + -- whereas @transparency 0@ is the same as 'opaque'. + -> FadeHook +transparency = doS . Opacity . (1-) . clampRatio + +-- | Specify a window's opacity; this is the inverse of 'transparency'. +opacity :: Rational -- ^ The opacity of a window as a fraction. + -- @opacity 1@ is the same as 'opaque', + -- whereas @opacity 0@ is the same as 'transparent'. + -> FadeHook +opacity = doS . Opacity . clampRatio + +fadeTo, translucence, fadeBy :: Rational -> FadeHook +-- ^ An alias for 'transparency'. +fadeTo = transparency +-- ^ An alias for 'transparency'. +translucence = transparency +-- ^ An alias for 'transparency'. +fadeBy = opacity + +invisible, solid :: FadeHook +-- ^ An alias for 'transparent'. +invisible = transparent +-- ^ An alias for 'opaque'. +solid = opaque + +-- | Like 'doF', but usable with 'ManageHook'-like hooks that +-- aren't 'Query' wrapped around transforming functions ('Endo'). +doS :: Monoid m => m -> Query m +doS = return + +-- | The identity 'FadeHook', which renders windows 'opaque'. +idFadeHook :: FadeHook +idFadeHook = opaque + +-- | A Query to determine if a window is floating. +isFloating :: Query Bool +isFloating = ask >>= \w -> liftX . gets $ M.member w . W.floating . windowset + +-- boring windows can't be seen outside of a layout, so we watch messages with +-- a dummy LayoutModifier and stow them in a persistent bucket. this is not +-- entirely reliable given that boringAuto still isn't observable; we just hope +-- those aren't visible and won;t be affected anyway +-- @@@ punted for now, will be a separate module. it's still slimy, though + +-- | A 'logHook' to fade windows under control of a 'FadeHook', which is +-- similar to but not identical to 'ManageHook'. +fadeWindowsLogHook :: FadeHook -> X () +fadeWindowsLogHook h = withWindowSet $ \s -> do + let visibleWins = (W.integrate' . W.stack . W.workspace . W.current $ s) ++ + concatMap (W.integrate' . W.stack . W.workspace) (W.visible s) + forM_ visibleWins $ \w -> do + o <- userCodeDef (Opacity 1) (runQuery h w) + setOpacity w $ case o of + OEmpty -> 0.93 + Opacity r -> r + +-- | A 'handleEventHook' to handle fading and unfading of newly mapped +-- or unmapped windows; this avoids problems with layouts such as +-- "XMonad.Layout.Full" or "XMonad.Layout.Tabbed". This hook may +-- also be useful with "XMonad.Hooks.FadeInactive". +fadeWindowsEventHook :: Event -> X All +fadeWindowsEventHook (MapNotifyEvent {}) = + -- we need to run the fadeWindowsLogHook. only one way... + asks config >>= logHook >> return (All True) +fadeWindowsEventHook _ = return (All True) + +-- A utility to clamp opacity fractions to the range (0,1) +clampRatio :: Rational -> Rational +clampRatio r | r >= 0 && r <= 1 = r + | r < 0 = 0 + | otherwise = 1 diff --git a/XMonad/Hooks/FloatNext.hs b/XMonad/Hooks/FloatNext.hs --- a/XMonad/Hooks/FloatNext.hs +++ b/XMonad/Hooks/FloatNext.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.Hooks.FloatNext --- Copyright : Quentin Moser +-- Copyright : Quentin Moser -- License : BSD-style (see LICENSE) -- --- Maintainer : Quentin Moser +-- Maintainer : orphaned -- Stability : unstable -- Portability : unportable -- @@ -35,40 +36,11 @@ , willFloatAllNewPP , runLogHook ) where -import Prelude hiding (all) - import XMonad - -import Control.Monad (join) -import Control.Applicative ((<$>)) -import Control.Arrow (first, second) -import Control.Concurrent.MVar -import System.IO.Unsafe (unsafePerformIO) - - -{- Helper functions -} - -modifyMVar2 :: MVar a -> (a -> a) -> IO () -modifyMVar2 v f = modifyMVar_ v (return . f) - -_set :: ((a -> a) -> (Bool, Bool) -> (Bool, Bool)) -> a -> X () -_set f b = io $ modifyMVar2 floatModeMVar (f $ const b) - -_toggle :: ((Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)) -> X () -_toggle f = io $ modifyMVar2 floatModeMVar (f not) - -_get :: ((Bool, Bool) -> a) -> X a -_get f = io $ f <$> readMVar floatModeMVar - -_pp :: ((Bool, Bool) -> Bool) -> String -> (String -> String) -> X (Maybe String) -_pp f s st = _get f >>= \b -> if b then return $ Just $ st s else return Nothing - - -{- The current state is kept here -} - -floatModeMVar :: MVar (Bool, Bool) -floatModeMVar = unsafePerformIO $ newMVar (False, False) +import XMonad.Hooks.ToggleHook +hookName :: String +hookName = "__float" -- $usage -- This module provides actions (that can be set as keybindings) @@ -93,40 +65,34 @@ -- -- > , ((modm, xK_r), toggleFloatAllNew) - -- | This 'ManageHook' will selectively float windows as set -- by 'floatNext' and 'floatAllNew'. floatNextHook :: ManageHook -floatNextHook = do (next, all) <- io $ takeMVar floatModeMVar - io $ putMVar floatModeMVar (False, all) - if next || all then doFloat else idHook - +floatNextHook = toggleHook hookName doFloat -- | @floatNext True@ arranges for the next spawned window to be -- sent to the floating layer, @floatNext False@ cancels it. floatNext :: Bool -> X () -floatNext = _set first +floatNext = hookNext hookName toggleFloatNext :: X () -toggleFloatNext = _toggle first +toggleFloatNext = toggleHookNext hookName -- | @floatAllNew True@ arranges for new windows to be -- sent to the floating layer, @floatAllNew False@ cancels it floatAllNew :: Bool -> X () -floatAllNew = _set second +floatAllNew = hookAllNew hookName toggleFloatAllNew :: X () -toggleFloatAllNew = _toggle second - +toggleFloatAllNew = toggleHookAllNew hookName -- | Whether the next window will be set floating willFloatNext :: X Bool -willFloatNext = _get fst +willFloatNext = willHookNext hookName -- | Whether new windows will be set floating willFloatAllNew :: X Bool -willFloatAllNew = _get snd - +willFloatAllNew = willHookAllNew hookName -- $pp -- The following functions are used to display the current @@ -148,10 +114,7 @@ -- pass them 'id'. willFloatNextPP :: (String -> String) -> X (Maybe String) -willFloatNextPP = _pp fst "Next" +willFloatNextPP = willHookNextPP hookName willFloatAllNewPP :: (String -> String) -> X (Maybe String) -willFloatAllNewPP = _pp snd "All" - -runLogHook :: X () -runLogHook = join $ asks $ logHook . config +willFloatAllNewPP = willHookAllNewPP hookName diff --git a/XMonad/Hooks/ICCCMFocus.hs b/XMonad/Hooks/ICCCMFocus.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/ICCCMFocus.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.ICCCMFocus +-- License : BSD +-- +-- Maintainer : Tony Morris +-- +-- Implemented in your @logHook@, Java swing applications will not misbehave +-- when it comes to taking and losing focus. +-- +-- This has been done by taking the patch in and refactoring it so that it can be included in @~\/.xmonad\/xmonad.hs@. +-- +-- @ +-- conf' = +-- conf { +-- logHook = takeTopFocus +-- } +-- @ +----------------------------------------------------------------------------- +module XMonad.Hooks.ICCCMFocus +( + atom_WM_TAKE_FOCUS +, takeFocusX +, takeTopFocus +) where + +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 + +-- | The value to add to your log hook configuration. +takeTopFocus :: + X () +takeTopFocus = + (withWindowSet $ maybe (setFocusX =<< asks theRoot) takeFocusX . W.peek) >> setWMName "LG3D" + diff --git a/XMonad/Hooks/InsertPosition.hs b/XMonad/Hooks/InsertPosition.hs --- a/XMonad/Hooks/InsertPosition.hs +++ b/XMonad/Hooks/InsertPosition.hs @@ -46,7 +46,7 @@ insertPosition :: Position -> Focus -> ManageHook insertPosition pos foc = Endo . g <$> ask where - g w = viewingWs w (updateFocus w . ins w . W.delete w) + g w = viewingWs w (updateFocus w . ins w . W.delete' w) ins w = (\f ws -> fromMaybe id (W.focusWindow <$> W.peek ws) $ f ws) $ case pos of Master -> W.insertUp w . W.focusMaster diff --git a/XMonad/Hooks/ManageDocks.hs b/XMonad/Hooks/ManageDocks.hs --- a/XMonad/Hooks/ManageDocks.hs +++ b/XMonad/Hooks/ManageDocks.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE PatternGuards, FlexibleInstances, MultiParamTypeClasses #-} -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable, PatternGuards, FlexibleInstances, MultiParamTypeClasses, CPP #-} -- deriving Typeable for ghc-6.6 compatibility, which is retained in the core ----------------------------------------------------------------------------- -- | @@ -18,10 +17,17 @@ -- * Usage -- $usage manageDocks, checkDock, AvoidStruts, avoidStruts, avoidStrutsOn, + docksEventHook, ToggleStruts(..), SetStruts(..), module XMonad.Util.Types, +#ifdef TESTING + r2c, + c2r, + RectC(..), +#endif + -- for XMonad.Actions.FloatSnap calcGap ) where @@ -30,10 +36,11 @@ ----------------------------------------------------------------------------- import XMonad import Foreign.C.Types (CLong) -import Control.Monad import XMonad.Layout.LayoutModifier import XMonad.Util.Types import XMonad.Util.WindowProperties (getProp32s) +import XMonad.Util.XUtils (fi) +import Data.Monoid (All(..)) import qualified Data.Set as S @@ -56,6 +63,11 @@ -- > layoutHook = avoidStruts (tall ||| mirror tall ||| ...) -- > where tall = Tall 1 (3/100) (1/2) -- +-- The third component is an event hook that causes new docks to appear +-- immediately, instead of waiting for the next focus change. +-- +-- > handleEventHook = ... <+> docksEventHook +-- -- 'AvoidStruts' also supports toggling the dock gaps; add a keybinding -- similar to: -- @@ -102,6 +114,14 @@ Just [r] -> return $ elem (fromIntegral r) [dock, desk] _ -> return False +-- | Whenever a new dock appears, refresh the layout immediately to avoid the +-- new dock. +docksEventHook :: Event -> X All +docksEventHook (MapNotifyEvent {ev_window = w}) = do + whenX ((not `fmap` (isClient w)) <&&> runQuery checkDock w) refresh + return (All True) +docksEventHook _ = return (All True) + -- | Gets the STRUT config, if present, in xmonad gap order getStrut :: Window -> X [Strut] getStrut w = do @@ -210,41 +230,34 @@ -- | (Initial x pixel, initial y pixel, -- final x pixel, final y pixel). -type RectC = (CLong, CLong, CLong, CLong) - -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral +newtype RectC = RectC (CLong, CLong, CLong, CLong) deriving (Eq,Show) -- | Invertible conversion. r2c :: Rectangle -> RectC -r2c (Rectangle x y w h) = (fi x, fi y, fi x + fi w - 1, fi y + fi h - 1) +r2c (Rectangle x y w h) = RectC (fi x, fi y, fi x + fi w - 1, fi y + fi h - 1) -- | Invertible conversion. c2r :: RectC -> Rectangle -c2r (x1, y1, x2, y2) = Rectangle (fi x1) (fi y1) (fi $ x2 - x1 + 1) (fi $ y2 - y1 + 1) +c2r (RectC (x1, y1, x2, y2)) = Rectangle (fi x1) (fi y1) (fi $ x2 - x1 + 1) (fi $ y2 - y1 + 1) --- TODO: Add these QuickCheck properties to the test suite, along with --- suitable Arbitrary instances. --- prop_r2c_c2r :: RectC -> Bool --- prop_r2c_c2r r = r2c (c2r r) == r - --- prop_c2r_r2c :: Rectangle -> Bool --- prop_c2r_r2c r = c2r (r2c r) == r - reduce :: RectC -> Strut -> RectC -> RectC -reduce (sx0, sy0, sx1, sy1) (s, n, l, h) (x0, y0, x1, y1) = case s of - L | p (y0, y1) -> (mx x0 sx0 , y0 , x1 , y1 ) - R | p (y0, y1) -> (x0 , y0 , mn x1 sx1, y1 ) - U | p (x0, x1) -> (x0 , mx y0 sy0, x1 , y1 ) - D | p (x0, x1) -> (x0 , y0 , x1 , mn y1 sy1) - _ -> (x0 , y0 , x1 , y1 ) +reduce (RectC (sx0, sy0, sx1, sy1)) (s, n, l, h) (RectC (x0, y0, x1, y1)) = + RectC $ case s of + L | p (y0, y1) && qh x1 -> (mx x0 sx0, y0 , x1 , y1 ) + R | p (y0, y1) && qv sx1 x0 -> (x0 , y0 , mn x1 sx1, y1 ) + U | p (x0, x1) && qh y1 -> (x0 , mx y0 sy0, x1 , y1 ) + D | p (x0, x1) && qv sy1 y0 -> (x0 , y0 , x1 , mn y1 sy1) + _ -> (x0 , y0 , x1 , y1 ) where mx a b = max a (b + n) mn a b = min a (b - n) p r = r `overlaps` (l, h) + -- Filter out struts that cover the entire rectangle: + qh d1 = n <= d1 + qv sd1 d0 = sd1 - n >= d0 -- | Do the two ranges overlap? -- diff --git a/XMonad/Hooks/ManageHelpers.hs b/XMonad/Hooks/ManageHelpers.hs --- a/XMonad/Hooks/ManageHelpers.hs +++ b/XMonad/Hooks/ManageHelpers.hs @@ -28,6 +28,7 @@ Side(..), composeOne, (-?>), (/=?), (<==?), (>), (-?>>), + currentWs, isInProperty, isKDETrayWindow, isFullscreen, @@ -44,7 +45,8 @@ doSideFloat, doFloatAt, doFloatDep, - doHideIgnore + doHideIgnore, + Match, ) where import XMonad @@ -117,6 +119,10 @@ p -?>> f = do Match b m <- p if b then fmap Just (f m) else return Nothing + +-- | Return the current workspace +currentWs :: Query WorkspaceId +currentWs = liftX (withWindowSet $ return . W.currentTag) -- | A predicate to check whether a window is a KDE system tray icon. isKDETrayWindow :: Query Bool diff --git a/XMonad/Hooks/Minimize.hs b/XMonad/Hooks/Minimize.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/Minimize.hs @@ -0,0 +1,53 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.Minimize +-- Copyright : (c) Justin Bogner 2010 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Justin Bogner +-- Stability : unstable +-- Portability : not portable +-- +-- Handles window manager hints to minimize and restore windows. Use +-- this with XMonad.Layout.Minimize. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.Minimize + ( -- * Usage + -- $usage + minimizeEventHook + ) where + +import Data.Monoid +import Control.Monad(when) + +import XMonad +import XMonad.Layout.Minimize + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Hooks.Minimize +-- > import XMonad.Layout.Minimize +-- > +-- > myHandleEventHook = minimizeEventHook +-- > myLayout = minimize (Tall 1 (3/100) (1/2)) ||| Full ||| etc.. +-- > main = xmonad defaultConfig { layoutHook = myLayout +-- > , handleEventHook = myHandleEventHook } + +minimizeEventHook :: Event -> X All +minimizeEventHook (ClientMessageEvent {ev_window = w, + ev_message_type = mt, + ev_data = dt}) = do + a_aw <- getAtom "_NET_ACTIVE_WINDOW" + a_cs <- getAtom "WM_CHANGE_STATE" + + when (mt == a_aw) $ sendMessage (RestoreMinimizedWin w) + when (mt == a_cs) $ do + let message = fromIntegral . head $ dt + when (message == normalState) $ sendMessage (RestoreMinimizedWin w) + when (message == iconicState) $ minimizeWindow w + + return (All True) +minimizeEventHook _ = return (All True) diff --git a/XMonad/Hooks/Place.hs b/XMonad/Hooks/Place.hs --- a/XMonad/Hooks/Place.hs +++ b/XMonad/Hooks/Place.hs @@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : XMonad.Hooks.Place --- Copyright : Quentin Moser +-- Copyright : Quentin Moser -- License : BSD-style (see LICENSE) -- --- Maintainer : Quentin Moser +-- Maintainer : orphaned -- Stability : unstable -- Portability : unportable -- @@ -38,11 +38,12 @@ import XMonad.Layout.WindowArranger import XMonad.Actions.FloatKeys +import XMonad.Util.XUtils import qualified Data.Map as M import Data.Ratio ((%)) import Data.List (sortBy, minimumBy, partition) -import Data.Maybe (maybe, fromMaybe, catMaybes) +import Data.Maybe (fromMaybe, catMaybes) import Data.Monoid (Endo(..)) import Control.Monad (guard, join) import Control.Monad.Trans (lift) @@ -262,8 +263,6 @@ scale :: (RealFrac a, Integral b) => a -> b -> b -> b scale r n1 n2 = truncate $ r * fi n2 + (1 - r) * fi n1 -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral r2rr :: Rectangle -> Rectangle -> S.RationalRect r2rr (Rectangle x0 y0 w0 h0) (Rectangle x y w h) diff --git a/XMonad/Hooks/PositionStoreHooks.hs b/XMonad/Hooks/PositionStoreHooks.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/PositionStoreHooks.hs @@ -0,0 +1,106 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.PositionStoreHooks +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- This module contains two hooks for the +-- PositionStore (see "XMonad.Util.PositionStore") - a ManageHook and +-- an EventHook. +-- +-- The ManageHook can be used to fill the PositionStore with position and size +-- information about new windows. The advantage of using this hook is, that the +-- information is recorded independent of the currently active layout. So the +-- floating shape of the window can later be restored even if it was opened in a +-- tiled layout initially. +-- +-- For windows, that do not request a particular position, a random position will +-- be assigned. This prevents windows from piling up exactly on top of each other. +-- +-- The EventHook makes sure that windows are deleted from the PositionStore +-- when they are closed. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.PositionStoreHooks ( + -- * Usage + -- $usage + positionStoreManageHook, + positionStoreEventHook + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Util.PositionStore +import XMonad.Hooks.ManageDocks +import XMonad.Layout.Decoration + +import System.Random(randomRIO) +import Control.Applicative((<$>)) +import Control.Monad(when) +import Data.Maybe +import Data.Monoid +import qualified Data.Set as S + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Hooks.PositionStoreHooks +-- +-- and adding 'positionStoreManageHook' to your 'ManageHook' as well +-- as 'positionStoreEventHook' to your event hooks. To be accurate +-- about window sizes, the module needs to know if any decoration is in effect. +-- This is specified with the first argument: Supply 'Nothing' for no decoration, +-- otherwise use 'Just defaultTheme' or similar to inform the module about the +-- decoration theme used. +-- +-- > myManageHook = positionStoreManageHook Nothing <+> manageHook defaultConfig +-- > myHandleEventHook = positionStoreEventHook +-- > +-- > main = xmonad defaultConfig { manageHook = myManageHook +-- > , handleEventHook = myHandleEventHook +-- > } +-- + +positionStoreManageHook :: Maybe Theme -> ManageHook +positionStoreManageHook mDecoTheme = ask >>= liftX . positionStoreInit mDecoTheme >> idHook + +positionStoreInit :: Maybe Theme -> Window -> X () +positionStoreInit mDecoTheme w = withDisplay $ \d -> do + let decoH = maybe 0 decoHeight mDecoTheme -- take decoration into account, which - in its current + -- form - makes windows smaller to make room for it + wa <- io $ getWindowAttributes d w + ws <- gets windowset + arbitraryOffsetX <- randomIntOffset + arbitraryOffsetY <- randomIntOffset + if (wa_x wa == 0) && (wa_y wa == 0) + then do + let sr@(Rectangle srX srY _ _) = screenRect . W.screenDetail . W.current $ ws + modifyPosStore (\ps -> posStoreInsert ps w + (Rectangle (srX + fi arbitraryOffsetX) + (srY + fi arbitraryOffsetY) + (fi $ wa_width wa) + (decoH + fi (wa_height wa))) sr ) + else do + sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa) + let sr = screenRect . W.screenDetail $ sc + sr' <- fmap ($ sr) (calcGap $ S.fromList [minBound .. maxBound]) -- take docks into account, accepting + -- a somewhat unfortunate inter-dependency + -- with 'XMonad.Hooks.ManageDocks' + modifyPosStore (\ps -> posStoreInsert ps w + (Rectangle (fi $ wa_x wa) (fi (wa_y wa) - fi decoH) + (fi $ wa_width wa) (decoH + fi (wa_height wa))) sr' ) + where + randomIntOffset :: X (Int) + randomIntOffset = io $ randomRIO (42, 242) + +positionStoreEventHook :: Event -> X All +positionStoreEventHook (DestroyWindowEvent {ev_window = w, ev_event_type = et}) = do + when (et == destroyNotify) $ do + modifyPosStore (\ps -> posStoreRemove ps w) + return (All True) +positionStoreEventHook _ = return (All True) diff --git a/XMonad/Hooks/RestoreMinimized.hs b/XMonad/Hooks/RestoreMinimized.hs --- a/XMonad/Hooks/RestoreMinimized.hs +++ b/XMonad/Hooks/RestoreMinimized.hs @@ -8,9 +8,9 @@ -- Stability : unstable -- Portability : not portable -- --- Lets you restore minimized windows (see "XMonad.Layout.Minimize") --- by selecting them on a taskbar (listens for _NET_ACTIVE_WINDOW --- and WM_CHANGE_STATE). +-- (Deprecated: Use XMonad.Hooks.Minimize) Lets you restore minimized +-- windows (see "XMonad.Layout.Minimize") by selecting them on a +-- taskbar (listens for _NET_ACTIVE_WINDOW and WM_CHANGE_STATE). -- ----------------------------------------------------------------------------- diff --git a/XMonad/Hooks/ScreenCorners.hs b/XMonad/Hooks/ScreenCorners.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/ScreenCorners.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.ScreenCorners +-- Copyright : (c) 2009 Nils Schweinsberg +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Nils Schweinsberg +-- Stability : unstable +-- Portability : unportable +-- +-- Run @X ()@ actions by touching the edge of your screen with your mouse. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.ScreenCorners + ( + -- * Usage + -- $usage + + -- * Adding screen corners + ScreenCorner (..) + , addScreenCorner + , addScreenCorners + + -- * Event hook + , screenCornerEventHook + ) where + +import Data.Monoid +import Data.List (find) +import XMonad +import XMonad.Util.XUtils (fi) + +import qualified Data.Map as M +import qualified XMonad.Util.ExtensibleState as XS + +data ScreenCorner = SCUpperLeft + | SCUpperRight + | SCLowerLeft + | SCLowerRight + deriving (Eq, Ord, Show) + + + +-------------------------------------------------------------------------------- +-- ExtensibleState modifications +-------------------------------------------------------------------------------- + +newtype ScreenCornerState = ScreenCornerState (M.Map Window (ScreenCorner, X ())) + deriving Typeable + +instance ExtensionClass ScreenCornerState where + initialValue = ScreenCornerState M.empty + +-- | Add one single @X ()@ action to a screen corner +addScreenCorner :: ScreenCorner -> X () -> X () +addScreenCorner corner xF = do + + ScreenCornerState m <- XS.get + (win,xFunc) <- case find (\(_,(sc,_)) -> sc == corner) (M.toList m) of + + Just (w, (_,xF')) -> return (w, xF' >> xF) -- chain X actions + Nothing -> flip (,) xF `fmap` createWindowAt corner + + XS.modify $ \(ScreenCornerState m') -> ScreenCornerState $ M.insert win (corner,xFunc) m' + +-- | Add a list of @(ScreenCorner, X ())@ tuples +addScreenCorners :: [ (ScreenCorner, X ()) ] -> X () +addScreenCorners = mapM_ (\(corner, xF) -> addScreenCorner corner xF) + + +-------------------------------------------------------------------------------- +-- Xlib functions +-------------------------------------------------------------------------------- + +-- "Translate" a ScreenCorner to real (x,y) Positions +createWindowAt :: ScreenCorner -> X Window +createWindowAt SCUpperLeft = createWindowAt' 0 0 +createWindowAt SCUpperRight = withDisplay $ \dpy -> + let w = displayWidth dpy (defaultScreen dpy) - 1 + in createWindowAt' (fi w) 0 + +createWindowAt SCLowerLeft = withDisplay $ \dpy -> + let h = displayHeight dpy (defaultScreen dpy) - 1 + in createWindowAt' 0 (fi h) + +createWindowAt SCLowerRight = withDisplay $ \dpy -> + let w = displayWidth dpy (defaultScreen dpy) - 1 + h = displayHeight dpy (defaultScreen dpy) - 1 + in createWindowAt' (fi w) (fi h) + +-- Create a new X window at a (x,y) Position +createWindowAt' :: Position -> Position -> X Window +createWindowAt' x y = withDisplay $ \dpy -> io $ do + + rootw <- rootWindow dpy (defaultScreen dpy) + + let + visual = defaultVisualOfScreen $ defaultScreenOfDisplay dpy + attrmask = cWOverrideRedirect + + w <- allocaSetWindowAttributes $ \attributes -> do + + set_override_redirect attributes True + createWindow dpy -- display + rootw -- parent window + x -- x + y -- y + 1 -- width + 1 -- height + 0 -- border width + 0 -- depth + inputOnly -- class + visual -- visual + attrmask -- valuemask + attributes -- attributes + + -- we only need mouse entry events + selectInput dpy w enterWindowMask + mapWindow dpy w + sync dpy False + return w + + +-------------------------------------------------------------------------------- +-- Event hook +-------------------------------------------------------------------------------- + +-- | Handle screen corner events +screenCornerEventHook :: Event -> X All +screenCornerEventHook CrossingEvent { ev_window = win } = do + + ScreenCornerState m <- XS.get + + case M.lookup win m of + Just (_, xF) -> xF + Nothing -> return () + + return (All True) + +screenCornerEventHook _ = return (All True) + + +-------------------------------------------------------------------------------- +-- $usage +-- +-- This extension adds KDE-like screen corners to XMonad. By moving your cursor +-- into one of your screen corners you can trigger an @X ()@ action, for +-- example @"XMonad.Actions.GridSelect".goToSelected@ or +-- @"XMonad.Actions.CycleWS".nextWS@ etc. +-- +-- To use it, import it on top of your @xmonad.hs@: +-- +-- > import XMonad.Hooks.ScreenCorners +-- +-- Then add your screen corners in our startup hook: +-- +-- > myStartupHook = do +-- > ... +-- > addScreenCorner SCUpperRight (goToSelected defaultGSConfig { gs_cellwidth = 200}) +-- > addScreenCorners [ (SCLowerRight, nextWS) +-- > , (SCLowerLeft, prevWS) +-- > ] +-- +-- And finally wait for screen corner events in your event hook: +-- +-- > myEventHook e = do +-- > ... +-- > screenCornerEventHook e diff --git a/XMonad/Hooks/Script.hs b/XMonad/Hooks/Script.hs --- a/XMonad/Hooks/Script.hs +++ b/XMonad/Hooks/Script.hs @@ -26,7 +26,6 @@ -- import XMonad -import Control.Monad.Trans import System.Directory -- $usage diff --git a/XMonad/Hooks/ServerMode.hs b/XMonad/Hooks/ServerMode.hs --- a/XMonad/Hooks/ServerMode.hs +++ b/XMonad/Hooks/ServerMode.hs @@ -64,7 +64,6 @@ ) where import Control.Monad (when) -import Data.List import Data.Monoid import System.IO diff --git a/XMonad/Hooks/ToggleHook.hs b/XMonad/Hooks/ToggleHook.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/ToggleHook.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.ToggleHook +-- Copyright : Ben Boeckel +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Ben Boeckel +-- Stability : unstable +-- Portability : unportable +-- +-- Hook and keybindings for toggling hook behavior. +----------------------------------------------------------------------------- + +module XMonad.Hooks.ToggleHook ( -- * Usage + -- $usage + + -- * The hook + toggleHook + , toggleHook' + + -- * Actions + , hookNext + , toggleHookNext + , hookAllNew + , toggleHookAllNew + + -- * Queries + , willHook + , willHookNext + , willHookAllNew + + -- * 'DynamicLog' utilities + -- $pp + , willHookNextPP + , willHookAllNewPP + , runLogHook ) where + +import Prelude hiding (all) + +import XMonad +import qualified XMonad.Util.ExtensibleState as XS + +import Control.Monad (join,guard) +import Control.Applicative ((<$>)) +import Control.Arrow (first, second) + +import Data.Map + +{- Helper functions -} + +_set :: String -> ((a -> a) -> (Bool, Bool) -> (Bool, Bool)) -> a -> X () +_set n f b = modify' n (f $ const b) + +_toggle :: String -> ((Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)) -> X () +_toggle n f = modify' n (f not) + +_get :: String -> ((Bool, Bool) -> a) -> X a +_get n f = XS.gets $ f . (findWithDefault (False, False) n . hooks) + +_pp :: String -> ((Bool, Bool) -> Bool) -> String -> (String -> String) -> X (Maybe String) +_pp n f s st = (\b -> guard b >> Just (st s)) <$> _get n f + +{- The current state is kept here -} + +data HookState = HookState { hooks :: Map String (Bool, Bool) } deriving (Typeable) + +instance ExtensionClass HookState where + initialValue = HookState empty + +modify' :: String -> ((Bool, Bool) -> (Bool, Bool)) -> X () +modify' n f = XS.modify (HookState . setter . hooks) + where + setter m = insert n (f (findWithDefault (False, False) n m)) m + +-- $usage +-- This module provides actions (that can be set as keybindings) +-- to be able to cause hooks to be occur on a conditional basis. +-- +-- You can use it by including the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Hooks.ToggleHook +-- +-- and adding 'toggleHook name hook' to your 'ManageHook' where @name@ is the +-- name of the hook and @hook@ is the hook to execute based on the state. +-- +-- > myManageHook = toggleHook "float" doFloat <+> manageHook defaultConfig +-- +-- Additionally, toggleHook' is provided to toggle between two hooks (rather +-- than on/off). +-- +-- > myManageHook = toggleHook' "oldfocus" (const id) W.focusWindow <+> manageHook defaultConfig +-- +-- The 'hookNext' and 'toggleHookNext' functions can be used in key +-- bindings to set whether the hook is applied or not. +-- +-- > , ((modm, xK_e), toggleHookNext "float") +-- +-- 'hookAllNew' and 'toggleHookAllNew' are similar but float all +-- spawned windows until disabled again. +-- +-- > , ((modm, xK_r), toggleHookAllNew "float") + +-- | This 'ManageHook' will selectively apply a hook as set +-- by 'hookNext' and 'hookAllNew'. +toggleHook :: String -> ManageHook -> ManageHook +toggleHook n h = toggleHook' n h idHook + +toggleHook' :: String -> ManageHook -> ManageHook -> ManageHook +toggleHook' n th fh = do m <- liftX $ XS.gets hooks + (next, all) <- return $ findWithDefault (False, False) n m + liftX $ XS.put $ HookState $ insert n (False, all) m + if next || all then th else fh + +-- | @hookNext name True@ arranges for the next spawned window to +-- have the hook @name@ applied, @hookNext name False@ cancels it. +hookNext :: String -> Bool -> X () +hookNext n = _set n first + +toggleHookNext :: String -> X () +toggleHookNext n = _toggle n first + +-- | @hookAllNew name True@ arranges for new windows to +-- have the hook @name@ applied, @hookAllNew name False@ cancels it +hookAllNew :: String -> Bool -> X () +hookAllNew n = _set n second + +toggleHookAllNew :: String -> X () +toggleHookAllNew n = _toggle n second + +-- | Query what will happen at the next ManageHook call for the hook @name@. +willHook :: String -> X Bool +willHook n = willHookNext n <||> willHookAllNew n + +-- | Whether the next window will trigger the hook @name@. +willHookNext :: String -> X Bool +willHookNext n = _get n fst + +-- | Whether new windows will trigger the hook @name@. +willHookAllNew :: String -> X Bool +willHookAllNew n = _get n snd + +-- $pp +-- The following functions are used to display the current +-- state of 'hookNext' and 'hookAllNew' in your +-- 'XMonad.Hooks.DynamicLog.dynamicLogWithPP'. +-- 'willHookNextPP' and 'willHookAllNewPP' should be added +-- to the 'XMonad.Hooks.DynamicLog.ppExtras' field of your +-- 'XMonad.Hooks.DynamicLog.PP'. +-- +-- Use 'runLogHook' to refresh the output of your 'logHook', so +-- that the effects of a 'hookNext'/... will be visible +-- immediately: +-- +-- > , ((modm, xK_e), toggleHookNext "float" >> runLogHook) +-- +-- The @String -> String@ parameters to 'willHookNextPP' and +-- 'willHookAllNewPP' will be applied to their output, you +-- can use them to set the text color, etc., or you can just +-- pass them 'id'. + +willHookNextPP :: String -> (String -> String) -> X (Maybe String) +willHookNextPP n = _pp n fst "Next" + +willHookAllNewPP :: String -> (String -> String) -> X (Maybe String) +willHookAllNewPP n = _pp n snd "All" + +runLogHook :: X () +runLogHook = join $ asks $ logHook . config diff --git a/XMonad/Hooks/UrgencyHook.hs b/XMonad/Hooks/UrgencyHook.hs --- a/XMonad/Hooks/UrgencyHook.hs +++ b/XMonad/Hooks/UrgencyHook.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards, DeriveDataTypeable, + FlexibleInstances #-} ----------------------------------------------------------------------------- -- | @@ -64,24 +65,24 @@ readUrgents, withUrgents, StdoutUrgencyHook(..), SpawnUrgencyHook(..), - UrgencyHook(urgencyHook) + UrgencyHook(urgencyHook), + Interval, ) where import XMonad import qualified XMonad.StackSet as W import XMonad.Util.Dzen (dzenWithArgs, seconds) +import qualified XMonad.Util.ExtensibleState as XS import XMonad.Util.NamedWindows (getName) import XMonad.Util.Timer (TimerId, startTimer, handleTimer) import Control.Applicative ((<$>)) import Control.Monad (when) import Data.Bits (testBit) -import Data.IORef -import Data.List (delete) +import Data.List (delete, (\\)) import Data.Maybe (listToMaybe, maybeToList) import qualified Data.Set as S -import Foreign (unsafePerformIO) -- $usage -- @@ -195,7 +196,7 @@ -- hopefully you know where to find it. -- | This is the method to enable an urgency hook. It uses the default --- 'urgencyConfig' to control behavior. To change this, use 'withUrgencyHook' +-- 'urgencyConfig' to control behavior. To change this, use 'withUrgencyHookC' -- instead. withUrgencyHook :: (LayoutClass l Window, UrgencyHook h) => h -> XConfig l -> XConfig l @@ -213,6 +214,15 @@ logHook = cleanupUrgents (suppressWhen urgConf) >> logHook conf } +data Urgents = Urgents { fromUrgents :: [Window] } deriving (Read,Show,Typeable) + +onUrgents :: ([Window] -> [Window]) -> Urgents -> Urgents +onUrgents f = Urgents . f . fromUrgents + +instance ExtensionClass Urgents where + initialValue = Urgents [] + extensionType = PersistentExtension + -- | Global configuration, applied to all types of 'UrgencyHook'. See -- 'urgencyConfig' for the defaults. data UrgencyConfig = UrgencyConfig @@ -262,25 +272,18 @@ clearUrgents :: X () clearUrgents = adjustUrgents (const []) >> adjustReminders (const []) --- | Stores the global set of all urgent windows, across workspaces. Not exported -- use --- 'readUrgents' or 'withUrgents' instead. -{-# NOINLINE urgents #-} -urgents :: IORef [Window] -urgents = unsafePerformIO (newIORef []) --- (Hey, I don't like it any more than you do.) - -- | X action that returns a list of currently urgent windows. You might use -- it, or 'withUrgents', in your custom logHook, to display the workspaces that -- contain urgent windows. readUrgents :: X [Window] -readUrgents = io $ readIORef urgents +readUrgents = XS.gets fromUrgents -- | An HOF version of 'readUrgents', for those who prefer that sort of thing. withUrgents :: ([Window] -> X a) -> X a withUrgents f = readUrgents >>= f adjustUrgents :: ([Window] -> [Window]) -> X () -adjustUrgents f = io $ modifyIORef urgents f +adjustUrgents = XS.modify . onUrgents type Interval = Rational @@ -290,18 +293,19 @@ , window :: Window , interval :: Interval , remaining :: Maybe Int - } deriving Eq + } deriving (Show,Read,Eq,Typeable) +instance ExtensionClass [Reminder] where + initialValue = [] + extensionType = PersistentExtension + -- | Stores the list of urgency reminders. -{-# NOINLINE reminders #-} -reminders :: IORef [Reminder] -reminders = unsafePerformIO (newIORef []) readReminders :: X [Reminder] -readReminders = io $ readIORef reminders +readReminders = XS.get adjustReminders :: ([Reminder] -> [Reminder]) -> X () -adjustReminders f = io $ modifyIORef reminders f +adjustReminders = XS.modify clearUrgency :: Window -> X () clearUrgency w = adjustUrgents (delete w) >> adjustReminders (filter $ (w /=) . window) @@ -332,7 +336,7 @@ callUrgencyHook wuh w else clearUrgency w - userCodeDef () =<< asks (logHook . config) -- call *after* IORef has been modified + userCodeDef () =<< asks (logHook . config) DestroyWindowEvent {ev_window = w} -> clearUrgency w _ -> @@ -369,7 +373,9 @@ shouldSuppress sw w = elem w <$> suppressibleWindows sw cleanupUrgents :: SuppressWhen -> X () -cleanupUrgents sw = mapM_ clearUrgency =<< suppressibleWindows sw +cleanupUrgents sw = do + sw' <- suppressibleWindows sw + adjustUrgents (\\ sw') >> adjustReminders (filter $ ((`notElem` sw') . window)) suppressibleWindows :: SuppressWhen -> X [Window] suppressibleWindows Visible = gets $ S.toList . mapped diff --git a/XMonad/Hooks/XPropManage.hs b/XMonad/Hooks/XPropManage.hs --- a/XMonad/Hooks/XPropManage.hs +++ b/XMonad/Hooks/XPropManage.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.Hooks.XPropManage @@ -17,14 +18,14 @@ xPropManageHook, XPropMatch, pmX, pmP ) where +import Prelude hiding (catch) +import Control.Exception import Data.Char (chr) -import Data.List (concat) import Data.Monoid (mconcat, Endo(..)) import Control.Monad.Trans (lift) import XMonad -import XMonad.ManageHook ((-->)) -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -75,7 +76,7 @@ getProp :: Display -> Window -> Atom -> X ([String]) getProp d w p = do - prop <- io $ catch (getTextProperty d w p >>= wcTextPropertyToTextList d) (\_ -> return [[]]) + prop <- io $ 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/Accordion.hs b/XMonad/Layout/Accordion.hs --- a/XMonad/Layout/Accordion.hs +++ b/XMonad/Layout/Accordion.hs @@ -42,7 +42,7 @@ instance LayoutClass Accordion Window where pureLayout _ sc ws = zip ups tops ++ [(W.focus ws, mainPane)] ++ zip dns bottoms where - ups = W.up ws + ups = reverse $ W.up ws dns = W.down ws (top, allButTop) = splitVerticallyBy (1%8 :: Ratio Int) sc (center, bottom) = splitVerticallyBy (6%7 :: Ratio Int) allButTop diff --git a/XMonad/Layout/AutoMaster.hs b/XMonad/Layout/AutoMaster.hs --- a/XMonad/Layout/AutoMaster.hs +++ b/XMonad/Layout/AutoMaster.hs @@ -18,7 +18,7 @@ module XMonad.Layout.AutoMaster ( -- * Usage -- $usage - autoMaster + autoMaster, AutoMaster ) where import Control.Monad @@ -48,7 +48,7 @@ data AutoMaster a = AutoMaster Int Float Float deriving (Read,Show) -instance LayoutModifier AutoMaster Window where +instance (Eq w) => LayoutModifier AutoMaster w where modifyLayout (AutoMaster k bias _) = autoLayout k bias pureMess = autoMess @@ -61,12 +61,12 @@ resize Shrink = AutoMaster k (max (-0.4) $ bias-delta) delta -- | Main layout function -autoLayout :: (LayoutClass l Window) => +autoLayout :: (Eq w, LayoutClass l w) => Int -> Float -> - W.Workspace WorkspaceId (l Window) Window + W.Workspace WorkspaceId (l w) w -> Rectangle - -> X ([(Window, Rectangle)], Maybe (l Window)) + -> X ([(w, Rectangle)], Maybe (l w)) autoLayout k bias wksp rect = do let stack = W.stack wksp let ws = W.integrate' stack diff --git a/XMonad/Layout/BorderResize.hs b/XMonad/Layout/BorderResize.hs --- a/XMonad/Layout/BorderResize.hs +++ b/XMonad/Layout/BorderResize.hs @@ -12,8 +12,10 @@ -- This layout modifier will allow to resize windows by dragging their -- borders with the mouse. However, it only works in layouts or modified -- layouts that react to the 'SetGeometry' message. --- "XMonad.Layout.WindowArranger" can be used to create such a setup. --- BorderResize is probably most useful in floating layouts. +-- "XMonad.Layout.WindowArranger" can be used to create such a setup, +-- but it is probably must useful in a floating layout such as +-- "XMonad.Layout.PositionStoreFloat" with which it has been mainly tested. +-- See the documentation of PositionStoreFloat for a typical usage example. -- ----------------------------------------------------------------------------- @@ -22,15 +24,15 @@ -- $usage borderResize , BorderResize (..) + , RectWithBorders, BorderInfo, ) where import XMonad import XMonad.Layout.Decoration import XMonad.Layout.WindowArranger import XMonad.Util.XUtils -import Control.Monad(when,forM) -import Control.Arrow(first) -import Control.Applicative((<$>)) +import Control.Monad(when) +import qualified Data.Map as M -- $usage -- You can use this module with the following in your @@ -41,89 +43,141 @@ -- > main = xmonad defaultConfig { layoutHook = myLayout } -- -data BorderInfo = RightSideBorder Window Rectangle - | LeftSideBorder Window Rectangle - | TopSideBorder Window Rectangle - | BottomSideBorder Window Rectangle +type BorderBlueprint = (Rectangle, Glyph, BorderType) + +data BorderType = RightSideBorder + | LeftSideBorder + | TopSideBorder + | BottomSideBorder deriving (Show, Read, Eq) -type BorderWithRect = (Rectangle, Rectangle, Glyph, BorderInfo) -type BorderWithWin = (Window, BorderInfo) +data BorderInfo = BI { bWin :: Window, + bRect :: Rectangle, + bType :: BorderType + } deriving (Show, Read) -data BorderResize a = BR [BorderWithWin] deriving (Show, Read) +type RectWithBorders = (Rectangle, [BorderInfo]) +data BorderResize a = BR (M.Map Window RectWithBorders) deriving (Show, Read) + brBorderOffset :: Position brBorderOffset = 5 brBorderSize :: Dimension brBorderSize = 10 -brCursorRightSide :: Glyph -brCursorRightSide = 96 -brCursorLeftSide :: Glyph -brCursorLeftSide = 70 -brCursorTopSide :: Glyph -brCursorTopSide = 138 -brCursorBottomSide :: Glyph -brCursorBottomSide = 16 - borderResize :: l a -> ModifiedLayout BorderResize l a -borderResize = ModifiedLayout (BR []) +borderResize = ModifiedLayout (BR M.empty) instance LayoutModifier BorderResize Window where redoLayout _ _ Nothing wrs = return (wrs, Nothing) - redoLayout (BR borders) _ _ wrs = do - let preparedBorders = for wrs $ \wr -> (wr, prepareBorders wr) - mapM_ deleteBorder borders - newBorders <- forM preparedBorders $ \(wr, (b1, b2, b3, b4)) -> - first (++[wr]) . unzip <$> mapM createBorder [b1,b2,b3,b4] - let wrs' = concat $ map fst newBorders - newBordersSerialized = concat $ map snd newBorders - return (wrs', Just $ BR newBordersSerialized) + redoLayout (BR wrsLastTime) _ _ wrs = do + let correctOrder = map fst wrs + wrsCurrent = M.fromList wrs + wrsGone = M.difference wrsLastTime wrsCurrent + wrsAppeared = M.difference wrsCurrent wrsLastTime + wrsStillThere = M.intersectionWith testIfUnchanged wrsLastTime wrsCurrent + handleGone wrsGone + wrsCreated <- handleAppeared wrsAppeared + let wrsChanged = handleStillThere wrsStillThere + wrsThisTime = M.union wrsChanged wrsCreated + return (compileWrs wrsThisTime correctOrder, Just $ BR wrsThisTime) -- What we return is the original wrs with the new border -- windows inserted at the correct positions - this way, the core -- will restack the borders correctly. -- We also return information about our borders, so that we -- can handle events that they receive and destroy them when -- they are no longer needed. + where + testIfUnchanged entry@(rLastTime, _) rCurrent = + if rLastTime == rCurrent + then (Nothing, entry) + else (Just rCurrent, entry) - handleMess (BR borders) m - | Just e <- fromMessage m :: Maybe Event = handleResize borders e >> return Nothing + handleMess (BR wrsLastTime) m + | Just e <- fromMessage m :: Maybe Event = + handleResize (createBorderLookupTable wrsLastTime) e >> return Nothing | Just _ <- fromMessage m :: Maybe LayoutMessages = - mapM_ deleteBorder borders >> return (Just $ BR []) + handleGone wrsLastTime >> return (Just $ BR M.empty) handleMess _ _ = return Nothing -prepareBorders :: (Window, Rectangle) -> (BorderWithRect, BorderWithRect, BorderWithRect, BorderWithRect) -prepareBorders (w, r@(Rectangle x y wh ht)) = - ((r, (Rectangle (x + fi wh - brBorderOffset) y brBorderSize ht) , brCursorRightSide , RightSideBorder w r), - (r, (Rectangle (x - brBorderOffset) y brBorderSize ht) , brCursorLeftSide , LeftSideBorder w r), - (r, (Rectangle x (y - brBorderOffset) wh brBorderSize) , brCursorTopSide , TopSideBorder w r), - (r, (Rectangle x (y + fi ht - brBorderOffset) wh brBorderSize) , brCursorBottomSide , BottomSideBorder w r) - ) +compileWrs :: M.Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)] +compileWrs wrsThisTime correctOrder = let wrs = reorder (M.toList wrsThisTime) correctOrder + in concat $ map compileWr wrs -handleResize :: [BorderWithWin] -> Event -> X () +compileWr :: (Window, RectWithBorders) -> [(Window, Rectangle)] +compileWr (w, (r, borderInfos)) = + let borderWrs = for borderInfos $ \bi -> (bWin bi, bRect bi) + in borderWrs ++ [(w, r)] + +handleGone :: M.Map Window RectWithBorders -> X () +handleGone wrsGone = mapM_ deleteWindow borderWins + where + borderWins = map bWin . concat . map snd . M.elems $ wrsGone + +handleAppeared :: M.Map Window Rectangle -> X (M.Map Window RectWithBorders) +handleAppeared wrsAppeared = do + let wrs = M.toList wrsAppeared + wrsCreated <- mapM handleSingleAppeared wrs + return $ M.fromList wrsCreated + +handleSingleAppeared :: (Window, Rectangle) -> X (Window, RectWithBorders) +handleSingleAppeared (w, r) = do + let borderBlueprints = prepareBorders r + borderInfos <- mapM createBorder borderBlueprints + return (w, (r, borderInfos)) + +handleStillThere :: M.Map Window (Maybe Rectangle, RectWithBorders) -> M.Map Window RectWithBorders +handleStillThere wrsStillThere = M.map handleSingleStillThere wrsStillThere + +handleSingleStillThere :: (Maybe Rectangle, RectWithBorders) -> RectWithBorders +handleSingleStillThere (Nothing, entry) = entry +handleSingleStillThere (Just rCurrent, (_, borderInfos)) = (rCurrent, updatedBorderInfos) + where + changedBorderBlueprints = prepareBorders rCurrent + updatedBorderInfos = map updateBorderInfo . zip borderInfos $ changedBorderBlueprints + -- assuming that the four borders are always in the same order + +updateBorderInfo :: (BorderInfo, BorderBlueprint) -> BorderInfo +updateBorderInfo (borderInfo, (r, _, _)) = borderInfo { bRect = r } + +createBorderLookupTable :: M.Map Window RectWithBorders -> [(Window, (BorderType, Window, Rectangle))] +createBorderLookupTable wrsLastTime = concat $ map processSingleEntry $ M.toList wrsLastTime + where + processSingleEntry :: (Window, RectWithBorders) -> [(Window, (BorderType, Window, Rectangle))] + processSingleEntry (w, (r, borderInfos)) = for borderInfos $ \bi -> (bWin bi, (bType bi, w, r)) + +prepareBorders :: Rectangle -> [BorderBlueprint] +prepareBorders (Rectangle x y wh ht) = + [((Rectangle (x + fi wh - brBorderOffset) y brBorderSize ht), xC_right_side , RightSideBorder), + ((Rectangle (x - brBorderOffset) y brBorderSize ht) , xC_left_side , LeftSideBorder), + ((Rectangle x (y - brBorderOffset) wh brBorderSize) , xC_top_side , TopSideBorder), + ((Rectangle x (y + fi ht - brBorderOffset) wh brBorderSize), xC_bottom_side, BottomSideBorder) + ] + +handleResize :: [(Window, (BorderType, Window, Rectangle))] -> Event -> X () handleResize borders ButtonEvent { ev_window = ew, ev_event_type = et } | et == buttonPress, Just edge <- lookup ew borders = case edge of - RightSideBorder hostWin (Rectangle hx hy _ hht) -> + (RightSideBorder, hostWin, (Rectangle hx hy _ hht)) -> mouseDrag (\x _ -> do let nwh = max 1 $ fi (x - hx) rect = Rectangle hx hy nwh hht focus hostWin when (x - hx > 0) $ sendMessage (SetGeometry rect)) (focus hostWin) - LeftSideBorder hostWin (Rectangle hx hy hwh hht) -> + (LeftSideBorder, hostWin, (Rectangle hx hy hwh hht)) -> mouseDrag (\x _ -> do let nx = max 0 $ min (hx + fi hwh) $ x nwh = max 1 $ hwh + fi (hx - x) rect = Rectangle nx hy nwh hht focus hostWin when (x < hx + fi hwh) $ sendMessage (SetGeometry rect)) (focus hostWin) - TopSideBorder hostWin (Rectangle hx hy hwh hht) -> + (TopSideBorder, hostWin, (Rectangle hx hy hwh hht)) -> mouseDrag (\_ y -> do let ny = max 0 $ min (hy + fi hht) $ y nht = max 1 $ hht + fi (hy - y) rect = Rectangle hx ny hwh nht focus hostWin when (y < hy + fi hht) $ sendMessage (SetGeometry rect)) (focus hostWin) - BottomSideBorder hostWin (Rectangle hx hy hwh _) -> + (BottomSideBorder, hostWin, (Rectangle hx hy hwh _)) -> mouseDrag (\_ y -> do let nht = max 1 $ fi (y - hy) rect = Rectangle hx hy hwh nht @@ -131,13 +185,10 @@ when (y - hy > 0) $ sendMessage (SetGeometry rect)) (focus hostWin) handleResize _ _ = return () -createBorder :: BorderWithRect -> X (((Window, Rectangle), BorderWithWin)) -createBorder (_, borderRect, borderCursor, borderInfo) = do +createBorder :: BorderBlueprint -> X (BorderInfo) +createBorder (borderRect, borderCursor, borderType) = do borderWin <- createInputWindow borderCursor borderRect - return ((borderWin, borderRect), (borderWin, borderInfo)) - -deleteBorder :: BorderWithWin -> X () -deleteBorder (borderWin, _) = deleteWindow borderWin + return BI { bWin = borderWin, bRect = borderRect, bType = borderType } createInputWindow :: Glyph -> Rectangle -> X Window createInputWindow cursorGlyph r = withDisplay $ \d -> do @@ -162,3 +213,13 @@ for :: [a] -> (a -> b) -> [b] for = flip map + +reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)] +reorder wrs order = + let ordered = concat $ map (pickElem wrs) order + rest = filter (\(w, _) -> not (w `elem` order)) wrs + in ordered ++ rest + where + pickElem list e = case (lookup e list) of + Just result -> [(e, result)] + Nothing -> [] diff --git a/XMonad/Layout/BoringWindows.hs b/XMonad/Layout/BoringWindows.hs --- a/XMonad/Layout/BoringWindows.hs +++ b/XMonad/Layout/BoringWindows.hs @@ -6,7 +6,7 @@ -- Copyright : (c) 2008 David Roundy -- License : BSD3-style (see LICENSE) -- --- Maintainer : none +-- Maintainer : Adam Vogt -- Stability : unstable -- Portability : unportable -- @@ -24,6 +24,10 @@ UpdateBoring(UpdateBoring), BoringMessage(Replace,Merge), BoringWindows() + + -- * Tips + -- ** variant of 'Full' + -- $simplest ) where import XMonad.Layout.LayoutModifier(ModifiedLayout(..), @@ -31,10 +35,8 @@ import XMonad(Typeable, LayoutClass, Message, X, fromMessage, sendMessage, windows, withFocused, Window) import Control.Applicative((<$>)) -import Control.Monad(Monad(return, (>>))) import Data.List((\\), union) -import Data.Maybe(Maybe(..), maybe, fromMaybe, listToMaybe, - maybeToList) +import Data.Maybe(fromMaybe, listToMaybe, maybeToList) import qualified Data.Map as M import qualified XMonad.StackSet as W @@ -136,3 +138,12 @@ focusMaster' :: W.Stack a -> W.Stack a focusMaster' c@(W.Stack _ [] _) = c focusMaster' (W.Stack t ls rs) = W.Stack x [] (xs ++ t : rs) where (x:xs) = reverse ls + +{- $simplest + +An alternative to 'Full' is "XMonad.Layout.Simplest". Less windows are +ignored by 'focusUp' and 'focusDown'. This may be helpful when you want windows +to be uninteresting by some other layout modifier (ex. +"XMonad.Layout.Minimize") + +-} diff --git a/XMonad/Layout/ButtonDecoration.hs b/XMonad/Layout/ButtonDecoration.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/ButtonDecoration.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ButtonDecoration +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A decoration that includes small buttons on both ends which invoke +-- various actions when clicked on: Show a window menu (see +-- "XMonad.Actions.WindowMenu"), minimize, maximize or close the window. +-- +-- Note: For maximizing and minimizing to actually work, you will need +-- to integrate "XMonad.Layout.Maximize" and "XMonad.Layout.Minimize" into your +-- setup. See the documentation of those modules for more information. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.ButtonDecoration + ( -- * Usage: + -- $usage + buttonDeco, + ButtonDecoration, + ) where + +import XMonad +import XMonad.Layout.Decoration +import XMonad.Layout.DecorationAddons + +-- $usage +-- You can use this module with the following in your +-- @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.DecorationAddons +-- > import XMonad.Layout.ButtonDecoration +-- +-- Then edit your @layoutHook@ by adding the ButtonDecoration to +-- your layout: +-- +-- > myL = buttonDeco shrinkText defaultThemeWithButtons (layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- + +buttonDeco :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration ButtonDecoration s) l a +buttonDeco s c = decoration s c $ NFD True + +data ButtonDecoration a = NFD Bool deriving (Show, Read) + +instance Eq a => DecorationStyle ButtonDecoration a where + describeDeco _ = "ButtonDeco" + decorationCatchClicksHook _ mainw dFL dFR = titleBarButtonHandler mainw dFL dFR + decorationAfterDraggingHook _ (mainw, _) decoWin = focus mainw >> handleScreenCrossing mainw decoWin >> return () diff --git a/XMonad/Layout/CenteredMaster.hs b/XMonad/Layout/CenteredMaster.hs --- a/XMonad/Layout/CenteredMaster.hs +++ b/XMonad/Layout/CenteredMaster.hs @@ -21,7 +21,8 @@ -- $usage centerMaster, - topRightMaster + topRightMaster, + CenteredMaster, TopRightMaster, ) where import XMonad diff --git a/XMonad/Layout/Column.hs b/XMonad/Layout/Column.hs --- a/XMonad/Layout/Column.hs +++ b/XMonad/Layout/Column.hs @@ -61,9 +61,9 @@ mkRect :: Rectangle -> (Dimension,Position) -> Rectangle mkRect (Rectangle xs ys ws _) (h,y) = Rectangle xs (ys+fromIntegral y) ws h - + xn :: Int -> Rectangle -> Float -> Int -> Dimension -xn n (Rectangle _ _ _ h) q k = if q==1 then +xn n (Rectangle _ _ _ h) q k = if q==1 then h `div` (fromIntegral n) else round ((fromIntegral h)*q^(n-k)*(1-q)/(1-q^n)) diff --git a/XMonad/Layout/ComboP.hs b/XMonad/Layout/ComboP.hs --- a/XMonad/Layout/ComboP.hs +++ b/XMonad/Layout/ComboP.hs @@ -27,7 +27,7 @@ import Data.Maybe ( isJust ) import Control.Monad import XMonad hiding (focus) -import XMonad.StackSet ( integrate, Workspace (..), Stack(..) ) +import XMonad.StackSet ( Workspace (..), Stack(..) ) import XMonad.Layout.WindowNavigation import XMonad.Util.WindowProperties import qualified XMonad.StackSet as W diff --git a/XMonad/Layout/Decoration.hs b/XMonad/Layout/Decoration.hs --- a/XMonad/Layout/Decoration.hs +++ b/XMonad/Layout/Decoration.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : XMonad.Layout.Decoration --- Copyright : (c) 2007 Andrea Rossato +-- Copyright : (c) 2007 Andrea Rossato, 2009 Jan Vornberger -- License : BSD-style (see xmonad/LICENSE) -- -- Maintainer : andrea.rossato@unibz.it @@ -27,11 +27,13 @@ , isInStack, isVisible, isInvisible, isWithin, fi , findWindowByDecoration , module XMonad.Layout.LayoutModifier + , DecorationState, OrigWin ) where import Control.Monad (when) import Data.Maybe import Data.List +import Foreign.C.Types(CInt) import XMonad import qualified XMonad.StackSet as W @@ -42,6 +44,7 @@ import XMonad.Util.Invisible import XMonad.Util.XUtils import XMonad.Util.Font +import XMonad.Util.Image -- $usage -- This module is intended for layout developers, who want to decorate @@ -65,18 +68,22 @@ -- -- For a collection of 'Theme's see "XMonad.Util.Themes" data Theme = - Theme { activeColor :: String -- ^ Color of the active window - , inactiveColor :: String -- ^ Color of the inactive window - , urgentColor :: String -- ^ Color of the urgent window - , activeBorderColor :: String -- ^ Color of the border of the active window - , inactiveBorderColor :: String -- ^ Color of the border of the inactive window - , urgentBorderColor :: String -- ^ Color of the border of the urgent window - , activeTextColor :: String -- ^ Color of the text of the active window - , inactiveTextColor :: String -- ^ Color of the text of the inactive window - , urgentTextColor :: String -- ^ Color of the text of the urgent window - , fontName :: String -- ^ Font name - , decoWidth :: Dimension -- ^ Maximum width of the decorations (if supported by the 'DecorationStyle') - , decoHeight :: Dimension -- ^ Height of the decorations + Theme { activeColor :: String -- ^ Color of the active window + , inactiveColor :: String -- ^ Color of the inactive window + , urgentColor :: String -- ^ Color of the urgent window + , activeBorderColor :: String -- ^ Color of the border of the active window + , inactiveBorderColor :: String -- ^ Color of the border of the inactive window + , urgentBorderColor :: String -- ^ Color of the border of the urgent window + , activeTextColor :: String -- ^ Color of the text of the active window + , inactiveTextColor :: String -- ^ Color of the text of the inactive window + , urgentTextColor :: String -- ^ Color of the text of the urgent window + , fontName :: String -- ^ Font name + , decoWidth :: Dimension -- ^ Maximum width of the decorations (if supported by the 'DecorationStyle') + , decoHeight :: Dimension -- ^ Height of the decorations + , windowTitleAddons :: [(String, Align)] -- ^ Extra text to appear in a window's title bar. + -- Refer to for a use "XMonad.Layout.ImageButtonDecoration" + , windowTitleIcons :: [([[Bool]], Placement)] -- ^ Extra icons to appear in a window's title bar. + -- Inner @[Bool]@ is a row in a icon bitmap. } deriving (Show, Read) -- | The default xmonad 'Theme'. @@ -94,6 +101,8 @@ , fontName = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" , decoWidth = 200 , decoHeight = 20 + , windowTitleAddons = [] + , windowTitleIcons = [] } -- | A 'Decoration' layout modifier will handle 'SetTheme', a message @@ -136,30 +145,36 @@ shrink :: ds a -> Rectangle -> Rectangle -> Rectangle shrink _ (Rectangle _ _ _ dh) (Rectangle x y w h) = Rectangle x (y + fi dh) w (h - dh) - -- | The decoration event hook, where the - -- 'decorationMouseFocusHook' and 'decorationMouseDragHook' are - -- called. If you reimplement it those methods will not be - -- called. + -- | The decoration event hook decorationEventHook :: ds a -> DecorationState -> Event -> X () - decorationEventHook ds s e = do decorationMouseFocusHook ds s e - decorationMouseDragHook ds s e + decorationEventHook ds s e = handleMouseFocusDrag ds s e - -- | This method is called when the user clicks the pointer over - -- the decoration. - decorationMouseFocusHook :: ds a -> DecorationState -> Event -> X () - decorationMouseFocusHook _ s e = handleMouseFocusDrag False s e + -- | A hook that can be used to catch the cases when the user + -- clicks on the decoration. If you return True here, the click event + -- will be considered as dealt with and no further processing will take place. + decorationCatchClicksHook :: ds a + -> Window + -> Int -- ^ distance from the left where the click happened on the decoration + -> Int -- ^ distance from the right where the click happened on the decoration + -> X Bool + decorationCatchClicksHook _ _ _ _ = return False - -- | This method is called when the user starts grabbing the - -- decoration. - decorationMouseDragHook :: ds a -> DecorationState -> Event -> X () - decorationMouseDragHook _ s e = handleMouseFocusDrag True s e + -- | This hook is called while a window is dragged using the decoration. + -- The hook can be overwritten if a different way of handling the dragging + -- is required. + decorationWhileDraggingHook :: ds a -> CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X () + decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleDraggingInProgress ex ey (mainw, r) x y + -- | This hoook is called after a window has been dragged using the decoration. + decorationAfterDraggingHook :: ds a -> (Window, Rectangle) -> Window -> X () + decorationAfterDraggingHook _ds (mainw, _r) _decoWin = focus mainw + -- | The pure version of the main method, 'decorate'. pureDecoration :: ds a -> Dimension -> Dimension -> Rectangle -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> Maybe Rectangle - pureDecoration _ _ ht _ s _ (w,Rectangle x y wh _) = if isInStack s w - then Just $ Rectangle x y wh ht - else Nothing + pureDecoration _ _ ht _ s _ (w,Rectangle x y wh ht') = if isInStack s w && (ht < ht') + then Just $ Rectangle x y wh ht + else Nothing -- | Given the theme's decoration width and height, the screen -- rectangle, the windows stack, the list of windows and @@ -283,22 +298,30 @@ -- | Mouse focus and mouse drag are handled by the same function, this -- way we can start dragging unfocused windows too. -handleMouseFocusDrag :: Bool -> DecorationState -> Event -> X () -handleMouseFocusDrag b (DS dwrs _) ButtonEvent { ev_window = ew - , ev_event_type = et - , ev_x_root = ex - , ev_y_root = ey } +handleMouseFocusDrag :: (DecorationStyle ds a) => ds a -> DecorationState -> Event -> X () +handleMouseFocusDrag ds (DS dwrs _) ButtonEvent { ev_window = ew + , ev_event_type = et + , ev_x_root = ex + , ev_y_root = ey } | et == buttonPress - , Just ((mainw,r),_) <- lookFor ew dwrs = do - focus mainw - when b $ mouseDrag (\x y -> do - let rect = Rectangle (x - (fi ex - rect_x r)) - (y - (fi ey - rect_y r)) - (rect_width r) - (rect_height r) - sendMessage (SetGeometry rect)) (return ()) + , Just ((mainw,r), (_, decoRectM)) <- lookFor ew dwrs = do + let Just (Rectangle dx _ dwh _) = decoRectM + distFromLeft = ex - fi dx + distFromRight = fi dwh - (ex - fi dx) + dealtWith <- decorationCatchClicksHook ds mainw (fi distFromLeft) (fi distFromRight) + when (not dealtWith) $ do + mouseDrag (\x y -> focus mainw >> decorationWhileDraggingHook ds ex ey (mainw, r) x y) + (decorationAfterDraggingHook ds (mainw, r) ew) handleMouseFocusDrag _ _ _ = return () +handleDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X () +handleDraggingInProgress ex ey (_, r) x y = do + let rect = Rectangle (x - (fi ex - rect_x r)) + (y - (fi ey - rect_y r)) + (rect_width r) + (rect_height r) + sendMessage $ SetGeometry rect + -- | Given a window and the state, if a matching decoration is in the -- state return it with its ('Maybe') 'Rectangle'. lookFor :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,(Window,Maybe Rectangle)) @@ -345,7 +368,7 @@ createNewWindow r mask (inactiveColor t) True showDecos :: [DecoWin] -> X () -showDecos = showWindows . catMaybes . map fst +showDecos = showWindows . catMaybes . map fst . filter (isJust . snd) hideDecos :: [DecoWin] -> X () hideDecos = hideWindows . catMaybes . map fst @@ -374,7 +397,11 @@ let s = shrinkIt sh name <- shrinkWhile s (\n -> do size <- io $ textWidthXMF dpy fs n return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) - paintAndWrite dw fs wh ht 1 bc borderc tc bc AlignCenter name + let als = AlignCenter : map snd (windowTitleAddons t) + strs = name : map fst (windowTitleAddons t) + i_als = map snd (windowTitleIcons t) + icons = map fst (windowTitleIcons t) + paintTextAndIcons dw fs wh ht 1 bc borderc tc bc als strs i_als icons updateDeco _ _ _ (_,(Just w,Nothing)) = hideWindow w updateDeco _ _ _ _ = return () diff --git a/XMonad/Layout/DecorationAddons.hs b/XMonad/Layout/DecorationAddons.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/DecorationAddons.hs @@ -0,0 +1,123 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.DecorationAddons +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- Various stuff that can be added to the decoration. Most of it +-- is intended to be used by other modules. See +-- "XMonad.Layout.ButtonDecoration" for a module that makes use of this. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.DecorationAddons ( + titleBarButtonHandler + ,defaultThemeWithButtons + ,handleScreenCrossing + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Layout.Decoration +import XMonad.Actions.WindowMenu +import XMonad.Layout.Minimize +import XMonad.Layout.Maximize +import XMonad.Hooks.ManageDocks +import XMonad.Util.Font +import XMonad.Util.PositionStore + +import Control.Applicative((<$>)) +import Data.Maybe +import qualified Data.Set as S + +minimizeButtonOffset :: Int +minimizeButtonOffset = 48 + +maximizeButtonOffset :: Int +maximizeButtonOffset = 25 + +closeButtonOffset :: Int +closeButtonOffset = 10 + +buttonSize :: Int +buttonSize = 10 + +-- | A function intended to be plugged into the 'decorationCatchClicksHook' of a decoration. +-- It will intercept clicks on the buttons of the decoration and invoke the associated action. +-- To actually see the buttons, you will need to use a theme that includes them. +-- See 'defaultThemeWithButtons' below. +titleBarButtonHandler :: Window -> Int -> Int -> X Bool +titleBarButtonHandler mainw distFromLeft distFromRight = do + let action = if (fi distFromLeft <= 3 * buttonSize) + then focus mainw >> windowMenu >> return True + else if (fi distFromRight >= closeButtonOffset && + fi distFromRight <= closeButtonOffset + buttonSize) + then focus mainw >> kill >> return True + else if (fi distFromRight >= maximizeButtonOffset && + fi distFromRight <= maximizeButtonOffset + (2 * buttonSize)) + then focus mainw >> sendMessage (maximizeRestore mainw) >> return True + else if (fi distFromRight >= minimizeButtonOffset && + fi distFromRight <= minimizeButtonOffset + buttonSize) + then focus mainw >> minimizeWindow mainw >> return True + else return False + action + +-- | Intended to be used together with 'titleBarButtonHandler'. See above. +defaultThemeWithButtons :: Theme +defaultThemeWithButtons = defaultTheme { + windowTitleAddons = [ (" (M)", AlignLeft) + , ("_" , AlignRightOffset minimizeButtonOffset) + , ("[]" , AlignRightOffset maximizeButtonOffset) + , ("X" , AlignRightOffset closeButtonOffset) + ] + } + +-- | A function intended to be plugged into the 'decorationAfterDraggingHook' of a decoration. +-- It will check if the window has been dragged onto another screen and shift it there. +-- The PositionStore is also updated accordingly, as this is designed to be used together +-- with "XMonad.Layout.PositionStoreFloat". +handleScreenCrossing :: Window -> Window -> X Bool +handleScreenCrossing w decoWin = withDisplay $ \d -> do + root <- asks theRoot + (_, _, _, px, py, _, _, _) <- io $ queryPointer d root + ws <- gets windowset + sc <- fromMaybe (W.current ws) <$> pointScreen (fi px) (fi py) + maybeWksp <- screenWorkspace $ W.screen sc + let targetWksp = maybeWksp >>= \wksp -> + W.findTag w ws >>= \currentWksp -> + if (currentWksp /= wksp) + then Just wksp + else Nothing + case targetWksp of + Just wksp -> do + -- find out window under cursor on target workspace + -- apparently we have to switch to the workspace first + -- to make this work, which unforunately introduces some flicker + windows $ \ws' -> W.view wksp ws' + (_, _, selWin, _, _, _, _, _) <- io $ queryPointer d root + + -- adjust PositionStore + let oldScreenRect = screenRect . W.screenDetail $ W.current ws + newScreenRect = screenRect . W.screenDetail $ sc + {-- somewhat ugly hack to get proper ScreenRect, + creates unwanted inter-dependencies + TODO: get ScreenRects in a proper way --} + oldScreenRect' <- fmap ($ oldScreenRect) (calcGap $ S.fromList [minBound .. maxBound]) + newScreenRect' <- fmap ($ newScreenRect) (calcGap $ S.fromList [minBound .. maxBound]) + wa <- io $ getWindowAttributes d decoWin + modifyPosStore (\ps -> + posStoreMove ps w (fi $ wa_x wa) (fi $ wa_y wa) + oldScreenRect' newScreenRect') + + -- set focus correctly so the window will be inserted + -- at the correct position on the target workspace + -- and then shift the window + windows $ \ws' -> W.shiftWin wksp w . W.focusWindow selWin $ ws' + + -- return True to signal that screen crossing has taken place + return True + Nothing -> return False diff --git a/XMonad/Layout/DecorationMadness.hs b/XMonad/Layout/DecorationMadness.hs --- a/XMonad/Layout/DecorationMadness.hs +++ b/XMonad/Layout/DecorationMadness.hs @@ -94,7 +94,6 @@ import XMonad.Layout.Accordion import XMonad.Layout.Circle -import XMonad.Layout.ResizeScreen import XMonad.Layout.WindowArranger import XMonad.Layout.SimpleFloat diff --git a/XMonad/Layout/Dishes.hs b/XMonad/Layout/Dishes.hs --- a/XMonad/Layout/Dishes.hs +++ b/XMonad/Layout/Dishes.hs @@ -21,7 +21,6 @@ Dishes (..) ) where -import Data.List import XMonad import XMonad.StackSet (integrate) import Control.Monad (ap) diff --git a/XMonad/Layout/DraggingVisualizer.hs b/XMonad/Layout/DraggingVisualizer.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/DraggingVisualizer.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.DraggingVisualizer +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A helper module to visualize the process of dragging a window by +-- making it follow the mouse cursor. See "XMonad.Layout.WindowSwitcherDecoration" +-- for a module that makes use of this. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.DraggingVisualizer + ( draggingVisualizer, + DraggingVisualizerMsg (..), + DraggingVisualizer, + ) where + +import XMonad +import XMonad.Layout.LayoutModifier + +data DraggingVisualizer a = DraggingVisualizer (Maybe (Window, Rectangle)) deriving ( Read, Show ) +draggingVisualizer :: LayoutClass l Window => l Window -> ModifiedLayout DraggingVisualizer l Window +draggingVisualizer = ModifiedLayout $ DraggingVisualizer Nothing + +data DraggingVisualizerMsg = DraggingWindow Window Rectangle + | DraggingStopped + deriving ( Typeable, Eq ) +instance Message DraggingVisualizerMsg + +instance LayoutModifier DraggingVisualizer Window where + modifierDescription (DraggingVisualizer _) = "DraggingVisualizer" + pureModifier (DraggingVisualizer (Just dragged@(draggedWin, _))) _ _ wrs = + if draggedWin `elem` (map fst wrs) + then (dragged : rest, Nothing) + else (wrs, Just $ DraggingVisualizer Nothing) + where + rest = filter (\(w, _) -> w /= draggedWin) wrs + pureModifier _ _ _ wrs = (wrs, Nothing) + + pureMess (DraggingVisualizer _) m = case fromMessage m of + Just (DraggingWindow w rect) -> Just $ DraggingVisualizer $ Just (w, rect) + Just (DraggingStopped) -> Just $ DraggingVisualizer Nothing + _ -> Nothing diff --git a/XMonad/Layout/Drawer.hs b/XMonad/Layout/Drawer.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/Drawer.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Drawer +-- Copyright : (c) 2009 Max Rabkin +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : max.rabkin@gmail.com +-- Stability : unstable +-- Portability : unportable +-- +-- A layout modifier that puts some windows in a "drawer" which retracts and +-- expands depending on whether any window in it has focus. +-- +-- Useful for music players, tool palettes, etc. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Drawer + ( -- * Usage + -- $usage + + -- * Drawers + simpleDrawer + , drawer + + -- * Placing drawers + -- The drawer can be placed on any side of the screen with these functions + , onLeft, onTop, onRight, onBottom + + , module XMonad.Util.WindowProperties + + , Drawer, Reflected + ) where + +import XMonad +import XMonad.Layout.LayoutModifier +import XMonad.Util.WindowProperties +import XMonad.StackSet as S +import XMonad.Layout.Reflect + +-- $usage +-- To use this module, add the following import to @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.Drawer +-- +-- > myLayout = drawer `onTop` (Tall 1 0.03 0.5) ||| Full ||| RandomOtherLayout... +-- > where +-- > drawer = simpleDrawer 0.01 0.3 (ClassName "Rhythmbox" `Or` ClassName "Xchat") +-- > +-- > main = xmonad defaultConfig { layoutHook = myLayout } +-- +-- This will place the Rhythmbox and Xchat windows in at the top of the screen +-- only when using the 'Tall' layout. See "XMonad.Util.WindowProperties" for +-- more information on selecting windows. + +data Drawer l a = Drawer Rational Rational Property (l a) + deriving (Read, Show) + +-- | filter : filterM :: partition : partitionM +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = return ([], []) +partitionM f (x:xs) = do + b <- f x + (ys, zs) <- partitionM f xs + return $ if b + then (x:ys, zs) + else (ys, x:zs) + +instance (LayoutClass l Window, Read (l Window)) => LayoutModifier (Drawer l) Window where + modifyLayout (Drawer rs rb p l) ws rect = + case stack ws of + Nothing -> runLayout ws rect + Just stk@(Stack { up=up_, down=down_, S.focus=w }) -> do + (upD, upM) <- partitionM (hasProperty p) up_ + (downD, downM) <- partitionM (hasProperty p) down_ + b <- hasProperty p w + focusedWindow <- gets (fmap S.focus . stack . workspace . current . windowset) + + let rectD = if b && Just w == focusedWindow then rectB else rectS + + let (stackD, stackM) = if b + then ( Just $ stk { up=upD, down=downD } + , mkStack upM downM ) + else ( mkStack upD downD + , Just $ stk { up=upM, down=downM } ) + + (winsD, _) <- runLayout (ws { layout=l, stack=stackD }) rectD + (winsM, u') <- runLayout (ws { stack=stackM }) rectM + return (winsD ++ winsM, u') + where + mkStack [] [] = Nothing + mkStack xs (y:ys) = Just (Stack { up=xs, S.focus=y, down=ys }) + mkStack (x:xs) ys = Just (Stack { up=xs, S.focus=x, down=ys }) + + rectB = rect { rect_width=round $ fromIntegral (rect_width rect) * rb } + rectS = rectB { rect_x=rect_x rectB - (round $ (rb - rs) * fromIntegral (rect_width rect)) } + rectM = rect { rect_x=rect_x rect + round (fromIntegral (rect_width rect) * rs) + , rect_width=rect_width rect - round (fromIntegral (rect_width rect) * rs) } + +type Reflected l = ModifiedLayout Reflect l + +-- | Construct a drawer with a simple layout of the windows inside +simpleDrawer :: Rational -- ^ The portion of the screen taken up by the drawer when closed + -> Rational -- ^ The portion of the screen taken up by the drawer when open + -> Property -- ^ Which windows to put in the drawer + -> Drawer Tall a +simpleDrawer rs rb p = Drawer rs rb p vertical + where + vertical = Tall 0 0 0 + +-- Export a synonym for the constructor as a Haddock workaround +-- | Construct a drawer with an arbitrary layout for windows inside +drawer :: Rational -- ^ The portion of the screen taken up by the drawer when closed + -> Rational -- ^ The portion of the screen taken up by the drawer when open + -> Property -- ^ Which windows to put in the drawer + -> (l a) -- ^ The layout of windows in the drawer + -> Drawer l a +drawer = Drawer + +onLeft :: Drawer l a -> l' a -> ModifiedLayout (Drawer l) l' a +onLeft = ModifiedLayout + +onRight :: Drawer l a -> l' a -> Reflected (ModifiedLayout (Drawer l) (Reflected l')) a +onRight d = reflectHoriz . onLeft d . reflectHoriz + +onTop :: Drawer l a -> l' a -> Mirror (ModifiedLayout (Drawer l) (Mirror l')) a +onTop d = Mirror . onLeft d . Mirror + +onBottom :: Drawer l a -> l' a -> Reflected (Mirror (ModifiedLayout (Drawer l) (Mirror (Reflected l')))) a +onBottom d = reflectVert . onTop d . reflectVert diff --git a/XMonad/Layout/Fullscreen.hs b/XMonad/Layout/Fullscreen.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/Fullscreen.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Decoration +-- Copyright : (c) 2010 Audun Skaugen +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : audunskaugen@gmail.com +-- Stability : unstable +-- Portability : unportable +-- +-- Hooks for sending messages about fullscreen windows to layouts, and +-- a few example layout modifier that implement fullscreen windows. +----------------------------------------------------------------------------- +module XMonad.Layout.Fullscreen + ( -- * Usage: + -- $usage + fullscreenFull + ,fullscreenFocus + ,fullscreenFullRect + ,fullscreenFocusRect + ,fullscreenFloat + ,fullscreenFloatRect + ,fullscreenEventHook + ,fullscreenManageHook + ,fullscreenManageHookWith + ,FullscreenMessage(..) + -- * Types for reference + ,FullscreenFloat, FullscreenFocus, FullscreenFull + ) where + +import XMonad +import XMonad.Layout.LayoutModifier +import XMonad.Util.WindowProperties +import XMonad.Hooks.ManageHelpers (isFullscreen) +import qualified XMonad.StackSet as W +import Data.List +import Data.Maybe +import Data.Monoid +import qualified Data.Map as M +import Control.Monad +import Control.Arrow (second) + +-- $usage +-- Provides a ManageHook and an EventHook that sends layout messages +-- with information about fullscreening windows. This allows layouts +-- to make their own decisions about what they should to with a +-- window that requests fullscreen. +-- +-- The module also includes a few layout modifiers as an illustration +-- of how such layouts should behave. +-- +-- To use this module, add 'fullscreenEventHook' and 'fullscreenManageHook' +-- to your config, i.e. +-- +-- > xmonad defaultconfig { eventHook = fullscreenEventHook, +-- > manageHook = fullscreenManageHook, +-- > layoutHook = myLayouts } +-- +-- Now you can use layouts that respect fullscreen, for example the +-- provided 'fullscreenFull': +-- +-- > myLayouts = fullscreenFull someLayout +-- + +-- | Messages that control the fullscreen state of the window. +-- AddFullscreen and RemoveFullscreen are sent to all layouts +-- when a window wants or no longer wants to be fullscreen. +-- FullscreenChanged is sent to the current layout after one +-- of the above have been sent. +data FullscreenMessage = AddFullscreen Window + | RemoveFullscreen Window + | FullscreenChanged + deriving (Typeable) + +instance Message FullscreenMessage + +data FullscreenFull a = FullscreenFull W.RationalRect [a] + deriving (Read, Show) + +data FullscreenFocus a = FullscreenFocus W.RationalRect [a] + deriving (Read, Show) + +data FullscreenFloat a = FullscreenFloat W.RationalRect (M.Map a (W.RationalRect, Bool)) + deriving (Read, Show) + +instance LayoutModifier FullscreenFull Window where + pureMess ff@(FullscreenFull frect fulls) m = case fromMessage m of + Just (AddFullscreen win) -> Just $ FullscreenFull frect $ nub $ win:fulls + Just (RemoveFullscreen win) -> Just $ FullscreenFull frect $ delete win $ fulls + Just FullscreenChanged -> Just ff + _ -> Nothing + + pureModifier (FullscreenFull frect fulls) rect _ list = + (map (flip (,) rect') visfulls ++ rest, Nothing) + where visfulls = intersect fulls $ map fst list + rest = filter (flip notElem visfulls . fst) list + rect' = scaleRationalRect rect frect + +instance LayoutModifier FullscreenFocus Window where + pureMess ff@(FullscreenFocus frect fulls) m = case fromMessage m of + Just (AddFullscreen win) -> Just $ FullscreenFocus frect $ nub $ win:fulls + Just (RemoveFullscreen win) -> Just $ FullscreenFocus frect $ delete win $ fulls + Just FullscreenChanged -> Just ff + _ -> Nothing + + pureModifier (FullscreenFocus frect fulls) rect (Just (W.Stack {W.focus = f})) list + | f `elem` fulls = ((f, rect') : rest, Nothing) + | otherwise = (list, Nothing) + where rest = filter ((/= f) . fst) list + rect' = scaleRationalRect rect frect + pureModifier _ _ Nothing list = (list, Nothing) + +instance LayoutModifier FullscreenFloat Window where + handleMess (FullscreenFloat frect fulls) m = case fromMessage m of + Just (AddFullscreen win) -> do + mrect <- (M.lookup win . W.floating) `fmap` gets windowset + return $ case mrect of + Just rect -> Just $ FullscreenFloat frect $ M.insert win (rect,True) fulls + Nothing -> Nothing + + Just (RemoveFullscreen win) -> + return $ Just $ FullscreenFloat frect $ M.adjust (second $ const False) win fulls + + -- Modify the floating member of the stack set directly; this is the hackish part. + Just FullscreenChanged -> do + state <- get + let ws = windowset state + flt = W.floating ws + flt' = M.intersectionWith doFull fulls flt + put state {windowset = ws {W.floating = M.union flt' flt}} + return $ Just $ FullscreenFloat frect $ M.filter snd fulls + where doFull (_, True) _ = frect + doFull (rect, False) _ = rect + + Nothing -> return Nothing + +-- | Layout modifier that makes fullscreened window fill the +-- entire screen. +fullscreenFull :: LayoutClass l a => + l a -> ModifiedLayout FullscreenFull l a +fullscreenFull = fullscreenFullRect $ W.RationalRect 0 0 1 1 + +-- | As above, but the fullscreened window will fill the +-- specified rectangle instead of the entire screen. +fullscreenFullRect :: LayoutClass l a => + W.RationalRect -> l a -> ModifiedLayout FullscreenFull l a +fullscreenFullRect r = ModifiedLayout $ FullscreenFull r [] + +-- | Layout modifier that makes the fullscreened window fill +-- the entire screen only if it is currently focused. +fullscreenFocus :: LayoutClass l a => + l a -> ModifiedLayout FullscreenFocus l a +fullscreenFocus = fullscreenFocusRect $ W.RationalRect 0 0 1 1 + +-- | As above, but the fullscreened window will fill the +-- specified rectangle instead of the entire screen. +fullscreenFocusRect :: LayoutClass l a => + W.RationalRect -> l a -> ModifiedLayout FullscreenFocus l a +fullscreenFocusRect r = ModifiedLayout $ FullscreenFocus r [] + +-- | Hackish layout modifier that makes floating fullscreened +-- windows fill the entire screen. +fullscreenFloat :: LayoutClass l a => + l a -> ModifiedLayout FullscreenFloat l a +fullscreenFloat = fullscreenFloatRect $ W.RationalRect 0 0 1 1 + +-- | As above, but the fullscreened window will fill the +-- specified rectangle instead of the entire screen. +fullscreenFloatRect :: LayoutClass l a => + W.RationalRect -> l a -> ModifiedLayout FullscreenFloat l a +fullscreenFloatRect r = ModifiedLayout $ FullscreenFloat r M.empty + +-- | 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" + fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN" + wstate <- fromMaybe [] `fmap` getProp32 state win + let fi :: (Integral i, Num n) => i -> n + fi = fromIntegral + isFull = fi fullsc `elem` wstate + remove = 0 + 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 + when (action == add || (action == toggle && not isFull)) $ do + chWState (fi fullsc:) + broadcastMessage $ AddFullscreen win + sendMessage FullscreenChanged + when (action == remove || (action == toggle && isFull)) $ do + chWState $ delete (fi fullsc) + broadcastMessage $ RemoveFullscreen win + sendMessage FullscreenChanged + return $ All True + +fullscreenEventHook (DestroyWindowEvent {ev_window = w}) = do + -- When a window is destroyed, the layouts should remove that window + -- from their states. + broadcastMessage $ RemoveFullscreen w + cw <- (W.workspace . W.current) `fmap` gets windowset + sendMessageWithNoRefresh FullscreenChanged cw + return $ All True + +fullscreenEventHook _ = return $ All True + +-- | Manage hook that sets the fullscreen property for +-- windows that are initially fullscreen +fullscreenManageHook :: ManageHook +fullscreenManageHook = fullscreenManageHook' isFullscreen + +-- | A version of fullscreenManageHook that lets you specify +-- your own query to decide whether a window should be fullscreen. +fullscreenManageHookWith :: Query Bool -> ManageHook +fullscreenManageHookWith h = fullscreenManageHook' $ isFullscreen <||> h + +fullscreenManageHook' :: Query Bool -> ManageHook +fullscreenManageHook' isFull = isFull --> do + w <- ask + liftX $ do + broadcastMessage $ AddFullscreen w + cw <- (W.workspace . W.current) `fmap` gets windowset + sendMessageWithNoRefresh FullscreenChanged cw + idHook + diff --git a/XMonad/Layout/Gaps.hs b/XMonad/Layout/Gaps.hs --- a/XMonad/Layout/Gaps.hs +++ b/XMonad/Layout/Gaps.hs @@ -28,7 +28,7 @@ module XMonad.Layout.Gaps ( -- * Usage -- $usage - Direction2D(..), + Direction2D(..), Gaps, GapSpec, gaps, GapMessage(..) ) where @@ -38,6 +38,7 @@ import XMonad.Layout.LayoutModifier import XMonad.Util.Types (Direction2D(..)) +import XMonad.Util.XUtils (fi) import Data.List (delete) @@ -56,8 +57,8 @@ -- -- > , ((modm .|. controlMask, xK_g), sendMessage $ ToggleGaps) -- toggle all gaps -- > , ((modm .|. controlMask, xK_t), sendMessage $ ToggleGap U) -- toggle the top gap --- > , ((modm .|. controlMask, xK_w), sendMessage $ IncGap R 5) -- increment the right-hand gap --- > , ((modm .|. controlMask, xK_q), sendMessage $ DecGap R 5) -- decrement the right-hand gap +-- > , ((modm .|. controlMask, xK_w), sendMessage $ IncGap 5 R) -- increment the right-hand gap +-- > , ((modm .|. controlMask, xK_q), sendMessage $ DecGap 5 R) -- decrement the right-hand gap -- -- If you want complete control over all gaps, you could include -- something like this in your keybindings, assuming in this case you @@ -132,9 +133,6 @@ incGap :: GapSpec -> Direction2D -> Int -> GapSpec incGap gs d i = map (\(dir,j) -> if dir == d then (dir,max (j+i) 0) else (dir,j)) gs - -fi :: (Num b, Integral a) => a -> b -fi = fromIntegral -- | Add togglable manual gaps to a layout. gaps :: GapSpec -- ^ The gaps to allow, paired with their initial sizes. diff --git a/XMonad/Layout/GridVariants.hs b/XMonad/Layout/GridVariants.hs --- a/XMonad/Layout/GridVariants.hs +++ b/XMonad/Layout/GridVariants.hs @@ -19,7 +19,8 @@ module XMonad.Layout.GridVariants ( -- * Usage -- $usage - ChangeMasterGeom(..) + ChangeMasterGridGeom(..) + , ChangeGridGeom(..) , Grid(..) , TallGrid(..) , SplitGrid(..) @@ -68,9 +69,24 @@ nwins = length wins rects = arrangeAspectGrid rect nwins aspect + pureMessage layout msg = fmap (changeGridAspect layout) (fromMessage msg) + description _ = "Grid" --- | SplitGrid layout. Parameters are +changeGridAspect :: Grid a -> ChangeGridGeom -> Grid a +changeGridAspect (Grid _) (SetGridAspect aspect) = Grid aspect +changeGridAspect (Grid aspect) (ChangeGridAspect delta) = + Grid (max 0.00001 (aspect + delta)) + +-- |Geometry change messages understood by Grid and SplitGrid +data ChangeGridGeom + = SetGridAspect !Rational + | ChangeGridAspect !Rational + deriving Typeable + +instance Message ChangeGridGeom + +-- |SplitGrid layout. Parameters are -- -- - side where the master is -- - number of master rows @@ -81,8 +97,8 @@ data SplitGrid a = SplitGrid Orientation !Int !Int !Rational !Rational !Rational deriving (Read, Show) --- | Type to specify the side of the screen that holds --- the master area of a SplitGrid. +-- |Type to specify the side of the screen that holds +-- the master area of a SplitGrid. data Orientation = T | B | L | R deriving (Eq, Read, Show) @@ -95,18 +111,23 @@ rects = arrangeSplitGrid rect o nwins mrows mcols mfrac saspect pureMessage layout msg = - msum [ fmap (resizeMaster layout) (fromMessage msg) - , fmap (changeMasterGrid layout) (fromMessage msg) ] + msum [ fmap (resizeMaster layout) (fromMessage msg) + , fmap (changeMasterGrid layout) (fromMessage msg) + , fmap (changeSlaveGridAspect layout) (fromMessage msg) + ] description _ = "SplitGrid" -- |The geometry change message understood by the master grid -data ChangeMasterGeom - = IncMasterRows !Int -- ^Change the number of master rows - | IncMasterCols !Int -- ^Change the number of master columns +data ChangeMasterGridGeom + = IncMasterRows !Int -- ^Change the number of master rows + | IncMasterCols !Int -- ^Change the number of master columns + | SetMasterRows !Int -- ^Set the number of master rows to absolute value + | SetMasterCols !Int -- ^Set the number of master columns to absolute value + | SetMasterFraction !Rational -- ^Set the fraction of the screen used by the master grid deriving Typeable -instance Message ChangeMasterGeom +instance Message ChangeMasterGridGeom arrangeSplitGrid :: Rectangle -> Orientation -> Int -> Int -> Int -> Rational -> Rational -> [Rectangle] arrangeSplitGrid rect@(Rectangle rx ry rw rh) o nwins mrows mcols mfrac saspect @@ -183,11 +204,23 @@ resizeMaster (SplitGrid o mrows mcols mfrac saspect delta) Expand = SplitGrid o mrows mcols (min 1 (mfrac + delta)) saspect delta -changeMasterGrid :: SplitGrid a -> ChangeMasterGeom -> SplitGrid a +changeMasterGrid :: SplitGrid a -> ChangeMasterGridGeom -> SplitGrid a changeMasterGrid (SplitGrid o mrows mcols mfrac saspect delta) (IncMasterRows d) = SplitGrid o (max 0 (mrows + d)) mcols mfrac saspect delta changeMasterGrid (SplitGrid o mrows mcols mfrac saspect delta) (IncMasterCols d) = SplitGrid o mrows (max 0 (mcols + d)) mfrac saspect delta +changeMasterGrid (SplitGrid o _ mcols mfrac saspect delta) (SetMasterRows mrows) = + SplitGrid o (max 0 mrows) mcols mfrac saspect delta +changeMasterGrid (SplitGrid o mrows _ mfrac saspect delta) (SetMasterCols mcols) = + SplitGrid o mrows (max 0 mcols) mfrac saspect delta +changeMasterGrid (SplitGrid o mrows mcols _ saspect delta) (SetMasterFraction mfrac) = + SplitGrid o mrows mcols mfrac saspect delta + +changeSlaveGridAspect :: SplitGrid a -> ChangeGridGeom -> SplitGrid a +changeSlaveGridAspect (SplitGrid o mrows mcols mfrac _ delta) (SetGridAspect saspect) = + SplitGrid o mrows mcols mfrac saspect delta +changeSlaveGridAspect (SplitGrid o mrows mcols mfrac saspect delta) (ChangeGridAspect sdelta) = + SplitGrid o mrows mcols mfrac (max 0.00001 (saspect + sdelta)) delta -- | TallGrid layout. Parameters are -- diff --git a/XMonad/Layout/Groups.hs b/XMonad/Layout/Groups.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/Groups.hs @@ -0,0 +1,510 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-} +{-# LANGUAGE StandaloneDeriving, FlexibleContexts, DeriveDataTypeable + , UndecidableInstances, FlexibleInstances, MultiParamTypeClasses + , PatternGuards, Rank2Types, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Groups +-- Copyright : Quentin Moser +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : orphaned +-- Stability : unstable +-- Portability : unportable +-- +-- Two-level layout with windows split in individual layout groups, +-- themselves managed by a user-provided layout. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Groups ( -- * Usage + -- $usage + -- * Creation + group + -- * Messages + , GroupsMessage(..) + , ModifySpec + -- ** Useful 'ModifySpec's + , swapUp + , swapDown + , swapMaster + , focusUp + , focusDown + , focusMaster + , swapGroupUp + , swapGroupDown + , swapGroupMaster + , focusGroupUp + , focusGroupDown + , focusGroupMaster + , moveToGroupUp + , moveToGroupDown + , moveToNewGroupUp + , moveToNewGroupDown + , splitGroup + -- * Types + , Groups + , Group(..) + , onZipper + , onLayout + , WithID + , sameID + ) where + +import XMonad +import qualified XMonad.StackSet as W + +import XMonad.Util.Stack + +import Data.Maybe (isJust, isNothing, fromMaybe, catMaybes, fromJust) +import Data.List ((\\)) +import Control.Arrow ((>>>)) +import Control.Applicative ((<$>)) +import Control.Monad (forM) + +-- $usage +-- This module provides a layout combinator that allows you +-- to manage your windows in independent groups. You can provide +-- both the layout with which to arrange the windows inside each +-- 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 +-- 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 +-- notion of the order of windows, which is completely separate +-- from XMonad's. For this reason, operations like 'XMonad.StackSet.SwapUp' +-- 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 +-- by this module. +-- +-- If you use both 'Groups'-based and other layouts, The "XMonad.Layout.Groups.Helpers" +-- module provides actions that can work correctly with both, defined using +-- functions from "XMonad.Actions.MessageFeedback". + +-- | Create a 'Groups' layout. +-- +-- Note that the second parameter (the layout for arranging the +-- groups) is not used on 'Windows', but on 'Group's. For this +-- reason, you can only use layouts that don't specifically +-- need to manage 'Window's. This is obvious, when you think +-- about it. +group :: l Window -> l2 (Group l Window) -> Groups l l2 Window +group l l2 = Groups l l2 startingGroups (U 1 0) + where startingGroups = fromJust $ singletonZ $ G (ID (U 0 0) l) emptyZ + + +-- * Stuff with unique keys + +data Uniq = U Integer Integer + deriving (Eq, Show, Read) + +-- | 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) +gen :: Uniq -> (Uniq, [Uniq]) +gen (U i1 i2) = (U (i1+1) i2, zipWith U (repeat i1) [i2..]) + +-- | Split an infinite list into two. I ended up not +-- needing this, but let's keep it just in case. +-- split :: [a] -> ([a], [a]) +-- split as = snd $ foldr step (True, ([], [])) as +-- where step a (True, (as1, as2)) = (False, (a:as1, as2)) +-- step a (False, (as1, as2)) = (True, (as1, a:as2)) + +-- | Add a unique identity to a layout so we can +-- follow it around. +data WithID l a = ID { getID :: Uniq + , unID :: (l a)} + deriving (Show, Read) + +-- | Compare the ids of two 'WithID' values +sameID :: WithID l a -> WithID l a -> Bool +sameID (ID id1 _) (ID id2 _) = id1 == id2 + +instance Eq (WithID l a) where + 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 + 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 + + +-- ** Datatypes + +-- | A group of windows and its layout algorithm. +data Group l a = G { gLayout :: WithID l a + , gZipper :: Zipper a } + deriving (Show, Read, Eq) + +onLayout :: (WithID l a -> WithID l a) -> Group l a -> Group l a +onLayout f g = g { gLayout = f $ gLayout g } + +onZipper :: (Zipper a -> Zipper a) -> Group l a -> Group l a +onZipper f g = g { gZipper = f $ gZipper g } + +-- | The type of our layouts. +data Groups l l2 a = Groups { -- | The starting layout for new groups + baseLayout :: l a + -- | The layout for placing each group on the screen + , partitioner :: l2 (Group l a) + -- | The window groups + , groups :: W.Stack (Group l a) + -- | A seed for generating unique ids + , seed :: Uniq + } + +deriving instance (Show a, Show (l a), Show (l2 (Group l a))) => Show (Groups l l2 a) +deriving instance (Read a, Read (l a), Read (l2 (Group l a))) => Read (Groups l l2 a) + +-- | Messages accepted by 'Groups'-based layouts. +-- All other messages are forwarded to the layout of the currently +-- focused subgroup (as if they had been wrapped in 'ToFocused'). +data GroupsMessage = ToEnclosing SomeMessage -- ^ Send a message to the enclosing layout + -- (the one that places the groups themselves) + | ToGroup Int SomeMessage -- ^ Send a message to the layout for nth group + -- (starting at 0) + | ToFocused SomeMessage -- ^ Send a message to the layout for the focused + -- group + | ToAll SomeMessage -- ^ Send a message to all the sub-layouts + | Refocus -- ^ Refocus the window which should be focused according + -- to the layout. + | Modify ModifySpec -- ^ Modify the ordering\/grouping\/focusing + -- of windows according to a 'ModifySpec' + deriving Typeable + +instance Show GroupsMessage where + show (ToEnclosing _) = "ToEnclosing {...}" + show (ToGroup i _) = "ToGroup "++show i++" {...}" + show (ToFocused _) = "ToFocused {...}" + show (ToAll _) = "ToAll {...}" + show Refocus = "Refocus" + show (Modify _) = "Modify {...}" + +instance Message GroupsMessage + +modifyGroups :: (Zipper (Group l a) -> Zipper (Group l a)) + -> Groups l l2 a -> Groups l l2 a +modifyGroups f g = let (seed', id:_) = gen (seed g) + defaultGroups = fromJust $ singletonZ $ G (ID id $ baseLayout g) emptyZ + in g { groups = fromMaybe defaultGroups . f . Just $ groups g + , seed = seed' } + + +-- ** Readaptation + +-- | 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 +-- 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 + (seed', id:_) = gen $ seed g + g' = g { seed = seed' } + in flip modifyGroups g' $ mapZ_ (onZipper $ removeDeleted z) + >>> filterKeepLast (isJust . gZipper) + >>> findNewWindows (W.integrate' z) + >>> addWindows (ID id $ baseLayout g) + >>> focusGroup mf + >>> onFocusedZ (onZipper $ focusWindow mf) + where filterKeepLast _ Nothing = Nothing + filterKeepLast f z@(Just s) = maybe (singletonZ $ W.focus s) Just + $ filterZ_ f z + +-- | Remove the windows from a group which are no longer present in +-- the stack. +removeDeleted :: Eq a => Zipper a -> Zipper a -> Zipper a +removeDeleted z = filterZ_ (flip elemZ z) + +-- | Identify the windows not already in a group. +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' + +-- | Add windows to the focused group. If you need to create one, +-- use the given layout and an id from the given list. +addWindows :: WithID l a -> (Zipper (Group l a), [a]) -> Zipper (Group l a) +addWindows l (Nothing, as) = singletonZ $ G l (W.differentiate as) +addWindows _ (z, as) = onFocusedZ (onZipper add) z + where add z = foldl (flip insertUpZ) z as + +-- | Focus the group containing the given window +focusGroup :: Eq a => Maybe a -> Zipper (Group l a) -> Zipper (Group l a) +focusGroup Nothing = id +focusGroup (Just a) = fromTags . map (tagBy $ elemZ a . gZipper) . W.integrate' + +-- | Focus the given window +focusWindow :: Eq a => Maybe a -> Zipper a -> Zipper a +focusWindow Nothing = id +focusWindow (Just a) = fromTags . map (tagBy (==a)) . W.integrate' + + +-- * Interface + +-- ** Layout instance + +instance (LayoutClass l Window, LayoutClass l2 (Group l Window)) + => LayoutClass (Groups l l2) Window where + + description (Groups _ p gs _) = s1++" by "++s2 + where s1 = description $ gLayout $ W.focus gs + s2 = description p + + runLayout ws@(W.Workspace _ _l z) r = let l = readapt z _l in + do (areas, mpart') <- runLayout ws { W.layout = partitioner l + , W.stack = Just $ groups l } r + + results <- forM areas $ \(g, r') -> runLayout ws { W.layout = gLayout g + , W.stack = gZipper g } r' + + let hidden = map gLayout (W.integrate $ groups l) \\ map (gLayout . fst) areas + hidden' <- mapM (flip handleMessage $ SomeMessage Hide) hidden + + 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 + = do mp' <- handleMessage p sm' + return $ maybeMakeNew l mp' [] + + handleMessage l@(Groups _ p gs _) sm | Just (ToAll sm') <- fromMessage sm + = do mp' <- handleMessage p sm' + mg's <- mapZM_ (handle sm') $ Just gs + return $ maybeMakeNew l mp' $ W.integrate' mg's + where handle sm (G l _) = handleMessage l sm + + handleMessage l sm | Just a <- fromMessage sm + = let _rightType = a == Hide -- Is there a better-looking way + -- of doing this? + in handleMessage l $ SomeMessage $ ToAll sm + + handleMessage l@(Groups _ _ z _) sm = case fromMessage sm of + Just (ToFocused sm') -> do mg's <- W.integrate' <$> handleOnFocused sm' z + return $ maybeMakeNew l Nothing mg's + Just (ToGroup i sm') -> do mg's <- handleOnIndex i sm' z + return $ maybeMakeNew l Nothing mg's + Just (Modify spec) -> case applySpec spec l of + Just l' -> refocus l' >> return (Just l') + Nothing -> return $ Just l + Just Refocus -> refocus l >> return (Just l) + Just _ -> return Nothing + Nothing -> handleMessage l $ SomeMessage (ToFocused sm) + where handleOnFocused sm z = mapZM step $ Just z + where step True (G l _) = handleMessage l sm + step False _ = return Nothing + handleOnIndex i sm z = mapM step $ zip [0..] $ W.integrate z + where step (j, (G l _)) | i == j = handleMessage l sm + step _ = return Nothing + + +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 } + where combine z ml's = let table = map (\(ID id a) -> (id, a)) $ catMaybes ml's + in flip mapS_ z $ \(G (ID id l) ws) -> case lookup id table of + Nothing -> G (ID id l) ws + Just l' -> G (ID id l') ws + mapS_ f = fromJust . mapZ_ f . Just + + +maybeMakeNew :: Groups l l2 a -> Maybe (l2 (Group l a)) -> [Maybe (WithID l a)] + -> Maybe (Groups l l2 a) +maybeMakeNew _ Nothing ml's | all isNothing ml's = Nothing +maybeMakeNew g mpart' ml's = justMakeNew g mpart' ml's + +refocus :: Groups l l2 Window -> X () +refocus g = case getFocusZ $ gZipper $ W.focus $ groups g + of Just w -> focus w + Nothing -> return () + +-- ** ModifySpec type + +-- | Type of functions describing modifications to a 'Groups' layout. They +-- are transformations on 'Zipper's of groups. +-- +-- Things you shouldn't do: +-- +-- * Forge new windows (they will be ignored) +-- +-- * Duplicate windows (whatever happens is your problem) +-- +-- * Remove windows (they will be added again) +-- +-- * Duplicate layouts (only one will be kept, the rest will +-- get the base layout) +-- +-- Note that 'ModifySpec' is a rank-2 type (indicating that 'ModifySpec's must +-- be polymorphic in the layout type), so if you define functions taking +-- '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) + +-- | Apply a ModifySpec. +applySpec :: ModifySpec -> Groups l l2 Window -> Maybe (Groups l l2 Window) +applySpec f g = let (seed', id:ids) = gen $ seed g + g' = flip modifyGroups g $ f (ID id $ baseLayout g) + >>> toTags + >>> foldr reID ((ids, []), []) + >>> snd + >>> fromTags + in case groups g == groups g' of + True -> Nothing + False -> Just g' { seed = seed' } + + where reID eg ((id:ids, seen), egs) + = let myID = getID $ gLayout $ fromE eg + in case elem myID seen of + False -> ((id:ids, myID:seen), eg:egs) + True -> ((ids, seen), mapE_ (setID id) eg:egs) + where setID id (G (ID _ _) z) = G (ID id $ baseLayout g) z + reID _ (([], _), _) = undefined -- The list of ids is infinite + + + + + +-- ** Misc. ModifySpecs + +-- | helper +onFocused :: (Zipper Window -> Zipper Window) -> ModifySpec +onFocused f _ gs = onFocusedZ (onZipper f) gs + +-- | Swap the focused window with the previous one. +swapUp :: ModifySpec +swapUp = onFocused swapUpZ + +-- | Swap the focused window with the next one. +swapDown :: ModifySpec +swapDown = onFocused swapDownZ + +-- | Swap the focused window with the (group's) master +-- window. +swapMaster :: ModifySpec +swapMaster = onFocused swapMasterZ + +-- | Swap the focused group with the previous one. +swapGroupUp :: ModifySpec +swapGroupUp _ = swapUpZ + +-- | Swap the focused group with the next one. +swapGroupDown :: ModifySpec +swapGroupDown _ = swapDownZ + +-- | Swap the focused group with the master group. +swapGroupMaster :: ModifySpec +swapGroupMaster _ = swapMasterZ + +-- | Move focus to the previous window in the group. +focusUp :: ModifySpec +focusUp = onFocused focusUpZ + +-- | Move focus to the next window in the group. +focusDown :: ModifySpec +focusDown = onFocused focusDownZ + +-- | Move focus to the group's master window. +focusMaster :: ModifySpec +focusMaster = onFocused focusMasterZ + +-- | Move focus to the previous group. +focusGroupUp :: ModifySpec +focusGroupUp _ = focusUpZ + +-- | Move focus to the next group. +focusGroupDown :: ModifySpec +focusGroupDown _ = focusDownZ + +-- | Move focus to the master group. +focusGroupMaster :: ModifySpec +focusGroupMaster _ = focusMasterZ + +-- | helper +_removeFocused :: W.Stack a -> (a, Zipper a) +_removeFocused (W.Stack f (u:up) down) = (f, Just $ W.Stack u up down) +_removeFocused (W.Stack f [] (d:down)) = (f, Just $ W.Stack d [] down) +_removeFocused (W.Stack f [] []) = (f, Nothing) + +-- helper +_moveToNewGroup :: WithID l Window -> W.Stack (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 + = let (w, f') = _removeFocused f + 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 +moveToNewGroupUp l0 (Just s) = _moveToNewGroup l0 s insertUpZ + +-- | Move the focused window to a new group after the current one. +moveToNewGroupDown :: ModifySpec +moveToNewGroupDown _ Nothing = Nothing +moveToNewGroupDown l0 (Just s) = _moveToNewGroup l0 s insertDownZ + + +-- | Move the focused window to the previous group. +-- If 'True', when in the first group, wrap around to the last one. +-- If 'False', create a new group before it. +moveToGroupUp :: Bool -> ModifySpec +moveToGroupUp _ _ Nothing = Nothing +moveToGroupUp False l0 (Just s) = if null (W.up s) then moveToNewGroupUp l0 (Just s) + else moveToGroupUp True l0 (Just s) +moveToGroupUp True _ (Just s@(W.Stack _ [] [])) = Just s +moveToGroupUp True _ (Just s@(W.Stack (G l (Just f)) _ _)) + = let (w, f') = _removeFocused f + in onFocusedZ (onZipper $ insertUpZ w) $ focusUpZ $ Just s { W.focus = G l f' } +moveToGroupUp True _ gs = gs + +-- | Move the focused window to the next group. +-- If 'True', when in the last group, wrap around to the first one. +-- If 'False', create a new group after it. +moveToGroupDown :: Bool -> ModifySpec +moveToGroupDown _ _ Nothing = Nothing +moveToGroupDown False l0 (Just s) = if null (W.down s) then moveToNewGroupDown l0 (Just s) + else moveToGroupDown True l0 (Just s) +moveToGroupDown True _ (Just s@(W.Stack _ [] [])) = Just s +moveToGroupDown True _ (Just s@(W.Stack (G l (Just f)) _ _)) + = let (w, f') = _removeFocused f + in onFocusedZ (onZipper $ insertUpZ w) $ focusDownZ $ Just s { W.focus = G l f' } +moveToGroupDown True _ gs = gs + +-- | Split the focused group into two at the position of the focused window (below it, +-- unless it's the last window - in that case, above it). +splitGroup :: ModifySpec +splitGroup _ Nothing = Nothing +splitGroup l0 z@(Just s) | G l (Just ws) <- W.focus s + = case ws of + W.Stack _ [] [] -> z + W.Stack f (u:up) [] -> let g1 = G l $ Just $ W.Stack f [] [] + g2 = G l0 $ Just $ W.Stack u up [] + in insertDownZ g1 $ onFocusedZ (const g2) z + W.Stack f up (d:down) -> let g1 = G l $ Just $ W.Stack f up [] + g2 = G l0 $ Just $ W.Stack d [] down + in insertUpZ g1 $ onFocusedZ (const g2) z +splitGroup _ _ = Nothing diff --git a/XMonad/Layout/Groups/Examples.hs b/XMonad/Layout/Groups/Examples.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/Groups/Examples.hs @@ -0,0 +1,240 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE MultiParamTypeClasses, Rank2Types #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Groups.Examples +-- Copyright : Quentin Moser +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : orphaned +-- Stability : unstable +-- Portability : unportable +-- +-- Example layouts for "XMonad.Layout.Groups". +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Groups.Examples ( -- * Usage + -- $usage + + -- * Example: Row of columns + -- $example1 + rowOfColumns + , zoomColumnIn + , zoomColumnOut + , zoomColumnReset + , toggleColumnFull + , zoomWindowIn + , zoomWindowOut + , zoomWindowReset + , toggleWindowFull + + -- * Example: Tiled tab groups + -- $example2 + , tallTabs + , mirrorTallTabs + , fullTabs + , TiledTabsConfig(..) + , defaultTiledTabsConfig + , increaseNMasterGroups + , decreaseNMasterGroups + , shrinkMasterGroups + , expandMasterGroups + , nextOuterLayout + + + -- * Useful re-exports and utils + , module XMonad.Layout.Groups.Helpers + , shrinkText + , defaultTheme + , GroupEQ(..) + , zoomRowG + ) where + +import XMonad hiding ((|||)) + +import qualified XMonad.Layout.Groups as G +import XMonad.Layout.Groups.Helpers + +import XMonad.Layout.ZoomRow +import XMonad.Layout.Tabbed +import XMonad.Layout.Named +import XMonad.Layout.Renamed +import XMonad.Layout.LayoutCombinators +import XMonad.Layout.Decoration +import XMonad.Layout.Simplest + + +-- $usage +-- 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@. +-- +-- 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 +-- 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 +-- re-exported by this module. +-- +-- For more information on how to extend your layour hook and key bindings, see +-- "XMonad.Doc.Extending". + + +-- * Helper: ZoomRow of Group elements + +-- | Compare two 'Group's by comparing the ids of their layouts. +data GroupEQ a = GroupEQ + deriving (Show, Read) + +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)) + => ZoomRow GroupEQ (G.Group l a) +zoomRowG = zoomRowWith GroupEQ + + +-- * Example 1: Row of columns + +-- $example1 +-- A layout that arranges windows in a row of columns. It uses 'ZoomRow's for +-- both, allowing you to: +-- +-- * Freely change the proportion of the screen width allocated to each column +-- +-- * Freely change the proportion of a column's heigth allocated to each of its windows +-- +-- * Set a column to occupy the whole screen space whenever it has focus +-- +-- * Set a window to occupy its whole column whenever it has focus +-- +-- to use this layout, add 'rowOfColumns' to your layout hook, for example: +-- +-- > myLayout = rowOfColumns +-- +-- To be able to change the sizes of columns and windows, you can create key bindings +-- for the relevant actions: +-- +-- > ((modMask, xK_minus), zoomWindowOut) +-- +-- and so on. + +rowOfColumns = G.group column zoomRowG + where column = renamed [CutWordsLeft 2, PrependWords "ZoomColumn"] $ Mirror zoomRow + +-- | Increase the width of the focused column +zoomColumnIn :: X () +zoomColumnIn = sendMessage $ G.ToEnclosing $ SomeMessage $ zoomIn + +-- | Decrease the width of the focused column +zoomColumnOut :: X () +zoomColumnOut = sendMessage $ G.ToEnclosing $ SomeMessage $ zoomOut + +-- | Reset the width of the focused column +zoomColumnReset :: X () +zoomColumnReset = sendMessage $ G.ToEnclosing $ SomeMessage $ zoomReset + +-- | Toggle whether the currently focused column should +-- take up all available space whenever it has focus +toggleColumnFull :: X () +toggleColumnFull = sendMessage $ G.ToEnclosing $ SomeMessage $ ZoomFullToggle + +-- | Increase the heigth of the focused window +zoomWindowIn :: X () +zoomWindowIn = sendMessage zoomIn + +-- | Decrease the height of the focused window +zoomWindowOut :: X () +zoomWindowOut = sendMessage zoomOut + +-- | Reset the height of the focused window +zoomWindowReset :: X () +zoomWindowReset = sendMessage zoomReset + +-- | Toggle whether the currently focused window should +-- take up the whole column whenever it has focus +toggleWindowFull :: X () +toggleWindowFull = sendMessage ZoomFullToggle + + +-- * Example 2: Tabbed groups in a Tall/Full layout. + +-- $example2 +-- A layout which arranges windows into tabbed groups, and the groups +-- 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 +-- case you can freely switch between the three afterwards. +-- +-- You can use any of these three layouts by including it in your layout hook. +-- You will need to provide it with a 'TiledTabsConfig' containing the size +-- parameters for 'Tall' and 'Mirror' 'Tall', and the shrinker and decoration theme +-- for the tabs. If you're happy with defaults, you can use 'defaultTiledTabsConfig': +-- +-- > myLayout = tallTabs defaultTiledTabsConfig +-- +-- To be able to increase\/decrease the number of master groups and shrink\/expand +-- the master area, you can create key bindings for the relevant actions: +-- +-- > ((modMask, xK_h), shrinkMasterGroups) +-- +-- and so on. + +-- | Configuration data for the "tiled tab groups" layout +data TiledTabsConfig s = TTC { vNMaster :: Int + , vRatio :: Rational + , vIncrement :: Rational + , hNMaster :: Int + , hRatio :: Rational + , hIncrement :: Rational + , tabsShrinker :: s + , tabsTheme :: Theme } + +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 + +tallTabs c = _tab c $ G.group _tabs $ _vert c ||| _horiz c ||| Full + +mirrorTallTabs c = _tab c $ G.group _tabs $ _horiz c ||| Full ||| _vert c + +_tabs = named "Tabs" Simplest + +_tab c l = renamed [CutWordsLeft 1] $ addTabs (tabsShrinker c) (tabsTheme c) l + +_vert c = named "Vertical" $ Tall (vNMaster c) (vIncrement c) (vRatio c) + +_horiz c = named "Horizontal" $ Mirror $ Tall (hNMaster c) (hIncrement c) (hRatio c) + +-- | Increase the number of master groups by one +increaseNMasterGroups :: X () +increaseNMasterGroups = sendMessage $ G.ToEnclosing $ SomeMessage $ IncMasterN 1 + +-- | Decrease the number of master groups by one +decreaseNMasterGroups :: X () +decreaseNMasterGroups = sendMessage $ G.ToEnclosing $ SomeMessage $ IncMasterN (-1) + +-- | Shrink the master area +shrinkMasterGroups :: X () +shrinkMasterGroups = sendMessage $ G.ToEnclosing $ SomeMessage $ Shrink + +-- | Expand the master area +expandMasterGroups :: X () +expandMasterGroups = sendMessage $ G.ToEnclosing $ SomeMessage $ Expand + +-- | Rotate the available outer layout algorithms +nextOuterLayout :: X () +nextOuterLayout = sendMessage $ G.ToEnclosing $ SomeMessage $ NextLayout + diff --git a/XMonad/Layout/Groups/Helpers.hs b/XMonad/Layout/Groups/Helpers.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/Groups/Helpers.hs @@ -0,0 +1,232 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE MultiParamTypeClasses, Rank2Types #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Groups.Helpers +-- Copyright : Quentin Moser +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : orphaned +-- Stability : stable +-- Portability : unportable +-- +-- Utility functions for "XMonad.Layout.Groups". +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Groups.Helpers ( -- * Usage + -- $usage + + -- ** Layout-generic actions + swapUp + , swapDown + , swapMaster + , focusUp + , focusDown + , focusMaster + , toggleFocusFloat + + -- ** 'G.Groups'-secific actions + , swapGroupUp + , swapGroupDown + , swapGroupMaster + , focusGroupUp + , focusGroupDown + , focusGroupMaster + , moveToGroupUp + , moveToGroupDown + , moveToNewGroupUp + , moveToNewGroupDown + , splitGroup ) where + +import XMonad hiding ((|||)) +import qualified XMonad.StackSet as W + +import qualified XMonad.Layout.Groups as G + +import XMonad.Actions.MessageFeedback + +import Control.Monad (unless) +import qualified Data.Map as M + +-- $usage +-- +-- This module provides helpers functions for use with "XMonad.Layout.Groups"-based +-- layouts. You can use its contents by adding +-- +-- > import XMonad.Layout.Groups.Helpers +-- +-- to the top of your @.\/.xmonad\/xmonad.hs@. +-- +-- "XMonad.Layout.Groups"-based layouts do not have the same notion +-- of window ordering as the rest of XMonad. For this reason, the usual +-- ways of reordering windows and moving focus do not work with them. +-- "XMonad.Layout.Groups" provides 'Message's that can be used to obtain +-- the right effect. +-- +-- But what if you want to use both 'G.Groups' and other layouts? +-- 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 +-- write @sendMessage $ Modify $ ...@ everytime. +-- +-- This module exports many operations with the same names as +-- 'G.ModifySpec's from "XMonad.Layout.Groups", so if you want +-- to import both, we suggest to import "XMonad.Layout.Groups" +-- qualified: +-- +-- > import qualified XMonad.Layout.Groups as G +-- +-- For more information on how to extend your layour hook and key bindings, see +-- "XMonad.Doc.Extending". + +-- ** Layout-generic actions +-- #Layout-generic actions# + +alt :: G.ModifySpec -> (WindowSet -> WindowSet) -> X () +alt f g = alt2 (G.Modify f) $ windows g + +alt2 :: G.GroupsMessage -> X () -> X () +alt2 m x = do b <- send m + unless b x + +-- | Swap the focused window with the previous one +swapUp :: X () +swapUp = alt G.swapUp W.swapUp + +-- | Swap the focused window with the next one +swapDown :: X () +swapDown = alt G.swapDown W.swapDown + +-- | Swap the focused window with the master window +swapMaster :: X () +swapMaster = alt G.swapMaster W.swapMaster + +-- | If the focused window is floating, focus the next floating +-- window. otherwise, focus the next non-floating one. +focusUp :: X () +focusUp = ifFloat focusFloatUp focusNonFloatUp + +-- | If the focused window is floating, focus the next floating +-- window. otherwise, focus the next non-floating one. +focusDown :: X () +focusDown = ifFloat focusFloatDown focusNonFloatDown + +-- | Move focus to the master window +focusMaster :: X () +focusMaster = alt G.focusMaster W.shiftMaster + +-- | Move focus between the floating and non-floating layers +toggleFocusFloat :: X () +toggleFocusFloat = ifFloat focusNonFloat focusFloatUp + +-- *** Floating layer helpers + +getFloats :: X [Window] +getFloats = gets $ M.keys . W.floating . windowset + +getWindows :: X [Window] +getWindows = gets $ W.integrate' . W.stack . W.workspace . W.current . windowset + +ifFloat :: X () -> X () -> X () +ifFloat x1 x2 = withFocused $ \w -> do floats <- getFloats + if elem w floats then x1 else x2 + +focusNonFloat :: X () +focusNonFloat = alt2 G.Refocus helper + where helper = withFocused $ \w -> do + ws <- getWindows + floats <- getFloats + let (before, after) = span (/=w) ws + case filter (flip notElem floats) $ after ++ before of + [] -> return () + w':_ -> focus w' + +focusHelper :: (Bool -> Bool) -- ^ if you want to focus a floating window, 'id'. + -- if you want a non-floating one, 'not'. + -> ([Window] -> [Window]) -- ^ if you want the next window, 'id'. + -- if you want the previous one, 'reverse'. + -> X () +focusHelper f g = withFocused $ \w -> do + ws <- getWindows + let (before, _:after) = span (/=w) ws + let toFocus = g $ after ++ before + floats <- getFloats + case filter (f . flip elem floats) toFocus of + [] -> return () + w':_ -> focus w' + + +focusNonFloatUp :: X () +focusNonFloatUp = alt2 (G.Modify G.focusUp) $ focusHelper not reverse + +focusNonFloatDown :: X () +focusNonFloatDown = alt2 (G.Modify G.focusDown) $ focusHelper not id + +focusFloatUp :: X () +focusFloatUp = focusHelper id reverse + +focusFloatDown :: X () +focusFloatDown = focusHelper id id + + +-- ** Groups-specific actions + +wrap :: G.ModifySpec -> X () +wrap = sendMessage . G.Modify + +-- | Swap the focused group with the previous one +swapGroupUp :: X () +swapGroupUp = wrap G.swapGroupUp + +-- | Swap the focused group with the next one +swapGroupDown :: X () +swapGroupDown = wrap G.swapGroupDown + +-- | Swap the focused group with the master group +swapGroupMaster :: X () +swapGroupMaster = wrap G.swapGroupMaster + +-- | Move the focus to the previous group +focusGroupUp :: X () +focusGroupUp = wrap G.focusGroupUp + +-- | Move the focus to the next group +focusGroupDown :: X () +focusGroupDown = wrap G.focusGroupDown + +-- | Move the focus to the master group +focusGroupMaster :: X () +focusGroupMaster = wrap G.focusGroupMaster + +-- | Move the focused window to the previous group. The 'Bool' argument +-- determines what will be done if the focused window is in the very first +-- group: Wrap back to the end ('True'), or create a new group before +-- it ('False'). +moveToGroupUp :: Bool -> X () +moveToGroupUp b = wrap (G.moveToGroupUp b) + +-- | Move the focused window to the next group. The 'Bool' argument +-- determines what will be done if the focused window is in the very last +-- group: Wrap back to the beginning ('True'), or create a new group after +-- it ('False'). +moveToGroupDown :: Bool -> X () +moveToGroupDown b = wrap (G.moveToGroupDown b) + +-- | Move the focused window to a new group before the current one +moveToNewGroupUp :: X () +moveToNewGroupUp = wrap G.moveToNewGroupUp + +-- | Move the focused window to a new group after the current one +moveToNewGroupDown :: X () +moveToNewGroupDown = wrap G.moveToNewGroupDown + +-- | Split the focused group in two at the position of the focused +-- window. +splitGroup :: X () +splitGroup = wrap G.splitGroup diff --git a/XMonad/Layout/Groups/Wmii.hs b/XMonad/Layout/Groups/Wmii.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/Groups/Wmii.hs @@ -0,0 +1,133 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE MultiParamTypeClasses, Rank2Types #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Groups.Wmii +-- Copyright : Quentin Moser +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : orphaned +-- Stability : stable +-- Portability : unportable +-- +-- A wmii-like layout algorithm. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Groups.Wmii ( -- * Usage + -- $usage + + wmii + , zoomGroupIn + , zoomGroupOut + , zoomGroupReset + , toggleGroupFull + , groupToNextLayout + , groupToFullLayout + , groupToTabbedLayout + , groupToVerticalLayout + + -- * Useful re-exports + , shrinkText + , defaultTheme + , module XMonad.Layout.Groups.Helpers ) where + +import XMonad hiding ((|||)) + +import qualified XMonad.Layout.Groups as G +import XMonad.Layout.Groups.Examples +import XMonad.Layout.Groups.Helpers + +import XMonad.Layout.Tabbed +import XMonad.Layout.Named +import XMonad.Layout.Renamed +import XMonad.Layout.LayoutCombinators +import XMonad.Layout.MessageControl +import XMonad.Layout.Simplest + + +-- $usage +-- 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 +-- its windows +-- +-- * by maximizing the focused one +-- +-- * by tabbing them (wmii uses a stacked layout, but I'm too lazy to write it) +-- +-- * 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 +-- 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 +-- parameters) to your layout hook, for example: +-- +-- > myLayout = wmii shrinkText defaultTheme +-- +-- To be able to zoom in and out of groups, change their inner layout, etc., +-- create key bindings for the relevant actions: +-- +-- > ((modMask, xK_f), toggleGroupFull) +-- +-- and so on. +-- +-- For more information on how to extend your layout hook and key bindings, see +-- "XMonad.Doc.Extending". +-- +-- Finally, you will probably want to be able to move focus and windows +-- between groups in a consistent fashion. For this, you should take a look +-- at the "XMonad.Layout.Groups.Helpers" module, whose contents are re-exported +-- by this module. + +-- | A layout inspired by wmii +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] + $ addTabs s t + $ ignore NextLayout + $ ignore (JumpToLayout "") $ unEscape + $ column ||| tabs ||| Full + +-- | Increase the width of the focused group +zoomGroupIn :: X () +zoomGroupIn = zoomColumnIn + +-- | Decrease the size of the focused group +zoomGroupOut :: X () +zoomGroupOut = zoomColumnOut + +-- | Reset the size of the focused group to the default +zoomGroupReset :: X () +zoomGroupReset = zoomColumnReset + +-- | Toggle whether the currently focused group should be maximized +-- whenever it has focus. +toggleGroupFull :: X () +toggleGroupFull = toggleGroupFull + +-- | Rotate the layouts in the focused group. +groupToNextLayout :: X () +groupToNextLayout = sendMessage $ escape NextLayout + +-- | Switch the focused group to the \"maximized\" layout. +groupToFullLayout :: X () +groupToFullLayout = sendMessage $ escape $ JumpToLayout "Full" + +-- | Switch the focused group to the \"tabbed\" layout. +groupToTabbedLayout :: X () +groupToTabbedLayout = sendMessage $ escape $ JumpToLayout "Tabs" + +-- | Switch the focused group to the \"column\" layout. +groupToVerticalLayout :: X () +groupToVerticalLayout = sendMessage $ escape $ JumpToLayout "Column" + diff --git a/XMonad/Layout/IM.hs b/XMonad/Layout/IM.hs --- a/XMonad/Layout/IM.hs +++ b/XMonad/Layout/IM.hs @@ -25,12 +25,11 @@ -- * TODO -- $todo Property(..), IM(..), withIM, gridIM, + AddRoster, ) where import XMonad import qualified XMonad.StackSet as S -import Data.List -import XMonad.Layout (splitHorizontallyBy) import XMonad.Layout.Grid import XMonad.Layout.LayoutModifier import XMonad.Util.WindowProperties diff --git a/XMonad/Layout/ImageButtonDecoration.hs b/XMonad/Layout/ImageButtonDecoration.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/ImageButtonDecoration.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ImageButtonDecoration +-- Copyright : (c) Jan Vornberger 2009 +-- Alejandro Serrano 2010 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : trupill@gmail.com +-- Stability : unstable +-- Portability : not portable +-- +-- A decoration that includes small image buttons on both ends which invoke +-- various actions when clicked on: Show a window menu (see +-- "XMonad.Actions.WindowMenu"), minimize, maximize or close the window. +-- +-- Note: For maximizing and minimizing to actually work, you will need +-- to integrate "XMonad.Layout.Maximize" and "XMonad.Layout.Minimize" into your +-- setup. See the documentation of those modules for more information. +-- +----------------------------------------------------------------------------- + +-- This module is mostly derived from "XMonad.Layout.DecorationAddons" +-- and "XMonad.Layout.ButtonDecoration" + +module XMonad.Layout.ImageButtonDecoration + ( -- * Usage: + -- $usage + imageButtonDeco + , defaultThemeWithImageButtons + , imageTitleBarButtonHandler + , ImageButtonDecoration + ) where + +import XMonad +import XMonad.Layout.Decoration +import XMonad.Layout.DecorationAddons +import XMonad.Util.Image + +import XMonad.Actions.WindowMenu +import XMonad.Layout.Minimize +import XMonad.Layout.Maximize + +-- $usage +-- You can use this module with the following in your +-- @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.ImageButtonDecoration +-- +-- Then edit your @layoutHook@ by adding the ImageButtonDecoration to +-- your layout: +-- +-- > myL = imageButtonDeco shrinkText defaultThemeWithImageButtons (layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- + +-- The buttons' dimension and placements + +buttonSize :: Int +buttonSize = 10 + +menuButtonOffset :: Int +menuButtonOffset = 4 + +minimizeButtonOffset :: Int +minimizeButtonOffset = 32 + +maximizeButtonOffset :: Int +maximizeButtonOffset = 18 + +closeButtonOffset :: Int +closeButtonOffset = 4 + + +-- The images in a 0-1 scale to make +-- it easier to visualize + +convertToBool' :: [Int] -> [Bool] +convertToBool' = map (\x -> x == 1) + +convertToBool :: [[Int]] -> [[Bool]] +convertToBool = map convertToBool' + +menuButton' :: [[Int]] +menuButton' = [[1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1]] + +menuButton :: [[Bool]] +menuButton = convertToBool menuButton' + +miniButton' :: [[Int]] +miniButton' = [[0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1]] + +miniButton :: [[Bool]] +miniButton = convertToBool miniButton' + +maxiButton' :: [[Int]] +maxiButton' = [[1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1]] + +maxiButton :: [[Bool]] +maxiButton = convertToBool maxiButton' + +closeButton' :: [[Int]] +closeButton' = [[1,1,0,0,0,0,0,0,1,1], + [1,1,1,0,0,0,0,1,1,1], + [0,1,1,1,0,0,1,1,1,0], + [0,0,1,1,1,1,1,1,0,0], + [0,0,0,1,1,1,1,0,0,0], + [0,0,0,1,1,1,1,0,0,0], + [0,0,1,1,1,1,1,1,0,0], + [0,1,1,1,0,0,1,1,1,0], + [1,1,1,0,0,0,0,1,1,1], + [1,1,0,0,0,0,0,0,1,1]] + + +closeButton :: [[Bool]] +closeButton = convertToBool closeButton' + +-- | A function intended to be plugged into the 'decorationCatchClicksHook' of a decoration. +-- It will intercept clicks on the buttons of the decoration and invoke the associated action. +-- To actually see the buttons, you will need to use a theme that includes them. +-- See 'defaultThemeWithImageButtons' below. +imageTitleBarButtonHandler :: Window -> Int -> Int -> X Bool +imageTitleBarButtonHandler mainw distFromLeft distFromRight = do + let action = if (fi distFromLeft >= menuButtonOffset && + fi distFromLeft <= menuButtonOffset + buttonSize) + then focus mainw >> windowMenu >> return True + else if (fi distFromRight >= closeButtonOffset && + fi distFromRight <= closeButtonOffset + buttonSize) + then focus mainw >> kill >> return True + else if (fi distFromRight >= maximizeButtonOffset && + fi distFromRight <= maximizeButtonOffset + buttonSize) + then focus mainw >> sendMessage (maximizeRestore mainw) >> return True + else if (fi distFromRight >= minimizeButtonOffset && + fi distFromRight <= minimizeButtonOffset + buttonSize) + then focus mainw >> minimizeWindow mainw >> return True + else return False + action + +defaultThemeWithImageButtons :: Theme +defaultThemeWithImageButtons = defaultTheme { + windowTitleIcons = [ (menuButton, CenterLeft 3), + (closeButton, CenterRight 3), + (maxiButton, CenterRight 18), + (miniButton, CenterRight 33) ] + } + +imageButtonDeco :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration ImageButtonDecoration s) l a +imageButtonDeco s c = decoration s c $ NFD True + +data ImageButtonDecoration a = NFD Bool deriving (Show, Read) + +instance Eq a => DecorationStyle ImageButtonDecoration a where + describeDeco _ = "ImageButtonDeco" + decorationCatchClicksHook _ mainw dFL dFR = imageTitleBarButtonHandler mainw dFL dFR + decorationAfterDraggingHook _ (mainw, _) decoWin = focus mainw >> handleScreenCrossing mainw decoWin >> return () diff --git a/XMonad/Layout/IndependentScreens.hs b/XMonad/Layout/IndependentScreens.hs --- a/XMonad/Layout/IndependentScreens.hs +++ b/XMonad/Layout/IndependentScreens.hs @@ -19,18 +19,23 @@ VirtualWorkspace, PhysicalWorkspace, workspaces', withScreens, onCurrentScreen, + marshallPP, countScreens, - marshall, unmarshall + -- * Converting between virtual and physical workspaces + -- $converting + marshall, unmarshall, unmarshallS, unmarshallW, + marshallWindowSpace, unmarshallWindowSpace ) where -- for the screen stuff +import Control.Applicative((<*), liftA2) import Control.Arrow hiding ((|||)) import Control.Monad -import Control.Monad.Instances import Data.List import Graphics.X11.Xinerama import XMonad -import XMonad.StackSet hiding (workspaces) +import XMonad.StackSet hiding (filter, workspaces) +import XMonad.Hooks.DynamicLog -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -48,15 +53,19 @@ -- to specific workspace names. In the default configuration, only -- the keybindings for changing workspace do this: -- --- > [((m .|. modm, k), windows $ f i) --- > | (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. xK_9] --- > , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]] +-- > keyBindings conf = let m = modMask conf in fromList $ +-- > {- lots of other keybindings -} +-- > [((m .|. modm, k), windows $ f i) +-- > | (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. xK_9] +-- > , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]] -- -- This should change to -- --- > [((m .|. modm, k), windows $ onCurrentScreen f i) --- > | (i, k) <- zip (workspaces' conf) [xK_1 .. xK_9] --- > , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]] +-- > keyBindings conf = let m = modMask conf in fromList $ +-- > {- lots of other keybindings -} +-- > [((m .|. modm, k), windows $ onCurrentScreen f i) +-- > | (i, k) <- zip (workspaces' conf) [xK_1 .. xK_9] +-- > , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]] -- -- In particular, the analogue of @XMonad.workspaces@ is -- @workspaces'@, and you can use @onCurrentScreen@ to convert functions @@ -67,17 +76,24 @@ type VirtualWorkspace = WorkspaceId type PhysicalWorkspace = WorkspaceId +-- $converting +-- You shouldn't need to use the functions below very much. They are used +-- internally. However, in some cases, they may be useful, and so are exported +-- just in case. In general, the \"marshall\" functions convert the convenient +-- form (like \"web\") you would like to use in your configuration file to the +-- inconvenient form (like \"2_web\") that xmonad uses internally. Similarly, +-- the \"unmarshall\" functions convert in the other direction. + marshall :: ScreenId -> VirtualWorkspace -> PhysicalWorkspace marshall (S sc) vws = show sc ++ '_':vws -unmarshall :: PhysicalWorkspace -> (ScreenId, VirtualWorkspace) -unmarshall = ((S . read) *** drop 1) . break (=='_') +unmarshall :: PhysicalWorkspace -> (ScreenId, VirtualWorkspace) +unmarshallS :: PhysicalWorkspace -> ScreenId +unmarshallW :: PhysicalWorkspace -> VirtualWorkspace --- ^ You shouldn't need to use @marshall@ and @unmarshall@ very much. --- They simply convert between the physical and virtual worlds. For --- example, you might want to use them as part of a status bar --- configuration. The function @snd . unmarshall@ would discard the --- screen information from an otherwise unsightly workspace name. +unmarshall = ((S . read) *** drop 1) . break (=='_') +unmarshallS = fst . unmarshall +unmarshallW = snd . unmarshall workspaces' :: XConfig l -> [VirtualWorkspace] workspaces' = nub . map (snd . unmarshall) . workspaces @@ -101,4 +117,39 @@ -- > } -- countScreens :: (MonadIO m, Integral i) => m i -countScreens = liftM genericLength . liftIO $ openDisplay "" >>= getScreenInfo +countScreens = liftM genericLength . liftIO $ openDisplay "" >>= liftA2 (<*) getScreenInfo closeDisplay + +-- | This turns a naive pretty-printer into one that is aware of the +-- independent screens. That is, you can write your pretty printer to behave +-- the way you want on virtual workspaces; this function will convert that +-- pretty-printer into one that first filters out physical workspaces on other +-- screens, then converts all the physical workspaces on this screen to their +-- virtual names. +-- +-- For example, 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 . marshallPP screen . pp $ handle +-- > in log 0 hLeft >> log 1 hRight +marshallPP :: ScreenId -> PP -> PP +marshallPP s pp = pp { + ppCurrent = ppCurrent pp . snd . unmarshall, + ppVisible = ppVisible pp . snd . unmarshall, + ppHidden = ppHidden pp . snd . unmarshall, + ppHiddenNoWindows = ppHiddenNoWindows pp . snd . unmarshall, + ppUrgent = ppUrgent pp . snd . unmarshall, + ppSort = fmap (marshallSort s) (ppSort pp) + } + +marshallSort :: ScreenId -> ([WindowSpace] -> [WindowSpace]) -> ([WindowSpace] -> [WindowSpace]) +marshallSort s vSort = pScreens . vSort . vScreens where + onScreen ws = unmarshallS (tag ws) == s + vScreens = map unmarshallWindowSpace . filter onScreen + pScreens = map (marshallWindowSpace s) + +-- | Convert the tag of the 'WindowSpace' from a 'VirtualWorkspace' to a 'PhysicalWorkspace'. +marshallWindowSpace :: ScreenId -> WindowSpace -> WindowSpace +-- | Convert the tag of the 'WindowSpace' from a 'PhysicalWorkspace' to a 'VirtualWorkspace'. +unmarshallWindowSpace :: WindowSpace -> WindowSpace + +marshallWindowSpace s ws = ws { tag = marshall s (tag ws) } +unmarshallWindowSpace ws = ws { tag = unmarshallW (tag ws) } diff --git a/XMonad/Layout/LayoutBuilder.hs b/XMonad/Layout/LayoutBuilder.hs --- a/XMonad/Layout/LayoutBuilder.hs +++ b/XMonad/Layout/LayoutBuilder.hs @@ -24,15 +24,13 @@ SubMeasure (..), SubBox (..), absBox, - relBox + relBox, + LayoutN, ) where import XMonad -import XMonad.Layout import qualified XMonad.StackSet as W -import Graphics.X11.Xlib import Data.Maybe (isJust) -import Control.Monad -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: diff --git a/XMonad/Layout/LayoutBuilderP.hs b/XMonad/Layout/LayoutBuilderP.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/LayoutBuilderP.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, PatternGuards, DeriveDataTypeable, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.LayoutBuilderP +-- Copyright : (c) 2009 Anders Engstrom , 2011 Ilya Portnov +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Ilya Portnov +-- Stability : unstable +-- Portability : unportable +-- +-- A layout combinator that sends windows matching given predicate to one rectangle +-- and the rest to another. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.LayoutBuilderP ( + LayoutP (..), + layoutP, layoutAll, + B.relBox, B.absBox, + -- * Overloading ways to select windows + -- $selectWin + Predicate (..), Proxy(..), + ) where + +import Control.Monad +import Data.Maybe (isJust) + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Util.WindowProperties + +import qualified XMonad.Layout.LayoutBuilder as B + +-- $selectWin +-- +-- 'Predicate' exists because layouts are required to be serializable, and +-- "XMonad.Util.WindowProperties" is not sufficient (for example it does not +-- allow using regular expressions). +-- +-- compare "XMonad.Util.Invisible" + +-- | 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 +class Predicate p w where + alwaysTrue :: Proxy w -> p -- ^ A predicate that is always True. + checkPredicate :: p -> w -> X Bool -- ^ Check if given object (window or smth else) matches that predicate + +-- | Contains no actual data, but is needed to help select the correct instance +-- of 'Predicate' +data Proxy a = Proxy + +-- | Data type for our layout. +data LayoutP p l1 l2 a = + LayoutP (Maybe a) (Maybe a) p B.SubBox (Maybe B.SubBox) (l1 a) (Maybe (l2 a)) + deriving (Show,Read) + +-- | Use the specified layout in the described area windows that match given predicate and send the rest of the windows to the next layout in the chain. +-- It is possible to supply an alternative area that will then be used instead, if there are no windows to send to the next layout. +layoutP :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a, LayoutClass l3 a, Predicate p a) => + p + -> B.SubBox -- ^ The box to place the windows in + -> Maybe B.SubBox -- ^ Possibly an alternative box that is used when this layout handles all windows that are left + -> l1 a -- ^ The layout to use in the specified area + -> LayoutP p l2 l3 a -- ^ Where to send the remaining windows + -> LayoutP p l1 (LayoutP p l2 l3) a -- ^ The resulting layout +layoutP prop box mbox sub next = LayoutP Nothing Nothing prop box mbox sub (Just next) + +-- | Use the specified layout in the described area for all remaining windows. +layoutAll :: forall l1 p a. (Read a, Eq a, LayoutClass l1 a, Predicate p a) => + B.SubBox -- ^ The box to place the windows in + -> l1 a -- ^ The layout to use in the specified area + -> LayoutP p l1 Full a -- ^ The resulting layout +layoutAll box sub = + let a = alwaysTrue (Proxy :: Proxy a) + in LayoutP Nothing Nothing a box Nothing sub Nothing + +instance (LayoutClass l1 w, LayoutClass l2 w, Predicate p w, Show w, Read w, Eq w, Typeable w, Show p) => + LayoutClass (LayoutP p l1 l2) w where + + -- | Update window locations. + runLayout (W.Workspace _ (LayoutP subf nextf prop box mbox sub next) s) rect + = do (subs,nexts,subf',nextf') <- splitStack s prop subf nextf + let selBox = if isJust nextf' + then box + else maybe box id mbox + + (sublist,sub') <- handle sub subs $ calcArea selBox rect + + (nextlist,next') <- case next of Nothing -> return ([],Nothing) + Just n -> do (res,l) <- handle n nexts rect + return (res,Just l) + + return (sublist++nextlist, Just $ LayoutP subf' nextf' prop box mbox sub' next' ) + where + handle l s' r = do (res,ml) <- runLayout (W.Workspace "" l s') r + l' <- return $ maybe l id ml + return (res,l') + + -- | Propagate messages. + handleMessage l m + | Just (IncMasterN _) <- fromMessage m = sendFocus l m + | Just (Shrink) <- fromMessage m = sendFocus l m + | Just (Expand) <- fromMessage m = sendFocus l m + | otherwise = sendBoth l m + + -- | Descriptive name for layout. + description (LayoutP _ _ _ _ _ sub (Just next)) = "layoutP "++ description sub ++" "++ description next + description (LayoutP _ _ _ _ _ sub Nothing) = "layoutP "++ description sub + + +sendSub :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a, Predicate p a) + => LayoutP p l1 l2 a -> SomeMessage -> X (Maybe (LayoutP p l1 l2 a)) +sendSub (LayoutP subf nextf prop box mbox sub next) m = + do sub' <- handleMessage sub m + return $ if isJust sub' + then Just $ LayoutP subf nextf prop box mbox (maybe sub id sub') next + else Nothing + +sendBoth :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a, Predicate p a) + => LayoutP p l1 l2 a -> SomeMessage -> X (Maybe (LayoutP p l1 l2 a)) +sendBoth l@(LayoutP _ _ _ _ _ _ Nothing) m = sendSub l m +sendBoth (LayoutP subf nextf prop box mbox sub (Just next)) m = + do sub' <- handleMessage sub m + next' <- handleMessage next m + return $ if isJust sub' || isJust next' + then Just $ LayoutP subf nextf prop box mbox (maybe sub id sub') (Just $ maybe next id next') + else Nothing + +sendNext :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a, Predicate p a) + => LayoutP p l1 l2 a -> SomeMessage -> X (Maybe (LayoutP p l1 l2 a)) +sendNext (LayoutP _ _ _ _ _ _ Nothing) _ = return Nothing +sendNext (LayoutP subf nextf prop box mbox sub (Just next)) m = + do next' <- handleMessage next m + return $ if isJust next' + then Just $ LayoutP subf nextf prop box mbox sub next' + else Nothing + +sendFocus :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a, Predicate p a) + => LayoutP p l1 l2 a -> SomeMessage -> X (Maybe (LayoutP p l1 l2 a)) +sendFocus l@(LayoutP subf _ _ _ _ _ _) m = do foc <- isFocus subf + if foc then sendSub l m + else sendNext l m + +isFocus :: (Show a) => Maybe a -> X Bool +isFocus Nothing = return False +isFocus (Just w) = do ms <- (W.stack . W.workspace . W.current) `fmap` gets windowset + return $ maybe False (\s -> show w == (show $ W.focus s)) ms + + +-- | Split given list of objects (i.e. windows) using predicate. +splitBy :: (Predicate p w) => p -> [w] -> X ([w], [w]) +splitBy prop ws = foldM step ([], []) ws + where + step (good, bad) w = do + ok <- checkPredicate prop w + return $ if ok + then (w:good, bad) + else (good, w:bad) + +splitStack :: (Predicate p w, Eq w) => Maybe (W.Stack w) -> p -> Maybe w -> Maybe w -> X (Maybe (W.Stack w),Maybe (W.Stack w),Maybe w,Maybe w) +splitStack Nothing _ _ _ = return (Nothing,Nothing,Nothing,Nothing) +splitStack (Just s) prop subf nextf = do + let ws = W.integrate s + (good, other) <- splitBy prop ws + let subf' = foc good subf + nextf' = foc other nextf + return ( differentiate' subf' good + , differentiate' nextf' other + , subf' + , nextf' + ) + where + foc [] _ = Nothing + foc l f = if W.focus s `elem` l + then Just $ W.focus s + else if maybe False (`elem` l) f + then f + else Just $ head l + +calcArea :: B.SubBox -> Rectangle -> Rectangle +calcArea (B.SubBox xpos ypos width height) rect = Rectangle (rect_x rect + fromIntegral xpos') (rect_y rect + fromIntegral ypos') width' height' + where + xpos' = calc False xpos $ rect_width rect + ypos' = calc False ypos $ rect_height rect + width' = calc True width $ rect_width rect - xpos' + height' = calc True height $ rect_height rect - ypos' + + calc zneg val tot = fromIntegral $ min (fromIntegral tot) $ max 0 $ + case val of B.Rel v -> floor $ v * fromIntegral tot + B.Abs v -> if v<0 || (zneg && v==0) + then (fromIntegral tot)+v + else v + +differentiate' :: Eq q => Maybe q -> [q] -> Maybe (W.Stack q) +differentiate' _ [] = Nothing +differentiate' Nothing w = W.differentiate w +differentiate' (Just f) w + | f `elem` w = Just $ W.Stack { W.focus = f + , W.up = reverse $ takeWhile (/=f) w + , W.down = tail $ dropWhile (/=f) w + } + | otherwise = W.differentiate w + +instance Predicate Property Window where + alwaysTrue _ = Const True + checkPredicate = hasProperty + diff --git a/XMonad/Layout/LayoutCombinators.hs b/XMonad/Layout/LayoutCombinators.hs --- a/XMonad/Layout/LayoutCombinators.hs +++ b/XMonad/Layout/LayoutCombinators.hs @@ -47,6 +47,9 @@ -- $jtl , (|||) , JumpToLayout(..) + + -- * Types + , NewSelect ) where import Data.Maybe ( isJust, isNothing ) @@ -76,6 +79,7 @@ -- > import XMonad hiding ( (|||) ) -- > import XMonad.Layout.LayoutCombinators -- +-- If you import XMonad.Layout, you will need to hide it from there as well. -- Then bind some keys to a 'JumpToLayout' message: -- -- > , ((modm .|. controlMask, xK_f), sendMessage $ JumpToLayout "Full") -- jump directly to the Full layout @@ -179,9 +183,16 @@ -- The standard xmonad core exports a layout combinator @|||@ which -- represents layout choice. This is a reimplementation which also -- provides the capability to support 'JumpToLayout' messages. To use --- it, be sure to hide the import of @|||@ from the xmonad core: +-- it, be sure to hide the import of @|||@ from the xmonad core; if either of +-- these two lines appear in your configuration: -- +-- > import XMonad +-- > import XMonad.Layout +-- +-- replace them with these instead, respectively: +-- -- > import XMonad hiding ( (|||) ) +-- > import XMonad.Layout hiding ( (|||) ) -- -- The argument given to a 'JumpToLayout' message should be the -- @description@ of the layout to be selected. If you use @@ -213,7 +224,7 @@ data NewSelect l1 l2 a = NewSelect Bool (l1 a) (l2 a) deriving ( Read, Show ) --- | +-- | data JumpToLayout = JumpToLayout String -- ^ A message to jump to a particular layout -- , specified by its description string.. | NextLayoutNoWrap diff --git a/XMonad/Layout/LayoutHints.hs b/XMonad/Layout/LayoutHints.hs --- a/XMonad/Layout/LayoutHints.hs +++ b/XMonad/Layout/LayoutHints.hs @@ -20,10 +20,15 @@ , layoutHintsWithPlacement , layoutHintsToCenter , LayoutHints + , LayoutHintsToCenter + , hintsEventHook ) where import XMonad(LayoutClass(runLayout), mkAdjust, Window, - Dimension, Position, Rectangle(Rectangle),D) + Dimension, Position, Rectangle(Rectangle), D, + X, refresh, Event(..), propertyNotify, wM_NORMAL_HINTS, + (<&&>), io, applySizeHints, whenX, isClient, withDisplay, + getWindowAttributes, getWMNormalHints, WindowAttributes(..)) import qualified XMonad.StackSet as W import XMonad.Layout.Decoration(isInStack) @@ -32,9 +37,10 @@ import XMonad.Util.Types(Direction2D(..)) import Control.Applicative((<$>)) import Control.Arrow(Arrow((***), first, second)) -import Control.Monad(Monad(return), mapM, join) +import Control.Monad(join) import Data.Function(on) import Data.List(sortBy) +import Data.Monoid(All(..)) import Data.Set (Set) import qualified Data.Set as Set @@ -62,6 +68,14 @@ -- For more detailed instructions on editing the layoutHook see: -- -- "XMonad.Doc.Extending#Editing_the_layout_hook" +-- +-- To make XMonad reflect changes in window hints immediately, add +-- 'hintsEventHook' to your 'handleEventHook'. +-- +-- > myHandleEventHook = hintsEventHook <+> ... +-- > +-- > main = xmonad defaultConfig { handleEventHook = myHandleEventHook +-- > , ... } layoutHints :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHints l a layoutHints = ModifiedLayout (LayoutHints (0, 0)) @@ -235,3 +249,19 @@ = (cf $ cx - cwx, cf $ cy - cwy) where (cx,cy) = center root (cwx,cwy) = center assigned + +-- | Event hook that refreshes the layout whenever a window changes its hints. +hintsEventHook :: Event -> X All +hintsEventHook (PropertyEvent { ev_event_type = t, ev_atom = a, ev_window = w }) + | t == propertyNotify && a == wM_NORMAL_HINTS = do + whenX (isClient w <&&> hintsMismatch w) $ refresh + return (All True) +hintsEventHook _ = return (All True) + +-- | True if the window's current size does not satisfy its size hints. +hintsMismatch :: Window -> X Bool +hintsMismatch w = withDisplay $ \d -> io $ do + wa <- getWindowAttributes d w + sh <- getWMNormalHints d w + let dim = (fromIntegral $ wa_width wa, fromIntegral $ wa_height wa) + return $ dim /= applySizeHints 0 sh dim diff --git a/XMonad/Layout/LayoutModifier.hs b/XMonad/Layout/LayoutModifier.hs --- a/XMonad/Layout/LayoutModifier.hs +++ b/XMonad/Layout/LayoutModifier.hs @@ -29,6 +29,8 @@ LayoutModifier(..), ModifiedLayout(..) ) where +import Control.Monad + import XMonad import XMonad.StackSet ( Stack, Workspace (..) ) @@ -106,6 +108,22 @@ -> X ([(a, Rectangle)], Maybe (l a)) modifyLayout _ w r = runLayout w r + -- | Similar to 'modifyLayout', but this function also allows you + -- update the state of your layout modifier(the second value in the + -- outer tuple). + -- + -- If both 'modifyLayoutWithUpdate' and 'redoLayout' return a + -- modified state of the layout modifier, 'redoLayout' takes + -- precedence. If this function returns a modified state, this + -- state will internally be used in the subsequent call to + -- 'redoLayout' as well. + modifyLayoutWithUpdate :: (LayoutClass l a) => + m a + -> Workspace WorkspaceId (l a) a + -> Rectangle + -> X (([(a,Rectangle)], Maybe (l a)), Maybe (m a)) + modifyLayoutWithUpdate m w r = flip (,) Nothing `fmap` modifyLayout m w r + -- | 'handleMess' allows you to spy on messages to the underlying -- layout, in order to have an effect in the X monad, or alter -- the layout modifier state in some way (by returning @Just @@ -234,9 +252,9 @@ -- semantics of a 'LayoutModifier' applied to an underlying layout. instance (LayoutModifier m a, LayoutClass l a) => LayoutClass (ModifiedLayout m l) a where runLayout (Workspace i (ModifiedLayout m l) ms) r = - do (ws, ml') <- modifyLayout m (Workspace i l ms) r - (ws', mm') <- redoLayout m r ms ws - let ml'' = case mm' of + do ((ws, ml'),mm') <- modifyLayoutWithUpdate m (Workspace i l ms) r + (ws', mm'') <- redoLayout (maybe m id mm') r ms ws + let ml'' = case mm'' `mplus` mm' of Just m' -> Just $ (ModifiedLayout m') $ maybe l id ml' Nothing -> ModifiedLayout m `fmap` ml' return (ws', ml'') diff --git a/XMonad/Layout/LayoutScreens.hs b/XMonad/Layout/LayoutScreens.hs --- a/XMonad/Layout/LayoutScreens.hs +++ b/XMonad/Layout/LayoutScreens.hs @@ -16,7 +16,8 @@ module XMonad.Layout.LayoutScreens ( -- * Usage -- $usage - layoutScreens, fixedLayout + layoutScreens, layoutSplitScreen, fixedLayout, + FixedLayout, ) where import XMonad @@ -55,6 +56,7 @@ -- For detailed instructions on editing your key bindings, see -- "XMonad.Doc.Extending#Editing_key_bindings". +-- | Modify all screens. layoutScreens :: LayoutClass l Int => Int -> l Int -> X () layoutScreens nscr _ | nscr < 1 = trace $ "Can't layoutScreens with only " ++ show nscr ++ " screens." layoutScreens nscr l = @@ -65,6 +67,20 @@ s:ss = map snd wss in ws { W.current = W.Screen x 0 (SD s) , W.visible = zipWith3 W.Screen xs [1 ..] $ map SD ss + , W.hidden = ys } + +-- | Modify current screen. +layoutSplitScreen :: LayoutClass l Int => Int -> l Int -> X () +layoutSplitScreen nscr _ | nscr < 1 = trace $ "Can't layoutSplitScreen with only " ++ show nscr ++ " screens." +layoutSplitScreen nscr l = + do rect <- gets $ screenRect . W.screenDetail . W.current . windowset + (wss, _) <- runLayout (W.Workspace "" l (Just $ W.Stack { W.focus=1, W.up=[],W.down=[1..nscr-1] })) rect + windows $ \ws@(W.StackSet { W.current = c, W.visible = vs, W.hidden = hs }) -> + let (x:xs, ys) = splitAt nscr $ W.workspace c : hs + s:ss = map snd wss + in ws { W.current = W.Screen x (W.screen c) (SD s) + , W.visible = (zipWith3 W.Screen xs [(W.screen c+1) ..] $ map SD ss) ++ + map (\v -> if W.screen v>W.screen c then v{W.screen = W.screen v + fromIntegral (nscr-1)} else v) vs , W.hidden = ys } getWindowRectangle :: Window -> X Rectangle diff --git a/XMonad/Layout/LimitWindows.hs b/XMonad/Layout/LimitWindows.hs --- a/XMonad/Layout/LimitWindows.hs +++ b/XMonad/Layout/LimitWindows.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, PatternGuards #-} +{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.Layout.LimitWindows @@ -23,13 +23,20 @@ limitWindows,limitSlice,limitSelect, -- * Change the number of windows - increaseLimit,decreaseLimit,setLimit + increaseLimit,decreaseLimit,setLimit, + +#ifdef TESTING + -- * For tests + select,update,Selection(..),updateAndSelect, +#endif + + -- * Types + LimitWindows, Selection, ) where import XMonad.Layout.LayoutModifier import XMonad import qualified XMonad.StackSet as W -import XMonad.Layout (IncMasterN (..)) import Control.Monad((<=<),guard) import Control.Applicative((<$>)) import Data.Maybe(fromJust) @@ -139,7 +146,7 @@ downs = W.down stk ups = reverse $ W.up stk lups = length ups - + updateStart :: Selection l -> W.Stack a -> Int updateStart s stk | lups < nMaster s -- the focussed window is in the master pane diff --git a/XMonad/Layout/MagicFocus.hs b/XMonad/Layout/MagicFocus.hs --- a/XMonad/Layout/MagicFocus.hs +++ b/XMonad/Layout/MagicFocus.hs @@ -20,7 +20,8 @@ promoteWarp, promoteWarp', followOnlyIf, - disableFollowOnWS + disableFollowOnWS, + MagicFocus, ) where import XMonad diff --git a/XMonad/Layout/Magnifier.hs b/XMonad/Layout/Magnifier.hs --- a/XMonad/Layout/Magnifier.hs +++ b/XMonad/Layout/Magnifier.hs @@ -26,12 +26,14 @@ magnifiercz, magnifiercz', maximizeVertical, - MagnifyMsg (..) + MagnifyMsg (..), + Magnifier, ) where import XMonad import XMonad.StackSet import XMonad.Layout.LayoutModifier +import XMonad.Util.XUtils -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -159,6 +161,3 @@ y' = max sy (y - (max 0 (y + fi h - sy - fi sh))) w' = min sw w h' = min sh h - -fi :: (Num b, Integral a) => a -> b -fi = fromIntegral diff --git a/XMonad/Layout/Master.hs b/XMonad/Layout/Master.hs --- a/XMonad/Layout/Master.hs +++ b/XMonad/Layout/Master.hs @@ -17,7 +17,9 @@ -- * Usage -- $usage - mastered + mastered, + multimastered, + AddMaster, ) where import XMonad @@ -34,6 +36,10 @@ -- -- > mastered (1/100) (1/2) $ Grid -- +-- Or if you want multiple (here two) master windows from the beginning: +-- +-- > multimastered 2 (1/100) (1/2) $ Grid +-- -- This will use the left half of your screen for a master window and let -- Grid manage the right half. -- @@ -45,42 +51,68 @@ -- | Data type for LayoutModifier which converts given layout to a mastered -- layout -data AddMaster a = AddMaster Rational Rational deriving (Show, Read) +data AddMaster a = AddMaster Int Rational Rational deriving (Show, Read) -- | Modifier which converts given layout to a mastered one +multimastered :: (LayoutClass l a) => + Int -- ^ @k@, number of master windows + -> Rational -- ^ @delta@, the ratio of the screen to resize by + -> Rational -- ^ @frac@, what portion of the screen to use for the master window + -> l a -- ^ the layout to be modified + -> ModifiedLayout AddMaster l a +multimastered k delta frac = ModifiedLayout $ AddMaster k delta frac + mastered :: (LayoutClass l a) => Rational -- ^ @delta@, the ratio of the screen to resize by -> Rational -- ^ @frac@, what portion of the screen to use for the master window -> l a -- ^ the layout to be modified -> ModifiedLayout AddMaster l a -mastered delta frac = ModifiedLayout $ AddMaster delta frac +mastered delta frac = multimastered 1 delta frac instance LayoutModifier AddMaster Window where - modifyLayout (AddMaster delta frac) = applyMaster delta frac + modifyLayout (AddMaster k delta frac) = applyMaster k delta frac modifierDescription _ = "Mastered" - pureMess (AddMaster delta frac) m - | Just Shrink <- fromMessage m = Just $ AddMaster delta (frac-delta) - | Just Expand <- fromMessage m = Just $ AddMaster delta (frac+delta) + pureMess (AddMaster k delta frac) m + | Just Shrink <- fromMessage m = Just $ AddMaster k delta (frac-delta) + | Just Expand <- fromMessage m = Just $ AddMaster k delta (frac+delta) + | Just (IncMasterN d) <- fromMessage m = Just $ AddMaster (max 1 (k+d)) delta frac pureMess _ _ = Nothing -- | Internal function for adding a master window and let the modified -- layout handle the rest of the windows applyMaster :: (LayoutClass l Window) => - Rational + Int -> Rational + -> Rational -> S.Workspace WorkspaceId (l Window) Window -> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window)) -applyMaster _ frac wksp rect = do +applyMaster k _ frac wksp rect = do let st= S.stack wksp let ws = S.integrate' $ st - if length ws > 1 then do - let m = head ws - let (mr, sr) = splitHorizontallyBy frac rect - let nst = st>>= S.filter (m/=) - wrs <- runLayout (wksp {S.stack = nst}) sr - return ((m, mr) : fst wrs, snd wrs) - + let n = length ws + if n > 1 then do + if(n<=k) then + return ((divideCol rect ws), Nothing) + else do + let m = take k ws + let (mr, sr) = splitHorizontallyBy frac rect + let nst = st>>= S.filter (\w -> not (w `elem` m)) + wrs <- runLayout (wksp {S.stack = nst}) sr + return ((divideCol mr m) ++ (fst wrs), snd wrs) else runLayout wksp rect + +-- | Shift rectangle down +shiftD :: Position -> Rectangle -> Rectangle +shiftD s (Rectangle x y w h) = Rectangle x (y+s) w h + +-- | Divide rectangle between windows +divideCol :: Rectangle -> [a] -> [(a, Rectangle)] +divideCol (Rectangle x y w h) ws = zip ws rects + where n = length ws + oneH = fromIntegral h `div` n + oneRect = Rectangle x y w (fromIntegral oneH) + rects = take n $ iterate (shiftD (fromIntegral oneH)) oneRect + diff --git a/XMonad/Layout/Maximize.hs b/XMonad/Layout/Maximize.hs --- a/XMonad/Layout/Maximize.hs +++ b/XMonad/Layout/Maximize.hs @@ -19,7 +19,8 @@ -- * Usage -- $usage maximize, - maximizeRestore + maximizeRestore, + Maximize, MaximizeRestore, ) where import XMonad @@ -64,12 +65,14 @@ pureModifier (Maximize (Just target)) rect (Just (S.Stack focused _ _)) wrs = if focused == target then (maxed ++ rest, Nothing) - else (rest ++ maxed, Nothing) + else (rest ++ maxed, lay) where (toMax, rest) = partition (\(w, _) -> w == target) wrs maxed = map (\(w, _) -> (w, maxRect)) toMax maxRect = Rectangle (rect_x rect + 25) (rect_y rect + 25) (rect_width rect - 50) (rect_height rect - 50) + lay | null maxed = Just (Maximize Nothing) + | otherwise = Nothing pureModifier _ _ _ wrs = (wrs, Nothing) pureMess (Maximize mw) m = case fromMessage m of diff --git a/XMonad/Layout/MessageControl.hs b/XMonad/Layout/MessageControl.hs --- a/XMonad/Layout/MessageControl.hs +++ b/XMonad/Layout/MessageControl.hs @@ -6,7 +6,7 @@ -- Copyright : (c) 2008 Quentin Moser -- License : BSD3 -- --- Maintainer : +-- Maintainer : orphaned -- Stability : unstable -- Portability : unportable -- @@ -41,7 +41,7 @@ -- > import XMonad.Layout.MessageEscape -- -- Then, if you use a modified layout where the modifier would intercept --- a message, but you'd want to be able to send it to the inner layout +-- a message, but you'd want to be able to send it to the inner layout -- only, add the 'unEscape' modifier to the inner layout like so: -- -- > import XMonad.Layout.Master (mastered) @@ -60,7 +60,7 @@ -- layout, use the 'ignore' modifier: -- -- > myLayout = Tall ||| (ignore NextLayout $ ignore (JumpToLayout "") $ --- > unEscape $ mastered 0.01 0.5 +-- > unEscape $ mastered 0.01 0.5 -- > $ Full ||| simpleTabbed) -- -- /IMPORTANT NOTE:/ The standard '(|||)' operator from "XMonad.Layout" @@ -121,6 +121,6 @@ -- | Applies the Ignore layout modifier to a layout, blocking -- all messages of the same type as the one passed as its first argument. -ignore :: (Message m, LayoutClass l w) +ignore :: (Message m, LayoutClass l w) => m -> l w -> (Ignore m l w) ignore _ l = I l diff --git a/XMonad/Layout/Minimize.hs b/XMonad/Layout/Minimize.hs --- a/XMonad/Layout/Minimize.hs +++ b/XMonad/Layout/Minimize.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleContexts, PatternGuards #-} ---------------------------------------------------------------------------- -- | -- Module : XMonad.Layout.Minimize --- Copyright : (c) Jan Vornberger 2009 +-- Copyright : (c) Jan Vornberger 2009, Alejandro Serrano 2010 -- License : BSD3-style (see LICENSE) -- -- Maintainer : jan.vornberger@informatik.uni-oldenburg.de @@ -18,14 +18,20 @@ -- * Usage -- $usage minimize, - MinimizeMsg(..) + minimizeWindow, + MinimizeMsg(RestoreMinimizedWin,RestoreNextMinimizedWin), + Minimize, ) where import XMonad import qualified XMonad.StackSet as W import XMonad.Layout.LayoutModifier import XMonad.Layout.BoringWindows as BW +import XMonad.Util.WindowProperties (getProp32) import Data.List +import qualified Data.Map as M +import Data.Maybe +import Foreign.C.Types (CLong) -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -43,7 +49,7 @@ -- -- In the key-bindings, do something like: -- --- > , ((modm, xK_m ), withFocused (\f -> sendMessage (MinimizeWin f))) +-- > , ((modm, xK_m ), withFocused minimizeWindow) -- > , ((modm .|. shiftMask, xK_m ), sendMessage RestoreNextMinimizedWin) -- -- The first action will minimize the focused window, while the second one will restore @@ -54,15 +60,16 @@ -- "XMonad.Doc.Extending#Editing_key_bindings". -- -- The module is designed to work together with "XMonad.Layout.BoringWindows" so --- that minimized windows will be skipped when switching the focus window with --- the keyboard. Use the 'BW.boringAuto' function. +-- that minimized windows will be skipped over when switching the focused window with +-- the keyboard. Include 'BW.boringWindows' in your layout hook and see the +-- documentation of "XMonad.Layout.BoringWindows" on how to modify your keybindings. -- --- Also see "XMonad.Hooks.RestoreMinimized" if you want to be able to restore --- minimized windows from your taskbar. +-- Also see "XMonad.Hooks.Minimize" if you want to be able to minimize +-- and restore windows from your taskbar. -data Minimize a = Minimize [Window] deriving ( Read, Show ) +data Minimize a = Minimize [Window] (M.Map Window W.RationalRect) deriving ( Read, Show ) minimize :: LayoutClass l Window => l Window -> ModifiedLayout Minimize l Window -minimize = ModifiedLayout $ Minimize [] +minimize = ModifiedLayout $ Minimize [] M.empty data MinimizeMsg = MinimizeWin Window | RestoreMinimizedWin Window @@ -70,25 +77,68 @@ deriving (Typeable, Eq) instance Message MinimizeMsg +minimizeWindow :: Window -> X () +minimizeWindow w = sendMessage (MinimizeWin w) >> BW.focusDown + +setMinimizedState :: Window -> Int -> (CLong -> [CLong] -> [CLong]) -> X () +setMinimizedState win st f = do + setWMState win st + withDisplay $ \dpy -> do + state <- getAtom "_NET_WM_STATE" + mini <- getAtom "_NET_WM_STATE_HIDDEN" + wstate <- fromMaybe [] `fmap` getProp32 state win + let ptype = 4 -- The atom property type for changeProperty + fi_mini = fromIntegral mini + io $ changeProperty32 dpy win state ptype propModeReplace (f fi_mini wstate) + +setMinimized :: Window -> X () +setMinimized win = setMinimizedState win iconicState (:) + +setNotMinimized :: Window -> X () +setNotMinimized win = setMinimizedState win normalState delete + instance LayoutModifier Minimize Window where - modifierDescription (Minimize _) = "Minimize" + modifierDescription _ = "Minimize" - modifyLayout (Minimize minimized) wksp rect = do + modifyLayout (Minimize minimized _) wksp rect = do let stack = W.stack wksp filtStack = stack >>=W.filter (\w -> not (w `elem` minimized)) runLayout (wksp {W.stack = filtStack}) rect - handleMess (Minimize minimized) m = case fromMessage m of - Just (MinimizeWin w) - | not (w `elem` minimized) -> do - BW.focusDown - return $ Just $ Minimize (w:minimized) - | otherwise -> return Nothing - Just (RestoreMinimizedWin w) -> - return $ Just $ Minimize (minimized \\ [w]) - Just (RestoreNextMinimizedWin) - | not (null minimized) -> do - focus (head minimized) - return $ Just $ Minimize (tail minimized) - | otherwise -> return Nothing - _ -> return Nothing + handleMess (Minimize minimized unfloated) m + | Just (MinimizeWin w) <- fromMessage m, not (w `elem` minimized) = do + setMinimized w + ws <- gets windowset + case M.lookup w (W.floating ws) of + Nothing -> return $ Just $ Minimize (w:minimized) unfloated + Just r -> do + modify (\s -> s { windowset = W.sink w ws}) + return $ Just $ Minimize (w:minimized) (M.insert w r unfloated) + | Just (RestoreMinimizedWin w) <- fromMessage m = do + setNotMinimized w + case M.lookup w unfloated of + Nothing -> return $ Just $ Minimize (minimized \\ [w]) unfloated + Just r -> do + ws <- gets windowset + modify (\s -> s { windowset = W.float w r ws}) + return $ Just $ Minimize (minimized \\ [w]) (M.delete w unfloated) + | Just RestoreNextMinimizedWin <- fromMessage m = do + ws <- gets windowset + if not (null minimized) + then case M.lookup (head minimized) unfloated of + Nothing -> do + let w = head minimized + setNotMinimized w + modify (\s -> s { windowset = W.focusWindow w ws}) + return $ Just $ Minimize (tail minimized) unfloated + Just r -> do + let w = head minimized + setNotMinimized w + modify (\s -> s { windowset = (W.focusWindow w . W.float w r) ws}) + return $ Just $ Minimize (tail minimized) (M.delete w unfloated) + else return Nothing + | Just BW.UpdateBoring <- fromMessage m = do + ws <- gets (W.workspace . W.current . windowset) + flip sendMessageWithNoRefresh ws $ BW.Replace "Minimize" minimized + return Nothing + | otherwise = return Nothing diff --git a/XMonad/Layout/Mosaic.hs b/XMonad/Layout/Mosaic.hs --- a/XMonad/Layout/Mosaic.hs +++ b/XMonad/Layout/Mosaic.hs @@ -21,6 +21,8 @@ ,mosaic ,changeMaster ,changeFocused + + ,Mosaic ) where diff --git a/XMonad/Layout/MosaicAlt.hs b/XMonad/Layout/MosaicAlt.hs --- a/XMonad/Layout/MosaicAlt.hs +++ b/XMonad/Layout/MosaicAlt.hs @@ -25,6 +25,9 @@ , tallWindowAlt , wideWindowAlt , resetAlt + + , Params, Param + , HandleWindowAlt ) where import XMonad diff --git a/XMonad/Layout/MouseResizableTile.hs b/XMonad/Layout/MouseResizableTile.hs --- a/XMonad/Layout/MouseResizableTile.hs +++ b/XMonad/Layout/MouseResizableTile.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} ---------------------------------------------------------------------------- -- | -- Module : XMonad.Layout.MouseResizableTile @@ -19,12 +19,24 @@ -- $usage mouseResizableTile, mouseResizableTileMirrored, - MRTMessage (ShrinkSlave, ExpandSlave) + MRTMessage (ShrinkSlave, ExpandSlave), + + -- * Parameters + -- $mrtParameters + nmaster, + masterFrac, + slaveFrac, + fracIncrement, + isMirrored, + draggerType, + DraggerType (..), + MouseResizableTile, ) where import XMonad hiding (tile, splitVertically, splitHorizontallyBy) import qualified XMonad.StackSet as W import XMonad.Util.XUtils +import Control.Applicative((<$>)) -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -38,11 +50,7 @@ -- > myLayout = mouseResizableTile ||| etc.. -- > main = xmonad defaultConfig { layoutHook = myLayout } -- --- or -- --- > myLayout = mouseResizableTileMirrored ||| etc.. --- > main = xmonad defaultConfig { layoutHook = myLayout } --- -- For more detailed instructions on editing the layoutHook see: -- -- "XMonad.Doc.Extending#Editing_the_layout_hook" @@ -56,6 +64,17 @@ -- -- "XMonad.Doc.Extending#Editing_key_bindings". +-- $mrtParameters +-- The following functions are also labels for updating the @data@ (whose +-- representation is otherwise hidden) produced by 'mouseResizableTile'. +-- +-- Usage: +-- +-- > myLayout = mouseResizableTile{ masterFrac = 0.7, +-- > fracIncrement = 0.05, +-- > draggerType = BordersDragger } +-- > ||| etc.. + data MRTMessage = SetMasterFraction Rational | SetLeftSlaveFraction Int Rational | SetRightSlaveFraction Int Rational @@ -71,50 +90,68 @@ type DraggerWithRect = (Rectangle, Glyph, DraggerInfo) type DraggerWithWin = (Window, DraggerInfo) +-- | Specifies the size of the clickable area between windows. +data DraggerType = FixedDragger + { gapWidth :: Dimension -- ^ width of a gap between windows + , draggerWidth :: Dimension -- ^ width of the dragger itself + -- (will overlap windows if greater than gap) + } + | BordersDragger -- ^ no gaps, draggers overlap window borders + deriving (Show, Read) +type DraggerGeometry = (Position, Dimension, Position, Dimension) + data MouseResizableTile a = MRT { nmaster :: Int, + -- ^ Get/set the number of windows in + -- master pane (default: 1). masterFrac :: Rational, + -- ^ Get/set the proportion of screen + -- occupied by master pane (default: 1/2). + slaveFrac :: Rational, + -- ^ Get/set the proportion of remaining + -- space in a column occupied by a slave + -- window (default: 1/2). + fracIncrement :: Rational, + -- ^ Get/set the increment used when + -- modifying masterFrac/slaveFrac by the + -- Shrink, Expand, etc. messages (default: + -- 3/100). leftFracs :: [Rational], rightFracs :: [Rational], draggers :: [DraggerWithWin], + draggerType :: DraggerType, + -- ^ Get/set dragger and gap dimensions + -- (default: FixedDragger 6 6). focusPos :: Int, numWindows :: Int, isMirrored :: Bool + -- ^ Get/set whether the layout is + -- mirrored (default: False). } deriving (Show, Read) -mrtFraction :: Rational -mrtFraction = 0.5 -mrtDelta :: Rational -mrtDelta = 0.03 -mrtDraggerOffset :: Position -mrtDraggerOffset = 3 -mrtDraggerSize :: Dimension -mrtDraggerSize = 6 -mrtHDoubleArrow :: Glyph -mrtHDoubleArrow = 108 -mrtVDoubleArrow :: Glyph -mrtVDoubleArrow = 116 - mouseResizableTile :: MouseResizableTile a -mouseResizableTile = MRT 1 mrtFraction [] [] [] 0 0 False +mouseResizableTile = MRT 1 0.5 0.5 0.03 [] [] [] (FixedDragger 6 6) 0 0 False +-- | May be removed in favor of @mouseResizableTile { isMirrored = True }@ mouseResizableTileMirrored :: MouseResizableTile a -mouseResizableTileMirrored= MRT 1 mrtFraction [] [] [] 0 0 True +mouseResizableTileMirrored = mouseResizableTile { isMirrored = True } -instance LayoutClass MouseResizableTile a where - doLayout state sr (W.Stack w l r) = +instance LayoutClass MouseResizableTile Window where + doLayout state sr (W.Stack w l r) = do + drg <- draggerGeometry $ draggerType state let wins = reverse l ++ w : r num = length wins sr' = mirrorAdjust sr (mirrorRect sr) (rects, preparedDraggers) = tile (nmaster state) (masterFrac state) - (leftFracs state ++ repeat mrtFraction) - (rightFracs state ++ repeat mrtFraction) sr' num + (leftFracs state ++ repeat (slaveFrac state)) + (rightFracs state ++ repeat (slaveFrac state)) sr' num drg rects' = map (mirrorAdjust id mirrorRect . sanitizeRectangle sr') rects - in do - mapM_ deleteDragger $ draggers state - newDraggers <- mapM (createDragger sr . adjustForMirror (isMirrored state)) preparedDraggers - return (zip wins rects', Just $ state { draggers = newDraggers, - focusPos = length l, - numWindows = length wins }) + mapM_ deleteDragger $ draggers state + (draggerWrs, newDraggers) <- unzip <$> mapM + (createDragger sr . adjustForMirror (isMirrored state)) + preparedDraggers + return (draggerWrs ++ zip wins rects', Just $ state { draggers = newDraggers, + focusPos = length l, + numWindows = length wins }) where mirrorAdjust a b = if (isMirrored state) then b @@ -124,19 +161,21 @@ | Just (IncMasterN d) <- fromMessage m = return $ Just $ state { nmaster = max 0 (nmaster state + d) } | Just Shrink <- fromMessage m = - return $ Just $ state { masterFrac = max 0 (masterFrac state - mrtDelta) } + return $ Just $ state { masterFrac = max 0 (masterFrac state - fracIncrement state) } | Just Expand <- fromMessage m = - return $ Just $ state { masterFrac = min 1 (masterFrac state + mrtDelta) } + return $ Just $ state { masterFrac = min 1 (masterFrac state + fracIncrement state) } | Just ShrinkSlave <- fromMessage m = - return $ Just $ modifySlave state (-mrtDelta) + return $ Just $ modifySlave state (- fracIncrement state) | Just ExpandSlave <- fromMessage m = - return $ Just $ modifySlave state mrtDelta + return $ Just $ modifySlave state (fracIncrement state) | Just (SetMasterFraction f) <- fromMessage m = return $ Just $ state { masterFrac = max 0 (min 1 f) } | Just (SetLeftSlaveFraction pos f) <- fromMessage m = - return $ Just $ state { leftFracs = replaceAtPos (leftFracs state) pos (max 0 (min 1 f)) } + return $ Just $ state { leftFracs = replaceAtPos (slaveFrac state) + (leftFracs state) pos (max 0 (min 1 f)) } | Just (SetRightSlaveFraction pos f) <- fromMessage m = - return $ Just $ state { rightFracs = replaceAtPos (rightFracs state) pos (max 0 (min 1 f)) } + return $ Just $ state { rightFracs = replaceAtPos (slaveFrac state) + (rightFracs state) pos (max 0 (min 1 f)) } | Just e <- fromMessage m :: Maybe Event = handleResize (draggers state) (isMirrored state) e >> return Nothing | Just Hide <- fromMessage m = releaseResources >> return (Just $ state { draggers = [] }) @@ -144,45 +183,54 @@ where releaseResources = mapM_ deleteDragger $ draggers state handleMessage _ _ = return Nothing - description _ = "MouseResizableTile" + description state = mirror "MouseResizableTile" + where mirror = if isMirrored state then ("Mirror " ++) else id +draggerGeometry :: DraggerType -> X DraggerGeometry +draggerGeometry (FixedDragger g d) = + return (fromIntegral $ g `div` 2, g, fromIntegral $ d `div` 2, d) +draggerGeometry BordersDragger = do + w <- asks (borderWidth . config) + return (0, 0, fromIntegral w, 2*w) + adjustForMirror :: Bool -> DraggerWithRect -> DraggerWithRect adjustForMirror False dragger = dragger adjustForMirror True (draggerRect, draggerCursor, draggerInfo) = (mirrorRect draggerRect, draggerCursor', draggerInfo) where - draggerCursor' = if (draggerCursor == mrtHDoubleArrow) - then mrtVDoubleArrow - else mrtHDoubleArrow + draggerCursor' = if (draggerCursor == xC_sb_h_double_arrow) + then xC_sb_v_double_arrow + else xC_sb_h_double_arrow -modifySlave :: MouseResizableTile a -> Rational-> MouseResizableTile a +modifySlave :: MouseResizableTile a -> Rational -> MouseResizableTile a modifySlave state delta = let pos = focusPos state num = numWindows state nmaster' = nmaster state leftFracs' = leftFracs state rightFracs' = rightFracs state + slFrac = slaveFrac state draggersLeft = nmaster' - 1 draggersRight = (num - nmaster') - 1 in if pos < nmaster' then if draggersLeft > 0 then let draggerPos = min (draggersLeft - 1) pos - oldFraction = (leftFracs' ++ repeat mrtFraction) !! draggerPos - in state { leftFracs = replaceAtPos leftFracs' draggerPos + oldFraction = (leftFracs' ++ repeat slFrac) !! draggerPos + in state { leftFracs = replaceAtPos slFrac leftFracs' draggerPos (max 0 (min 1 (oldFraction + delta))) } else state else if draggersRight > 0 then let draggerPos = min (draggersRight - 1) (pos - nmaster') - oldFraction = (rightFracs' ++ repeat mrtFraction) !! draggerPos - in state { rightFracs = replaceAtPos rightFracs' draggerPos + oldFraction = (rightFracs' ++ repeat slFrac) !! draggerPos + in state { rightFracs = replaceAtPos slFrac rightFracs' draggerPos (max 0 (min 1 (oldFraction + delta))) } else state -replaceAtPos :: (Num t) => [Rational] -> t -> Rational -> [Rational] -replaceAtPos [] 0 x' = [x'] -replaceAtPos [] pos x' = mrtFraction : replaceAtPos [] (pos - 1) x' -replaceAtPos (_:xs) 0 x' = x' : xs -replaceAtPos (x:xs) pos x' = x : replaceAtPos xs (pos -1 ) x' +replaceAtPos :: (Num t, Eq t) => Rational -> [Rational] -> t -> Rational -> [Rational] +replaceAtPos _ [] 0 x' = [x'] +replaceAtPos d [] pos x' = d : replaceAtPos d [] (pos - 1) x' +replaceAtPos _ (_:xs) 0 x' = x' : xs +replaceAtPos d (x:xs) pos x' = x : replaceAtPos d xs (pos -1 ) x' sanitizeRectangle :: Rectangle -> Rectangle -> Rectangle sanitizeRectangle (Rectangle sx sy swh sht) (Rectangle x y wh ht) = @@ -192,44 +240,46 @@ within :: (Ord a) => a -> a -> a -> a within low high a = max low $ min high a -tile :: Int -> Rational -> [Rational] -> [Rational] -> Rectangle -> Int -> ([Rectangle], [DraggerWithRect]) -tile nmaster' masterFrac' leftFracs' rightFracs' sr num - | num <= nmaster' = splitVertically (take (num - 1) leftFracs') sr True 0 - | nmaster' == 0 = splitVertically (take (num - 1) rightFracs') sr False 0 +tile :: Int -> Rational -> [Rational] -> [Rational] -> Rectangle -> Int -> DraggerGeometry -> ([Rectangle], [DraggerWithRect]) +tile nmaster' masterFrac' leftFracs' rightFracs' sr num drg + | num <= nmaster' = splitVertically (take (num - 1) leftFracs') sr True 0 drg + | nmaster' == 0 = splitVertically (take (num - 1) rightFracs') sr False 0 drg | otherwise = (leftRects ++ rightRects, masterDragger : leftDraggers ++ rightDraggers) - where ((sr1, sr2), masterDragger) = splitHorizontallyBy masterFrac' sr - (leftRects, leftDraggers) = splitVertically (take (nmaster' - 1) leftFracs') sr1 True 0 - (rightRects, rightDraggers) = splitVertically (take (num - nmaster' - 1) rightFracs') sr2 False 0 + where ((sr1, sr2), masterDragger) = splitHorizontallyBy masterFrac' sr drg + (leftRects, leftDraggers) = splitVertically (take (nmaster' - 1) leftFracs') sr1 True 0 drg + (rightRects, rightDraggers) = splitVertically (take (num - nmaster' - 1) rightFracs') sr2 False 0 drg -splitVertically :: RealFrac r => [r] -> Rectangle -> Bool -> Int -> ([Rectangle], [DraggerWithRect]) -splitVertically [] r _ _ = ([r], []) -splitVertically (f:fx) (Rectangle sx sy sw sh) isLeft num = - let nextRect = Rectangle sx sy sw $ smallh - div mrtDraggerSize 2 +splitVertically :: RealFrac r => [r] -> Rectangle -> Bool -> Int -> DraggerGeometry -> ([Rectangle], [DraggerWithRect]) +splitVertically [] r _ _ _ = ([r], []) +splitVertically (f:fx) (Rectangle sx sy sw sh) isLeft num drg@(drOff, drSz, drOff2, drSz2) = + let nextRect = Rectangle sx sy sw $ smallh - div drSz 2 (otherRects, otherDragger) = splitVertically fx - (Rectangle sx (sy + fromIntegral smallh + mrtDraggerOffset) - sw (sh - smallh - div mrtDraggerSize 2)) - isLeft (num + 1) - draggerRect = Rectangle sx (sy + fromIntegral smallh - mrtDraggerOffset) sw mrtDraggerSize + (Rectangle sx (sy + fromIntegral smallh + drOff) + sw (sh - smallh - div drSz 2)) + isLeft (num + 1) drg + draggerRect = Rectangle sx (sy + fromIntegral smallh - drOff2) sw drSz2 draggerInfo = if isLeft then LeftSlaveDragger sy (fromIntegral sh) num else RightSlaveDragger sy (fromIntegral sh) num - nextDragger = (draggerRect, mrtVDoubleArrow, draggerInfo) + nextDragger = (draggerRect, xC_sb_v_double_arrow, draggerInfo) in (nextRect : otherRects, nextDragger : otherDragger) where smallh = floor $ fromIntegral sh * f -splitHorizontallyBy :: RealFrac r => r -> Rectangle -> ((Rectangle, Rectangle), DraggerWithRect) -splitHorizontallyBy f (Rectangle sx sy sw sh) = ((leftHalf, rightHalf), (draggerRect, mrtHDoubleArrow, draggerInfo)) +splitHorizontallyBy :: RealFrac r => r -> Rectangle -> DraggerGeometry -> ((Rectangle, Rectangle), DraggerWithRect) +splitHorizontallyBy f (Rectangle sx sy sw sh) (drOff, drSz, drOff2, drSz2) = + ((leftHalf, rightHalf), (draggerRect, xC_sb_h_double_arrow, draggerInfo)) where leftw = floor $ fromIntegral sw * f - leftHalf = Rectangle sx sy (leftw - mrtDraggerSize `div` 2) sh - rightHalf = Rectangle (sx + fromIntegral leftw + mrtDraggerOffset) sy - (sw - fromIntegral leftw - mrtDraggerSize `div` 2) sh - draggerRect = Rectangle (sx + fromIntegral leftw - mrtDraggerOffset) sy mrtDraggerSize sh + leftHalf = Rectangle sx sy (leftw - drSz `div` 2) sh + rightHalf = Rectangle (sx + fromIntegral leftw + drOff) sy + (sw - fromIntegral leftw - drSz `div` 2) sh + draggerRect = Rectangle (sx + fromIntegral leftw - drOff2) sy drSz2 sh draggerInfo = MasterDragger sx (fromIntegral sw) -createDragger :: Rectangle -> DraggerWithRect -> X DraggerWithWin +createDragger :: Rectangle -> DraggerWithRect -> X ((Window, Rectangle), DraggerWithWin) createDragger sr (draggerRect, draggerCursor, draggerInfo) = do - draggerWin <- createInputWindow draggerCursor $ sanitizeRectangle sr draggerRect - return (draggerWin, draggerInfo) + let draggerRect' = sanitizeRectangle sr draggerRect + draggerWin <- createInputWindow draggerCursor draggerRect' + return ((draggerWin, draggerRect'), (draggerWin, draggerInfo)) deleteDragger :: DraggerWithWin -> X () deleteDragger (draggerWin, _) = deleteWindow draggerWin diff --git a/XMonad/Layout/MultiColumns.hs b/XMonad/Layout/MultiColumns.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/MultiColumns.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.MultiColumns +-- Copyright : (c) Anders Engstrom +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Anders Engstrom +-- Stability : unstable +-- Portability : unportable +-- +-- This layout tiles windows in a growing number of columns. The number of +-- windows in each column can be controlled by messages. +----------------------------------------------------------------------------- + +module XMonad.Layout.MultiColumns ( + -- * Usage + -- $usage + + multiCol, + MultiCol, + ) where + +import XMonad +import qualified XMonad.StackSet as W + +import Control.Monad + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.MultiColumns +-- +-- Then edit your @layoutHook@ by adding the multiCol layout: +-- +-- > myLayouts = multiCol [1] 4 0.01 0.5 ||| etc.. +-- > main = xmonad defaultConfig { layoutHook = myLayouts } +-- +-- Or alternatively: +-- +-- > myLayouts = Mirror (multiCol [1] 2 0.01 (-0.25)) ||| etc.. +-- > main = xmonad defaultConfig { layoutHook = myLayouts } +-- +-- The maximum number of windows in a column can be controlled using the +-- IncMasterN messages and the column containing the focused window will be +-- modified. If the value is 0, all remaining windows will be placed in that +-- column when all columns before that has been filled. +-- +-- The size can be set to between 1 and -0.5. If the value is positive, the +-- master column will be of that size. The rest of the screen is split among +-- the other columns. But if the size is negative, it instead indicates the +-- size of all non-master columns and the master column will cover the rest of +-- the screen. If the master column would become smaller than the other +-- columns, the screen is instead split equally among all columns. Therefore, +-- if equal size among all columns are desired, set the size to -0.5. +-- +-- For more detailed instructions on editing the layoutHook see: +-- +-- "XMonad.Doc.Extending#Editing_the_layout_hook" + +-- | Layout constructor. +multiCol + :: [Int] -- ^ Windows in each column, starting with master. Set to 0 to catch the rest. + -> Int -- ^ Default value for all following columns. + -> Rational -- ^ How much to change size each time. + -> Rational -- ^ Initial size of master area, or column area if the size is negative. + -> MultiCol a +multiCol n defn ds s = MultiCol (map (max 0) n) (max 0 defn) ds s 0 + +data MultiCol a = MultiCol + { multiColNWin :: ![Int] + , multiColDefWin :: !Int + , multiColDeltaSize :: !Rational + , multiColSize :: !Rational + , multiColActive :: !Int + } deriving (Show,Read,Eq) + +instance LayoutClass MultiCol a where + doLayout l r s = return (zip w rlist, resl) + where rlist = doL (multiColNWin l') (multiColSize l') r wlen + w = W.integrate s + wlen = length w + -- Make sure the list of columns is big enough and update active column + nw = multiColNWin l ++ repeat (multiColDefWin l) + l' = l { multiColNWin = take (max (length $ multiColNWin l) $ getCol (wlen-1) nw + 1) nw + , multiColActive = getCol (length $ W.up s) nw + } + -- Only return new layout if it has been modified + resl = if l'==l + then Nothing + else Just l' + handleMessage l m = + return $ msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] + where resize Shrink = l { multiColSize = max (-0.5) $ s-ds } + resize Expand = l { multiColSize = min 1 $ s+ds } + incmastern (IncMasterN x) = l { multiColNWin = take a n ++ [newval] ++ tail r } + where newval = max 0 $ head r + x + r = drop a n + n = multiColNWin l + ds = multiColDeltaSize l + s = multiColSize l + a = multiColActive l + description _ = "MultiCol" + + +-- | Get which column a window is in, starting at 0. +getCol :: Int -> [Int] -> Int +getCol w (n:ns) = if n<1 || w < n + then 0 + else 1 + getCol (w-n) ns +-- Should never occur... +getCol _ _ = -1 + +doL :: [Int] -> Rational -> Rectangle -> Int -> [Rectangle] +doL nwin s r n = rlist + where -- Number of columns to tile + ncol = getCol (n-1) nwin + 1 + -- Compute the actual size + size = floor $ abs s * fromIntegral (rect_width r) + -- Extract all but last column to tile + c = take (ncol-1) nwin + -- Compute number of windows in last column and add it to the others + col = c ++ [n-sum c] + -- Compute width of columns + width = if s>0 + then if ncol==1 + -- Only one window + then [fromIntegral $ rect_width r] + -- Give the master it's space and split the rest equally for the other columns + else size:replicate (ncol-1) ((fromIntegral (rect_width r) - size) `div` (ncol-1)) + else if fromIntegral ncol * abs s >= 1 + -- Split equally + then replicate ncol $ fromIntegral (rect_width r) `div` ncol + -- Let the master cover what is left... + else (fromIntegral (rect_width r) - (ncol-1)*size):replicate (ncol-1) size + -- Compute the horizontal position of columns + xpos = accumEx (fromIntegral $ rect_x r) width + -- Exclusive accumulation + accumEx a (x:xs) = a:accumEx (a+x) xs + accumEx _ _ = [] + -- Create a rectangle for each column + cr = zipWith (\x w -> r { rect_x=fromIntegral x, rect_width=fromIntegral w }) xpos width + -- Split the columns into the windows + rlist = concat $ zipWith (\num rect -> splitVertically num rect) col cr diff --git a/XMonad/Layout/MultiToggle.hs b/XMonad/Layout/MultiToggle.hs --- a/XMonad/Layout/MultiToggle.hs +++ b/XMonad/Layout/MultiToggle.hs @@ -24,7 +24,11 @@ EOT(..), single, mkToggle, - mkToggle1 + mkToggle1, + + HList, + HCons, + MultiToggle, ) where import XMonad @@ -41,11 +45,6 @@ -- first disables any currently active transformer; i.e. it works like a -- group of radio buttons. -- --- A side effect of this meta-layout is that layout transformers no longer --- receive any messages; any message not handled by MultiToggle itself will --- undo the current layout transformer, pass the message on to the base --- layout, then reapply the transformer. --- -- To use this module, you need some data types which represent -- transformers; for some commonly used transformers (including -- MIRROR, NOBORDERS, and FULL used in the examples below) you can @@ -89,7 +88,7 @@ -- -- > data MIRROR = MIRROR deriving (Read, Show, Eq, Typeable) -- > instance Transformer MIRROR Window where --- > transform _ x k = k (Mirror x) +-- > transform _ x k = k (Mirror x) (\(Mirror x') -> x') -- -- Note, you need to put @{-\# LANGUAGE DeriveDataTypeable \#-}@ at the -- beginning of your file. @@ -97,16 +96,20 @@ -- | A class to identify custom transformers (and look up transforming -- functions by type). class (Eq t, Typeable t) => Transformer t a | t -> a where - transform :: (LayoutClass l a) => t -> l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b + transform :: (LayoutClass l a) => t -> l a -> + (forall l'. (LayoutClass l' a) => l' a -> (l' a -> l a) -> b) -> b -data EL a = forall l. (LayoutClass l a) => EL (l a) +data (LayoutClass l a) => EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a) -unEL :: EL a -> (forall l. (LayoutClass l a) => l a -> b) -> b -unEL (EL x) k = k x +unEL :: (LayoutClass l a) => EL l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b +unEL (EL x _) k = k x -transform' :: (Transformer t a) => t -> EL a -> EL a -transform' t el = el `unEL` \l -> transform t l EL +deEL :: (LayoutClass l a) => EL l a -> l a +deEL (EL x det) = det x +transform' :: (Transformer t a, LayoutClass l a) => t -> EL l a -> EL l a +transform' t (EL l det) = transform t l (\l' det' -> EL l' (det . det')) + -- | Toggle the specified layout transformer. data Toggle a = forall t. (Transformer t a) => Toggle t deriving (Typeable) @@ -117,10 +120,8 @@ deriving (Read, Show) data MultiToggle ts l a = MultiToggle{ - baseLayout :: l a, - currLayout :: EL a, + currLayout :: EL l a, currIndex :: Maybe Int, - currTrans :: EL a -> EL a, transformers :: ts } @@ -128,27 +129,23 @@ expand (MultiToggleS b i ts) = resolve ts (fromMaybe (-1) i) id (\x mt -> - let g = transform' x in - mt{ - currLayout = g . EL $ baseLayout mt, - currTrans = g - } + let g = transform' x in mt{ currLayout = g $ currLayout mt } ) - (MultiToggle b (EL b) i id ts) + (MultiToggle (EL b id) i ts) -collapse :: MultiToggle ts l a -> MultiToggleS ts l a -collapse mt = MultiToggleS (baseLayout mt) (currIndex mt) (transformers mt) +collapse :: (LayoutClass l a) => MultiToggle ts l a -> MultiToggleS ts l a +collapse mt = MultiToggleS (deEL (currLayout mt)) (currIndex mt) (transformers mt) instance (LayoutClass l a, Read (l a), HList ts a, Read ts) => Read (MultiToggle ts l a) where readsPrec p s = map (first expand) $ readsPrec p s -instance (Show ts, Show (l a)) => Show (MultiToggle ts l a) where +instance (Show ts, Show (l a), LayoutClass l a) => Show (MultiToggle ts l a) where showsPrec p = showsPrec p . collapse -- | Construct a @MultiToggle@ layout from a transformer table and a base -- layout. mkToggle :: (LayoutClass l a) => ts -> l a -> MultiToggle ts l a -mkToggle ts l = MultiToggle l (EL l) Nothing id ts +mkToggle ts l = MultiToggle (EL l id) Nothing ts -- | Construct a @MultiToggle@ layout from a single transformer and a base -- layout. @@ -190,48 +187,26 @@ geq :: (Typeable a, Eq a, Typeable b) => a -> b -> Bool geq a b = Just a == cast b -acceptChange :: (LayoutClass l' a) => MultiToggle ts l a -> ((l' a -> MultiToggle ts l a) -> b -> c) -> X b -> X c -acceptChange mt f = fmap (f (\x -> mt{ currLayout = EL x })) - instance (Typeable a, Show ts, HList ts a, LayoutClass l a) => LayoutClass (MultiToggle ts l) a where description mt = currLayout mt `unEL` \l -> description l - runLayout (Workspace i mt s) r - | isNothing (currIndex mt) = - acceptChange mt (fmap . fmap . \f x -> (f x){ baseLayout = x }) $ runLayout (Workspace i (baseLayout mt) s) r - | otherwise = currLayout mt `unEL` \l -> - acceptChange mt (fmap . fmap) $ runLayout (Workspace i l s) r + runLayout (Workspace i mt s) r = case currLayout mt of + EL l det -> fmap (fmap . fmap $ (\x -> mt { currLayout = EL x det })) $ + runLayout (Workspace i l s) r handleMessage mt m | Just (Toggle t) <- fromMessage m , i@(Just _) <- find (transformers mt) t - = currLayout mt `unEL` \l -> - if i == currIndex mt - then do - handleMessage l (SomeMessage ReleaseResources) - return . Just $ - mt{ - currLayout = EL $ baseLayout mt, - currIndex = Nothing, - currTrans = id - } - else do - handleMessage l (SomeMessage ReleaseResources) - let f = transform' t + = case currLayout mt of + EL l det -> do + l' <- fromMaybe l `fmap` handleMessage l (SomeMessage ReleaseResources) return . Just $ - mt{ - currLayout = f . EL $ baseLayout mt, - currIndex = i, - currTrans = f + mt { + currLayout = (if cur then id else transform' t) (EL (det l') id), + currIndex = if cur then Nothing else i } - | fromMessage m == Just ReleaseResources || - fromMessage m == Just Hide - = currLayout mt `unEL` \l -> acceptChange mt fmap (handleMessage l m) - | otherwise = do - ml <- handleMessage (baseLayout mt) m - case ml of - Nothing -> return Nothing - Just b' -> currLayout mt `unEL` \l -> do - handleMessage l (SomeMessage ReleaseResources) - return . Just $ - mt{ baseLayout = b', currLayout = currTrans mt . EL $ b' } + where cur = (i == currIndex mt) + | otherwise + = case currLayout mt of + EL l det -> fmap (fmap (\x -> mt { currLayout = EL x det })) $ + handleMessage l m diff --git a/XMonad/Layout/MultiToggle/Instances.hs b/XMonad/Layout/MultiToggle/Instances.hs --- a/XMonad/Layout/MultiToggle/Instances.hs +++ b/XMonad/Layout/MultiToggle/Instances.hs @@ -22,6 +22,7 @@ import XMonad import XMonad.Layout.NoBorders +import XMonad.Layout.LayoutModifier data StdTransformers = FULL -- ^ switch to Full layout | NBFULL -- ^ switch to Full with no borders @@ -31,8 +32,8 @@ deriving (Read, Show, Eq, Typeable) instance Transformer StdTransformers Window where - transform FULL _ k = k Full - transform NBFULL _ k = k (noBorders Full) - transform MIRROR x k = k (Mirror x) - transform NOBORDERS x k = k (noBorders x) - transform SMARTBORDERS x k = k (smartBorders x) + transform FULL x k = k Full (const x) + transform NBFULL x k = k (noBorders Full) (const x) + transform MIRROR x k = k (Mirror x) (\(Mirror x') -> x') + transform NOBORDERS x k = k (noBorders x) (\(ModifiedLayout _ x') -> x') + transform SMARTBORDERS x k = k (smartBorders x) (\(ModifiedLayout _ x') -> x') diff --git a/XMonad/Layout/Named.hs b/XMonad/Layout/Named.hs --- a/XMonad/Layout/Named.hs +++ b/XMonad/Layout/Named.hs @@ -10,7 +10,8 @@ -- Stability : unstable -- Portability : unportable -- --- A module for assigning a name to a given layout. +-- A module for assigning a name to a given layout. Deprecated, use +-- "XMonad.Layout.Renamed" instead. -- ----------------------------------------------------------------------------- @@ -21,8 +22,8 @@ nameTail ) where -import XMonad import XMonad.Layout.LayoutModifier +import XMonad.Layout.Renamed -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -38,22 +39,14 @@ -- For more detailed instructions on editing the layoutHook see: -- -- "XMonad.Doc.Extending#Editing_the_layout_hook" - --- | Rename a layout. -named :: String -> l a -> ModifiedLayout Named l a -named s = ModifiedLayout (Named s) - -data Named a = Named String deriving ( Read, Show ) - -instance LayoutModifier Named a where - modifyDescription (Named n) _ = n - - --- | Remove the first word of the name. -nameTail :: l a -> ModifiedLayout NameTail l a -nameTail = ModifiedLayout NameTail +-- +-- Note that this module has been deprecated and may be removed in a future +-- release, please use "XMonad.Layout.Renamed" instead. -data NameTail a = NameTail deriving (Read,Show) +-- | (Deprecated) Rename a layout. +named :: String -> l a -> ModifiedLayout Rename l a +named s = renamed [Replace s] -instance LayoutModifier NameTail a where - modifyDescription NameTail i = dropWhile (==' ') $ dropWhile (/=' ') $ description i +-- | (Deprecated) Remove the first word of the name. +nameTail :: l a -> ModifiedLayout Rename l a +nameTail = renamed [CutWordsLeft 1] diff --git a/XMonad/Layout/NoBorders.hs b/XMonad/Layout/NoBorders.hs --- a/XMonad/Layout/NoBorders.hs +++ b/XMonad/Layout/NoBorders.hs @@ -27,13 +27,13 @@ lessBorders, SetsAmbiguous(..), Ambiguity(..), - With(..) + With(..), + SmartBorder, WithBorder, ConfigurableBorder, ) where import XMonad import XMonad.Layout.LayoutModifier import qualified XMonad.StackSet as W -import Control.Monad import Data.List import qualified Data.Map as M import Data.Function (on) @@ -129,11 +129,11 @@ -- -- > layoutHook = lessBorders (Combine Difference Screen OnlyFloat) (Tall 1 0.5 0.03 ||| ... ) -- --- To get the same result as smartBorders: +-- To get the same result as 'smartBorders': -- --- > layoutHook = lessBorders (Combine Never) (Tall 1 0.5 0.03 ||| ...) +-- > layoutHook = lessBorders Never (Tall 1 0.5 0.03 ||| ...) -- --- This indirect method is required to keep the Read and Show for +-- This indirect method is required to keep the 'Read' and 'Show' for -- ConfigurableBorder so that xmonad can serialize state. class SetsAmbiguous p where hiddens :: p -> WindowSet -> Maybe (W.Stack Window) -> [(Window, Rectangle)] -> [Window] @@ -173,7 +173,7 @@ -- | In order of increasing ambiguity (less borders more frequently), where -- subsequent constructors add additional cases where borders are not drawn -- than their predecessors. These behaviors make most sense with with multiple --- screens: for single screens, Never or 'smartBorders' makes more sense. +-- screens: for single screens, 'Never' or 'smartBorders' makes more sense. data Ambiguity = Combine With Ambiguity Ambiguity -- ^ This constructor is used to combine the -- borderless windows provided by the @@ -195,7 +195,7 @@ -- | Used to indicate to the 'SetsAmbiguous' instance for 'Ambiguity' how two -- lists should be combined. -data With = Union -- ^ Combine with Data.List.union - | Difference -- ^ Combine with Data.List.\\ - | Intersection -- ^ Combine with Data.List.intersect +data With = Union -- ^ uses 'Data.List.union' + | Difference -- ^ uses 'Data.List.\\' + | Intersection -- ^ uses 'Data.List.intersect' deriving (Read, Show) diff --git a/XMonad/Layout/NoFrillsDecoration.hs b/XMonad/Layout/NoFrillsDecoration.hs --- a/XMonad/Layout/NoFrillsDecoration.hs +++ b/XMonad/Layout/NoFrillsDecoration.hs @@ -20,9 +20,13 @@ ( -- * Usage: -- $usage noFrillsDeco + + , module XMonad.Layout.SimpleDecoration + , NoFrillsDecoration ) where import XMonad.Layout.Decoration +import XMonad.Layout.SimpleDecoration -- $usage -- You can use this module with the following in your diff --git a/XMonad/Layout/PositionStoreFloat.hs b/XMonad/Layout/PositionStoreFloat.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/PositionStoreFloat.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.PositionStoreFloat +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A floating layout which has been designed with a dual-head setup +-- in mind. It makes use of "XMonad.Util.PositionStore" as well as +-- "XMonad.Hooks.PositionStoreHooks" . Since there is currently no way +-- to move or resize windows with the keyboard alone in this layout, +-- it is adviced to use it in combination with a decoration such as +-- "XMonad.Layout.NoFrillsDecoration" (to move windows) and the +-- layout modifier "XMonad.Layout.BorderResize" (to resize windows). +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.PositionStoreFloat + ( -- * Usage + -- $usage + positionStoreFloat, PositionStoreFloat + ) where + +import XMonad +import XMonad.Util.PositionStore +import qualified XMonad.StackSet as S +import XMonad.Layout.WindowArranger +import Control.Monad(when) +import Data.Maybe(isJust) +import Data.List(nub) + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.PositionStoreFloat +-- > import XMonad.Layout.NoFrillsDecoration +-- > import XMonad.Layout.BorderResize +-- +-- Then edit your @layoutHook@ by adding the PositionStoreFloat layout. +-- Below is a suggestion which uses the mentioned NoFrillsDecoration and +-- BorderResize: +-- +-- > myLayouts = floatingDeco $ borderResize $ positionStoreFloat ||| etc.. +-- > where floatingDeco l = noFrillsDeco shrinkText defaultTheme l +-- > main = xmonad defaultConfig { layoutHook = myLayouts } +-- +-- See the documentation of "XMonad.Hooks.PositionStoreHooks" on how +-- to add the support hooks. + +positionStoreFloat :: PositionStoreFloat a +positionStoreFloat = PSF (Nothing, []) + +data PositionStoreFloat a = PSF (Maybe Rectangle, [a]) deriving (Show, Read) +instance LayoutClass PositionStoreFloat Window where + description _ = "PSF" + doLayout (PSF (maybeChange, paintOrder)) sr (S.Stack w l r) = do + posStore <- getPosStore + let wrs = map (\w' -> (w', pSQ posStore w' sr)) (reverse l ++ r) + let focused = case maybeChange of + Nothing -> (w, pSQ posStore w sr) + Just changedRect -> (w, changedRect) + let wrs' = focused : wrs + let paintOrder' = nub (w : paintOrder) + when (isJust maybeChange) $ do + updatePositionStore focused sr + return (reorder wrs' paintOrder', Just $ PSF (Nothing, paintOrder')) + where + pSQ posStore w' sr' = case (posStoreQuery posStore w' sr') of + Just rect -> rect + Nothing -> (Rectangle 50 50 200 200) -- should usually not happen + pureMessage (PSF (_, paintOrder)) m + | Just (SetGeometry rect) <- fromMessage m = + Just $ PSF (Just rect, paintOrder) + | otherwise = Nothing + +updatePositionStore :: (Window, Rectangle) -> Rectangle -> X () +updatePositionStore (w, rect) sr = modifyPosStore (\ps -> + posStoreInsert ps w rect sr) + +reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)] +reorder wrs order = + let ordered = concat $ map (pickElem wrs) order + rest = filter (\(w, _) -> not (w `elem` order)) wrs + in ordered ++ rest + where + pickElem list e = case (lookup e list) of + Just result -> [(e, result)] + Nothing -> [] diff --git a/XMonad/Layout/Reflect.hs b/XMonad/Layout/Reflect.hs --- a/XMonad/Layout/Reflect.hs +++ b/XMonad/Layout/Reflect.hs @@ -18,7 +18,8 @@ -- $usage reflectHoriz, reflectVert, - REFLECTX(..), REFLECTY(..) + REFLECTX(..), REFLECTY(..), + Reflect ) where @@ -28,6 +29,7 @@ import XMonad.Layout.LayoutModifier import XMonad.Layout.MultiToggle +import XMonad.Util.XUtils (fi) -- $usage -- You can use this module by importing it into your @~\/.xmonad\/xmonad.hs@ file: @@ -84,8 +86,6 @@ reflectRect Vert (Rectangle _ sy _ sh) (Rectangle rx ry rw rh) = Rectangle rx (2*sy + fi sh - ry - fi rh) rw rh -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral data Reflect a = Reflect ReflectDir deriving (Show, Read) @@ -105,7 +105,7 @@ data REFLECTY = REFLECTY deriving (Read, Show, Eq, Typeable) instance Transformer REFLECTX Window where - transform REFLECTX x k = k (reflectHoriz x) + transform REFLECTX x k = k (reflectHoriz x) (\(ModifiedLayout _ x') -> x') instance Transformer REFLECTY Window where - transform REFLECTY x k = k (reflectVert x) + transform REFLECTY x k = k (reflectVert x) (\(ModifiedLayout _ x') -> x') diff --git a/XMonad/Layout/Renamed.hs b/XMonad/Layout/Renamed.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/Renamed.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Groups +-- Copyright : Quentin Moser +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : orphaned +-- Stability : unstable +-- Portability : unportable +-- +-- Layout modifier that can modify the description of its underlying +-- layout on a (hopefully) flexible way. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Renamed ( -- * Usage + -- $usage + renamed + , Rename(..) ) where + +import XMonad +import XMonad.Layout.LayoutModifier + +-- $usage +-- You can use this module by adding +-- +-- > import XMonad.Layout.Renamed +-- +-- to your @~\/.xmonad\/xmonad.hs@. +-- +-- You can then use 'renamed' to modify the description of your +-- layouts. For example: +-- +-- > myLayout = renamed [PrependWords "Awesome"] $ tiled ||| Mirror tiled ||| Full + +-- | Apply a list of 'Rename' values to a layout, from left to right. +renamed :: [Rename a] -> l a -> ModifiedLayout Rename l a +renamed = ModifiedLayout . Chain + +-- | The available renaming operations +data Rename a = CutLeft Int -- ^ Remove a number of characters from the left + | CutRight Int -- ^ Remove a number of characters from the right + | Append String -- ^ Add a string on the right + | Prepend String -- ^ Add a string on the left + | CutWordsLeft Int -- ^ Remove a number of words from the left + | CutWordsRight Int -- ^ Remove a number of words from the right + | AppendWords String -- ^ Add a string to the right, prepending a space to it + -- if necessary + | PrependWords String -- ^ Add a string to the left, appending a space to it if + -- necessary + | Replace String -- ^ Repace with another wtring + | Chain [Rename a] -- ^ Apply a list of modifications in left-to-right order + deriving (Show, Read, Eq) + +apply :: Rename a -> String -> String +apply (CutLeft i) s = drop i s +apply (CutRight i) s = take (length s - i) s +apply (CutWordsLeft i) s = unwords $ drop i $ words s +apply (CutWordsRight i) s = let ws = words s + in unwords $ take (length ws - i) ws +apply (Replace s) _ = s +apply (Append s') s = s ++ s' +apply (Prepend s') s = s' ++ s +apply (AppendWords s') s = unwords $ words s ++ [s'] +apply (PrependWords s') s = unwords $ s' : words s +apply (Chain rs) s = ($s) $ foldr (flip (.)) id $ map apply rs + +instance LayoutModifier Rename a where + modifyDescription r l = apply r (description l) diff --git a/XMonad/Layout/ResizeScreen.hs b/XMonad/Layout/ResizeScreen.hs --- a/XMonad/Layout/ResizeScreen.hs +++ b/XMonad/Layout/ResizeScreen.hs @@ -22,6 +22,7 @@ , resizeHorizontalRight, resizeVerticalBottom , withNewRectangle , ResizeScreen (..) + , ResizeMode ) where import XMonad diff --git a/XMonad/Layout/ShowWName.hs b/XMonad/Layout/ShowWName.hs --- a/XMonad/Layout/ShowWName.hs +++ b/XMonad/Layout/ShowWName.hs @@ -19,6 +19,7 @@ , showWName' , defaultSWNConfig , SWNConfig(..) + , ShowWName ) where import XMonad @@ -96,7 +97,7 @@ 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 "" "" (swn_color c) (swn_bgcolor c) AlignCenter n + paintAndWrite w f (fi width) (fi hight) 0 "" "" (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 @@ -17,12 +17,13 @@ -- * Usage -- $usage - spacing + spacing, Spacing, ) where import Graphics.X11 (Rectangle(..)) import Control.Arrow (second) +import XMonad.Util.Font (fi) import XMonad.Layout.LayoutModifier @@ -51,4 +52,3 @@ 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) - where fi n = fromIntegral n -- avoid the DMR diff --git a/XMonad/Layout/Spiral.hs b/XMonad/Layout/Spiral.hs --- a/XMonad/Layout/Spiral.hs +++ b/XMonad/Layout/Spiral.hs @@ -21,6 +21,8 @@ , spiralWithDir , Rotation (..) , Direction (..) + + , SpiralWithDir ) where import Data.Ratio diff --git a/XMonad/Layout/SubLayouts.hs b/XMonad/Layout/SubLayouts.hs --- a/XMonad/Layout/SubLayouts.hs +++ b/XMonad/Layout/SubLayouts.hs @@ -28,6 +28,8 @@ defaultSublMap, + Sublayout, + -- * Screenshots -- $screenshots @@ -51,13 +53,10 @@ import XMonad import Control.Applicative((<$>),(<*)) import Control.Arrow(Arrow(second, (&&&))) -import Control.Monad(Monad(return), Functor(..), - MonadPlus(mplus), (=<<), sequence, foldM, guard, when, join) -import Data.Function((.), ($), flip, id, on) -import Data.List((++), foldr, filter, map, concatMap, elem, - notElem, null, nubBy, (\\), find) -import Data.Maybe(Maybe(..), isNothing, maybe, fromMaybe, listToMaybe, - mapMaybe) +import Control.Monad(MonadPlus(mplus), foldM, guard, when, join) +import Data.Function(on) +import Data.List(nubBy, (\\), find) +import Data.Maybe(isNothing, fromMaybe, listToMaybe, mapMaybe) import Data.Traversable(sequenceA) import qualified XMonad.Layout.BoringWindows as B diff --git a/XMonad/Layout/TabBarDecoration.hs b/XMonad/Layout/TabBarDecoration.hs --- a/XMonad/Layout/TabBarDecoration.hs +++ b/XMonad/Layout/TabBarDecoration.hs @@ -66,7 +66,7 @@ instance Eq a => DecorationStyle TabBarDecoration a where describeDeco _ = "TabBar" shrink _ _ r = r - decorationMouseDragHook _ _ _ = return () + decorationCatchClicksHook _ mainw _ _ = focus mainw >> return True pureDecoration (TabBar p) _ dht (Rectangle x y wh ht) s _ (w,_) = if isInStack s w then Just $ Rectangle nx ny wid (fi dht) else Nothing where wrs = S.integrate s diff --git a/XMonad/Layout/Tabbed.hs b/XMonad/Layout/Tabbed.hs --- a/XMonad/Layout/Tabbed.hs +++ b/XMonad/Layout/Tabbed.hs @@ -26,9 +26,9 @@ , TabbedDecoration (..) , shrinkText, CustomShrink(CustomShrink) , Shrinker(..) + , TabbarShown, TabbarLocation ) where -import Data.Maybe import Data.List import XMonad @@ -81,7 +81,7 @@ -- This is a minimal working configuration: -- -- > import XMonad --- > import XMonad.Layout.DecorationMadness +-- > import XMonad.Layout.Tabbed -- > main = xmonad defaultConfig { layoutHook = simpleTabbed } simpleTabbed :: ModifiedLayout (Decoration TabbedDecoration DefaultShrinker) Simplest Window simpleTabbed = tabbed shrinkText defaultTheme @@ -155,17 +155,16 @@ instance Eq a => DecorationStyle TabbedDecoration a where describeDeco (Tabbed Top _ ) = "Tabbed" describeDeco (Tabbed Bottom _ ) = "Tabbed Bottom" - decorationMouseFocusHook _ ds ButtonEvent { ev_window = ew - , ev_event_type = et - , ev_button = eb } + decorationEventHook _ ds ButtonEvent { ev_window = ew + , ev_event_type = et + , ev_button = eb } | et == buttonPress , Just ((w,_),_) <-findWindowByDecoration ew ds = if eb == button2 then killWindow w else focus w - decorationMouseFocusHook _ _ _ = return () + decorationEventHook _ _ _ = return () - decorationMouseDragHook _ _ _ = return () pureDecoration (Tabbed lc sh) _ ht _ s wrs (w,r@(Rectangle x y wh hh)) = if ((sh == Always && numWindows > 0) || numWindows > 1) then Just $ case lc of diff --git a/XMonad/Layout/ToggleLayouts.hs b/XMonad/Layout/ToggleLayouts.hs --- a/XMonad/Layout/ToggleLayouts.hs +++ b/XMonad/Layout/ToggleLayouts.hs @@ -16,7 +16,7 @@ module XMonad.Layout.ToggleLayouts ( -- * Usage -- $usage - toggleLayouts, ToggleLayout(..) + toggleLayouts, ToggleLayout(..), ToggleLayouts ) where import XMonad diff --git a/XMonad/Layout/TrackFloating.hs b/XMonad/Layout/TrackFloating.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/TrackFloating.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} +{- | + +Module : XMonad.Layout.TrackFloating +Copyright : (c) 2010 Adam Vogt +License : BSD-style (see xmonad/LICENSE) + +Maintainer : vogt.adam@gmail.com +Stability : unstable +Portability : unportable + +Layout modifier that tracks focus in the tiled layer while the floating layer +is in use. This is particularly helpful for tiled layouts where the focus +determines what is visible. + +The relevant bug is Issue 4 +. +-} +module XMonad.Layout.TrackFloating + (-- * Usage + -- $usage + + -- ** For other layout modifiers + -- $layoutModifier + trackFloating, + TrackFloating, + ) where + +import Control.Monad +import Data.Function +import Data.List +import Data.Maybe +import qualified Data.Map as M +import qualified Data.Set as S + +import XMonad +import XMonad.Layout.LayoutModifier +import qualified XMonad.StackSet as W + + +data TrackFloating a = TrackFloating + { _wasFloating :: Bool, + _tiledFocus :: Maybe Window } + deriving (Read,Show,Eq) + + +instance LayoutModifier TrackFloating Window where + modifyLayoutWithUpdate os@(TrackFloating wasF mw) ws@(W.Workspace{ W.stack = ms }) r + = do + winset <- gets windowset + let xCur = fmap W.focus xStack + xStack = W.stack $ W.workspace $ W.current winset + isF = fmap (\x -> x `M.member` W.floating winset || + (let (\\\) = (S.\\) `on` (S.fromList . W.integrate') + in x `S.member` (xStack \\\ ms))) + xCur + newStack + -- focus is floating, so use the remembered focus point + | Just isF' <- isF, + isF' || wasF, + Just w <- mw, + Just s <- ms, + Just ns <- find ((==) w . W.focus) + $ zipWith const (iterate W.focusDown' s) (W.integrate s) + = Just ns + | otherwise + = ms + newState = case isF of + Just True -> mw + Just False | Just f <- xCur -> Just f + _ -> Nothing + ran <- runLayout ws{ W.stack = newStack } r + return (ran, + let n = TrackFloating (fromMaybe False isF) newState + in guard (n /= os) >> Just n) + + +{- $usage + +Apply to your layout in a config like: + +> main = xmonad (defaultConfig{ +> layoutHook = trackFloating +> (noBorders Full ||| Tall 1 0.3 0.5), +> ... +> }) + +-} + +{- | Runs another layout with a remembered focus, provided: + +* the subset of windows doesn't include the focus in XState + +* it was previously run with a subset that included the XState focus + +* the remembered focus hasn't since been killed + +-} +trackFloating :: l a -> ModifiedLayout TrackFloating l a +trackFloating layout = ModifiedLayout (TrackFloating False Nothing) layout + +{- $layoutModifier +It also corrects focus issues for full-like layouts inside other layout +modifiers: + +> import XMonad.Layout.IM +> import XMonad.Layout.Tabbed +> import XMonad.Layout.TrackFloating +> import XMonad.Layout.Reflect + +> gimpLayout = withIM 0.11 (Role "gimp-toolbox") $ reflectHoriz +> $ withIM 0.15 (Role "gimp-dock") (trackFloating simpleTabbed) + +Interactions with some layout modifiers (ex. decorations, minimizing) are +unknown but likely unpleasant. +-} diff --git a/XMonad/Layout/WindowArranger.hs b/XMonad/Layout/WindowArranger.hs --- a/XMonad/Layout/WindowArranger.hs +++ b/XMonad/Layout/WindowArranger.hs @@ -32,7 +32,6 @@ import Control.Arrow import Data.List -import Data.Maybe -- $usage -- You can use this module with the following in your diff --git a/XMonad/Layout/WindowNavigation.hs b/XMonad/Layout/WindowNavigation.hs --- a/XMonad/Layout/WindowNavigation.hs +++ b/XMonad/Layout/WindowNavigation.hs @@ -21,7 +21,8 @@ Navigate(..), Direction2D(..), MoveWindowToWindow(..), navigateColor, navigateBrightness, - noNavigateBorders, defaultWNConfig + noNavigateBorders, defaultWNConfig, + WNConfig, WindowNavigation, ) where import Data.List ( nub, sortBy, (\\) ) diff --git a/XMonad/Layout/WindowSwitcherDecoration.hs b/XMonad/Layout/WindowSwitcherDecoration.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/WindowSwitcherDecoration.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.WindowSwitcherDecoration +-- Copyright : (c) Jan Vornberger 2009 +-- Alejandro Serrano 2010 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A decoration that allows to switch the position of windows by dragging +-- them onto each other. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.WindowSwitcherDecoration + ( -- * Usage: + -- $usage + windowSwitcherDecoration, + windowSwitcherDecorationWithButtons, + windowSwitcherDecorationWithImageButtons, + WindowSwitcherDecoration, ImageWindowSwitcherDecoration, + ) where + +import XMonad +import XMonad.Layout.Decoration +import XMonad.Layout.DecorationAddons +import XMonad.Layout.ImageButtonDecoration +import XMonad.Layout.DraggingVisualizer +import qualified XMonad.StackSet as S +import Control.Monad +import Foreign.C.Types(CInt) + +-- $usage +-- You can use this module with the following in your +-- @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.WindowSwitcherDecoration +-- > import XMonad.Layout.DraggingVisualizer +-- +-- Then edit your @layoutHook@ by adding the WindowSwitcherDecoration to +-- your layout: +-- +-- > myL = windowSwitcherDecoration shrinkText defaultTheme (draggingVisualizer $ layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- +-- There is also a version of the decoration that contains buttons like +-- "XMonad.Layout.ButtonDecoration". To use that version, you will need to +-- import "XMonad.Layout.DecorationAddons" as well and modify your @layoutHook@ +-- in the following way: +-- +-- > import XMonad.Layout.DecorationAddons +-- > +-- > myL = windowSwitcherDecorationWithButtons shrinkText defaultThemeWithButtons (draggingVisualizer $ layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- +-- Additionaly, there is a version of the decoration that contains image buttons like +-- "XMonad.Layout.ImageButtonDecoration". To use that version, you will need to +-- import "XMonad.Layout.ImageButtonDecoration" as well and modify your @layoutHook@ +-- in the following way: +-- +-- > import XMonad.Layout.ImageButtonDecoration +-- > +-- > myL = windowSwitcherDecorationWithImageButtons shrinkText defaultThemeWithImageButtons (draggingVisualizer $ layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- + +windowSwitcherDecoration :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration WindowSwitcherDecoration s) l a +windowSwitcherDecoration s c = decoration s c $ WSD False + +windowSwitcherDecorationWithButtons :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration WindowSwitcherDecoration s) l a +windowSwitcherDecorationWithButtons s c = decoration s c $ WSD True + +data WindowSwitcherDecoration a = WSD Bool deriving (Show, Read) + +instance Eq a => DecorationStyle WindowSwitcherDecoration a where + describeDeco _ = "WindowSwitcherDeco" + + decorationCatchClicksHook (WSD withButtons) mainw dFL dFR = if withButtons + then titleBarButtonHandler mainw dFL dFR + else return False + decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleTiledDraggingInProgress ex ey (mainw, r) x y + decorationAfterDraggingHook _ (mainw, _) decoWin = do focus mainw + hasCrossed <- handleScreenCrossing mainw decoWin + unless hasCrossed $ do sendMessage $ DraggingStopped + performWindowSwitching mainw + +-- Note: the image button code is duplicated from the above +-- because the title bar handle is different + +windowSwitcherDecorationWithImageButtons :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration ImageWindowSwitcherDecoration s) l a +windowSwitcherDecorationWithImageButtons s c = decoration s c $ IWSD True + +data ImageWindowSwitcherDecoration a = IWSD Bool deriving (Show, Read) + +instance Eq a => DecorationStyle ImageWindowSwitcherDecoration a where + describeDeco _ = "ImageWindowSwitcherDeco" + + decorationCatchClicksHook (IWSD withButtons) mainw dFL dFR = if withButtons + then imageTitleBarButtonHandler mainw dFL dFR + else return False + decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleTiledDraggingInProgress ex ey (mainw, r) x y + decorationAfterDraggingHook _ (mainw, _) decoWin = do focus mainw + hasCrossed <- handleScreenCrossing mainw decoWin + unless hasCrossed $ do sendMessage $ DraggingStopped + performWindowSwitching mainw + +handleTiledDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X () +handleTiledDraggingInProgress ex ey (mainw, r) x y = do + let rect = Rectangle (x - (fi ex - rect_x r)) + (y - (fi ey - rect_y r)) + (rect_width r) + (rect_height r) + sendMessage $ DraggingWindow mainw rect + +performWindowSwitching :: Window -> X () +performWindowSwitching win = + withDisplay $ \d -> do + root <- asks theRoot + (_, _, selWin, _, _, _, _, _) <- io $ queryPointer d root + ws <- gets windowset + let allWindows = S.index ws + -- do a little double check to be sure + if (win `elem` allWindows) && (selWin `elem` allWindows) + then do + let allWindowsSwitched = map (switchEntries win selWin) allWindows + let (ls, t:rs) = break (win ==) allWindowsSwitched + let newStack = S.Stack t (reverse ls) rs + windows $ S.modify' $ \_ -> newStack + else return () + where + switchEntries a b x + | x == a = b + | x == b = a + | otherwise = x diff --git a/XMonad/Layout/WorkspaceDir.hs b/XMonad/Layout/WorkspaceDir.hs --- a/XMonad/Layout/WorkspaceDir.hs +++ b/XMonad/Layout/WorkspaceDir.hs @@ -25,9 +25,12 @@ -- * Usage -- $usage workspaceDir, - changeDir + changeDir, + WorkspaceDir, ) where +import Prelude hiding (catch) +import Control.Exception import System.Directory ( setCurrentDirectory, getCurrentDirectory ) import Control.Monad ( when ) @@ -38,6 +41,9 @@ 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@: -- @@ -84,7 +90,7 @@ cleanDir x = scd x >> io getCurrentDirectory scd :: String -> X () -scd x = do x' <- io (runProcessWithInput "bash" [] ("echo -n " ++ x) `catch` \_ -> return x) +scd x = do x' <- io (runProcessWithInput "bash" [] ("echo -n " ++ x) `catch` econst x) catchIO $ setCurrentDirectory x' changeDir :: XPConfig -> X () diff --git a/XMonad/Layout/ZoomRow.hs b/XMonad/Layout/ZoomRow.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/ZoomRow.hs @@ -0,0 +1,258 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses + , PatternGuards, DeriveDataTypeable, ExistentialQuantification + , FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ZoomRow +-- Copyright : Quentin Moser +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : orphaned +-- Stability : unstable +-- Portability : unportable +-- +-- Row layout with individually resizable elements. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.ZoomRow ( -- * Usage + -- $usage + ZoomRow + -- * Creation + , zoomRow + -- * Messages + , ZoomMessage(..) + , zoomIn + , zoomOut + , zoomReset + -- * Use with non-'Eq' elements + -- $noneq + , zoomRowWith + , EQF(..) + , ClassEQ(..) + ) where + +import XMonad +import qualified XMonad.StackSet as W + +import XMonad.Util.Stack +import XMonad.Layout.Decoration (fi) + +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 +-- and decreased, and a window can be set to use the whole available +-- space whenever it has focus. +-- +-- You can use this module by including the following in your @~\/.xmonad/xmonad.hs@: +-- +-- > import XMonad.Layout.ZoomRow +-- +-- and using 'zoomRow' somewhere in your 'layoutHook', for example: +-- +-- > myLayout = zoomRow ||| Mirror zoomRow +-- +-- To be able to resize windows, you can create keybindings to send +-- the relevant 'ZoomMessage's: +-- +-- > -- Increase the size occupied by the focused window +-- > , ((modMask .|. shifMask, xK_minus), sendMessage zoomIn) +-- > -- Decrease the size occupied by the focused window +-- > , ((modMayk , xK_minus), sendMessage zoomOut) +-- > -- Reset the size occupied by the focused window +-- > , ((modMask , xK_equal), sendMessage zoomReset) +-- > -- (Un)Maximize the focused window +-- > , ((modMask , xK_f ), sendMessage ToggleZoomFull) +-- +-- For more information on editing your layout hook and key bindings, +-- see "XMonad.Doc.Extending". + +-- * Creation functions + +-- | 'ZoomRow' layout for laying out elements which are instances of +-- 'Eq'. Perfect for 'Window's. +zoomRow :: (Eq a, Show a, Read a) => ZoomRow ClassEQ a +zoomRow = ZC ClassEQ emptyZ + +-- $noneq +-- 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 +-- 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. + +-- | ZoomRow layout with a custom equality predicate. It should +-- of course satisfy the laws for 'Eq', and you should also make +-- 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) + => f a -> ZoomRow f a +zoomRowWith f = ZC f emptyZ + + +-- * The datatypes + +-- | A layout that arranges its windows in a horizontal row, +-- and allows to change the relative size of each element +-- independently. +data ZoomRow f a = ZC { zoomEq :: f a + -- ^ Function to compare elements for + -- equality, a real Eq instance might + -- not be what you want in some cases + , zoomRatios :: (Zipper (Elt a)) + -- ^ Element specs. The zipper is so we + -- know what the focus is when we handle + -- a message + } + deriving (Show, Read, Eq) + +-- | Class for equivalence relations. Must be transitive, reflexive. +class EQF f a where + eq :: f a -> a -> a -> Bool + +-- | To use the usual '==': +data ClassEQ a = ClassEQ + deriving (Show, Read, Eq) + +instance Eq a => EQF ClassEQ a where + eq _ a b = a == b + +-- | Size specification for an element. +data Elt a = E { elt :: a -- ^ The element + , ratio :: Rational -- ^ Its size ratio + , full :: Bool -- ^ Whether it should occupy all the + -- available space when it has focus. + } + deriving (Show, Read, Eq) + + +-- * Helpers + +getRatio :: Elt a -> (a, Rational) +getRatio (E a r _) = (a,r) + +lookupBy :: (a -> a -> Bool) -> a -> [Elt a] -> Maybe (Elt a) +lookupBy _ _ [] = Nothing +lookupBy f a (E a' r b : _) | f a a' = Just $ E a r b +lookupBy f a (_:es) = lookupBy f a es + +setFocus :: Zipper a -> a -> Zipper a +setFocus Nothing a = Just $ W.Stack a [] [] +setFocus (Just s) a = Just s { W.focus = a } + + +-- * Messages + +-- | The type of messages accepted by a 'ZoomRow' layout +data ZoomMessage = Zoom Rational + -- ^ Multiply the focused window's size factor + -- by the given number. + | ZoomTo Rational + -- ^ Set the focused window's size factor to the + -- given number. + | ZoomFull Bool + -- ^ Set whether the focused window should occupy + -- all available space when it has focus + | ZoomFullToggle + -- ^ Toggle whether the focused window should + -- occupy all available space when it has focus + deriving (Typeable, Show) + +instance Message ZoomMessage + +-- | Increase the size of the focused window. +-- Defined as @Zoom 1.5@ +zoomIn :: ZoomMessage +zoomIn = Zoom 1.5 + +-- | Decrease the size of the focused window. +-- Defined as @Zoom (2/3)@ +zoomOut :: ZoomMessage +zoomOut = Zoom $ 2/3 + +-- | Reset the size of the focused window. +-- Defined as @ZoomTo 1@ +zoomReset :: ZoomMessage +zoomReset = ZoomTo 1 + + +-- * LayoutClass instance + +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 + then " (Max)" + else "" + + emptyLayout (ZC _ Nothing) _ = return ([], Nothing) + emptyLayout (ZC f _) _ = return ([], Just $ ZC f Nothing) + + doLayout (ZC f zelts) r@(Rectangle _ _ w _) s + = let elts = W.integrate' zelts + zelts' = mapZ_ (\a -> fromMaybe (E a 1 False) + $ lookupBy (eq f) a elts) $ Just s + elts' = W.integrate' zelts' + + maybeL' = if zelts `noChange` zelts' + then Nothing + else Just $ ZC f zelts' + + total = sum $ map ratio elts' + + widths = map (second ((* fi w) . (/total)) . getRatio) elts' + + in case getFocusZ zelts' of + Just (E a _ True) -> return ([(a, r)], maybeL') + _ -> return (makeRects r widths, maybeL') + + where makeRects :: Rectangle -> [(a, Rational)] -> [(a, Rectangle)] + makeRects r pairs = let as = map fst pairs + widths = map snd pairs + discreteWidths = snd $ foldr discretize (0, []) widths + rectangles = snd $ foldr makeRect (r, []) discreteWidths + in zip as rectangles + + -- | Make a new rectangle by substracting the given width from the available + -- space (from the right, since this is a foldr) + makeRect :: Dimension -> (Rectangle, [Rectangle]) -> (Rectangle, [Rectangle]) + makeRect w (Rectangle x y w0 h, rs) = ( Rectangle x y (w0-w) h + , Rectangle (x+fi w0-fi w) y w h : rs ) + + -- | Round a list of fractions in a way that maintains the total. + -- If you know a better way to do this I'm very interested. + discretize :: Rational -> (Rational, [Dimension]) -> (Rational, [Dimension]) + discretize r (carry, ds) = let (d, carry') = properFraction $ carry+r + in (carry', d:ds) + + noChange z1 z2 = toTags z1 `helper` toTags z2 + where helper [] [] = True + helper (Right a:as) (Right b:bs) = a `sameAs` b && as `helper` bs + helper (Left a:as) (Left b:bs) = a `sameAs` b && as `helper` bs + helper _ _ = False + E a1 r1 b1 `sameAs` E a2 r2 b2 = (eq f a1 a2) && (r1 == r2) && (b1 == b2) + + pureMessage (ZC f zelts) sm | Just (ZoomFull False) <- fromMessage sm + , Just (E a r True) <- getFocusZ zelts + = Just $ ZC f $ setFocus zelts $ E a r False + + pureMessage (ZC f zelts) sm | Just (ZoomFull True) <- fromMessage sm + , Just (E a r False) <- getFocusZ zelts + = Just $ ZC f $ setFocus zelts $ E a r True + + pureMessage (ZC f zelts) sm | Just (E a r b) <- getFocusZ zelts + = 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) + $ SomeMessage $ ZoomFull $ not b + _ -> Nothing + + pureMessage _ _ = Nothing diff --git a/XMonad/Prompt.hs b/XMonad/Prompt.hs --- a/XMonad/Prompt.hs +++ b/XMonad/Prompt.hs @@ -29,7 +29,8 @@ , defaultXPKeymap , quit , killBefore, killAfter, startOfLine, endOfLine - , pasteString, copyString, moveCursor + , pasteString, moveCursor + , setInput, getInput , moveWord, killWord, deleteString , moveHistory, setSuccess, setDone , Direction1D(..) @@ -51,39 +52,43 @@ , splitInSubListsAt , breakAtSpace , uniqSort - , decodeInput - , encodeOutput , historyCompletion , historyCompletionP -- * History filters , deleteAllDuplicates , deleteConsecutive + , HistoryMatches + , initMatches + , historyUpMatching + , historyDownMatching + -- * Types + , XPState ) where import Prelude hiding (catch) -import XMonad hiding (config, io, numlockMask, cleanMask) -import qualified XMonad as X (numlockMask,config) +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, putSelection) +import XMonad.Util.XSelection (getSelection) +import Codec.Binary.UTF8.String (decodeString) +import Control.Applicative ((<$>)) import Control.Arrow ((&&&),first) import Control.Concurrent (threadDelay) -import Control.Monad.Reader +import Control.Exception.Extensible hiding (handle) import Control.Monad.State -import Control.Applicative ((<$>)) -import Data.Char import Data.Bits -import Data.Maybe +import Data.Char (isSpace) +import Data.IORef import Data.List +import Data.Maybe (fromMaybe) import Data.Set (fromList, toList) -import System.Directory +import System.Directory (getAppUserDataDirectory) import System.IO import System.Posix.Files -import Control.Exception.Extensible hiding (handle) - import qualified Data.Map as M -- $usage @@ -136,7 +141,10 @@ , 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 - -- and delay by x microseconds + -- and delay by x microseconds + , searchPredicate :: String -> String -> Bool + -- ^ Given the typed string and a possible + -- completion, is the completion valid? } data XPType = forall p . XPrompt p => XPT p @@ -210,15 +218,17 @@ , historyFilter = id , defaultText = [] , autoComplete = Nothing - , showCompletionOnTab = False } -greenXPConfig = defaultXPConfig { fgColor = "green", bgColor = "black" } + , showCompletionOnTab = False + , searchPredicate = isPrefixOf + } +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 -> XPState -initState d rw w s compl gc fonts pt h c = + -> GC -> XMonadFont -> p -> [String] -> XPConfig -> KeyMask -> XPState +initState d rw w s compl gc fonts pt h c nm = XPS { dpy = d , rootw = rw , win = w @@ -237,7 +247,7 @@ , config = c , successful = False , done = False - , numlockMask = X.numlockMask defaultConfig + , numlockMask = nm } -- this would be much easier with functional references @@ -247,6 +257,15 @@ setCommand :: String -> XPState -> XPState setCommand xs s = s { commandHistory = (commandHistory s) { W.focus = xs }} +-- | Sets the input string to the given value. +setInput :: String -> XP () +setInput = modify . setCommand + +-- | Returns the current input string. Intented for use in custom keymaps +-- where the 'get' or similar can't be used to retrieve it. +getInput :: XP String +getInput = gets command + -- | Same as 'mkXPrompt', except that the action function can have -- type @String -> X a@, for any @a@, and the final action returned -- by 'mkXPromptWithReturn' will have type @X (Maybe a)@. @Nothing@ @@ -255,30 +274,28 @@ -- module. mkXPromptWithReturn :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X a) -> X (Maybe a) mkXPromptWithReturn t conf compl action = do - c <- ask - let d = display c - rw = theRoot c - s <- gets $ screenRect . W.screenDetail . W.current . windowset - hist <- liftIO readHistory - w <- liftIO $ createWin d rw conf s - liftIO $ selectInput d w $ exposureMask .|. keyPressMask - gc <- liftIO $ createGC d w - liftIO $ setGraphicsExposures d gc False + 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 <- asks $ X.numlockMask . X.config + 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) - { numlockMask = numlock } - st' <- liftIO $ execStateT runXP st + st = initState d rw w s compl gc fs (XPT t) hs conf numlock + st' <- io $ execStateT runXP st releaseXMF fs - liftIO $ freeGC d gc + io $ freeGC d gc if successful st' then do - liftIO $ writeHistory $ M.insertWith - (\xs ys -> take (historySize conf) - . historyFilter conf $ xs ++ ys) - (showXPrompt t) (historyFilter conf [command st']) + 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 @@ -302,8 +319,7 @@ runXP :: XP () runXP = do - st <- get - let (d,w) = (dpy &&& win) st + (d,w) <- gets (dpy &&& win) status <- io $ grabKeyboard d w True grabModeAsync grabModeAsync currentTime when (status == grabSuccess) $ do updateWindows @@ -403,13 +419,13 @@ , (xK_a, startOfLine) , (xK_e, endOfLine) , (xK_y, pasteString) - , (xK_c, copyString) , (xK_Right, moveWord Next) , (xK_Left, moveWord Prev) , (xK_Delete, killWord Next) , (xK_BackSpace, killWord Prev) , (xK_w, killWord Prev) - , (xK_q, quit) + , (xK_g, quit) + , (xK_bracketleft, quit) ] ++ map (first $ (,) 0) [ (xK_Return, setSuccess True >> setDone True) @@ -428,13 +444,13 @@ keyPressHandle :: KeyMask -> KeyStroke -> XP () keyPressHandle m (ks,str) = do km <- gets (promptKeymap . config) - mask <- cleanMask m - case M.lookup (mask,ks) km of + kmask <- cleanMask m -- mask is defined in ghc7 + case M.lookup (kmask,ks) km of Just action -> action >> updateWindows Nothing -> case str of "" -> eventLoop handle - _ -> when (mask .&. controlMask == 0) $ do - insertString (decodeInput str) + _ -> when (kmask .&. controlMask == 0) $ do + insertString (decodeString str) updateWindows completed <- tryAutoComplete when completed $ setSuccess True >> setDone True @@ -505,10 +521,6 @@ pasteString :: XP () pasteString = join $ io $ liftM insertString getSelection --- | Copy the currently entered string into the X selection. -copyString :: XP () -copyString = gets command >>= io . putSelection - -- | Remove a character at the cursor position deleteString :: Direction1D -> XP () deleteString d = @@ -724,28 +736,15 @@ printComplList :: Display -> Drawable -> GC -> String -> String -> [Position] -> [Position] -> [[String]] -> XP () -printComplList _ _ _ _ _ _ _ [] = return () -printComplList _ _ _ _ _ [] _ _ = return () -printComplList d drw gc fc bc (x:xs) y (s:ss) = do - printComplColumn d drw gc fc bc x y s - printComplList d drw gc fc bc xs y ss - -printComplColumn :: Display -> Drawable -> GC -> String -> String - -> Position -> [Position] -> [String] -> XP () -printComplColumn _ _ _ _ _ _ _ [] = return () -printComplColumn _ _ _ _ _ _ [] _ = return () -printComplColumn d drw gc fc bc x (y:yy) (s:ss) = do - printComplString d drw gc fc bc x y s - printComplColumn d drw gc fc bc x yy ss - -printComplString :: Display -> Drawable -> GC -> String -> String - -> Position -> Position -> String -> XP () -printComplString d drw gc fc bc x y s = do - st <- get - if completionToCommand (xptype st) s == commandToComplete (xptype st) (command st) - then printStringXMF d drw (fontS st) gc - (fgHLight $ config st) (bgHLight $ config st) x y s - else printStringXMF d drw (fontS st) gc fc bc x y s +printComplList d drw gc fc bc xs ys sss = + zipWithM_ (\x ss -> + zipWithM_ (\y s -> 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) + ys ss) xs sss -- History @@ -768,7 +767,9 @@ writeHistory :: History -> IO () writeHistory hist = do path <- getHistoryFile - writeFile path (show hist) `catch` \(SomeException _) -> hPutStrLn stderr "error in writing" + let filtered = M.filter (not . null) hist + writeFile path (show filtered) `catch` \(SomeException e) -> + hPutStrLn stderr ("error writing history: "++show e) setFileMode path mode where mode = ownerReadMode .|. ownerWriteMode @@ -834,14 +835,6 @@ Just i -> if i >= length l - 1 then 0 else i + 1 Nothing -> 0 --- Lift an IO action into the XP -io :: IO a -> XP a -io = liftIO - --- Shorthand for fromIntegral -fi :: (Num b, Integral a) => a -> b -fi = fromIntegral - -- | Given a maximum length, splits a list into sublists splitInSubListsAt :: Int -> [a] -> [[a]] splitInSubListsAt _ [] = [] @@ -889,3 +882,45 @@ deleteAllDuplicates, deleteConsecutive :: [String] -> [String] deleteAllDuplicates = nub deleteConsecutive = map head . group + +newtype HistoryMatches = HistoryMatches (IORef ([String],Maybe (W.Stack String))) + +-- | Initializes a new HistoryMatches structure to be passed +-- to historyUpMatching +initMatches :: (Functor m, MonadIO m) => m HistoryMatches +initMatches = HistoryMatches <$> liftIO (newIORef ([],Nothing)) + +historyNextMatching :: HistoryMatches -> (W.Stack String -> W.Stack String) -> XP () +historyNextMatching hm@(HistoryMatches ref) next = do + (completed,completions) <- io $ readIORef ref + input <- getInput + if input `elem` completed + then case completions of + Just cs -> do + let cmd = W.focus cs + modify $ setCommand cmd + modify $ \s -> s { offset = length cmd } + io $ writeIORef ref (cmd:completed,Just $ next cs) + Nothing -> return () + else do -- the user typed something new, recompute completions + io . writeIORef ref . ((,) [input]) . filterMatching input =<< gets commandHistory + historyNextMatching hm next + where filterMatching :: String -> W.Stack String -> Maybe (W.Stack String) + filterMatching prefix = W.filter (prefix `isPrefixOf`) . next + +-- | Retrieve the next history element that starts with +-- the current input. Pass it the result of initMatches +-- when creating the prompt. Example: +-- +-- > .. +-- > ((modMask,xK_p), shellPrompt . myPrompt =<< initMatches) +-- > .. +-- > myPrompt ref = defaultPrompt +-- > { promptKeymap = M.union [((0,xK_Up), historyUpMatching ref) +-- > ,((0,xK_Down), historyDownMatching ref)] +-- > (promptKeymap defaultPrompt) +-- > , .. } +-- +historyUpMatching, historyDownMatching :: HistoryMatches -> XP () +historyUpMatching hm = historyNextMatching hm W.focusDown' +historyDownMatching hm = historyNextMatching hm W.focusUp' diff --git a/XMonad/Prompt/AppLauncher.hs b/XMonad/Prompt/AppLauncher.hs --- a/XMonad/Prompt/AppLauncher.hs +++ b/XMonad/Prompt/AppLauncher.hs @@ -18,6 +18,9 @@ ,module XMonad.Prompt -- * Use case: launching gimp with file -- $tip + + -- * Types + ,Application, AppPrompt, ) where import XMonad (X(),MonadIO) diff --git a/XMonad/Prompt/AppendFile.hs b/XMonad/Prompt/AppendFile.hs --- a/XMonad/Prompt/AppendFile.hs +++ b/XMonad/Prompt/AppendFile.hs @@ -22,7 +22,8 @@ -- * Usage -- $usage - appendFilePrompt + appendFilePrompt, + AppendFile, ) where import XMonad.Core @@ -42,6 +43,17 @@ -- and adding an appropriate keybinding, for example: -- -- > , ((modm .|. controlMask, xK_n), appendFilePrompt defaultXPConfig "/home/me/NOTES") +-- +-- Additional notes can be added via regular Haskell or XMonad functions; for +-- example, to preface notes with the time they were made, one could write a +-- binding like +-- +-- > , ((modm .|. controlMask, xK_n), do +-- > spawn ("date>>"++"/home/me/NOTES") +-- > appendFilePrompt defaultXPConfig "/home/me/NOTES" +-- > ) +-- +-- (Put the spawn on the line after the prompt to append the time instead.) -- -- For detailed instructions on editing your key bindings, see -- "XMonad.Doc.Extending#Editing_key_bindings". diff --git a/XMonad/Prompt/DirExec.hs b/XMonad/Prompt/DirExec.hs --- a/XMonad/Prompt/DirExec.hs +++ b/XMonad/Prompt/DirExec.hs @@ -21,14 +21,20 @@ -- $usage dirExecPrompt , dirExecPromptNamed + , DirExec ) where +import Prelude hiding (catch) +import Control.Exception import System.Directory import Control.Monad import Data.List import XMonad import XMonad.Prompt +econst :: Monad m => a -> IOException -> m a +econst = const . return + -- $usage -- 1. In your @~\/.xmonad\/xmonad.hs@: -- @@ -98,5 +104,4 @@ liftM2 (&&) (doesFileExist x') (liftM executable (getPermissions x')))) - `catch` (return . return . show) - + `catch` econst [] diff --git a/XMonad/Prompt/Directory.hs b/XMonad/Prompt/Directory.hs --- a/XMonad/Prompt/Directory.hs +++ b/XMonad/Prompt/Directory.hs @@ -4,7 +4,7 @@ -- Copyright : (C) 2007 Andrea Rossato, David Roundy -- License : BSD3 -- --- Maintainer : +-- Maintainer : -- Stability : unstable -- Portability : unportable -- @@ -15,7 +15,8 @@ module XMonad.Prompt.Directory ( -- * Usage -- $usage - directoryPrompt + directoryPrompt, + Dir, ) where import XMonad diff --git a/XMonad/Prompt/Email.hs b/XMonad/Prompt/Email.hs --- a/XMonad/Prompt/Email.hs +++ b/XMonad/Prompt/Email.hs @@ -59,5 +59,5 @@ inputPromptWithCompl c "To" (mkComplFunFromList addrs) ?+ \to -> inputPrompt c "Subject" ?+ \subj -> inputPrompt c "Body" ?+ \body -> - io $ runProcessWithInput "mail" ["-s", subj, to] (body ++ "\n") + runProcessWithInput "mail" ["-s", subj, to] (body ++ "\n") >> return () diff --git a/XMonad/Prompt/Input.hs b/XMonad/Prompt/Input.hs --- a/XMonad/Prompt/Input.hs +++ b/XMonad/Prompt/Input.hs @@ -18,7 +18,8 @@ -- $usage inputPrompt, inputPromptWithCompl, - (?+) + (?+), + InputPrompt, ) where import XMonad.Core diff --git a/XMonad/Prompt/Layout.hs b/XMonad/Prompt/Layout.hs --- a/XMonad/Prompt/Layout.hs +++ b/XMonad/Prompt/Layout.hs @@ -4,7 +4,7 @@ -- Copyright : (C) 2007 Andrea Rossato, David Roundy -- License : BSD3 -- --- Maintainer : +-- Maintainer : -- Stability : unstable -- Portability : unportable -- @@ -21,6 +21,7 @@ import Data.List ( sort, nub ) import XMonad hiding ( workspaces ) import XMonad.Prompt +import XMonad.Prompt.Workspace ( Wor(..) ) import XMonad.StackSet ( workspaces, layout ) import XMonad.Layout.LayoutCombinators ( JumpToLayout(..) ) @@ -42,11 +43,6 @@ -- (which doesn't have this feature). So all in all, this module is really -- more a proof-of-principle than something you can actually use -- productively. - -data Wor = Wor String - -instance XPrompt Wor where - showXPrompt (Wor x) = x layoutPrompt :: XPConfig -> X () layoutPrompt c = do ls <- gets (map (description . layout) . workspaces . windowset) diff --git a/XMonad/Prompt/Man.hs b/XMonad/Prompt/Man.hs --- a/XMonad/Prompt/Man.hs +++ b/XMonad/Prompt/Man.hs @@ -20,7 +20,9 @@ -- $usage manPrompt , getCommandOutput + , Man ) where + import XMonad import XMonad.Prompt diff --git a/XMonad/Prompt/RunOrRaise.hs b/XMonad/Prompt/RunOrRaise.hs --- a/XMonad/Prompt/RunOrRaise.hs +++ b/XMonad/Prompt/RunOrRaise.hs @@ -16,7 +16,8 @@ module XMonad.Prompt.RunOrRaise ( -- * Usage -- $usage - runOrRaisePrompt + runOrRaisePrompt, + RunOrRaisePrompt, ) where import XMonad hiding (config) @@ -25,10 +26,14 @@ import XMonad.Actions.WindowGo (runOrRaise) import XMonad.Util.Run (runProcessWithInput) +import Prelude hiding (catch) +import Control.Exception import Control.Monad (liftM, liftM2) -import Data.Maybe import System.Directory (doesDirectoryExist, doesFileExist, executable, getPermissions) +econst :: Monad m => a -> IOException -> m a +econst = const . return + {- $usage 1. In your @~\/.xmonad\/xmonad.hs@: @@ -66,7 +71,7 @@ isApp x = liftM2 (==) pid $ pidof x pidof :: String -> Query Int -pidof x = io $ (runProcessWithInput "pidof" [x] [] >>= readIO) `catch` (\_ -> return 0) +pidof x = io $ (runProcessWithInput "pidof" [x] [] >>= readIO) `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 @@ -1,17 +1,15 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonad.Prompt.Shell --- Copyright : (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : andrea.rossato@unibz.it --- Stability : unstable --- Portability : unportable --- --- A shell prompt for XMonad --- ------------------------------------------------------------------------------ +{- | +Module : XMonad.Prompt.Shell +Copyright : (C) 2007 Andrea Rossato +License : BSD3 +Maintainer : andrea.rossato@unibz.it +Stability : unstable +Portability : unportable + +A shell prompt for XMonad +-} + module XMonad.Prompt.Shell ( -- * Usage -- $usage @@ -26,29 +24,35 @@ , safePrompt ) where -import System.Environment -import Control.Monad -import Data.List -import System.Directory -import System.IO -import System.Posix.Files +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 XMonad.Util.Run import XMonad hiding (config) import XMonad.Prompt --- $usage --- 1. In your @~\/.xmonad\/xmonad.hs@: --- --- > import XMonad.Prompt --- > import XMonad.Prompt.Shell --- --- 2. In your keybindings add something like: --- --- > , ((modm .|. controlMask, xK_x), shellPrompt defaultXPConfig) --- --- For detailed instruction on editing the key binding see --- "XMonad.Doc.Extending#Editing_key_bindings". +econst :: Monad m => a -> IOException -> m a +econst = const . return +{- $usage +1. In your @~\/.xmonad\/xmonad.hs@: + +> import XMonad.Prompt +> import XMonad.Prompt.Shell + +2. In your keybindings add something like: + +> , ((modm .|. controlMask, xK_x), shellPrompt defaultXPConfig) + +For detailed instruction on editing the key binding see +"XMonad.Doc.Extending#Editing_key_bindings". -} + data Shell = Shell instance XPrompt Shell where @@ -58,39 +62,40 @@ shellPrompt :: XPConfig -> X () shellPrompt c = do cmds <- io getCommands - mkXPrompt Shell c (getShellCompl cmds) (spawn . encodeOutput) + mkXPrompt Shell c (getShellCompl cmds) spawn --- | See safe and unsafeSpawn. 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 --- is the program to be run with the interactive input. --- You would use these like this: --- --- > , ((modm, xK_b), safePrompt "firefox" greenXPConfig) --- > , ((modm .|. shiftMask, xK_c), prompt ("xterm" ++ " -e") greenXPConfig) --- --- Note that you want to use safePrompt for Firefox input, as Firefox --- wants URLs, and unsafePrompt for the XTerm example because this allows --- you to easily start a terminal executing an arbitrary command, like --- 'top'. +{- | See safe and unsafeSpawn. 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 + is the program to be run with the interactive input. + You would use these like this: + + > , ((modm, xK_b), safePrompt "firefox" greenXPConfig) + > , ((modm .|. shiftMask, xK_c), prompt ("xterm" ++ " -e") greenXPConfig) + + Note that you want to use safePrompt for Firefox input, as Firefox + 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 - where run = safeSpawn c . return . encodeOutput + where run = safeSpawn c . return unsafePrompt c config = mkXPrompt Shell config (getShellCompl [c]) run - where run a = unsafeSpawn $ c ++ " " ++ encodeOutput a + where run a = unsafeSpawn $ c ++ " " ++ a getShellCompl :: [String] -> String -> IO [String] getShellCompl cmds s | s == "" || last s == ' ' = return [] | otherwise = do - f <- fmap lines $ runProcessWithInput "bash" [] ("compgen -A file " ++ encodeOutput s ++ "\n") + f <- fmap lines $ runProcessWithInput "bash" [] ("compgen -A file -- " + ++ s ++ "\n") files <- case f of - [x] -> do fs <- getFileStatus x + [x] -> do fs <- getFileStatus (encodeString x) if isDirectory fs then return [x ++ "/"] else return [x] _ -> return f - return . map decodeInput . uniqSort $ files ++ commandCompletionFunction cmds s + return . uniqSort $ files ++ commandCompletionFunction cmds s commandCompletionFunction :: [String] -> String -> [String] commandCompletionFunction cmds str | '/' `elem` str = [] @@ -98,8 +103,8 @@ getCommands :: IO [String] getCommands = do - p <- getEnv "PATH" `catch` const (return []) - let ds = split ':' p + p <- getEnv "PATH" `catch` econst [] + let ds = filter (/= "") $ split ':' p es <- forM ds $ \d -> do exists <- doesDirectoryExist d if exists @@ -127,7 +132,7 @@ -- | Ask the shell environment for env :: String -> String -> IO String -env variable fallthrough = getEnv variable `catch` \_ -> return fallthrough +env variable fallthrough = getEnv variable `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 @@ -15,20 +15,26 @@ module XMonad.Prompt.Ssh ( -- * Usage -- $usage - sshPrompt + sshPrompt, + 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.Monad -import Data.List import Data.Maybe +econst :: Monad m => a -> IOException -> m a +econst = const . return + -- $usage -- 1. In your @~\/.xmonad\/xmonad.hs@: -- @@ -66,11 +72,13 @@ sshComplListLocal :: IO [String] sshComplListLocal = do h <- getEnv "HOME" - sshComplListFile $ h ++ "/.ssh/known_hosts" + s1 <- sshComplListFile $ h ++ "/.ssh/known_hosts" + s2 <- sshComplListConf $ h ++ "/.ssh/config" + return $ s1 ++ s2 sshComplListGlobal :: IO [String] sshComplListGlobal = do - env <- getEnv "SSH_KNOWN_HOSTS" `catch` (\_ -> return "/nonexistent") + env <- getEnv "SSH_KNOWN_HOSTS" `catch` econst "/nonexistent" fs <- mapM fileExists [ env , "/usr/local/etc/ssh/ssh_known_hosts" , "/usr/local/etc/ssh_known_hosts" @@ -93,6 +101,22 @@ return $ map (getWithPort . takeWhile (/= ',') . concat . take 1 . words) $ filter nonComment $ lines l + +sshComplListConf :: String -> IO [String] +sshComplListConf kh = do + f <- doesFileExist kh + if f then sshComplListConf' kh + else return [] + +sshComplListConf' :: String -> IO [String] +sshComplListConf' kh = do + l <- readFile kh + return $ map (!!1) + $ filter isHost + $ map words + $ lines l + where + isHost ws = take 1 ws == ["Host"] && length ws > 1 fileExists :: String -> IO (Maybe String) fileExists kh = do diff --git a/XMonad/Prompt/Theme.hs b/XMonad/Prompt/Theme.hs --- a/XMonad/Prompt/Theme.hs +++ b/XMonad/Prompt/Theme.hs @@ -15,12 +15,12 @@ ( -- * Usage -- $usage themePrompt, + ThemePrompt, ) where import Control.Arrow ( (&&&) ) import qualified Data.Map as M import Data.Maybe ( fromMaybe ) -import Data.List import XMonad import XMonad.Prompt import XMonad.Layout.Decoration diff --git a/XMonad/Prompt/Window.hs b/XMonad/Prompt/Window.hs --- a/XMonad/Prompt/Window.hs +++ b/XMonad/Prompt/Window.hs @@ -20,11 +20,11 @@ -- $usage windowPromptGoto, windowPromptBring, - windowPromptBringCopy + windowPromptBringCopy, + WindowPrompt, ) where import qualified Data.Map as M -import Data.List import qualified XMonad.StackSet as W import XMonad @@ -89,7 +89,7 @@ bringAction = winAction bringWindow bringCopyAction = winAction bringCopyWindow - compList m s = return . filter (isPrefixOf s) . map fst . M.toList $ m + compList m s = return . filter (searchPredicate c s) . map fst . M.toList $ m -- | Brings a copy of the specified window into the current workspace. diff --git a/XMonad/Prompt/Workspace.hs b/XMonad/Prompt/Workspace.hs --- a/XMonad/Prompt/Workspace.hs +++ b/XMonad/Prompt/Workspace.hs @@ -4,7 +4,7 @@ -- Copyright : (C) 2007 Andrea Rossato, David Roundy -- License : BSD3 -- --- Maintainer : +-- Maintainer : -- Stability : unstable -- Portability : unportable -- @@ -15,7 +15,10 @@ module XMonad.Prompt.Workspace ( -- * Usage -- $usage - workspacePrompt + workspacePrompt, + + -- * For developers + Wor(Wor), ) where import XMonad hiding ( workspaces ) diff --git a/XMonad/Prompt/XMonad.hs b/XMonad/Prompt/XMonad.hs --- a/XMonad/Prompt/XMonad.hs +++ b/XMonad/Prompt/XMonad.hs @@ -16,7 +16,8 @@ -- * Usage -- $usage xmonadPrompt, - xmonadPromptC + xmonadPromptC, + XMonad, ) where import XMonad diff --git a/XMonad/Util/Dmenu.hs b/XMonad/Util/Dmenu.hs --- a/XMonad/Util/Dmenu.hs +++ b/XMonad/Util/Dmenu.hs @@ -17,7 +17,7 @@ module XMonad.Util.Dmenu ( -- * Usage -- $usage - dmenu, dmenuXinerama, dmenuMap, menu, menuMap + dmenu, dmenuXinerama, dmenuMap, menu, menuArgs, menuMap, menuMapArgs ) where import XMonad @@ -29,6 +29,11 @@ -- You can use this module with the following in your Config.hs file: -- -- > import XMonad.Util.Dmenu +-- +-- These functions block xmonad's event loop until dmenu exits; this means that +-- programs will not be able to open new windows and you will not be able to +-- change workspaces or input focus until you have responded to the prompt one +-- way or another. -- %import XMonad.Util.Dmenu @@ -37,20 +42,33 @@ dmenuXinerama :: [String] -> X String dmenuXinerama opts = do curscreen <- (fromIntegral . W.screen . W.current) `fmap` gets windowset :: X Int - io $ runProcessWithInput "dmenu" ["-xs", show (curscreen+1)] (unlines opts) + runProcessWithInput "dmenu" ["-xs", show (curscreen+1)] (unlines opts) + menuArgs "dmenu" ["-xs", show (curscreen+1)] opts +-- | Run dmenu to select an option from a list. dmenu :: [String] -> X String dmenu opts = menu "dmenu" opts +-- | like 'dmenu' but also takes the command to run. menu :: String -> [String] -> X String -menu menuCmd opts = io $ runProcessWithInput menuCmd [] (unlines opts) +menu menuCmd opts = menuArgs menuCmd [] opts +-- | 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) + +-- | Like 'dmenuMap' but also takes the command to run. menuMap :: String -> M.Map String a -> X (Maybe a) -menuMap menuCmd selectionMap = do +menuMap menuCmd selectionMap = menuMapArgs menuCmd [] selectionMap + +-- | Like 'menuMap' but also takes a list of command line arguments. +menuMapArgs :: String -> [String] -> M.Map String a -> X (Maybe a) +menuMapArgs menuCmd args selectionMap = do selection <- menuFunction (M.keys selectionMap) return $ M.lookup selection selectionMap where - menuFunction = menu menuCmd + menuFunction = menuArgs menuCmd args +-- | Run dmenu to select an entry from a map based on the key. dmenuMap :: M.Map String a -> X (Maybe a) dmenuMap selectionMap = menuMap "dmenu" selectionMap diff --git a/XMonad/Util/Dzen.hs b/XMonad/Util/Dzen.hs --- a/XMonad/Util/Dzen.hs +++ b/XMonad/Util/Dzen.hs @@ -13,36 +13,168 @@ ----------------------------------------------------------------------------- module XMonad.Util.Dzen ( + -- * Flexible interface + dzenConfig, DzenConfig, + timeout, + font, + xScreen, + vCenter, + hCenter, + center, + onCurr, + x, + y, + addArgs, + + -- * Legacy interface dzen, - dzenWithArgs, dzenScreen, - seconds + dzenWithArgs, + + -- * Miscellaneous + seconds, + chomp, + (>=>), ) where +import Control.Monad import XMonad +import XMonad.StackSet import XMonad.Util.Run (runProcessWithInputAndWait, seconds) +type DzenConfig = (Int, [String]) -> X (Int, [String]) + +-- | @dzenConfig config s@ will display the string @s@ according to the +-- configuration @config@. For example, to display the string @\"foobar\"@ with +-- all the default settings, you can simply call +-- +-- > dzenConfig return "foobar" +-- +-- Or, to set a longer timeout, you could use +-- +-- > dzenConfig (timeout 10) "foobar" +-- +-- You can combine configurations with the (>=>) operator. To display +-- @\"foobar\"@ for 10 seconds on the first screen, you could use +-- +-- > dzenConfig (timeout 10 >=> xScreen 0) "foobar" +-- +-- As a final example, you could adapt the above to display @\"foobar\"@ for +-- 10 seconds on the current screen with +-- +-- > dzenConfig (timeout 10 >=> onCurr xScreen) "foobar" +dzenConfig :: DzenConfig -> String -> X () +dzenConfig conf s = do + (t, args) <- conf (seconds 3, []) + runProcessWithInputAndWait "dzen2" args (chomp s) t + +-- | dzen wants exactly one newline at the end of its input, so this can be +-- used for your own invocations of dzen. However, all functions in this +-- module will call this for you. +chomp :: String -> String +chomp = (++"\n") . reverse . dropWhile ('\n' ==) . reverse + +-- | Set the timeout, in seconds. This defaults to 3 seconds if not +-- specified. +timeout :: Rational -> DzenConfig +timeout = timeoutMicro . seconds + +-- | Set the timeout, in microseconds. Mostly here for the legacy +-- interface. +timeoutMicro :: Int -> DzenConfig +timeoutMicro n (_, ss) = return (n, ss) + +-- | Add raw command-line arguments to the configuration. These will be +-- passed on verbatim to dzen2. The default includes no arguments. +addArgs :: [String] -> DzenConfig +addArgs ss (n, ss') = return (n, ss ++ ss') + +-- | Start dzen2 on a particular screen. Only works with versions of dzen +-- that support the "-xs" argument. +xScreen :: ScreenId -> DzenConfig +xScreen sc = addArgs ["-xs", show (fromIntegral sc + 1 :: Int)] + +-- | Take a screen-specific configuration and supply it with the screen ID +-- of the currently focused screen, according to xmonad. For example, show +-- a 100-pixel wide bar centered within the current screen, you could use +-- +-- > dzenConfig (onCurr (hCenter 100)) "foobar" +-- +-- Of course, you can still combine these with (>=>); for example, to center +-- the string @\"foobar\"@ both horizontally and vertically in a 100x14 box +-- using the lovely Terminus font, you could use +-- +-- > terminus = "-*-terminus-*-*-*-*-12-*-*-*-*-*-*-*" +-- > dzenConfig (onCurr (center 100 14) >=> font terminus) "foobar" +onCurr :: (ScreenId -> DzenConfig) -> DzenConfig +onCurr f conf = gets (screen . current . windowset) >>= flip f conf + +-- | Put the top of the dzen bar at a particular pixel. +x :: Int -> DzenConfig +x n = addArgs ["-x", show n] +-- | Put the left of the dzen bar at a particular pixel. +y :: Int -> DzenConfig +y n = addArgs ["-y", show n] + +-- | Specify the font. Check out xfontsel to get the format of the String +-- right; if your dzen supports xft, then you can supply that here, too. +font :: String -> DzenConfig +font fn = addArgs ["-fn", fn] + +-- | @vCenter height sc@ sets the configuration to have the dzen bar appear +-- on screen @sc@ with height @height@, vertically centered with respect to +-- the actual size of that screen. +vCenter :: Int -> ScreenId -> DzenConfig +vCenter = center' rect_height "-h" "-y" + +-- | @hCenter width sc@ sets the configuration to have the dzen bar appear +-- on screen @sc@ with width @width@, horizontally centered with respect to +-- the actual size of that screen. +hCenter :: Int -> ScreenId -> DzenConfig +hCenter = center' rect_width "-w" "-x" + +-- | @center width height sc@ sets the configuration to have the dzen bar +-- appear on screen @sc@ with width @width@ and height @height@, centered +-- both horizontally and vertically with respect to the actual size of that +-- screen. +center :: Int -> Int -> ScreenId -> DzenConfig +center width height sc = hCenter width sc >=> vCenter height sc + +-- Center things along a single dimension on a particular screen. +center' :: (Rectangle -> Dimension) -> String -> String -> Int -> ScreenId -> DzenConfig +center' selector extentName positionName extent sc conf = do + rect <- gets (detailFromScreenId sc . windowset) + case rect of + Nothing -> return conf + Just r -> addArgs + [extentName , show extent, + positionName, show ((fromIntegral (selector r) - extent) `div` 2), + "-xs" , show (fromIntegral sc + 1 :: Int) + ] conf + +-- Get the rectangle outlining a particular screen. +detailFromScreenId :: ScreenId -> WindowSet -> Maybe Rectangle +detailFromScreenId sc ws = fmap screenRect maybeSD where + c = current ws + v = visible ws + mapping = map (\s -> (screen s, screenDetail s)) (c:v) + maybeSD = lookup sc mapping + -- | @dzen str timeout@ pipes @str@ to dzen2 for @timeout@ microseconds. -- Example usage: -- -- > dzen "Hi, mom!" (5 `seconds`) dzen :: String -> Int -> X () -dzen str timeout = dzenWithArgs str [] timeout +dzen = flip (dzenConfig . timeoutMicro) -- | @dzen str args timeout@ pipes @str@ to dzen2 for @timeout@ seconds, passing @args@ to dzen. -- Example usage: -- -- > dzenWithArgs "Hi, dons!" ["-ta", "r"] (5 `seconds`) dzenWithArgs :: String -> [String] -> Int -> X () -dzenWithArgs str args timeout = io $ runProcessWithInputAndWait "dzen2" args (unchomp str) timeout - -- dzen seems to require the input to terminate with exactly one newline. - where unchomp s@['\n'] = s - unchomp [] = ['\n'] - unchomp (c:cs) = c : unchomp cs +dzenWithArgs str args t = dzenConfig (timeoutMicro t >=> addArgs args) str -- | @dzenScreen sc str timeout@ pipes @str@ to dzen2 for @timeout@ microseconds, and on screen @sc@. -- Requires dzen to be compiled with Xinerama support. -dzenScreen :: ScreenId -> String -> Int -> X() -dzenScreen sc str timeout = dzenWithArgs str ["-xs", screen] timeout - where screen = toXineramaArg sc - toXineramaArg n = show ( ((fromIntegral n)+1)::Int ) +dzenScreen :: ScreenId -> String -> Int -> X () +dzenScreen sc str t = dzenConfig (timeoutMicro t >=> xScreen sc) str diff --git a/XMonad/Util/EZConfig.hs b/XMonad/Util/EZConfig.hs --- a/XMonad/Util/EZConfig.hs +++ b/XMonad/Util/EZConfig.hs @@ -27,7 +27,9 @@ -- * Emacs-style keybinding specifications mkKeymap, checkKeymap, - mkNamedKeymap + mkNamedKeymap, + + parseKey -- used by XMonad.Util.Paste ) where import XMonad @@ -103,7 +105,7 @@ -- > `removeKeys` [(mod1Mask .|. shiftMask, n) | n <- [xK_1 .. xK_9]] removeKeys :: XConfig a -> [(ButtonMask, KeySym)] -> XConfig a removeKeys conf keyList = - conf { keys = \cnf -> keys conf cnf `M.difference` M.fromList (zip keyList $ return ()) } + conf { keys = \cnf -> keys conf cnf `M.difference` M.fromList (zip keyList $ repeat ()) } -- | Like 'removeKeys', except using short @String@ key descriptors -- like @\"M-m\"@ instead of @(modMask, xK_m)@, as described in the @@ -125,7 +127,7 @@ removeMouseBindings :: XConfig a -> [(ButtonMask, Button)] -> XConfig a removeMouseBindings conf mouseBindingList = conf { mouseBindings = \cnf -> mouseBindings conf cnf `M.difference` - M.fromList (zip mouseBindingList $ return ()) } + M.fromList (zip mouseBindingList $ repeat ()) } -------------------------------------------------------------- @@ -343,6 +345,7 @@ -- > -- > -- > +-- > -- > - -- > -- > @@ -410,9 +413,9 @@ parseModifier c = (string "M-" >> return (modMask c)) +++ (string "C-" >> return controlMask) +++ (string "S-" >> return shiftMask) - +++ do char 'M' + +++ do _ <- char 'M' n <- satisfy (`elem` ['1'..'5']) - char '-' + _ <- char '-' return $ indexMod (read [n] - 1) where indexMod = (!!) [mod1Mask,mod2Mask,mod3Mask,mod4Mask,mod5Mask] @@ -428,11 +431,11 @@ -- | Parse a special key name (one enclosed in angle brackets). parseSpecial :: ReadP KeySym -parseSpecial = do char '<' +parseSpecial = do _ <- char '<' key <- choice [ string name >> return k | (name,k) <- keyNames ] - char '>' + _ <- char '>' return key -- | A list of all special key names and their associated KeySyms. @@ -648,6 +651,7 @@ , "XF86MailForward" , "XF86Pictures" , "XF86Music" + , "XF86TouchpadToggle" , "XF86_Switch_VT_1" , "XF86_Switch_VT_2" , "XF86_Switch_VT_3" diff --git a/XMonad/Util/ExtensibleState.hs b/XMonad/Util/ExtensibleState.hs new file mode 100644 --- /dev/null +++ b/XMonad/Util/ExtensibleState.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.ExtensibleState +-- Copyright : (c) Daniel Schoepe 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : daniel.schoepe@gmail.com +-- Stability : unstable +-- Portability : not portable +-- +-- Module for storing custom mutable state in xmonad. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.ExtensibleState ( + -- * Usage + -- $usage + put + , modify + , remove + , get + , gets + ) where + +import Data.Typeable (typeOf,Typeable,cast) +import qualified Data.Map as M +import XMonad.Core +import qualified Control.Monad.State as State +import Data.Maybe (fromMaybe) + +-- --------------------------------------------------------------------- +-- $usage +-- +-- To utilize this feature in a contrib module, create a data type +-- and make it an instance of ExtensionClass. You can then use +-- the functions from this module for storing and retrieving your data: +-- +-- > {-# LANGUAGE DeriveDataTypeable #-} +-- > import qualified XMonad.Util.ExtensibleState as XS +-- > +-- > data ListStorage = ListStorage [Integer] deriving Typeable +-- > instance ExtensionClass ListStorage where +-- > initialValue = ListStorage [] +-- > +-- > .. XS.put (ListStorage [23,42]) +-- +-- To retrieve the stored value call: +-- +-- > .. XS.get +-- +-- If the type can't be inferred from the usage of the retrieved data, you +-- have to add an explicit type signature: +-- +-- > .. XS.get :: X ListStorage +-- +-- To make your data persistent between restarts, the data type needs to be +-- an instance of Read and Show and the instance declaration has to be changed: +-- +-- > data ListStorage = ListStorage [Integer] deriving (Typeable,Read,Show) +-- > +-- > instance ExtensionClass ListStorage where +-- > initialValue = ListStorage [] +-- > extensionType = PersistentExtension +-- +-- One should take care that the string representation of the chosen type +-- is unique among the stored values, otherwise it will be overwritten. +-- Normally these string representations contain fully qualified module names +-- when automatically deriving Typeable, so +-- name collisions should not be a problem in most cases. +-- A module should not try to store common datatypes(e.g. a list of Integers) +-- without a custom data type as a wrapper to avoid collisions with other modules +-- trying to store the same data type without a wrapper. +-- + +-- | Modify the map of state extensions by applying the given function. +modifyStateExts :: (M.Map String (Either String StateExtension) + -> M.Map String (Either String StateExtension)) + -> X () +modifyStateExts f = State.modify $ \st -> st { extensibleState = f (extensibleState st) } + +-- | Apply a function to a stored value of the matching type or the initial value if there +-- is none. +modify :: ExtensionClass a => (a -> a) -> X () +modify f = put . f =<< get + +-- | Add a value to the extensible state field. A previously stored value with the same +-- type will be overwritten. (More precisely: A value whose string representation of its type +-- is equal to the new one's) +put :: ExtensionClass a => a -> X () +put v = modifyStateExts . M.insert (show . typeOf $ v) . Right . extensionType $ v + +-- | Try to retrieve a value of the requested type, return an initial value if there is no such value. +get :: ExtensionClass a => X a +get = getState' undefined -- `trick' to avoid needing -XScopedTypeVariables + where toValue val = maybe initialValue id $ cast val + getState' :: ExtensionClass a => a -> X a + getState' k = do + v <- State.gets $ M.lookup (show . typeOf $ k) . extensibleState + case v of + Just (Right (StateExtension val)) -> return $ toValue val + Just (Right (PersistentExtension val)) -> return $ toValue val + Just (Left str) | PersistentExtension x <- extensionType k -> do + let val = fromMaybe initialValue $ cast =<< safeRead str `asTypeOf` Just x + put (val `asTypeOf` k) + return val + _ -> return $ initialValue + safeRead str = case reads str of + [(x,"")] -> Just x + _ -> Nothing + +gets :: ExtensionClass a => (a -> b) -> X b +gets = flip fmap get + +-- | Remove the value from the extensible state field that has the same type as the supplied argument +remove :: ExtensionClass a => a -> X () +remove wit = modifyStateExts $ M.delete (show . typeOf $ wit) diff --git a/XMonad/Util/Font.hs b/XMonad/Util/Font.hs new file mode 100644 --- /dev/null +++ b/XMonad/Util/Font.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE CPP #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Font +-- Copyright : (c) 2007 Andrea Rossato and Spencer Janssen +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A module for abstracting a font facility over Core fonts and Xft +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Font + ( -- * Usage: + -- $usage + XMonadFont(..) + , initXMF + , releaseXMF + , initCoreFont + , releaseCoreFont + , initUtf8Font + , releaseUtf8Font + , Align (..) + , stringPosition + , textWidthXMF + , textExtentsXMF + , printStringXMF + , stringToPixel + , fi + ) where + +import Prelude hiding (catch) +import XMonad +import Foreign +import Control.Applicative +import Control.Exception +import Data.Maybe + +#ifdef XFT +import Data.List +import Graphics.X11.Xft +import Graphics.X11.Xrender +#endif + +-- Hide the Core Font/Xft switching here +data XMonadFont = Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft XftFont +#endif + +-- $usage +-- See "Xmonad.Layout.Tabbed" or "XMonad.Prompt" for usage examples + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +stringToPixel :: (Functor m, MonadIO m) => Display -> String -> m Pixel +stringToPixel d s = fromMaybe fallBack <$> io getIt + where getIt = initColor d s + fallBack = blackPixel d (defaultScreen d) + +econst :: a -> IOException -> a +econst = const + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initCoreFont :: String -> X FontStruct +initCoreFont s = do + d <- asks display + io $ catch (getIt d) (fallBack d) + where getIt d = loadQueryFont d s + fallBack d = econst $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseCoreFont :: FontStruct -> X () +releaseCoreFont fs = do + d <- asks display + io $ freeFont d fs + +initUtf8Font :: String -> X FontSet +initUtf8Font s = do + d <- asks display + (_,_,fs) <- io $ catch (getIt d) (fallBack d) + return fs + where getIt d = createFontSet d s + fallBack d = econst $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseUtf8Font :: FontSet -> X () +releaseUtf8Font fs = do + d <- asks display + io $ freeFontSet d fs + +-- | When initXMF gets a font name that starts with 'xft:' it switches to the Xft backend +-- Example: 'xft: Sans-10' +initXMF :: String -> X XMonadFont +initXMF s = +#ifdef XFT + if xftPrefix `isPrefixOf` s then + do dpy <- asks display + xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s) + return (Xft xftdraw) + else +#endif + fmap Utf8 $ initUtf8Font s +#ifdef XFT + where xftPrefix = "xft:" +#endif + +releaseXMF :: XMonadFont -> X () +#ifdef XFT +releaseXMF (Xft xftfont) = do + dpy <- asks display + io $ xftFontClose dpy xftfont +#endif +releaseXMF (Utf8 fs) = releaseUtf8Font fs +releaseXMF (Core fs) = releaseCoreFont fs + + +textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int +textWidthXMF _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s +textWidthXMF _ (Core fs) s = return $ fi $ textWidth fs s +#ifdef XFT +textWidthXMF dpy (Xft xftdraw) s = liftIO $ do + gi <- xftTextExtents dpy xftdraw s + return $ xglyphinfo_xOff gi +#endif + +textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32) +textExtentsXMF (Utf8 fs) s = do + let (_,rl) = wcTextExtents fs s + ascent = fi $ - (rect_y rl) + descent = fi $ rect_height rl + (fi $ rect_y rl) + return (ascent, descent) +textExtentsXMF (Core fs) s = do + let (_,a,d,_) = textExtents fs s + return (a,d) +#ifdef XFT +textExtentsXMF (Xft xftfont) _ = io $ do + ascent <- fi `fmap` xftfont_ascent xftfont + descent <- fi `fmap` xftfont_descent xftfont + return (ascent, descent) +#endif + +-- | String position +data Align = AlignCenter | AlignRight | AlignLeft | AlignRightOffset Int + deriving (Show, Read) + +-- | Return the string x and y 'Position' in a 'Rectangle', given a +-- 'FontStruct' and the 'Align'ment +stringPosition :: (Functor m, MonadIO m) => Display -> XMonadFont -> Rectangle -> Align -> String -> m (Position,Position) +stringPosition dpy fs (Rectangle _ _ w h) al s = do + width <- textWidthXMF dpy fs s + (a,d) <- textExtentsXMF fs s + let y = fi $ ((h - fi (a + d)) `div` 2) + fi a; + x = case al of + AlignCenter -> fi (w `div` 2) - fi (width `div` 2) + AlignLeft -> 1 + AlignRight -> fi (w - (fi width + 1)); + AlignRightOffset offset -> fi (w - (fi width + 1)) - fi offset; + return (x,y) + +printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String + -> Position -> Position -> String -> m () +printStringXMF d p (Core fs) gc fc bc x y s = io $ do + setFont d gc $ fontFromFontStruct fs + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + drawImageString d p gc x y s +printStringXMF d p (Utf8 fs) gc fc bc x y s = io $ do + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + io $ wcDrawImageString d p fs gc x y s +#ifdef XFT +printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + bcolor <- stringToPixel dpy bc + (a,d) <- textExtentsXMF fs s + gi <- io $ xftTextExtents dpy font s + io $ setForeground dpy gc bcolor + io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) + (y - fi a) + (fi $ xglyphinfo_xOff gi) + (fi $ a + d) + io $ withXftDraw dpy drw visual colormap $ + \draw -> withXftColorName dpy visual colormap fc $ + \color -> xftDrawString draw color font x y s +#endif + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral diff --git a/XMonad/Util/Font.hsc b/XMonad/Util/Font.hsc deleted file mode 100644 --- a/XMonad/Util/Font.hsc +++ /dev/null @@ -1,200 +0,0 @@ ----------------------------------------------------------------------------- --- | --- Module : XMonad.Util.Font --- Copyright : (c) 2007 Andrea Rossato and Spencer Janssen --- License : BSD-style (see xmonad/LICENSE) --- --- Maintainer : andrea.rossato@unibz.it --- Stability : unstable --- Portability : unportable --- --- A module for abstracting a font facility over Core fonts and Xft --- ------------------------------------------------------------------------------ - -module XMonad.Util.Font - ( -- * Usage: - -- $usage - XMonadFont(..) - , initXMF - , releaseXMF - , initCoreFont - , releaseCoreFont - , initUtf8Font - , releaseUtf8Font - , Align (..) - , stringPosition - , textWidthXMF - , textExtentsXMF - , printStringXMF - , stringToPixel - , decodeInput - , encodeOutput - ) where - -import XMonad -import Foreign -import Control.Applicative -import Data.Maybe - -#ifdef XFT -import Data.List -import Graphics.X11.Xft -import Graphics.X11.Xrender -#endif - -import Codec.Binary.UTF8.String (encodeString, decodeString) - - --- Hide the Core Font/Xft switching here -data XMonadFont = Core FontStruct - | Utf8 FontSet -#ifdef XFT - | Xft XftFont -#endif - --- $usage --- See "Xmonad.Layout.Tabbed" or "XMonad.Prompt" for usage examples - --- | Get the Pixel value for a named color: if an invalid name is --- given the black pixel will be returned. -stringToPixel :: (Functor m, MonadIO m) => Display -> String -> m Pixel -stringToPixel d s = fromMaybe fallBack <$> io getIt - where getIt = initColor d s - fallBack = blackPixel d (defaultScreen d) - - --- | Given a fontname returns the font structure. If the font name is --- not valid the default font will be loaded and returned. -initCoreFont :: String -> X FontStruct -initCoreFont s = do - d <- asks display - io $ catch (getIt d) (fallBack d) - where getIt d = loadQueryFont d s - fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - -releaseCoreFont :: FontStruct -> X () -releaseCoreFont fs = do - d <- asks display - io $ freeFont d fs - -initUtf8Font :: String -> X FontSet -initUtf8Font s = do - d <- asks display - (_,_,fs) <- io $ catch (getIt d) (fallBack d) - return fs - where getIt d = createFontSet d s - fallBack d = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - -releaseUtf8Font :: FontSet -> X () -releaseUtf8Font fs = do - d <- asks display - io $ freeFontSet d fs - --- | When initXMF gets a font name that starts with 'xft:' it switches to the Xft backend --- Example: 'xft: Sans-10' -initXMF :: String -> X XMonadFont -initXMF s = -#ifdef XFT - if xftPrefix `isPrefixOf` s then - do dpy <- asks display - xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s) - return (Xft xftdraw) - else -#endif - fmap Utf8 $ initUtf8Font s -#ifdef XFT - where xftPrefix = "xft:" -#endif - -releaseXMF :: XMonadFont -> X () -#ifdef XFT -releaseXMF (Xft xftfont) = do - dpy <- asks display - io $ xftFontClose dpy xftfont -#endif -releaseXMF (Utf8 fs) = releaseUtf8Font fs -releaseXMF (Core fs) = releaseCoreFont fs - - -textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int -textWidthXMF _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s -textWidthXMF _ (Core fs) s = return $ fi $ textWidth fs s -#ifdef XFT -textWidthXMF dpy (Xft xftdraw) s = liftIO $ do - gi <- xftTextExtents dpy xftdraw s - return $ xglyphinfo_xOff gi -#endif - -textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32) -textExtentsXMF (Utf8 fs) s = do - let (_,rl) = wcTextExtents fs s - ascent = fi $ - (rect_y rl) - descent = fi $ rect_height rl + (fi $ rect_y rl) - return (ascent, descent) -textExtentsXMF (Core fs) s = do - let (_,a,d,_) = textExtents fs s - return (a,d) -#ifdef XFT -textExtentsXMF (Xft xftfont) _ = io $ do - ascent <- fi `fmap` xftfont_ascent xftfont - descent <- fi `fmap` xftfont_descent xftfont - return (ascent, descent) -#endif - --- | String position -data Align = AlignCenter | AlignRight | AlignLeft - --- | Return the string x and y 'Position' in a 'Rectangle', given a --- 'FontStruct' and the 'Align'ment -stringPosition :: (Functor m, MonadIO m) => Display -> XMonadFont -> Rectangle -> Align -> String -> m (Position,Position) -stringPosition dpy fs (Rectangle _ _ w h) al s = do - width <- textWidthXMF dpy fs s - (a,d) <- textExtentsXMF fs s - let y = fi $ ((h - fi (a + d)) `div` 2) + fi a; - x = case al of - AlignCenter -> fi (w `div` 2) - fi (width `div` 2) - AlignLeft -> 1 - AlignRight -> fi (w - (fi width + 1)); - return (x,y) - -printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String - -> Position -> Position -> String -> m () -printStringXMF d p (Core fs) gc fc bc x y s = io $ do - setFont d gc $ fontFromFontStruct fs - [fc',bc'] <- mapM (stringToPixel d) [fc,bc] - setForeground d gc fc' - setBackground d gc bc' - drawImageString d p gc x y s -printStringXMF d p (Utf8 fs) gc fc bc x y s = io $ do - [fc',bc'] <- mapM (stringToPixel d) [fc,bc] - setForeground d gc fc' - setBackground d gc bc' - io $ wcDrawImageString d p fs gc x y s -#ifdef XFT -printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do - let screen = defaultScreenOfDisplay dpy - colormap = defaultColormapOfScreen screen - visual = defaultVisualOfScreen screen - bcolor <- stringToPixel dpy bc - (a,d) <- textExtentsXMF fs s - gi <- io $ xftTextExtents dpy font s - io $ setForeground dpy gc bcolor - io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) - (y - fi a) - (fi $ xglyphinfo_xOff gi) - (fi $ a + d) - io $ withXftDraw dpy drw visual colormap $ - \draw -> withXftColorName dpy visual colormap fc $ - \color -> xftDrawString draw color font x y s -#endif - -decodeInput :: String -> String -decodeInput = decodeString - -encodeOutput :: String -> String -encodeOutput = encodeString - --- | Short-hand for 'fromIntegral' -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral diff --git a/XMonad/Util/Image.hs b/XMonad/Util/Image.hs new file mode 100644 --- /dev/null +++ b/XMonad/Util/Image.hs @@ -0,0 +1,87 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Image +-- Copyright : (c) 2010 Alejandro Serrano +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : trupill@gmail.com +-- Stability : unstable +-- Portability : unportable +-- +-- Utilities for manipulating [[Bool]] as images +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Image + ( -- * Usage: + -- $usage + Placement(..), + iconPosition, + drawIcon, + ) where + +import XMonad +import XMonad.Util.Font (stringToPixel,fi) + +-- | Placement of the icon in the title bar +data Placement = OffsetLeft Int Int -- ^ An exact amount of pixels from the upper left corner + | OffsetRight Int Int -- ^ An exact amount of pixels from the right left corner + | CenterLeft Int -- ^ Centered in the y-axis, an amount of pixels from the left + | CenterRight Int -- ^ Centered in the y-axis, an amount of pixels from the right + deriving (Show, Read) + +-- $usage +-- This module uses matrices of boolean values as images. When drawing them, +-- a True value tells that we want the fore color, and a False value that we +-- want the background color to be painted. +-- In the module we suppose that those matrices are represented as [[Bool]], +-- so the lengths of the inner lists must be the same. +-- +-- See "Xmonad.Layout.Decoration" for usage examples + +-- | Gets the ('width', 'height') of an image +imageDims :: [[Bool]] -> (Int, Int) +imageDims img = (length (head img), length img) + +-- | Return the 'x' and 'y' positions inside a 'Rectangle' to start drawing +-- the image given its 'Placement' +iconPosition :: Rectangle -> Placement -> [[Bool]] -> (Position,Position) +iconPosition (Rectangle _ _ _ _) (OffsetLeft x y) _ = (fi x, fi y) +iconPosition (Rectangle _ _ w _) (OffsetRight x y) icon = + let (icon_w, _) = imageDims icon + in (fi w - fi x - fi icon_w, fi y) +iconPosition (Rectangle _ _ _ h) (CenterLeft x) icon = + let (_, icon_h) = imageDims icon + in (fi x, fi (h `div` 2) - fi (icon_h `div` 2)) +iconPosition (Rectangle _ _ w h) (CenterRight x) icon = + let (icon_w, icon_h) = imageDims icon + in (fi w - fi x - fi icon_w, fi (h `div` 2) - fi (icon_h `div` 2)) + +-- | Converts an image represented as [[Bool]] to a series of points +-- to be painted (the ones with True values) +iconToPoints :: [[Bool]] -> [Point] +iconToPoints icon = + let labels_inside = map (zip (iterate (1+) 0)) icon + filtered_inside = map (\l -> [x | (x, t) <- l, t]) labels_inside + labels_outside = zip (iterate (1+) 0) filtered_inside + in [Point x y | (y, l) <- labels_outside, x <- l] + +-- | Displaces a point ('a', 'b') along a vector ('x', 'y') +movePoint :: Position -> Position -> Point -> Point +movePoint x y (Point a b) = Point (a + x) (b + y) + +-- | Displaces a list of points along a vector 'x', 'y' +movePoints :: Position -> Position -> [Point] -> [Point] +movePoints x y points = map (movePoint x y) points + +-- | Draw an image into a X surface +drawIcon :: (Functor m, MonadIO m) => Display -> Drawable -> GC -> String + ->String -> Position -> Position -> [[Bool]] -> m () +drawIcon dpy drw gc fc bc x y icon = do + let (i_w, i_h) = imageDims icon + fcolor <- stringToPixel dpy fc + bcolor <- stringToPixel dpy bc + io $ setForeground dpy gc bcolor + io $ fillRectangle dpy drw gc x y (fi i_w) (fi i_h) + io $ setForeground dpy gc fcolor + io $ drawPoints dpy drw gc (movePoints x y (iconToPoints icon)) coordModeOrigin diff --git a/XMonad/Util/Loggers.hs b/XMonad/Util/Loggers.hs --- a/XMonad/Util/Loggers.hs +++ b/XMonad/Util/Loggers.hs @@ -52,7 +52,9 @@ import XMonad.Util.Font (Align (..)) import XMonad.Util.NamedWindows (getName) +import Prelude hiding (catch) import Control.Applicative ((<$>)) +import Control.Exception import Data.List (isPrefixOf, isSuffixOf) import Data.Maybe (fromMaybe) import Data.Traversable (traverse) @@ -62,6 +64,9 @@ import System.Process (runInteractiveCommand) import System.Time +econst :: Monad m => a -> IOException -> m a +econst = const . return + -- $usage -- Use this module by importing it into your @~\/.xmonad\/xmonad.hs@: -- @@ -116,7 +121,7 @@ -- At some point it would be nice to make this more general\/have -- fewer dependencies (assumes @\/usr\/bin\/acpi@ and @sed@ are installed.) battery :: Logger -battery = logCmd "/usr/bin/acpi | sed -r 's/.*?: (.*%).*/\\1/; s/discharging, ([0-9]+%)/\\1-/; s/charging, ([0-9]+%)/\\1+/; s/charged, //'" +battery = logCmd "/usr/bin/acpi | sed -r 's/.*?: (.*%).*/\\1/; s/[dD]ischarging, ([0-9]+%)/\\1-/; s/[cC]harging, ([0-9]+%)/\\1+/; s/[cC]harged, //'" -- | Get the current date and time, and format them via the -- given format string. The format used is the same as that used @@ -138,7 +143,7 @@ -- | Create a 'Logger' from an arbitrary shell command. logCmd :: String -> Logger logCmd c = io $ do (_, out, _, _) <- runInteractiveCommand c - fmap Just (hGetLine out) `catch` (const $ return Nothing) + fmap Just (hGetLine out) `catch` econst Nothing -- no need to waitForProcess, we ignore SIGCHLD -- | Get a count of filtered files in a directory. @@ -254,7 +259,7 @@ case a of AlignCenter -> toL (take n $ padhalf l ++ l ++ cs) AlignRight -> toL (reverse (take n $ reverse l ++ cs)) - AlignLeft -> toL (take n $ l ++ cs) + _ -> toL (take n $ l ++ cs) where toL = return . Just cs = cycle str diff --git a/XMonad/Util/NamedActions.hs b/XMonad/Util/NamedActions.hs --- a/XMonad/Util/NamedActions.hs +++ b/XMonad/Util/NamedActions.hs @@ -42,27 +42,17 @@ import XMonad.Actions.Submap(submap) -import XMonad(KeySym, KeyMask, X, Layout, Message, - XConfig(keys, layoutHook, modMask, terminal, workspaces, XConfig), - io, spawn, whenJust, ChangeLayout(NextLayout), IncMasterN(..), - Resize(..), kill, refresh, screenWorkspace, sendMessage, setLayout, - windows, withFocused, controlMask, mod1Mask, mod2Mask, mod3Mask, - mod4Mask, mod5Mask, shiftMask, xK_1, xK_9, xK_Return, xK_Tab, xK_c, - xK_comma, xK_e, xK_h, xK_j, xK_k, xK_l, xK_m, xK_n, xK_p, - xK_period, xK_q, xK_r, xK_space, xK_t, xK_w, keysymToString) -import System.Posix.Process(executeFile, forkProcess) +import XMonad +import System.Posix.Process(executeFile) import Control.Arrow(Arrow((&&&), second, (***))) -import Data.Bits(Bits((.&.), complement, (.|.))) -import Data.Function((.), const, ($), flip, id) -import Data.List((++), filter, zip, map, concatMap, null, unlines, - groupBy) +import Data.Bits(Bits((.&.), complement)) +import Data.List (groupBy) import System.Exit(ExitCode(ExitSuccess), exitWith) import Control.Applicative ((<*>)) import qualified Data.Map as M import qualified XMonad.StackSet as W -import qualified XMonad -- $usage -- Here is an example config that demonstrates the usage of 'sendMessage'', @@ -212,7 +202,7 @@ -- | An action to send to 'addDescrKeys' for showing the keybindings. See also 'showKm' and 'showKmSimple' xMessage :: [((KeyMask, KeySym), NamedAction)] -> NamedAction xMessage x = addName "Show Keybindings" $ io $ do - forkProcess $ executeFile "xmessage" True ["-default", "okay", unlines $ showKm x] Nothing + xfork $ executeFile "xmessage" True ["-default", "okay", unlines $ showKm x] Nothing return () -- | Merge the supplied keys with 'defaultKeysDescr', also adding a keybinding diff --git a/XMonad/Util/NamedScratchpad.hs b/XMonad/Util/NamedScratchpad.hs --- a/XMonad/Util/NamedScratchpad.hs +++ b/XMonad/Util/NamedScratchpad.hs @@ -22,18 +22,17 @@ customFloating, NamedScratchpads, namedScratchpadAction, + allNamedScratchpadAction, namedScratchpadManageHook, namedScratchpadFilterOutWorkspace ) where import XMonad -import XMonad.Core -import XMonad.ManageHook (composeAll,doFloat) import XMonad.Hooks.ManageHelpers (doRectFloat) import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace) import Control.Monad (filterM) -import Data.Maybe (maybe,listToMaybe) +import Data.Maybe (listToMaybe) import qualified XMonad.StackSet as W @@ -118,28 +117,34 @@ namedScratchpadAction :: NamedScratchpads -- ^ Named scratchpads configuration -> String -- ^ Scratchpad name -> X () -namedScratchpadAction confs n - | Just conf <- findByName confs n = withWindowSet $ \s -> do - -- try to find it on the current workspace - filterCurrent <- filterM (runQuery (query conf)) - ( (maybe [] W.integrate . W.stack . - W.workspace . W.current) s) - case filterCurrent of - (x:_) -> do - -- create hidden workspace if it doesn't exist - if null (filter ((== scratchpadWorkspaceTag) . W.tag) (W.workspaces s)) - then addHiddenWorkspace scratchpadWorkspaceTag - else return () - -- push window there - windows $ W.shiftWin scratchpadWorkspaceTag x - [] -> do - -- try to find it on all workspaces - filterAll <- filterM (runQuery (query conf)) (W.allWindows s) - case filterAll of - (x:_) -> windows $ W.shiftWin (W.currentTag s) x - [] -> runApplication conf +namedScratchpadAction = someNamedScratchpadAction (\f ws -> f $ head ws) +allNamedScratchpadAction :: NamedScratchpads + -> String + -> X () +allNamedScratchpadAction = someNamedScratchpadAction mapM_ + +someNamedScratchpadAction :: ((Window -> X ()) -> [Window] -> X ()) + -> NamedScratchpads + -> String + -> X () +someNamedScratchpadAction f confs n + | Just conf <- findByName confs n = withWindowSet $ \s -> do + filterCurrent <- filterM (runQuery (query conf)) + ((maybe [] W.integrate . W.stack . W.workspace . W.current) s) + filterAll <- filterM (runQuery (query conf)) (W.allWindows s) + case filterCurrent of + [] -> do + case filterAll of + [] -> runApplication conf + _ -> f (windows . W.shiftWin (W.currentTag s)) filterAll + _ -> do + if null (filter ((== scratchpadWorkspaceTag) . W.tag) (W.workspaces s)) + then addHiddenWorkspace scratchpadWorkspaceTag + else return () + f (windows . W.shiftWin scratchpadWorkspaceTag) filterAll | otherwise = return () + -- tag of the scratchpad workspace scratchpadWorkspaceTag :: String diff --git a/XMonad/Util/Paste.hs b/XMonad/Util/Paste.hs --- a/XMonad/Util/Paste.hs +++ b/XMonad/Util/Paste.hs @@ -28,8 +28,10 @@ import Control.Monad.Reader (asks) import XMonad.Operations (withFocused) import Data.Char (isUpper) -import Graphics.X11.Xlib.Misc (stringToKeysym) +import Data.Maybe (listToMaybe) import XMonad.Util.XSelection (getSelection) +import XMonad.Util.EZConfig (parseKey) +import Text.ParserCombinators.ReadP (readP_to_S) {- $usage @@ -70,7 +72,8 @@ have trouble with any 'Char' outside ASCII. -} pasteChar :: KeyMask -> Char -> X () -pasteChar m c = sendKey m $ stringToKeysym [c] +pasteChar m c = sendKey m $ maybe (stringToKeysym [c]) fst + $ listToMaybe $ readP_to_S parseKey [c] sendKey :: KeyMask -> KeySym -> X () sendKey = (withFocused .) . sendKeyWindow diff --git a/XMonad/Util/PositionStore.hs b/XMonad/Util/PositionStore.hs new file mode 100644 --- /dev/null +++ b/XMonad/Util/PositionStore.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.PositionStore +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A utility module to store information about position and size of a window. +-- See "XMonad.Layout.PositionStoreFloat" for a layout that makes use of this. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.PositionStore ( + getPosStore, + modifyPosStore, + + posStoreInsert, + posStoreMove, + posStoreQuery, + posStoreRemove, + PositionStore, + ) where + +import XMonad +import qualified XMonad.Util.ExtensibleState as XS +import qualified Data.Map as M + +-- Store window positions relative to the upper left screen edge +-- and windows sizes as well as positions as fractions of the screen size. +-- This way windows can be easily relocated and scaled when switching screens. + +data PositionStore = PS (M.Map Window PosStoreRectangle) + deriving (Read,Show,Typeable) +data PosStoreRectangle = PSRectangle Double Double Double Double + deriving (Read,Show,Typeable) + +instance ExtensionClass PositionStore where + initialValue = PS M.empty + extensionType = PersistentExtension + +getPosStore :: X (PositionStore) +getPosStore = XS.get + +modifyPosStore :: (PositionStore -> PositionStore) -> X () +modifyPosStore = XS.modify + +posStoreInsert :: PositionStore -> Window -> Rectangle -> Rectangle -> PositionStore +posStoreInsert (PS posStoreMap) w (Rectangle x y wh ht) (Rectangle srX srY srWh srHt) = + let offsetX = x - srX + offsetY = y - srY + in PS $ M.insert w (PSRectangle (fromIntegral offsetX / fromIntegral srWh) + (fromIntegral offsetY / fromIntegral srHt) + (fromIntegral wh / fromIntegral srWh) + (fromIntegral ht / fromIntegral srHt)) posStoreMap + +posStoreRemove :: PositionStore -> Window -> PositionStore +posStoreRemove (PS posStoreMap) w = PS $ M.delete w posStoreMap + +posStoreQuery :: PositionStore -> Window -> Rectangle -> Maybe Rectangle +posStoreQuery (PS posStoreMap) w (Rectangle srX srY srWh srHt) = do + (PSRectangle x y wh ht) <- M.lookup w posStoreMap + let realWh = fromIntegral srWh * wh + realHt = fromIntegral srHt * ht + realOffsetX = fromIntegral srWh * x + realOffsetY = fromIntegral srHt * y + return (Rectangle (srX + round realOffsetX) (srY + round realOffsetY) + (round realWh) (round realHt)) + +posStoreMove :: PositionStore -> Window -> Position -> Position -> Rectangle -> Rectangle -> PositionStore +posStoreMove posStore w x y oldSr newSr = + case (posStoreQuery posStore w oldSr) of + Nothing -> posStore -- not in store, can't move -> do nothing + Just (Rectangle _ _ wh ht) -> posStoreInsert posStore w (Rectangle x y wh ht) newSr diff --git a/XMonad/Util/Replace.hs b/XMonad/Util/Replace.hs --- a/XMonad/Util/Replace.hs +++ b/XMonad/Util/Replace.hs @@ -19,7 +19,7 @@ ( -- * Usage -- $usage replace - + -- * Notes -- $shortcomings @@ -52,7 +52,7 @@ -- $getArgs -- You can use 'System.Environment.getArgs' to watch for an explicit -- @--replace@ flag: --- +-- -- > import XMonad -- > import XMonad.Util.Replace (replace) -- > import Control.Monad (when) diff --git a/XMonad/Util/Run.hs b/XMonad/Util/Run.hs --- a/XMonad/Util/Run.hs +++ b/XMonad/Util/Run.hs @@ -31,11 +31,10 @@ hPutStr, hPutStrLn -- re-export for convenience ) where +import Codec.Binary.UTF8.String import System.Posix.IO -import System.Posix.Process (executeFile, forkProcess, createSession) -import System.Posix.Types (ProcessID) +import System.Posix.Process (createSession, executeFile, forkProcess) import Control.Concurrent (threadDelay) -import Control.Exception.Extensible (try,SomeException) import System.IO import System.Process (runInteractiveProcess) import XMonad @@ -53,9 +52,10 @@ -- "XMonad.Util.Dzen" -- | Returns the output. -runProcessWithInput :: FilePath -> [String] -> String -> IO String -runProcessWithInput cmd args input = do - (pin, pout, perr, _) <- runInteractiveProcess cmd args Nothing Nothing +runProcessWithInput :: MonadIO m => FilePath -> [String] -> String -> m String +runProcessWithInput cmd args input = io $ do + (pin, pout, perr, _) <- runInteractiveProcess (encodeString cmd) + (map encodeString args) Nothing Nothing hPutStr pin input hClose pin output <- hGetContents pout @@ -65,11 +65,12 @@ -- no need to waitForProcess, we ignore SIGCHLD return output --- | Wait is in µs (microseconds) -runProcessWithInputAndWait :: FilePath -> [String] -> String -> Int -> IO () -runProcessWithInputAndWait cmd args input timeout = do - forkProcess $ do - (pin, pout, perr, _) <- runInteractiveProcess cmd args Nothing Nothing +-- | Wait is in μ (microseconds) +runProcessWithInputAndWait :: MonadIO m => FilePath -> [String] -> String -> Int -> m () +runProcessWithInputAndWait cmd args input timeout = io $ do + _ <- xfork $ do + (pin, pout, perr, _) <- runInteractiveProcess (encodeString cmd) + (map encodeString args) Nothing Nothing hPutStr pin input hFlush pin threadDelay timeout @@ -88,7 +89,7 @@ seconds :: Rational -> Int seconds = fromEnum . (* 1000000) -{- | 'safeSpawn' bypasses "XMonad.Core"'s 'spawn' command, because spawn passes +{- | 'safeSpawn' bypasses 'spawn', because spawn passes strings to \/bin\/sh to be interpreted as shell commands. This is often what one wants, but in many cases the passed string will contain shell metacharacters which one does not want interpreted as such (URLs @@ -96,28 +97,31 @@ this case, it is more useful to specify a file or program to be run and a string to give it as an argument so as to bypass the shell and be certain the program will receive the string as you typed it. -unsafeSpawn is internally an alias for XMonad's 'spawn', to remind one that use -of it can be, well, unsafe. + Examples: > , ((modm, xK_Print), unsafeSpawn "import -window root $HOME/xwd-$(date +%s)$$.png") -> , ((modm, xK_d ), safeSpawn "firefox" "") +> , ((modm, xK_d ), safeSpawn "firefox" []) Note that the unsafeSpawn example must be unsafe and not safe because it makes use of shell interpretation by relying on @$HOME@ and interpolation, whereas the safeSpawn example can be safe because Firefox doesn't need any arguments if it is just being started. -} safeSpawn :: MonadIO m => FilePath -> [String] -> m () -safeSpawn prog args = liftIO $ do - try $ forkProcess $ executeFile prog True args Nothing :: IO (Either SomeException ProcessID) - return () +safeSpawn prog args = io $ void_ $ forkProcess $ do + uninstallSignalHandlers + _ <- createSession + executeFile (encodeString prog) True (map encodeString args) Nothing + where void_ = (>> return ()) -- TODO: replace with Control.Monad.void / void not in ghc6 apparently --- | Like 'safeSpawn', but only takes a program (and no arguments for it). eg. +-- | Simplified 'safeSpawn'; only takes a program (and no arguments): -- --- > safeSpawnProg "firefox" +-- > , ((modm, xK_d ), safeSpawnProg "firefox") safeSpawnProg :: MonadIO m => FilePath -> m () safeSpawnProg = flip safeSpawn [] +-- | An alias for 'spawn'; the name emphasizes that one is calling out to a +-- Turing-complete interpreter which may do things one dislikes; for details, see 'safeSpawn'. unsafeSpawn :: MonadIO m => String -> m () unsafeSpawn = spawn @@ -132,16 +136,14 @@ safeRunInTerm options command = asks (terminal . config) >>= \t -> safeSpawn t [options, " -e " ++ command] -- | Launch an external application through the system shell and return a @Handle@ to its standard input. -spawnPipe :: String -> IO Handle -spawnPipe x = do +spawnPipe :: MonadIO m => String -> m Handle +spawnPipe x = io $ do (rd, wr) <- createPipe setFdOption wr CloseOnExec True h <- fdToHandle wr hSetBuffering h LineBuffering - forkProcess $ do - createSession - uninstallSignalHandlers - dupTo rd stdInput - executeFile "/bin/sh" False ["-c", x] Nothing + _ <- xfork $ do + _ <- dupTo rd stdInput + executeFile "/bin/sh" False ["-c", encodeString x] Nothing closeFd rd return h diff --git a/XMonad/Util/Scratchpad.hs b/XMonad/Util/Scratchpad.hs --- a/XMonad/Util/Scratchpad.hs +++ b/XMonad/Util/Scratchpad.hs @@ -24,7 +24,6 @@ ) where import XMonad -import XMonad.Core import qualified XMonad.StackSet as W import XMonad.Util.NamedScratchpad diff --git a/XMonad/Util/SpawnOnce.hs b/XMonad/Util/SpawnOnce.hs new file mode 100644 --- /dev/null +++ b/XMonad/Util/SpawnOnce.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.SpawnOnce +-- Copyright : (c) Spencer Janssen 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : spencerjanssen@gmail.com +-- Stability : unstable +-- Portability : not portable +-- +-- A module for spawning a command once, and only once. Useful to start +-- status bars and make session settings inside startupHook. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.SpawnOnce (spawnOnce) where + +import XMonad +import Data.Set as Set +import qualified XMonad.Util.ExtensibleState as XS +import Control.Monad + +data SpawnOnce = SpawnOnce { unspawnOnce :: (Set String) } + deriving (Read, Show, Typeable) + +instance ExtensionClass SpawnOnce where + initialValue = SpawnOnce Set.empty + extensionType = PersistentExtension + +-- | The first time 'spawnOnce' is executed on a particular command, that +-- command is executed. Subsequent invocations for a command do nothing. +spawnOnce :: String -> X () +spawnOnce xs = do + b <- XS.gets (Set.member xs . unspawnOnce) + when (not b) $ do + spawn xs + XS.modify (SpawnOnce . Set.insert xs . unspawnOnce) diff --git a/XMonad/Util/Stack.hs b/XMonad/Util/Stack.hs new file mode 100644 --- /dev/null +++ b/XMonad/Util/Stack.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Stack +-- Copyright : Quentin Moser +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : orphaned +-- Stability : unstable +-- Portability : unportable +-- +-- Utility functions for manipulating @Maybe Stack@s. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Stack ( -- * Usage + -- | This is a developer-oriented module, intended to be used + -- for writing new extentions. + Zipper + , emptyZ + , singletonZ + + -- * Conversions + , fromIndex + , toIndex + , fromTags + , toTags + + -- * 'Zipper' manipulation functions + -- ** Insertion, movement + , insertUpZ + , insertDownZ + , swapUpZ + , swapDownZ + , swapMasterZ + -- ** Focus movement + , focusUpZ + , focusDownZ + , focusMasterZ + -- ** Extraction + , getFocusZ + , getIZ + -- ** Sorting + , sortZ + , sortByZ + -- ** Maps + , mapZ + , mapZ_ + , mapZM + , mapZM_ + , onFocusedZ + , onFocusedZM + , onIndexZ + , onIndexZM + -- ** Filters + , filterZ + , filterZ_ + , deleteFocusedZ + , deleteIndexZ + -- ** Folds + , foldrZ + , foldlZ + , foldrZ_ + , foldlZ_ + , elemZ + + -- * Other utility functions + , getI + , tagBy + , fromE + , mapE + , mapE_ + , mapEM + , mapEM_ + ) where + +import qualified XMonad.StackSet as W +import Control.Monad (liftM) +import Data.List (sortBy) + + + +type Zipper a = Maybe (W.Stack a) + +emptyZ :: Zipper a +emptyZ = Nothing + +singletonZ :: a -> Zipper a +singletonZ a = Just $ W.Stack a [] [] + +-- * Conversions + +-- | Create a stack from a list, and the 0-based index of the focused element. +-- If the index is out of bounds, focus will go to the first element. +fromIndex :: [a] -> Int -> Zipper a +fromIndex as i = fromTags $ zipWith ($) (replicate i Left ++ [Right] ++ repeat Left) as + +-- | Turn a stack into a list and the index of its focused element. +toIndex :: Zipper a -> ([a], Maybe Int) +toIndex Nothing = ([], Nothing) +toIndex (Just s) = (W.integrate s, Just $ length $ W.up s) + +-- | Create a stack from a list of 'Either'-tagged values. Focus will go to +-- the first 'Right' value, or if there is none, to the first 'Left' one. +fromTags :: [Either a a] -> Zipper a +fromTags = finalize . foldr step ([], Nothing, []) + where step (Right a) (u, Just f, d) = ([], Just a, u++f:d) + step (Right a) (u, Nothing, d) = (u, Just a, d) + step (Left a) (u, Just f, d) = (a:u, Just f, d) + step (Left a) (u, Nothing, d) = (u, Nothing, a:d) + finalize (u, Just f, d) = Just $ W.Stack f (reverse u) d + finalize (u, Nothing, a:d) = Just $ W.Stack a (reverse u) d + finalize (_, Nothing, []) = Nothing + +-- | Turn a stack into an 'Either'-tagged list. The focused element +-- will be tagged with 'Right', the others with 'Left'. +toTags :: Zipper a -> [Either a a] +toTags Nothing = [] +toTags (Just s) = map Left (reverse . W.up $ s) ++ [Right . W.focus $ s] + ++ map Left (W.down s) + + +-- * Zipper functions + +-- ** Insertion, movement + +-- | Insert an element before the focused one, and focus it +insertUpZ :: a -> Zipper a -> Zipper a +insertUpZ a Nothing = W.differentiate [a] +insertUpZ a (Just s) = Just s { W.focus = a , W.down = W.focus s : W.down s } + +-- | Insert an element after the focused one, and focus it +insertDownZ :: a -> Zipper a -> Zipper a +insertDownZ a Nothing = W.differentiate [a] +insertDownZ a (Just s) = Just s { W.focus = a, W.up = W.focus s : W.up s } + +-- | Swap the focused element with the previous one +swapUpZ :: Zipper a -> Zipper a +swapUpZ Nothing = Nothing +swapUpZ (Just s) | u:up <- W.up s = Just s { W.up = up, W.down = u:W.down s} +swapUpZ (Just s) = Just s { W.up = reverse (W.down s), W.down = [] } + +-- | Swap the focused element with the next one +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) } + +-- | Swap the focused element with the first one +swapMasterZ :: Zipper a -> Zipper a +swapMasterZ Nothing = Nothing +swapMasterZ (Just (W.Stack f up down)) = Just $ W.Stack f [] (reverse up ++ down) + +-- ** Focus movement + +-- | Move the focus to the previous element +focusUpZ :: Zipper a -> Zipper a +focusUpZ Nothing = Nothing +focusUpZ (Just s) | u:up <- W.up s = Just $ W.Stack u up (W.focus s:W.down s) +focusUpZ (Just s) | null $ W.down s = Just s +focusUpZ (Just (W.Stack f _ down)) = Just $ W.Stack (last down) (reverse (init down) ++ [f]) [] + +-- | Move the focus to the next element +focusDownZ :: Zipper a -> Zipper a +focusDownZ Nothing = Nothing +focusDownZ (Just s) | d:down <- W.down s = Just $ W.Stack d (W.focus s:W.up s) down +focusDownZ (Just s) | null $ W.up s = Just s +focusDownZ (Just (W.Stack f up _)) = Just $ W.Stack (last up) [] (reverse (init up) ++ [f]) + +-- | Move the focus to the first element +focusMasterZ :: Zipper a -> Zipper a +focusMasterZ Nothing = Nothing +focusMasterZ (Just (W.Stack f up down)) | not $ null up + = Just $ W.Stack (last up) [] (reverse (init up) ++ [f] ++ down) +focusMasterZ (Just s) = Just s + +-- ** Extraction + +-- | Get the focused element +getFocusZ :: Zipper a -> Maybe a +getFocusZ = fmap W.focus + +-- | Get the element at a given index +getIZ :: Int -> Zipper a -> Maybe a +getIZ i = getI i . W.integrate' + +-- ** Sorting + +-- | Sort a stack of elements supporting 'Ord' +sortZ :: Ord a => Zipper a -> Zipper a +sortZ = sortByZ compare + +-- | Sort a stack with an arbitrary sorting function +sortByZ :: (a -> a -> Ordering) -> Zipper a -> Zipper a +sortByZ f = fromTags . sortBy (adapt f) . toTags + 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 +mapZ f as = fromTags . map (mapE f) . toTags $ as + +-- | 'mapZ' without the 'Bool' argument +mapZ_ :: (a -> b) -> Zipper a -> Zipper b +mapZ_ = mapZ . const + +-- | Monadic version of 'mapZ' +mapZM :: Monad m => (Bool -> a -> m b) -> Zipper a -> m (Zipper b) +mapZM f as = fromTags `liftM` (mapM (mapEM f) . toTags) as + + +-- | Monadic version of 'mapZ_' +mapZM_ :: Monad m => (a -> m b) -> Zipper a -> m (Zipper b) +mapZM_ = mapZM . const + +-- | Apply a function to the focused element +onFocusedZ :: (a -> a) -> Zipper a -> Zipper a +onFocusedZ f = mapZ $ \b a -> if b then f a else a + +-- | Monadic version of 'onFocusedZ' +onFocusedZM :: Monad m => (a -> m a) -> Zipper a -> m (Zipper a) +onFocusedZM f = mapZM $ \b a -> if b then f a else return a + +-- | Apply a function to the element at the given index +onIndexZ :: Int -> (a -> a) -> Zipper a -> Zipper a +onIndexZ i _ as | i < 0 = as +onIndexZ i f as = case splitAt i $ toTags as of + (before, []) -> fromTags before + (before, a:after) -> fromTags $ before ++ mapE (const f) a : after + +-- | Monadic version of 'onIndexZ' +onIndexZM :: Monad m => Int -> (a -> m a) -> Zipper a -> m (Zipper a) +onIndexZM i f as = case splitAt i $ toTags as of + (before, []) -> return $ fromTags before + (before, a:after) -> do a' <- mapEM (const f) a + return $ fromTags $ before ++ a' : after + +-- ** Filters + +-- | Fiter a stack according to a predicate. The refocusing behavior +-- mimics XMonad's usual one. The boolean argument indicates whether the current +-- element is the focused one. +filterZ :: (Bool -> a -> Bool) -> Zipper a -> Zipper a +filterZ _ Nothing = Nothing +filterZ p (Just s) = case ( p True (W.focus s) + , filter (p False) (W.up s) + , filter (p False) (W.down s) ) of + (True, up', down') -> Just s { W.up = up', W.down = down' } + (False, [], []) -> Nothing + (False, f:up', []) -> Just s { W.focus = f, W.up = up', W.down = [] } + (False, up', f:down') -> Just s { W.focus = f + , W.up = up' + , W.down = down' } + +-- | 'filterZ' without the 'Bool' argument +filterZ_ :: (a -> Bool) -> Zipper a -> Zipper a +filterZ_ = filterZ . const + +-- | Delete the focused element +deleteFocusedZ :: Zipper a -> Zipper a +deleteFocusedZ = filterZ (\b _ -> not b) + +-- | Delete the ith element +deleteIndexZ :: Int -> Zipper a -> Zipper a +deleteIndexZ i z = let numbered = (fromTags . zipWith number [0..] . toTags) z + number j ea = mapE (\_ a -> (j,a)) ea + in mapZ_ snd $ filterZ_ ((/=i) . fst) numbered + +-- ** Folds + +-- | Analogous to 'foldr'. The 'Bool' argument to the step functions indicates +-- whether the current element is the focused one +foldrZ :: (Bool -> a -> b -> b) -> b -> Zipper a -> b +foldrZ _ b Nothing = b +foldrZ f b (Just s) = let b1 = foldr (f False) b (W.down s) + b2 = f True (W.focus s) b1 + b3 = foldl (flip $ f False) b2 (W.up s) + in b3 + +-- | Analogous to 'foldl'. The 'Bool' argument to the step functions indicates +-- whether the current element is the focused one +foldlZ :: (Bool -> b -> a -> b) -> b -> Zipper a -> b +foldlZ _ b Nothing = b +foldlZ f b (Just s) = let b1 = foldr (flip $ f False) b (W.up s) + b2 = f True b1 (W.focus s) + b3 = foldl (f False) b2 (W.down s) + in b3 + +-- | 'foldrZ' without the 'Bool' argument. +foldrZ_ :: (a -> b -> b) -> b -> Zipper a -> b +foldrZ_ = foldrZ . const + +-- | 'foldlZ' without the 'Bool' argument. +foldlZ_ :: (b -> a -> b) -> b -> Zipper a -> b +foldlZ_ = foldlZ . const + +-- | Find whether an element is present in a stack. +elemZ :: Eq a => a -> Zipper a -> Bool +elemZ a as = foldlZ_ step False as + where step True _ = True + step False a' = a' == a + + +-- * Other utility functions + +-- | Safe version of '!!' +getI :: Int -> [a] -> Maybe a +getI _ [] = Nothing +getI 0 (a:_) = Just a +getI i (_:as) = getI (i-1) as + +-- | Map a function across both 'Left's and 'Right's. +-- The 'Bool' argument is 'True' in a 'Right', 'False' +-- in a 'Left'. +mapE :: (Bool -> a -> b) -> Either a a -> Either b b +mapE f (Left a) = Left $ f False a +mapE f (Right a) = Right $ f True a + +mapE_ :: (a -> b) -> Either a a -> Either b b +mapE_ = mapE . const + +-- | Monadic version of 'mapE' +mapEM :: Monad m => (Bool -> a -> m b) -> Either a a -> m (Either b b) +mapEM f (Left a) = Left `liftM` f False a +mapEM f (Right a) = Right `liftM` f True a + +mapEM_ :: Monad m => (a -> m b) -> Either a a -> m (Either b b) +mapEM_ = mapEM . const + +-- | Get the @a@ from an @Either a a@ +fromE :: Either a a -> a +fromE (Right a) = a +fromE (Left a) = a + +-- | Tag the element with 'Right' if the property is true, 'Left' otherwise +tagBy :: (a -> Bool) -> a -> Either a a +tagBy p a = if p a then Right a else Left a diff --git a/XMonad/Util/Timer.hs b/XMonad/Util/Timer.hs --- a/XMonad/Util/Timer.hs +++ b/XMonad/Util/Timer.hs @@ -23,7 +23,6 @@ import Control.Applicative import Control.Concurrent import Data.Unique -import System.Posix.Process (forkProcess) -- $usage -- This module can be used to setup a timer to handle deferred events. @@ -36,7 +35,7 @@ startTimer :: Rational -> X TimerId startTimer s = io $ do u <- hashUnique <$> newUnique - forkProcess $ do + xfork $ do d <- openDisplay "" rw <- rootWindow d $ defaultScreen d threadDelay (fromEnum $ s * 1000000) diff --git a/XMonad/Util/WindowProperties.hs b/XMonad/Util/WindowProperties.hs --- a/XMonad/Util/WindowProperties.hs +++ b/XMonad/Util/WindowProperties.hs @@ -49,15 +49,7 @@ -- | Does given window have this property? hasProperty :: Property -> Window -> X Bool -hasProperty (Title s) w = withDisplay $ \d -> fmap (Just s ==) $ io $ fetchName d w -hasProperty (Resource s) w = withDisplay $ \d -> fmap ((==) s . resName ) $ io $ getClassHint d w -hasProperty (ClassName s) w = withDisplay $ \d -> fmap ((==) s . resClass) $ io $ getClassHint d w -hasProperty (Role s) w = withDisplay $ \d -> fmap ((==) (Just s)) $ getStringProperty d w "WM_WINDOW_ROLE" -hasProperty (Machine s) w = withDisplay $ \d -> fmap ((==) (Just s)) $ getStringProperty d w "WM_CLIENT_MACHINE" -hasProperty (And p1 p2) w = do { r1 <- hasProperty p1 w; r2 <- hasProperty p2 w; return $ r1 && r2 } -hasProperty (Or p1 p2) w = do { r1 <- hasProperty p1 w; r2 <- hasProperty p2 w; return $ r1 || r2 } -hasProperty (Not p1) w = do { r1 <- hasProperty p1 w; return $ not r1 } -hasProperty (Const b) _ = return b +hasProperty p w = runQuery (propertyToQuery p) w -- | Does the focused window have this property? focusedHasProperty :: Property -> X Bool diff --git a/XMonad/Util/WorkspaceCompare.hs b/XMonad/Util/WorkspaceCompare.hs --- a/XMonad/Util/WorkspaceCompare.hs +++ b/XMonad/Util/WorkspaceCompare.hs @@ -8,15 +8,18 @@ -- Stability : unstable -- Portability : unportable -- +----------------------------------------------------------------------------- module XMonad.Util.WorkspaceCompare ( WorkspaceCompare, WorkspaceSort , getWsIndex , getWsCompare , getWsCompareByTag + , getXineramaPhysicalWsCompare , getXineramaWsCompare , mkWsSort , getSortByIndex , getSortByTag + , getSortByXineramaPhysicalRule , getSortByXineramaRule ) where import XMonad @@ -25,6 +28,7 @@ import Data.Monoid import Data.Ord import Data.Maybe +import Data.Function type WorkspaceCompare = WorkspaceId -> WorkspaceId -> Ordering type WorkspaceSort = [WindowSpace] -> [WindowSpace] @@ -41,12 +45,7 @@ getWsCompare :: X WorkspaceCompare getWsCompare = do wsIndex <- getWsIndex - return $ \a b -> f (wsIndex a) (wsIndex b) `mappend` compare a b - where - f Nothing Nothing = EQ - f (Just _) Nothing = LT - f Nothing (Just _) = GT - f (Just x) (Just y) = compare x y + return $ mconcat [compare `on` wsIndex, compare] -- | A simple comparison function that orders workspaces -- lexicographically by tag. @@ -57,10 +56,17 @@ -- and screen id. It produces the same ordering as -- 'XMonad.Hooks.DynamicLog.pprWindowSetXinerama'. getXineramaWsCompare :: X WorkspaceCompare -getXineramaWsCompare = do +getXineramaWsCompare = getXineramaWsCompare' False + +-- | A comparison function like 'getXineramaWsCompare', but uses physical locations for screens. +getXineramaPhysicalWsCompare :: X WorkspaceCompare +getXineramaPhysicalWsCompare = getXineramaWsCompare' True + +getXineramaWsCompare' :: Bool -> X WorkspaceCompare +getXineramaWsCompare' phy = do w <- gets windowset return $ \ a b -> case (isOnScreen a w, isOnScreen b w) of - (True, True) -> comparing (tagToSid (onScreen w)) a b + (True, True) -> cmpPosition phy w a b (False, False) -> compare a b (True, False) -> LT (False, True) -> GT @@ -68,6 +74,10 @@ onScreen w = S.current w : S.visible w isOnScreen a w = a `elem` map (S.tag . S.workspace) (onScreen w) tagToSid s x = S.screen $ fromJust $ find ((== x) . S.tag . S.workspace) s + cmpPosition False w a b = comparing (tagToSid $ onScreen w) a b + cmpPosition True w a b = comparing (rect.(tagToSid $ onScreen w)) a b + where rect i = let (Rectangle x y _ _) = screens !! fromIntegral i in (y,x) + screens = map (screenRect . S.screenDetail) $ sortBy (comparing S.screen) $ S.current w : S.visible w -- | Create a workspace sorting function from a workspace comparison -- function. @@ -91,4 +101,8 @@ -- sorted by tag. getSortByXineramaRule :: X WorkspaceSort getSortByXineramaRule = mkWsSort getXineramaWsCompare + +-- | Like 'getSortByXineramaRule', but uses physical locations for screens. +getSortByXineramaPhysicalRule :: X WorkspaceSort +getSortByXineramaPhysicalRule = mkWsSort getXineramaPhysicalWsCompare diff --git a/XMonad/Util/XSelection.hs b/XMonad/Util/XSelection.hs --- a/XMonad/Util/XSelection.hs +++ b/XMonad/Util/XSelection.hs @@ -9,7 +9,7 @@ Portability : unportable A module for accessing and manipulating X Window's mouse selection (the buffer used in copy and pasting). -'getSelection' and 'putSelection' are adaptations of Hxsel.hs and Hxput.hs from the XMonad-utils, available: +'getSelection' is an adaptation of Hxsel.hs and Hxput.hs from the XMonad-utils, available: > $ darcs get -} @@ -20,13 +20,10 @@ promptSelection, safePromptSelection, transformPromptSelection, - transformSafePromptSelection, - putSelection) where + transformSafePromptSelection) where -import Control.Concurrent (forkIO) import Control.Exception.Extensible as E (catch,SomeException(..)) -import Control.Monad(Monad (return, (>>)), Functor(..), liftM, join) -import Data.Char (ord) +import Control.Monad (liftM, join) import Data.Maybe (fromMaybe) import XMonad import XMonad.Util.Run (safeSpawn, unsafeSpawn) @@ -42,23 +39,13 @@ > , ((modm .|. shiftMask, xK_b), promptSelection "firefox") - There are a number of known problems with XSelection: - - * Unicode handling is busted. But it's still better than calling - 'chr' to translate to ASCII, at least. - As near as I can tell, the mangling happens when the String is - outputted somewhere, such as via promptSelection's passing through - the shell, or GHCi printing to the terminal. utf-string has IO functions - which can fix this, though I do not know have to use them here. It's - a complex issue; see - - and . + Future improvements for XSelection: - * Needs more elaborate functionality: Emacs' registers are nice; if you + * More elaborate functionality: Emacs' registers are nice; if you don't know what they are, see -} --- | Returns a String corresponding to the current mouse selection in X; if there is none, an empty string is returned. Note that this is --- really only reliable for ASCII text and currently escapes or otherwise mangles more complex UTF-8 characters. +-- | Returns a String corresponding to the current mouse selection in X; +-- if there is none, an empty string is returned. getSelection :: MonadIO m => m String getSelection = io $ do dpy <- openDisplay "" @@ -81,60 +68,25 @@ return $ decode . map fromIntegral . fromMaybe [] $ res else destroyWindow dpy win >> return "" --- | Set the current X Selection to a specified string. -putSelection :: MonadIO m => String -> m () -putSelection text = io $ do - dpy <- openDisplay "" - let dflt = defaultScreen dpy - rootw <- rootWindow dpy dflt - win <- createSimpleWindow dpy rootw 0 0 1 1 0 0 0 - p <- internAtom dpy "PRIMARY" True - ty <- internAtom dpy "UTF8_STRING" False - xSetSelectionOwner dpy p win currentTime - winOwn <- xGetSelectionOwner dpy p - if winOwn == win - then do forkIO ((allocaXEvent $ processEvent dpy ty text) >> destroyWindow dpy win) >> return () - else do putStrLn "Unable to obtain ownership of the selection" >> destroyWindow dpy win - return () - where - processEvent :: Display -> Atom -> [Char] -> XEventPtr -> IO () - processEvent dpy ty txt e = do - nextEvent dpy e - ev <- getEvent e - if ev_event_type ev == selectionRequest - then do print ev - allocaXEvent $ \replyPtr -> do - changeProperty8 (ev_event_display ev) - (ev_requestor ev) - (ev_property ev) - ty - propModeReplace - (map (fromIntegral . ord) txt) - setSelectionNotify replyPtr (ev_requestor ev) (ev_selection ev) - (ev_target ev) (ev_property ev) (ev_time ev) - sendEvent dpy (ev_requestor ev) False noEventMask replyPtr - sync dpy False - else do putStrLn "Unexpected Message Received" - print ev - processEvent dpy ty text e - {- | A wrapper around 'getSelection'. Makes it convenient to run a program with the current selection as an argument. -This is convenient for handling URLs, in particular. For example, in your Config.hs you could bind a key to + This is convenient for handling URLs, in particular. For example, in your Config.hs you could bind a key to @promptSelection \"firefox\"@; -this would allow you to highlight a URL string and then immediately open it up in Firefox. + this would allow you to highlight a URL string and then immediately open it up in Firefox. -'promptSelection' passes strings through the system shell, \/bin\/sh; if you do not wish your selected text -to be interpreted or mangled by the shell, use 'safePromptSelection'. safePromptSelection will bypass the -shell using 'safeSpawn' from "XMonad.Util.Run"; see its documentation for more -details on the advantages and disadvantages of using safeSpawn. -} + 'promptSelection' passes strings through the system shell, \/bin\/sh; if you do not wish your selected text + to be interpreted or mangled by the shell, use 'safePromptSelection'. safePromptSelection will bypass the + shell using 'safeSpawn' from "XMonad.Util.Run"; see its documentation for more + details on the advantages and disadvantages of using safeSpawn. -} promptSelection, safePromptSelection, unsafePromptSelection :: String -> X () promptSelection = unsafePromptSelection 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 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 to be run as @"sudo" ++ cmd@ or @"su - -c \""++ cmd ++"\""@. --} +{- | 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 + to be run as @"sudo" ++ cmd@ or @"su - -c \""++ cmd ++"\""@. -} transformPromptSelection, transformSafePromptSelection :: (String -> String) -> String -> X () transformPromptSelection f app = join $ io $ liftM (safeSpawn app . return) (fmap f getSelection) transformSafePromptSelection f app = join $ io $ liftM unsafeSpawn $ fmap (\x -> app ++ " " ++ x) (fmap f getSelection) diff --git a/XMonad/Util/XUtils.hs b/XMonad/Util/XUtils.hs --- a/XMonad/Util/XUtils.hs +++ b/XMonad/Util/XUtils.hs @@ -2,6 +2,7 @@ -- | -- Module : XMonad.Util.XUtils -- Copyright : (c) 2007 Andrea Rossato +-- 2010 Alejandro Serrano -- License : BSD-style (see xmonad/LICENSE) -- -- Maintainer : andrea.rossato@unibz.it @@ -25,6 +26,7 @@ , deleteWindows , paintWindow , paintAndWrite + , paintTextAndIcons , stringToPixel , fi ) where @@ -32,11 +34,12 @@ import Data.Maybe import XMonad import XMonad.Util.Font +import XMonad.Util.Image import Control.Monad -- $usage --- See "XMonad.Layout.Tabbed" or "XMonad.Layout.DragPane" for usage --- examples +-- See "XMonad.Layout.Tabbed" or "XMonad.Layout.DragPane" or +-- "XMonad.Layout.Decoration" for usage examples -- | Compute the weighted average the colors of two given Pixel values. averagePixels :: Pixel -> Pixel -> Double -> X Pixel @@ -60,6 +63,11 @@ case m of Just em -> io $ selectInput d win em Nothing -> io $ selectInput d win exposureMask + -- @@@ ugly hack to prevent compositing + whenX (return $ isJust m) $ flip catchX (return ()) $ do + wINDOW_TYPE <- getAtom "_NET_WM_WINDOW_TYPE" + dESKTOP <- getAtom "_NET_WM_WINDOW_TYPE_DESKTOP" + io $ changeProperty32 d win wINDOW_TYPE aTOM propModeReplace [fi dESKTOP] return win -- | Map a window @@ -101,9 +109,10 @@ -> String -- ^ Border color -> X () paintWindow w wh ht bw c bc = - paintWindow' w (Rectangle 0 0 wh ht) bw c bc Nothing + paintWindow' w (Rectangle 0 0 wh ht) bw c bc Nothing Nothing --- | Fill a window with a rectangle and a border, and write a string at given position +-- | Fill a window with a rectangle and a border, and write +-- | a number of strings to given positions paintAndWrite :: Window -- ^ The window where to draw -> XMonadFont -- ^ XMonad Font for drawing -> Dimension -- ^ Window width @@ -113,19 +122,50 @@ -> String -- ^ Border color -> String -- ^ String color -> String -- ^ String background color - -> Align -- ^ String 'Align'ment - -> String -- ^ String to be printed + -> [Align] -- ^ String 'Align'ments + -> [String] -- ^ Strings to be printed -> X () -paintAndWrite w fs wh ht bw bc borc ffc fbc al str = do +paintAndWrite w fs wh ht bw bc borc ffc fbc als strs = do d <- asks display - (x,y) <- stringPosition d fs (Rectangle 0 0 wh ht) al str - paintWindow' w (Rectangle x y wh ht) bw bc borc ms - where ms = Just (fs,ffc,fbc,str) + strPositions <- forM (zip als strs) $ \(al, str) -> + stringPosition d fs (Rectangle 0 0 wh ht) al str + let ms = Just (fs,ffc,fbc, zip strs strPositions) + paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms Nothing +-- | Fill a window with a rectangle and a border, and write +-- | a number of strings and a number of icons to given positions +paintTextAndIcons :: Window -- ^ The window where to draw + -> XMonadFont -- ^ XMonad Font for drawing + -> Dimension -- ^ Window width + -> Dimension -- ^ Window height + -> Dimension -- ^ Border width + -> String -- ^ Window background color + -> String -- ^ Border color + -> String -- ^ String color + -> String -- ^ String background color + -> [Align] -- ^ String 'Align'ments + -> [String] -- ^ Strings to be printed + -> [Placement] -- ^ Icon 'Placements' + -> [[[Bool]]] -- ^ Icons to be printed + -> X () +paintTextAndIcons w fs wh ht bw bc borc ffc fbc als strs i_als icons = do + d <- asks display + strPositions <- forM (zip als strs) $ \(al, str) -> + stringPosition d fs (Rectangle 0 0 wh ht) al str + let iconPositions = map ( \(al, icon) -> iconPosition (Rectangle 0 0 wh ht) al icon ) (zip i_als icons) + ms = Just (fs,ffc,fbc, zip strs strPositions) + is = Just (ffc, fbc, zip iconPositions icons) + paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms is + -- This stuff is not exported -paintWindow' :: Window -> Rectangle -> Dimension -> String -> String -> Maybe (XMonadFont,String,String,String) -> X () -paintWindow' win (Rectangle x y wh ht) bw color b_color str = do +-- | Paints a titlebar with some strings and icons +-- drawn inside it. +-- Not exported. +paintWindow' :: Window -> Rectangle -> Dimension -> String -> String + -> Maybe (XMonadFont,String,String,[(String, (Position, Position))]) + -> Maybe (String, String, [((Position, Position), [[Bool]])]) -> X () +paintWindow' win (Rectangle _ _ wh ht) bw color b_color strStuff iconStuff = do d <- asks display p <- io $ createPixmap d win wh ht (defaultDepthOfScreen $ defaultScreenOfDisplay d) gc <- io $ createGC d p @@ -138,9 +178,16 @@ -- and now again io $ setForeground d gc color' io $ fillRectangle d p gc (fi bw) (fi bw) (wh - (bw * 2)) (ht - (bw * 2)) - when (isJust str) $ do - let (xmf,fc,bc,s) = fromJust str - printStringXMF d p xmf gc fc bc x y s + -- paint strings + when (isJust strStuff) $ do + let (xmf,fc,bc,strAndPos) = fromJust strStuff + forM_ strAndPos $ \(s, (x, y)) -> + printStringXMF d p xmf gc fc bc x y s + -- paint icons + when (isJust iconStuff) $ do + let (fc, bc, iconAndPos) = fromJust iconStuff + forM_ iconAndPos $ \((x, y), icon) -> + drawIcon d p gc fc bc x y icon -- copy the pixmap over the window io $ copyArea d p win gc 0 0 wh ht 0 0 -- free the pixmap and GC @@ -162,6 +209,3 @@ createWindow d rw x y w h 0 (defaultDepthOfScreen s) inputOutput visual attrmask attributes --- | Short-hand for 'fromIntegral' -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral diff --git a/scripts/window-properties.sh b/scripts/window-properties.sh new file mode 100644 --- /dev/null +++ b/scripts/window-properties.sh @@ -0,0 +1,15 @@ +#! /bin/sh +# Script to print common window properties in ManageHook format, +# via xprop. All xprop options may be used, although anything other +# than -display, -id, and -name is probably a bad idea. +# +# Written and placed into the public domain by Brandon S Allbery +# KF8NH +# + +exec xprop -notype \ + -f WM_NAME 8s ':\n title =\? $0\n' \ + -f WM_CLASS 8s ':\n appName =\? $0\n className =\? $1\n' \ + -f WM_WINDOW_ROLE 8s ':\n stringProperty "WM_WINDOW_ROLE" =\? $0\n' \ + WM_NAME WM_CLASS WM_WINDOW_ROLE \ + ${1+"$@"} diff --git a/tests/ManageDocks.hs b/tests/ManageDocks.hs new file mode 100644 --- /dev/null +++ b/tests/ManageDocks.hs @@ -0,0 +1,21 @@ +module ManageDocks where +import XMonad +import XMonad.Hooks.ManageDocks +import Test.QuickCheck +import Foreign.C.Types +import Properties + +instance Arbitrary CLong where + arbitrary = fromIntegral `fmap` (arbitrary :: Gen Int) +instance Arbitrary RectC where + arbitrary = do + (x,y) <- arbitrary + NonNegative w <- arbitrary + NonNegative h <- arbitrary + return $ RectC (x,y,x+w,y+h) + +prop_r2c_c2r :: RectC -> Bool +prop_r2c_c2r r = r2c (c2r r) == r + +prop_c2r_r2c :: Rectangle -> Bool +prop_c2r_r2c r = c2r (r2c r) == r diff --git a/tests/Selective.hs b/tests/Selective.hs new file mode 100644 --- /dev/null +++ b/tests/Selective.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} +module Selective where + +-- Tests for limitSelect-related code in L.LimitWindows. +-- To run these tests, export (select,update,Selection(..),updateAndSelect) from +-- L.LimitWindows. + +import XMonad.Layout.LimitWindows +import XMonad.StackSet hiding (focusUp, focusDown, filter) +import Control.Applicative ((<$>)) +import Test.QuickCheck +import Control.Arrow (second) + +instance Arbitrary (Stack Int) where + arbitrary = do + xs <- arbNat + ys <- arbNat + return $ Stack { up=[xs-1,xs-2..0], focus=xs, down=[xs+1..xs+ys] } + coarbitrary = undefined + +instance Arbitrary (Selection a) where + arbitrary = do + nm <- arbNat + st <- arbNat + nr <- arbPos + return $ Sel nm (st+nm) nr + coarbitrary = undefined + +arbNat = abs <$> arbitrary +arbPos = (+1) . abs <$> arbitrary + +-- as many windows as possible should be selected +-- (when the selection is normalized) +prop_select_length sel (stk :: Stack Int) = + (length . integrate $ select sel' stk) == ((nMaster sel' + nRest sel') `min` length (integrate stk)) + where sel' = update sel stk + +-- update normalizes selections (is idempotent) +prop_update_idem sel (stk :: Stack Int) = sel' == update sel' stk + where sel' = update sel stk + +-- select selects the master pane +prop_select_master sel (stk :: Stack Int) = + take (nMaster sel) (integrate stk) == take (nMaster sel) (integrate $ select sel stk) + +-- the focus should always be selected in normalized selections +prop_select_focus sel (stk :: Stack Int) = focus stk == (focus $ select sel' stk) + where sel' = update sel stk + +-- select doesn't change order (or duplicate elements) +-- relies on the Arbitrary instance for Stack Int generating increasing stacks +prop_select_increasing sel (stk :: Stack Int) = + let res = integrate $ select sel stk + in and . zipWith (<) res $ tail res + +-- selection has the form [0..l] ++ [m..n] +-- relies on the Arbitrary instance for Stack Int generating stacks like [0..k] +prop_select_two_consec sel (stk :: Stack Int) = + let wins = integrate $ select sel stk + in (length . filter not . zipWith ((==) . (+1)) wins $ tail wins) <= 1 + +-- update preserves invariants on selections +prop_update_nm sel (stk :: Stack Int) = nMaster (update sel stk) >= 0 +prop_update_start sel (stk :: Stack Int) = nMaster sel' <= start sel' + where sel' = update sel stk +prop_update_nr sel (stk :: Stack Int) = nRest (update sel stk) >= 0 + +-- moving the focus to a window that's already selected doesn't change the selection +prop_update_focus_up sel (stk :: Stack Int) x' = + (length (up stk) >= x) && ((up stk !! (x-1)) `elem` integrate stk') ==> + sel' == update sel' (iterate focusUp stk !! x) + where + x = 1 + abs x' + sel' = update sel stk + stk' = select sel' stk + +prop_update_focus_down sel (stk :: Stack Int) x' = + (length (down stk) >= x) && ((down stk !! (x-1)) `elem` integrate stk') ==> + sel' == update sel' (iterate focusDown stk !! x) + where + x = 1 + abs x' + sel' = update sel stk + stk' = select sel' stk + +focusUp stk = stk { up=tail (up stk), focus=head (up stk), down=focus stk:down stk } +focusDown stk = stk { down=tail (down stk), focus=head (down stk), up=focus stk:up stk } diff --git a/tests/SwapWorkspaces.hs b/tests/SwapWorkspaces.hs new file mode 100644 --- /dev/null +++ b/tests/SwapWorkspaces.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module SwapWorkspaces where + +import Data.List(find,union) +import Data.Maybe(fromJust) +import Test.QuickCheck + +import XMonad.StackSet +import Properties(T, NonNegative) -- requires tests/Properties.hs from xmonad-core +import XMonad.Actions.SwapWorkspaces + +-- Ensures that no "loss of information" can happen from a swap. +prop_double_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) = + t1 `tagMember` ss && t2 `tagMember` ss ==> + ss == swap (swap ss) + where swap = swapWorkspaces t1 t2 + +-- Degrade nicely when given invalid data. +prop_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) = + not (t1 `tagMember` ss || t2 `tagMember` ss) ==> + ss == swapWorkspaces t1 t2 ss + +-- This doesn't pass yet. Probably should. +-- prop_half_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) = +-- t1 `tagMember` ss && not (t2 `tagMember` ss) ==> +-- ss == swapWorkspaces t1 t2 ss + +zipWorkspacesWith :: (Workspace i l a -> Workspace i l a -> n) -> StackSet i l a s sd -> + StackSet i l a s sd -> [n] +zipWorkspacesWith f s t = f (workspace $ current s) (workspace $ current t) : + zipWith f (map workspace $ visible s) (map workspace $ visible t) ++ + zipWith f (hidden s) (hidden t) + +-- Swap only modifies the workspaces tagged t1 and t2 -- leaves all others alone. +prop_swap_only_two (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) = + t1 `tagMember` ss && t2 `tagMember` ss ==> + and $ zipWorkspacesWith mostlyEqual ss (swapWorkspaces t1 t2 ss) + where mostlyEqual w1 w2 = map tag [w1, w2] `elem` [[t1, t2], [t2, t1]] || w1 == w2 + +-- swapWithCurrent stays on current +prop_swap_with_current (ss :: T) (t :: NonNegative Int) = + t `tagMember` ss ==> + layout before == layout after && stack before == stack after + where before = workspace $ current ss + after = workspace $ current $ swapWithCurrent t ss + +main = do + putStrLn "Testing double swap" + quickCheck prop_double_swap + putStrLn "Testing invalid swap" + quickCheck prop_invalid_swap + -- putStrLn "Testing half-invalid swap" + -- quickCheck prop_half_invalid_swap + putStrLn "Testing swap only two" + quickCheck prop_swap_only_two + putStrLn "Testing swap with current" + quickCheck prop_swap_with_current diff --git a/tests/XPrompt.hs b/tests/XPrompt.hs new file mode 100644 --- /dev/null +++ b/tests/XPrompt.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE ScopedTypeVariables #-} +------------------------------------- +-- +-- Tests for XPrompt and ShellPrompt +-- +------------------------------------- +module XPrompt where + +import Data.Char +import Test.QuickCheck + +import Data.List + +import XMonad.Prompt +import qualified XMonad.Prompt.Shell as S +import Properties + +{- +instance Arbitrary Char where + arbitrary = choose ('\32', '\255') + coarbitrary c = variant (ord c `rem` 4) + +-} + +doubleCheck p = check (defaultConfig { configMaxTest = 1000}) p +deepCheck p = check (defaultConfig { configMaxTest = 10000}) p +deepestCheck p = check (defaultConfig { configMaxTest = 100000}) p + +-- brute force check for exceptions +prop_split (str :: [Char]) = + forAll (elements str) $ \e -> S.split e str == S.split e str + +-- check if the first element of the new list is indeed the first part +-- of the string. +prop_spliInSubListsAt (x :: Int) (str :: [Char]) = + x < length str ==> result == take x str + where result = case splitInSubListsAt x str of + [] -> [] + x -> head x + +-- skipLastWord is complementary to getLastWord, unless the only space +-- in the string is the final character, in which case skipLastWord +-- and getLastWord will produce the same result. +prop_skipGetLastWord (str :: [Char]) = + skipLastWord str ++ getLastWord str == str || skipLastWord str == getLastWord str + + +-- newIndex and newCommand get only non empy lists +elemGen :: Gen ([String],String) +elemGen = do + a <- arbitrary :: Gen [[Char]] + let l = case filter (/= []) a of + [] -> ["a"] + x -> x + e <- elements l + return (l,e) + +{- newIndex and newCommand have since been renamed or are no longer used + +-- newIndex calculates the index of the next completion in the +-- completion list, so the index must be within the range of the +-- copletions list +prop_newIndex_range = + forAll elemGen $ \(l,c) -> newIndex c l >= 0 && newIndex c l < length l +-} + +-- this is actually the definition of newCommand... +-- just to check something. +{- +prop_newCommandIndex = + forAll elemGen $ \(l,c) -> (skipLastWord c ++ (l !! (newIndex c l))) == newCommand c l +-} + +main = do + putStrLn "Testing ShellPrompt.split" + deepCheck prop_split + putStrLn "Testing spliInSubListsAt" + deepCheck prop_spliInSubListsAt + putStrLn "Testing skip + get lastWord" + deepCheck prop_skipGetLastWord + diff --git a/tests/genMain.hs b/tests/genMain.hs new file mode 100644 --- /dev/null +++ b/tests/genMain.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ViewPatterns #-} +{- | generate another Main from all modules in the current directory, +extracting all functions with @prop_@. + +Usage (your QuickCheck-1 version may vary): + +> ln -s ../../xmonad/tests/Properties.hs . +> runghc genMain.hs > Main.hs +> ghc -DTESTING -i.. -i. -package QuickCheck-1.2.0.0 Main.hs -e ':main 200' + +-} +module Main where + +import Control.Monad.List +import Data.Char +import Data.IORef +import Data.List +import qualified Data.Set as S +import System.Directory +import System.FilePath +import Text.PrettyPrint.HughesPJ + +main = do + imports <- newIORef S.empty + props <- runListT $ do + f @ ((isUpper -> True) : (takeExtension -> ".hs")) + <- ListT (getDirectoryContents ".") + guard $ f `notElem` ["Main.hs", "Common.hs", "Properties.hs"] + let b = takeBaseName f + nesting <- io $ newIORef 0 + decl : _ <- ListT $ (map words . lines) `fmap` readFile f + case decl of + "{-" -> io $ modifyIORef nesting succ + "-}" -> io $ modifyIORef nesting pred + _ -> return () + 0 <- io $ readIORef nesting + guard $ "prop_" `isPrefixOf` decl + io $ modifyIORef imports (S.insert b) + return (b ++ "." ++ decl) + imports <- S.toList `fmap` readIORef imports + print $ genModule imports props + +genModule :: [String] -> [String] -> Doc +genModule imports props = vcat [header,imports', main ] + where + header = text "module Main where" + imports' = text "import Test.QuickCheck; import Data.Maybe; \ + \import System.Environment; import Text.Printf; \ + \import Properties hiding (main); import Control.Monad" + $$ vcat [ text "import qualified" <+> text im | im <- imports ] + props' = [ parens $ doubleQuotes (text p) <> comma <> text "mytest" <+> text p + | p <- props ] + main = hang (text "main = do") 4 $ + text "n <- maybe (return 100) readIO . listToMaybe =<< getArgs" + $$ + hang (text "let props = ") 8 + (brackets $ foldr1 (\x xs -> x <> comma $$ xs) props') + $$ + text "(results, passed) <- liftM unzip $ \ + \mapM (\\(s,a) -> printf \"%-40s: \" s >> a n) props" + $$ + text "printf \"Passed %d tests!\\n\" (sum passed)" + $$ + text "when (any not results) $ fail \"Not all tests passed!\"" + +io x = liftIO x diff --git a/tests/test_SwapWorkspaces.hs b/tests/test_SwapWorkspaces.hs deleted file mode 100644 --- a/tests/test_SwapWorkspaces.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -import Data.List(find,union) -import Data.Maybe(fromJust) -import Test.QuickCheck - -import StackSet -import Properties(T, NonNegative) -import XMonad.SwapWorkspaces - --- Ensures that no "loss of information" can happen from a swap. -prop_double_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) = - t1 `tagMember` ss && t2 `tagMember` ss ==> - ss == swap (swap ss) - where swap = swapWorkspaces t1 t2 - --- Degrade nicely when given invalid data. -prop_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) = - not (t1 `tagMember` ss || t2 `tagMember` ss) ==> - ss == swapWorkspaces t1 t2 ss - --- This doesn't pass yet. Probably should. --- prop_half_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) = --- t1 `tagMember` ss && not (t2 `tagMember` ss) ==> --- ss == swapWorkspaces t1 t2 ss - -zipWorkspacesWith :: (Workspace i l a -> Workspace i l a -> n) -> StackSet i l a s sd -> - StackSet i l a s sd -> [n] -zipWorkspacesWith f s t = f (workspace $ current s) (workspace $ current t) : - zipWith f (map workspace $ visible s) (map workspace $ visible t) ++ - zipWith f (hidden s) (hidden t) - --- Swap only modifies the workspaces tagged t1 and t2 -- leaves all others alone. -prop_swap_only_two (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) = - t1 `tagMember` ss && t2 `tagMember` ss ==> - and $ zipWorkspacesWith mostlyEqual ss (swapWorkspaces t1 t2 ss) - where mostlyEqual w1 w2 = map tag [w1, w2] `elem` [[t1, t2], [t2, t1]] || w1 == w2 - --- swapWithCurrent stays on current -prop_swap_with_current (ss :: T) (t :: NonNegative Int) = - t `tagMember` ss ==> - layout before == layout after && stack before == stack after - where before = workspace $ current ss - after = workspace $ current $ swapWithCurrent t ss - -main = do - putStrLn "Testing double swap" - quickCheck prop_double_swap - putStrLn "Testing invalid swap" - quickCheck prop_invalid_swap - -- putStrLn "Testing half-invalid swap" - -- quickCheck prop_half_invalid_swap - putStrLn "Testing swap only two" - quickCheck prop_swap_only_two - putStrLn "Testing swap with current" - quickCheck prop_swap_with_current diff --git a/tests/test_XPrompt.hs b/tests/test_XPrompt.hs deleted file mode 100644 --- a/tests/test_XPrompt.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -------------------------------------- --- --- Tests for XPrompt and ShellPrompt --- -------------------------------------- - -import Data.Char -import Test.QuickCheck - -import Data.List - -import XMonad.XPrompt -import qualified XMonad.ShellPrompt as S - -instance Arbitrary Char where - arbitrary = choose ('\32', '\255') - coarbitrary c = variant (ord c `rem` 4) - - -doubleCheck p = check (defaultConfig { configMaxTest = 1000}) p -deepCheck p = check (defaultConfig { configMaxTest = 10000}) p -deepestCheck p = check (defaultConfig { configMaxTest = 100000}) p - --- brute force check for exceptions -prop_split (str :: [Char]) = - forAll (elements str) $ \e -> S.split e str == S.split e str - --- check if the first element of the new list is indeed the first part --- of the string. -prop_spliInSubListsAt (x :: Int) (str :: [Char]) = - x < length str ==> result == take x str - where result = case splitInSubListsAt x str of - [] -> [] - x -> head x - --- skipLastWord is complementary to getLastWord, unless the only space --- in the string is the final character, in which case skipLastWord --- and getLastWord will produce the same result. -prop_skipGetLastWord (str :: [Char]) = - skipLastWord str ++ getLastWord str == str || skipLastWord str == getLastWord str - --- newIndex and newCommand get only non empy lists -elemGen :: Gen ([String],String) -elemGen = do - a <- arbitrary :: Gen [[Char]] - let l = case filter (/= []) a of - [] -> ["a"] - x -> x - e <- elements l - return (l,e) - --- newIndex calculates the index of the next completion in the --- completion list, so the index must be within the range of the --- copletions list -prop_newIndex_range = - forAll elemGen $ \(l,c) -> newIndex c l >= 0 && newIndex c l < length l - --- this is actually the definition of newCommand... --- just to check something. -prop_newCommandIndex = - forAll elemGen $ \(l,c) -> (skipLastWord c ++ (l !! (newIndex c l))) == newCommand c l - -main = do - putStrLn "Testing ShellPrompt.split" - deepCheck prop_split - putStrLn "Testing spliInSubListsAt" - deepCheck prop_spliInSubListsAt - putStrLn "Testing newIndex + newCommand" - deepCheck prop_newCommandIndex - putStrLn "Testing skip + get lastWord" - deepCheck prop_skipGetLastWord - putStrLn "Testing range of XPrompt.newIndex" - deepCheck prop_newIndex_range - 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.9.2 +version: 0.10 homepage: http://xmonad.org/ synopsis: Third party extensions for xmonad description: @@ -22,12 +22,16 @@ author: Spencer Janssen maintainer: spencerjanssen@gmail.com extra-source-files: README scripts/generate-configs scripts/run-xmonad.sh + scripts/window-properties.sh scripts/xinitrc scripts/xmonad-acpi.c - scripts/xmonad-clock.c tests/test_SwapWorkspaces.hs - tests/test_XPrompt.hs + scripts/xmonad-clock.c + tests/genMain.hs + tests/ManageDocks.hs + tests/Selective.hs + tests/SwapWorkspaces.hs + tests/XPrompt.hs cabal-version: >= 1.2.1 build-type: Simple -tested-with: GHC == 6.12.4, GHC == 7.0.1 flag small_base description: Choose the new smaller, split-up base package. @@ -57,13 +61,19 @@ extensions: ForeignFunctionInterface cpp-options: -DXFT - build-depends: mtl >= 1 && < 3, unix, X11>=1.5.0.0 && < 1.6, xmonad>=0.9.1, xmonad<0.10, utf8-string - ghc-options: -fwarn-tabs -Wall + build-depends: mtl >= 1 && < 3, unix, X11>=1.5.0.0 && < 1.6, xmonad>=0.10, xmonad<0.11, utf8-string + + if true + ghc-options: -fwarn-tabs -Wall + extensions: ForeignFunctionInterface if flag(testing) ghc-options: -fwarn-tabs -Werror + if impl(ghc >= 6.12.1) + ghc-options: -fno-warn-unused-do-bind + if impl (ghc == 6.10.1) && arch (x86_64) ghc-options: -O0 @@ -71,6 +81,7 @@ XMonad.Doc.Configuring XMonad.Doc.Extending XMonad.Doc.Developing + XMonad.Actions.BluetileCommands XMonad.Actions.Commands XMonad.Actions.ConstrainedResize XMonad.Actions.CopyWindow @@ -81,6 +92,8 @@ XMonad.Actions.DeManage XMonad.Actions.DwmPromote XMonad.Actions.DynamicWorkspaces + XMonad.Actions.DynamicWorkspaceGroups + XMonad.Actions.DynamicWorkspaceOrder XMonad.Actions.FindEmptyWorkspace XMonad.Actions.FlexibleManipulate XMonad.Actions.FlexibleResize @@ -88,6 +101,7 @@ XMonad.Actions.FloatSnap XMonad.Actions.FocusNth XMonad.Actions.GridSelect + XMonad.Actions.GroupNavigation XMonad.Actions.MessageFeedback XMonad.Actions.MouseGestures XMonad.Actions.MouseResize @@ -97,8 +111,9 @@ XMonad.Actions.PhysicalScreens XMonad.Actions.Plane XMonad.Actions.Promote - XMonad.Actions.RotSlaves XMonad.Actions.RandomBackground + XMonad.Actions.KeyRemap + XMonad.Actions.RotSlaves XMonad.Actions.Search XMonad.Actions.SimpleDate XMonad.Actions.SinkAll @@ -107,36 +122,46 @@ XMonad.Actions.SwapWorkspaces XMonad.Actions.TagWindows XMonad.Actions.TopicSpace - XMonad.Actions.UpdatePointer XMonad.Actions.UpdateFocus + XMonad.Actions.UpdatePointer XMonad.Actions.Warp + XMonad.Actions.WindowBringer + XMonad.Actions.WindowGo XMonad.Actions.WindowMenu XMonad.Actions.WindowNavigation - XMonad.Actions.WindowGo - XMonad.Actions.WindowBringer XMonad.Actions.WithAll XMonad.Actions.WorkspaceCursors + XMonad.Actions.WorkspaceNames XMonad.Config.Arossato XMonad.Config.Azerty + XMonad.Config.Bluetile XMonad.Config.Desktop XMonad.Config.Droundy XMonad.Config.Gnome XMonad.Config.Kde XMonad.Config.Sjanssen XMonad.Config.Xfce + XMonad.Hooks.CurrentWorkspaceOnTop + XMonad.Hooks.DebugKeyEvents XMonad.Hooks.DynamicHooks XMonad.Hooks.DynamicLog XMonad.Hooks.EwmhDesktops XMonad.Hooks.FadeInactive + XMonad.Hooks.FadeWindows XMonad.Hooks.FloatNext + XMonad.Hooks.ICCCMFocus XMonad.Hooks.InsertPosition XMonad.Hooks.ManageDocks XMonad.Hooks.ManageHelpers + XMonad.Hooks.Minimize XMonad.Hooks.Place + XMonad.Hooks.PositionStoreHooks XMonad.Hooks.RestoreMinimized + XMonad.Hooks.ScreenCorners XMonad.Hooks.Script - XMonad.Hooks.SetWMName XMonad.Hooks.ServerMode + XMonad.Hooks.SetWMName + XMonad.Hooks.ToggleHook XMonad.Hooks.UrgencyHook XMonad.Hooks.WorkspaceByPos XMonad.Hooks.XPropManage @@ -144,26 +169,37 @@ XMonad.Layout.AutoMaster XMonad.Layout.BorderResize XMonad.Layout.BoringWindows + XMonad.Layout.ButtonDecoration XMonad.Layout.CenteredMaster XMonad.Layout.Circle - XMonad.Layout.Cross XMonad.Layout.Column XMonad.Layout.Combo XMonad.Layout.ComboP + XMonad.Layout.Cross XMonad.Layout.Decoration + XMonad.Layout.DecorationAddons XMonad.Layout.DecorationMadness XMonad.Layout.Dishes + XMonad.Layout.DraggingVisualizer XMonad.Layout.DragPane + XMonad.Layout.Drawer XMonad.Layout.DwmStyle XMonad.Layout.FixedColumn + XMonad.Layout.Fullscreen XMonad.Layout.Gaps XMonad.Layout.Grid XMonad.Layout.GridVariants + XMonad.Layout.Groups + XMonad.Layout.Groups.Examples + XMonad.Layout.Groups.Helpers + XMonad.Layout.Groups.Wmii XMonad.Layout.HintedGrid XMonad.Layout.HintedTile XMonad.Layout.IM + XMonad.Layout.ImageButtonDecoration XMonad.Layout.IndependentScreens XMonad.Layout.LayoutBuilder + XMonad.Layout.LayoutBuilderP XMonad.Layout.LayoutCombinators XMonad.Layout.LayoutHints XMonad.Layout.LayoutModifier @@ -179,6 +215,7 @@ XMonad.Layout.Mosaic XMonad.Layout.MosaicAlt XMonad.Layout.MouseResizableTile + XMonad.Layout.MultiColumns XMonad.Layout.MultiToggle XMonad.Layout.MultiToggle.Instances XMonad.Layout.Named @@ -186,37 +223,42 @@ XMonad.Layout.NoFrillsDecoration XMonad.Layout.OneBig XMonad.Layout.PerWorkspace + XMonad.Layout.PositionStoreFloat XMonad.Layout.Reflect + XMonad.Layout.Renamed XMonad.Layout.ResizableTile XMonad.Layout.ResizeScreen XMonad.Layout.Roledex - XMonad.Layout.Simplest + XMonad.Layout.ShowWName XMonad.Layout.SimpleDecoration XMonad.Layout.SimpleFloat + XMonad.Layout.Simplest + XMonad.Layout.SimplestFloat XMonad.Layout.Spacing XMonad.Layout.Spiral XMonad.Layout.Square - XMonad.Layout.ShowWName XMonad.Layout.StackTile XMonad.Layout.SubLayouts - XMonad.Layout.Tabbed XMonad.Layout.TabBarDecoration + XMonad.Layout.Tabbed XMonad.Layout.ThreeColumns XMonad.Layout.ToggleLayouts + XMonad.Layout.TrackFloating XMonad.Layout.TwoPane XMonad.Layout.WindowArranger XMonad.Layout.WindowNavigation + XMonad.Layout.WindowSwitcherDecoration XMonad.Layout.WorkspaceDir - XMonad.Layout.SimplestFloat - XMonad.Prompt.Directory + XMonad.Layout.ZoomRow XMonad.Prompt XMonad.Prompt.AppendFile XMonad.Prompt.AppLauncher - XMonad.Prompt.Input + XMonad.Prompt.Directory + XMonad.Prompt.DirExec XMonad.Prompt.Email + XMonad.Prompt.Input XMonad.Prompt.Layout XMonad.Prompt.Man - XMonad.Prompt.DirExec XMonad.Prompt.RunOrRaise XMonad.Prompt.Shell XMonad.Prompt.Ssh @@ -228,22 +270,27 @@ XMonad.Util.CustomKeys XMonad.Util.Dmenu XMonad.Util.Dzen + XMonad.Util.ExtensibleState XMonad.Util.EZConfig XMonad.Util.Font + XMonad.Util.Image XMonad.Util.Invisible XMonad.Util.Loggers XMonad.Util.NamedActions XMonad.Util.NamedScratchpad XMonad.Util.NamedWindows - XMonad.Util.StringProp + XMonad.Util.Paste + XMonad.Util.PositionStore + XMonad.Util.Replace XMonad.Util.Run XMonad.Util.Scratchpad + XMonad.Util.SpawnOnce + XMonad.Util.Stack + XMonad.Util.StringProp XMonad.Util.Themes XMonad.Util.Timer XMonad.Util.Types XMonad.Util.WindowProperties XMonad.Util.WorkspaceCompare - XMonad.Util.Paste - XMonad.Util.Replace XMonad.Util.XSelection XMonad.Util.XUtils