From f4f3ce9117167055503cc24c10d9e37f6416d0f8 Mon Sep 17 00:00:00 2001 From: Clemens Fruhwirth Date: Tue, 2 Nov 2010 22:12:13 +0100 Subject: Substring search support for X.A.GridSelect. As keymaps get more complicated to support different styles, the gs_navigate element is fundamentially changed. Ignore-this: 95610ac8eb781cd74f6c3ce9e36ec039 darcs-hash:20101102211213-ed0c4-283fe8b940c07c5bdb72aedbf681f8e450405cfc.gz --- XMonad/Actions/GridSelect.hs | 259 ++++++++++++++++++++++++++++++------------- 1 file changed, 181 insertions(+), 78 deletions(-) (limited to 'XMonad/Actions/GridSelect.hs') diff --git a/XMonad/Actions/GridSelect.hs b/XMonad/Actions/GridSelect.hs index 434d1d1..3f3d4bc 100644 --- a/XMonad/Actions/GridSelect.hs +++ b/XMonad/Actions/GridSelect.hs @@ -28,7 +28,6 @@ module XMonad.Actions.GridSelect ( -- * Configuration GSConfig(..), defaultGSConfig, - NavigateMap, TwoDPosition, buildDefaultGSConfig, @@ -46,7 +45,24 @@ module XMonad.Actions.GridSelect ( HasColorizer(defaultColorizer), fromClassName, stringColorizer, - colorRangeFromClassName + colorRangeFromClassName, + + -- * Navigation Mode assembly + TwoD, + makeXEventhandler, + shadowWithKeymap, + + -- * Built-in Navigation Mode + defaultNavigation, + substringSearch, + navNSearch, + + -- * Navigation Components + setPos, + move, + select, + cancel, + transformSearchString -- * Screenshots -- $screenshots @@ -119,35 +135,38 @@ import Data.Word (Word8) -- $keybindings -- --- Adding more keybindings for gridselect to listen to is similar: +-- You can build you own navigation mode and submodes by combining the +-- exported action ingredients and assembling them using 'makeXEventhandler' and 'shadowWithKeymap'. -- --- At the top of your config: +-- > 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 -- --- > {-# LANGAUGE NoMonomorphismRestriction #-} --- > import XMonad --- > import qualified Data.Map as M --- --- 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 -- @@ -165,7 +184,7 @@ data GSConfig a = GSConfig { 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 } @@ -195,8 +214,6 @@ instance HasColorizer a where 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))] @@ -318,39 +335,8 @@ updateElementsWithColorizer colorizer elementmap = do (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 - state <- get - return $ fmap (snd . snd) $ findInElementMap (td_curpos state) (td_elementmap state) - | 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 state <- get let (TwoDState { td_paneX = px, td_paneY = py, @@ -359,12 +345,141 @@ handle _ (ButtonEvent { ev_event_type = t, ev_x = x, ev_y = y }) gridY = (fi y - (py - ch) `div` 2) `div` ch case lookup (gridX,gridY) (td_elementmap state) of Just (_,el) -> return (Just el) - Nothing -> eventLoop - | otherwise = eventLoop + Nothing -> contEventloop + | otherwise = contEventloop + +stdHandle (ExposeEvent { }) contEventloop = updateAllElements >> contEventloop + +stdHandle _ contEventloop = contEventloop -handle _ (ExposeEvent { }) = updateAllElements >> eventLoop +-- | 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 + state <- get + return $ fmap (snd . snd) $ findInElementMap (td_curpos state) (td_elementmap state) + +-- | 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 + state <- get + let elmap = td_elementmap state + newSelectedEl = findInElementMap newPos (td_elementmap state) + oldPos = td_curpos state + when (isJust newSelectedEl && newPos /= oldPos) $ do + put state { 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 + state <- get + let (x,y) = td_curpos state + newPos = (x+dx,y+dy) + setPos newPos + +-- | Apply a transformation function the current search string +transformSearchString :: (String -> String) -> TwoD a () +transformSearchString f = do + state <- get + let oldSearchString = td_searchString state + 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 state { 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) + ] + -- 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_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 -handle _ _ = eventLoop -- FIXME probably move that into Utils? -- Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space @@ -464,7 +579,7 @@ gridselect gsconfig elements = originPosY = floor $ ((gs_originFractY gsconfig) - (1/2)) * 2 * fromIntegral restrictY coords = diamondRestrict restrictX restrictY originPosX originPosY - evalTwoD (updateAllElements >> eventLoop) TwoDState { td_curpos = (head coords), + evalTwoD (updateAllElements >> (gs_navigate gsconfig)) TwoDState { td_curpos = (head coords), td_availSlots = coords, td_elements = elements, td_gsconfig = gsconfig, @@ -509,19 +624,7 @@ decorateName' w = do -- | 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 (\(x,y) (a,b) -> (x+a,y+b)) $ 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" -- cgit v1.2.3