diff --git a/XMonad/Actions/TreeSelect.hs b/XMonad/Actions/TreeSelect.hs new file mode 100644 index 00000000..fb651a54 --- /dev/null +++ b/XMonad/Actions/TreeSelect.hs @@ -0,0 +1,583 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase, RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.TreeSelect +-- Copyright : (c) Tom Smeets +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Tom Smeets +-- Stability : unstable +-- Portability : unportable +-- +-- +-- TreeSelect displays your workspaces or actions in a Tree-like format. +-- You can select the desired workspace/action with the cursor or hjkl keys. +-- +-- This module is fully configurable and very useful if you like to have a +-- lot of workspaces. +-- +----------------------------------------------------------------------------- +module XMonad.Actions.TreeSelect + ( + -- * Usage + -- $usage + treeselectWorkspace + , toWorkspaces + , treeselectAction + + -- * Configuring + -- $config + , Pixel + -- $pixel + + , TSConfig(..) + , tsDefaultConfig + + -- * Navigation + -- $navigation + , defaultNavigation + , select + , cancel + , moveParent + , moveChild + , moveNext + , movePrev + + -- * Advanced usage + -- $advusage + , TSNode(..) + , treeselect + , treeselectAt + ) where + +import Control.Monad.Reader +import Control.Monad.State +import Data.List (find) +import Data.Maybe +import Data.Tree +import Foreign +import XMonad hiding (liftX) +import XMonad.StackSet as W +import XMonad.Util.Font +import XMonad.Util.NamedWindows +import XMonad.Util.TreeZipper +import qualified Data.Map as M + +#ifdef XFT +import Graphics.X11.Xft +import Graphics.X11.Xrender +#endif + +-- $usage +-- +-- These imports are needed in the following example +-- +-- > import Data.Tree +-- > import XMonad.Actions.TreeSelect +-- > import qualified XMonad.StackSet as W +-- +-- For selecting Workspaces, you need to define them in a tree structure using 'Data.Tree.Node' instead of just a standard list +-- +-- Here is an example workspace-tree +-- +-- > myWorkspaces :: Forest String +-- > myWorkspaces = [ Node "Browser" [] -- a workspace for your browser +-- > , Node "Home" -- for everyday activity's +-- > [ Node "1" [] -- with 4 extra sub-workspaces, for even more activity's +-- > , Node "2" [] +-- > , Node "3" [] +-- > , Node "4" [] +-- > ] +-- > , Node "Programming" -- for all your programming needs +-- > [ Node "Haskell" [] +-- > , Node "Docs" [] -- documentation +-- > ] +-- > ] +-- +-- Then add it to your XMonad Config using the 'toWorkspaces' function +-- +-- > xmonad $ defaultConfig { ... +-- > , workspaces = toWorkspaces myWorkspaces +-- > } +-- +-- After that you still need to bind buttons to 'treeselectWorkspace' to start selecting a workspaces and moving windows +-- +-- you could bind @Mod-f@ to switch workspace +-- +-- > , ((modMask, xK_f), treeselectWorkspace myTreeConf myWorkspaces W.greedyView) +-- +-- and bind @Mod-Shift-f@ to moving the focused windows to a workspace +-- +-- > , ((modMask .|. shiftMask, xK_f), treeselectWorkspace myTreeConf myWorkspaces W.shift) + +-- $config +-- The selection menu is very configurable, you can change the font, all colors and the sizes of the boxes. +-- +-- The default config defined as 'tsDefaultConfig' +-- +-- > tsDefaultConfig = TSConfig { ts_hidechildren = True +-- > , ts_background = 0xc0c0c0c0 +-- > , ts_font = "xft:Sans-16" -- "xft:Sans-16" +-- > , ts_node = (0xff000000, 0xff50d0db) +-- > , ts_nodealt = (0xff000000, 0xff10b8d6) +-- > , ts_highlight = (0xffffffff, 0xffff0000) +-- > , ts_extra = 0xff000000 +-- > , ts_node_width = 200 +-- > , ts_node_height = 30 +-- > , ts_originX = 0 +-- > , ts_originY = 0 +-- > , ts_indent = 80 +-- > , ts_navigate = defaultNavigation +-- > } + +-- $pixel +-- +-- The 'Pixel' Color format is in the form of @0xaarrggbb@ +-- +-- Note that transparency is only supported if you have a window compositor running like +-- +-- Some Examples: +-- +-- @ +-- white = 0xffffffff +-- black = 0xff000000 +-- red = 0xffff0000 +-- blue = 0xff00ff00 +-- green = 0xff0000ff +-- transparent = 0x00000000 +-- @ + +-- $navigation +-- +-- Keybindings for navigations can also be modified +-- +-- This is the definition of 'defaultNavigation' +-- +-- > defaultNavigation :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a)) +-- > defaultNavigation = M.fromList +-- > [ ((0, xK_Escape), cancel) +-- > , ((0, xK_Return), select) +-- > , ((0, xK_space), select) +-- > , ((0, xK_Up), movePrev) +-- > , ((0, xK_Down), moveNext) +-- > , ((0, xK_Left), moveParent) +-- > , ((0, xK_Right), moveChild) +-- > , ((0, xK_k), movePrev) +-- > , ((0, xK_j), moveNext) +-- > , ((0, xK_h), moveParent) +-- > , ((0, xK_l), moveChild) +-- > ] + +-- $advusage +-- This module can also be used to select any other action + +-- | Extensive configuration for displaying the tree. +-- +-- This class also has a 'Default' instance +data TSConfig a = TSConfig { ts_hidechildren :: Bool -- ^ when enabled, only the parents (and their first children) of the current node will be shown (This feature is not yet implemented!) + , ts_background :: Pixel -- ^ background color filling the entire screen. + + , ts_font :: String -- ^ XMF font for drawing the node name extra text + + , ts_node :: (Pixel, Pixel) -- ^ node foreground (text) and background color when not selected + , ts_nodealt :: (Pixel, Pixel) -- ^ every other node will use this color instead of 'ts_node' + , ts_highlight :: (Pixel, Pixel) -- ^ node foreground (text) and background color when selected + + , ts_extra :: Pixel -- ^ extra text color + + , ts_node_width :: Int -- ^ node width in pixels + , ts_node_height :: Int -- ^ node height in pixels + , ts_originX :: Int -- ^ tree X position on the screen in pixels + , ts_originY :: Int -- ^ tree Y position on the screen in pixels + + , ts_indent :: Int -- ^ indentation amount for each level in pixels + + , ts_navigate :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a)) -- ^ key bindings for navigating the tree + } + +instance Default (TSConfig a) where + def = TSConfig { ts_hidechildren = True + , ts_background = 0xc0c0c0c0 + , ts_font = "xft:Sans-16" -- "xft:Sans-16" + , ts_node = (0xff000000, 0xff50d0db) + , ts_nodealt = (0xff000000, 0xff10b8d6) + , ts_highlight = (0xffffffff, 0xffff0000) + , ts_extra = 0xff000000 + , ts_node_width = 200 + , ts_node_height = 30 + , ts_originX = 0 + , ts_originY = 0 + , ts_indent = 80 + , ts_navigate = defaultNavigation + } + +-- | Default navigation +-- +-- * navigation using either arrow key or vi style hjkl +-- * Return or Space to confirm +-- * Escape or Backspace to cancel to +defaultNavigation :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a)) +defaultNavigation = M.fromList + [ ((0, xK_Escape), cancel) + , ((0, xK_Return), select) + , ((0, xK_space), select) + , ((0, xK_Up), movePrev) + , ((0, xK_Down), moveNext) + , ((0, xK_Left), moveParent) + , ((0, xK_Right), moveChild) + , ((0, xK_k), movePrev) + , ((0, xK_j), moveNext) + , ((0, xK_h), moveParent) + , ((0, xK_l), moveChild) + ] + +-- | Default configuration. +-- +-- Using nice alternating blue nodes +tsDefaultConfig :: TSConfig a +tsDefaultConfig = def + +-- | Tree Node With a name and extra text +data TSNode a = TSNode { tsn_name :: String + , tsn_extra :: String -- ^ extra text, displayed next to the node name + , tsn_value :: a -- ^ value to return when this node is selected + } + +-- | State used by TreeSelect. +-- +-- Contains all needed information such as the window, font and a zipper over the tree. +data TSState a = TSState { tss_tree :: TreeZipper (TSNode a) + , tss_window :: Window + , tss_display :: Display + , tss_size :: (Int, Int) -- ^ size of 'tz_window' + , tss_xfont :: XMonadFont + , tss_gc :: GC + , tss_visual :: Visual + , tss_colormap :: Colormap + } + +-- | State monad transformer using 'TSState' +newtype TreeSelect a b = TreeSelect { runTreeSelect :: ReaderT (TSConfig a) (StateT (TSState a) X) b } + deriving (Monad, Applicative, Functor, MonadState (TSState a), MonadReader (TSConfig a), MonadIO) + +-- | Lift the 'X' action into the 'XMonad.Actions.TreeSelect.TreeSelect' monad +liftX :: X a -> TreeSelect b a +liftX = TreeSelect . lift . lift + +-- | Run Treeselect with a given config and tree. +-- This can be used for selectiong anything +-- +-- * for switching workspaces and moving windows use 'treeselectWorkspace' +-- * for selecting actions use 'treeselectAction' +treeselect :: TSConfig a -- ^ config file + -> Forest (TSNode a) -- ^ a list of 'Data.Tree.Tree's to select from. + -> X (Maybe a) +treeselect c = treeselectAt c . fromForest + +-- | Same as 'treeselect' but ad a specific starting position +treeselectAt :: TSConfig a -- ^ config file + -> TreeZipper (TSNode a) -- ^ tree structure with a cursor position (starting node) + -> X (Maybe a) +treeselectAt conf@TSConfig{..} zipper = withDisplay $ \display -> do + -- create a window on the currently focused screen + rootw <- asks theRoot + Rectangle{..} <- gets $ screenRect . W.screenDetail . W.current . windowset + + Just vinfo <- liftIO $ matchVisualInfo display (defaultScreen display) 32 4 + + colormap <- liftIO $ createColormap display rootw (visualInfo_visual vinfo) allocNone + + win <- liftIO $ allocaSetWindowAttributes $ \attributes -> do + set_override_redirect attributes True + set_colormap attributes colormap + set_background_pixel attributes ts_background + set_border_pixel attributes 0 + createWindow display rootw rect_x rect_y rect_width rect_height 0 (visualInfo_depth vinfo) inputOutput (visualInfo_visual vinfo) (cWColormap .|. cWBorderPixel .|. cWBackPixel) attributes + + liftIO $ do + -- TODO: move below? + -- make the window visible + mapWindow display win + + -- listen to key and mouse button events + selectInput display win (exposureMask .|. keyPressMask .|. buttonReleaseMask) + + -- TODO: enable mouse select? + -- and mouse button 1 + grabButton display button1 anyModifier win True buttonReleaseMask grabModeAsync grabModeAsync none none + + -- grab the keyboard + status <- liftIO $ grabKeyboard display win True grabModeAsync grabModeAsync currentTime + + r <- if status == grabSuccess + then do + -- load the XMF font + gc <- liftIO $ createGC display win + xfont <- initXMF ts_font + + -- run the treeselect Monad + ret <- evalStateT (runReaderT (runTreeSelect (redraw >> navigate)) conf) + TSState{ tss_tree = zipper + , tss_window = win + , tss_display = display + , tss_xfont = xfont + , tss_size = (fromIntegral rect_width, fromIntegral rect_height) + , tss_gc = gc + , tss_visual = visualInfo_visual vinfo + , tss_colormap = colormap + } + + -- release the XMF font + releaseXMF xfont + liftIO $ freeGC display gc + return ret + + else return Nothing + + -- destroy the window + liftIO $ do + unmapWindow display win + destroyWindow display win + freeColormap display colormap + -- Flush the output buffer and wait for all the events to be processed + -- TODO: is this needed? + sync display False + return r + +-- | Select a workspace and execute a \"view\" function from "XMonad.StackSet" on it. +treeselectWorkspace :: TSConfig WorkspaceId + -> Forest String -- ^ your tree of workspace-names + -> (WorkspaceId -> WindowSet -> WindowSet) -- ^ the \"view\" function. + -- Instances can be 'W.greedyView' for switching to a workspace + -- and/or 'W.shift' for moving the focused window to a selected workspace. + -- + -- These actions can also be combined by doing @'W.greedyView' . 'W.shift'@ + -> X () +treeselectWorkspace c xs f = do + -- get all defined workspaces + -- They have to be set with 'toWorkspaces'! + ws <- gets (W.workspaces . windowset) + + -- convert the 'Forest WorkspaceId' to 'Forest (TSNode WorkspaceId)' + wsf <- forMForest (mkPaths xs) $ \(n, i) -> maybe (return (TSNode n "Does not exist!" "")) (mkNode n) (find (\w -> i == tag w) ws) + + -- get the current workspace path + me <- gets (W.tag . W.workspace . W.current . windowset) + treeselectAt c (fromJust $ followPath tsn_name (splitPath me) $ fromForest wsf) >>= maybe (return ()) (windows . f) + where + mkNode n w = do + -- find the focused window's name on this workspace + name <- maybe (return "") (fmap show . getName . W.focus) $ stack w + return $ TSNode n name (tag w) + + forMForest :: Monad m => [Tree a] -> (a -> m b) -> m [Tree b] + forMForest x g = mapM (mapM g) x + +-- | Convert the workspace-tree to a flat list of paths such that XMonad can use them +-- +-- The Nodes will be separated by a dot (\'.\') character +toWorkspaces :: Forest String -> [WorkspaceId] +toWorkspaces = map snd . concatMap flatten . mkPaths + +mkPaths :: Forest String -> Forest (String, WorkspaceId) +mkPaths = map (\(Node n ns) -> Node (n, n) (map (f n) ns)) + where + f pth (Node x xs) = let pth' = pth ++ '.' : x + in Node (x, pth') (map (f pth') xs) + +splitPath :: WorkspaceId -> [String] +splitPath i = case break (== '.') i of + (x, []) -> [x] + (x, _:xs) -> x : splitPath xs + +-- | Select from a Tree of 'X' actions +-- +-- Each of these actions have to be specified inside a 'TSNode' +-- +-- Example +-- +-- > treeselectAction myTreeConf +-- > [ Node (TSNode "Hello" "displays hello" (spawn "xmessage hello!")) [] +-- > , Node (TSNode "Shutdown" "Poweroff the system" (spawn "shutdown")) [] +-- > , Node (TSNode "Brightness" "Sets screen brightness using xbacklight" (return ())) +-- > [ Node (TSNode "Bright" "FULL POWER!!" (spawn "xbacklight -set 100")) [] +-- > , Node (TSNode "Normal" "Normal Brightness (50%)" (spawn "xbacklight -set 50")) [] +-- > , Node (TSNode "Dim" "Quite dark" (spawn "xbacklight -set 10")) [] +-- > ] +-- > ] +treeselectAction :: TSConfig (X a) -> Forest (TSNode (X a)) -> X () +treeselectAction c xs = treeselect c xs >>= sequence_ + +-- | Quit returning the currently selected node +select :: TreeSelect a (Maybe a) +select = Just <$> gets (tsn_value . cursor . tss_tree) + +-- | Quit without returning anything +cancel :: TreeSelect a (Maybe a) +cancel = return Nothing + +-- TODO: redraw only what is necessary. +-- Examples: redrawAboveCursor, redrawBelowCursor and redrawCursor + +-- | Move the cursor to its parent node +moveParent :: TreeSelect a (Maybe a) +moveParent = moveWith parent >> redraw >> navigate + +-- | Move the cursor one level down, highlighting its first child-node +moveChild :: TreeSelect a (Maybe a) +moveChild = moveWith children >> redraw >> navigate + +-- | Move the cursor to the next child-node +moveNext :: TreeSelect a (Maybe a) +moveNext = moveWith nextChild >> redraw >> navigate + +-- | Move the cursor to the previous child-node +movePrev :: TreeSelect a (Maybe a) +movePrev = moveWith previousChild >> redraw >> navigate + +-- | Apply a transformation on the internal 'XMonad.Util.TreeZipper.TreeZipper'. +moveWith :: (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))) -> TreeSelect a () +moveWith f = do + s <- get + case f (tss_tree s) of + -- TODO: redraw cursor only? + Just t -> put s{ tss_tree = t } + Nothing -> return () + +-- | wait for keys and run navigation +navigate :: TreeSelect a (Maybe a) +navigate = gets tss_display >>= \d -> join . liftIO . allocaXEvent $ \e -> do + maskEvent d (exposureMask .|. keyPressMask .|. buttonReleaseMask) e + + ev <- getEvent e + + if ev_event_type ev == keyPress + then do + (ks, _) <- lookupString $ asKeyEvent e + return $ do + mask <- liftX $ cleanMask (ev_state ev) + f <- asks ts_navigate + fromMaybe navigate $ M.lookup (mask, fromMaybe xK_VoidSymbol ks) f + else return navigate + +-- | Request a full redraw +redraw :: TreeSelect a () +redraw = do + win <- gets tss_window + dpy <- gets tss_display + + -- clear window + -- TODO: not always needed! + liftIO $ clearWindow dpy win + + t <- gets tss_tree + _ <- drawLayers 0 0 (reverse $ (tz_before t, cursor t, tz_after t) : tz_parents t) + return () + +drawLayers :: Int -- ^ indentation level + -> Int -- ^ height + -> [(Forest (TSNode a), TSNode a, Forest (TSNode a))] -- ^ node layers (from top to bottom!) + -> TreeSelect a Int +drawLayers _ yl [] = return yl +drawLayers xl yl ((bs, c, as):xs) = do + TSConfig{..} <- ask + + let nodeColor y = if odd y then ts_node else ts_nodealt + + -- draw nodes above + forM_ (zip [yl ..] (reverse bs)) $ \(y, Node n _) -> + drawNode xl y n (nodeColor y) + -- drawLayers (xl + 1) (y + 1) ns + -- TODO: draw rest? if not ts_hidechildren + -- drawLayers (xl + 1) (y + 1) ns + + -- draw the current / parent node + -- if this is the last (currently focused) we use the 'ts_highlight' color + let current_level = yl + length bs + drawNode xl current_level c $ + if null xs then ts_highlight + else nodeColor current_level + + l2 <- drawLayers (xl + 1) (current_level + 1) xs + + -- draw nodes below + forM_ (zip [l2 ..] as) $ \(y, Node n _) -> + drawNode xl y n (nodeColor y) + -- TODO: draw rest? if not ts_hidechildren + -- drawLayers (xl + 1) (y + 1) ns + return (l2 + length as) + + +-- | Draw a node at a given indentation and height level +drawNode :: Int -- ^ indentation level (not in pixels) + -> Int -- ^ height level (not in pixels) + -> TSNode a -- ^ node to draw + -> (Pixel, Pixel) -- ^ node foreground (font) and background color + -> TreeSelect a () +drawNode ix iy TSNode{..} col = do + TSConfig{..} <- ask + window <- gets tss_window + display <- gets tss_display + font <- gets tss_xfont + gc <- gets tss_gc + colormap <- gets tss_colormap + visual <- gets tss_visual + liftIO $ drawWinBox window display visual colormap gc font col tsn_name ts_extra tsn_extra + (ix * ts_indent) (iy * ts_node_height) + ts_node_width ts_node_height + + -- TODO: draw extra text (transparent background? or ts_background) + -- drawWinBox window fnt col2 nodeH (scW-x) (mes) (x+nodeW) y 8 + +-- | Draw a simple box with text +drawWinBox :: Window -> Display -> Visual -> Colormap -> GC -> XMonadFont -> (Pixel, Pixel) -> String -> Pixel -> String -> Int -> Int -> Int -> Int -> IO () +drawWinBox win display visual colormap gc font (fg, bg) text fg2 text2 x y w h = do + -- draw box + setForeground display gc bg + fillRectangle display win gc (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + + -- dreaw text + drawStringXMF display win visual colormap gc font fg + (fromIntegral $ x + 8) + (fromIntegral $ y + h - 8) + text + + -- dreaw extra text + drawStringXMF display win visual colormap gc font fg2 + (fromIntegral $ x + w + 8) + (fromIntegral $ y + h - 8) + text2 + +-- | Modified version of 'XMonad.Util.Font.printStringXMF' that uses 'Pixel' as color format +drawStringXMF :: Display -> Drawable -> Visual -> Colormap -> GC + -> XMonadFont -- ^ XMF Font + -> Pixel -- ^ font color + -> Position -- ^ x-position + -> Position -- ^ y-position + -> String -- ^ string text + -> IO () +drawStringXMF display window visual colormap gc font col x y text = case font of + Core fnt -> do + setForeground display gc col + setFont display gc $ fontFromFontStruct fnt + drawImageString display window gc x y text + Utf8 fnt -> do + setForeground display gc col + wcDrawImageString display window fnt gc x y text +#ifdef XFT + Xft fnt -> do + withXftDraw display window visual colormap $ + \ft_draw -> withXftColorValue display visual colormap (fromARGB col) $ + \ft_color -> xftDrawString ft_draw ft_color fnt x y text + +-- | Convert 'Pixel' to 'XRenderColor' +-- +-- Note that it uses short to represent its components +fromARGB :: Pixel -> XRenderColor +fromARGB x = XRenderColor (fromIntegral $ 0xff00 .&. shiftR x 8) -- red + (fromIntegral $ 0xff00 .&. x) -- green + (fromIntegral $ 0xff00 .&. shiftL x 8) -- blue + (fromIntegral $ 0xff00 .&. shiftR x 16) -- alpha +#endif diff --git a/XMonad/Util/TreeZipper.hs b/XMonad/Util/TreeZipper.hs new file mode 100644 index 00000000..f5077784 --- /dev/null +++ b/XMonad/Util/TreeZipper.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.TreeSelect +-- Copyright : (c) Tom Smeets +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Tom Smeets +-- Stability : unstable +-- Portability : unportable +-- +-- over the "Data.Tree" data structure. +-- This module is based on . +-- +----------------------------------------------------------------------------- + +module XMonad.Util.TreeZipper( + -- * Data structure + TreeZipper(..) + , cursor + + -- * Conversion + , fromForest + , toForest + , getSubForest + + -- * Navigation + , parent + , children + , nextChild + , previousChild + + -- * Utils + , nodeDepth + , nodeIndex + , followPath + , findChild + + , isLeaf + , isRoot + , isLast + , isFirst + ) where + +import Data.Tree + +-- | A over the "Data.Tree" data structure. +data TreeZipper a = TreeZipper { tz_current :: Tree a -- ^ the currently focused sub-tree under the cursor + , tz_before :: Forest a -- ^ all sub-tree's to the /left/ of the cursor that have the same parent + , tz_after :: Forest a -- ^ all sub-tree's to the /right/ of the cursor that have the same parent + , tz_parents :: [(Forest a, a, Forest a)] -- ^ list zippers for each parent level, the first element is the current parent + } +-- ^ Very crappy visualization of the 'TreeZipper' data structure +-- +-- @ +-- (tz_parents) +-- ([*], *, [*]) +-- ([*, *], *, []) +-- ([], * [*, *]) +-- | | | +-- +-------+--------+-------+------+ +-*-+ * +-- | | | | | | | +-- (tz_before) (tz_current) (tz_after) * * +-- | | | | +-- +-*-+ * * * +-- | | +-- * * +-- @ + +-- | Get the highlighted value +cursor :: TreeZipper a -> a +cursor = rootLabel . tz_current + +-- | Create a 'TreeZipper' from a list of 'Data.Tree.Tree's focused on the first element +fromForest :: Forest a -> TreeZipper a +fromForest [] = error "XMonad.Util.TreeZipper.fromForest: can't create a TreeZipper from an empty list!" +fromForest (x:xs) = TreeZipper { tz_current = x + , tz_before = [] + , tz_after = xs + , tz_parents = [] + } + +-- | Convert the entire zipper back to a 'Data.Tree.Forest' +toForest :: TreeZipper a -> Forest a +toForest = getSubForest . rootNode + +-- | Create a 'Data.Tree.Forest' from all the children of the current parent +getSubForest :: TreeZipper a -> Forest a +getSubForest TreeZipper{..} = tz_before ++ tz_current : tz_after + +-- | Go to the upper most node such that +-- nothing is before nor above the cursor +rootNode :: TreeZipper a -> TreeZipper a +rootNode z = maybe z rootNode $ parent z + +-- | Move to the parent node +parent :: TreeZipper a -> Maybe (TreeZipper a) +parent t = case tz_parents t of + (xs,a,ys) : ps -> Just + TreeZipper { tz_current = Node a (tz_before t ++ tz_current t : tz_after t) + , tz_before = xs + , tz_after = ys + , tz_parents = ps + } + [] -> Nothing + +-- | Move the cursor one level down to the first node +children :: TreeZipper a -> Maybe (TreeZipper a) +children z = case subForest $ tz_current z of + (n:xs) -> Just + TreeZipper { tz_current = n + , tz_before = [] + , tz_after = xs + , tz_parents = (tz_before z, cursor z, tz_after z) : tz_parents z + } + [] -> Nothing + +-- | Go to the next child node +nextChild :: TreeZipper a -> Maybe (TreeZipper a) +nextChild z = case tz_after z of + (n:xs) -> Just + TreeZipper { tz_current = n + , tz_before = tz_current z : tz_before z + , tz_after = xs + , tz_parents = tz_parents z + } + [] -> Nothing + +-- | Go to the previous child node +previousChild :: TreeZipper a -> Maybe (TreeZipper a) +previousChild z = case tz_before z of + (n:xs) -> Just + TreeZipper { tz_current = n + , tz_before = xs + , tz_after = tz_current z : tz_after z + , tz_parents = tz_parents z + } + [] -> Nothing + +-- | How many nodes are above this one? +nodeDepth :: TreeZipper a -> Int +nodeDepth = length . tz_parents + +-- | How many nodes are before the cursor? (on the current level) +nodeIndex :: TreeZipper a -> Int +nodeIndex = length . tz_before + +-- | follow a Path specified by the list of nodes +followPath :: Eq b => (a -> b) -> [b] -> TreeZipper a -> Maybe (TreeZipper a) +followPath _ [] z = Just z +followPath f [x] z = findChild (\y -> f y == x) z +followPath f (x:xs) z = findChild (\y -> f y == x) z >>= children >>= followPath f xs + +-- | go to the first node next to the cursor that matches +findChild :: (a -> Bool) -> TreeZipper a -> Maybe (TreeZipper a) +findChild f z | f (cursor z) = Just z + | otherwise = nextChild z >>= findChild f + +-- | Check whenther this is a leaf node +isLeaf :: TreeZipper a -> Bool +isLeaf = null . subForest . tz_current + +-- | Check whenther this is a leaf node +isRoot :: TreeZipper a -> Bool +isRoot = null . tz_parents + +-- | Check whenther this the last child +isLast :: TreeZipper a -> Bool +isLast = null . tz_after + +-- | Check whenther this the first child +isFirst :: TreeZipper a -> Bool +isFirst = null . tz_before diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 9a8bcf74..6b60b150 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -133,6 +133,7 @@ library XMonad.Actions.SwapWorkspaces XMonad.Actions.TagWindows XMonad.Actions.TopicSpace + XMonad.Actions.TreeSelect XMonad.Actions.UpdateFocus XMonad.Actions.UpdatePointer XMonad.Actions.Warp @@ -328,6 +329,7 @@ library XMonad.Util.StringProp XMonad.Util.Themes XMonad.Util.Timer + XMonad.Util.TreeZipper XMonad.Util.Types XMonad.Util.Ungrab XMonad.Util.WindowProperties