module XMonad.Stockholm.Rhombus ( MatchMethod(..) , rhombus , RhombusConfig(..) , RhombusState(..) ) where import Control.Monad (zipWithM_) import Data.Char import Data.List import Data.Ord import Data.Map (fromList) import Data.Maybe (fromJust) import XMonad hiding (keys) import XMonad.StackSet hiding (filter, tag) import XMonad.Util.Font import XMonad.Util.XUtils import XMonad.Stockholm.Submap import XMonad.Stockholm.XUtils import XMonad.Stockholm.Font data MatchMethod = MatchInfix | MatchPrefix data RhombusConfig = RhombusConfig { rc_font :: String , rc_cellwidth :: Dimension , rc_margin :: Dimension , rc_matchmethod :: MatchMethod , rc_wrap :: Bool , rc_colors :: Bool -> Bool -> Bool -> (String, String, String) , rc_paint :: RhombusConfig -> Display -> Pixmap -> GC -> String -> Rectangle -> Bool -> Bool -> Bool -> X () , rc_missAction :: X () } -- TODO currently xft is broken instance Default RhombusConfig where def = RhombusConfig { rc_font = "xft:Sans-8" , rc_cellwidth = 100 , rc_margin = 0 , rc_matchmethod = MatchInfix , rc_wrap = True , rc_colors = stupidColors , rc_paint = noPaint , rc_missAction = return () } where stupidColors _ _ _ = ("red", "magenta", "yellow") noPaint _ _ _ _ _ _ _ _ _ = return () data RhombusState = RhombusState { rs_window :: Window , rs_search :: String , rs_font :: XMonadFont , rs_focus :: (Position, Position) , rs_strings :: [String] } reachableCoords :: RhombusState -> [(Position, Position)] reachableCoords RhombusState{rs_strings=xs} = take (length xs) wave matchingReachableCoords :: RhombusConfig -> RhombusState -> [(Position, Position)] matchingReachableCoords rc rs = snd $ unzip $ filter (isXOf (rc_matchmethod rc) (rs_search rs) . fst) $ zip (rs_strings rs) (reachableCoords rs) match :: MatchMethod -> String -> [String] -> Maybe String match m s ws = do let cands = filter (isXOf m s) ws if length cands == 1 then Just $ head cands else Nothing rhombus :: RhombusConfig -> (String -> X ()) -> [String] -> X () rhombus rc viewFunc as = withGrabbedKeyboard $ do rs <- newRhombus rc as --redraw rc rs showWindow (rs_window rs) rhombusMode viewFunc rc rs rhombusMode :: (String -> X ()) -> RhombusConfig -> RhombusState -> X () rhombusMode viewFunc rc rs = case match (rc_matchmethod rc) (rs_search rs) (init $ rs_strings rs) of Nothing -> redraw rc rs >> submapString defAction keys Just i -> removeRhombus rs >> viewFunc i where defAction (ch:[]) | isPrint ch = incSearchPushChar ch rs >>= rhombusMode viewFunc rc defAction _ = rc_missAction rc >> rhombusMode viewFunc rc rs keys = fromList $ [ ((0 , xK_BackSpace ), incSearchPopChar rs >>= rhombusMode viewFunc rc) , ((0 , xK_Escape ), removeRhombus rs) , ((0 , xK_Menu ), removeRhombus rs) , ((0 , xK_Left ), goto rc (-1, 0) rs >>= rhombusMode viewFunc rc) , ((0 , xK_Right ), goto rc ( 1, 0) rs >>= rhombusMode viewFunc rc) , ((0 , xK_Up ), goto rc ( 0,-1) rs >>= rhombusMode viewFunc rc) , ((0 , xK_Down ), goto rc ( 0, 1) rs >>= rhombusMode viewFunc rc) , ((0 , xK_Tab ), gotoNextMatch rc rs >>= rhombusMode viewFunc rc) , ((_S , xK_Tab ), gotoPrevMatch rc rs >>= rhombusMode viewFunc rc) , ((0 , xK_Return ), removeRhombus rs >> return (selectFocused rs) >>= viewFunc) ] _S = shiftMask goto :: RhombusConfig -> (Position, Position) -> RhombusState -> X RhombusState goto rc xy rs = maybe (rc_missAction rc >> return rs) return $ op xy rs where op = if rc_wrap rc then wrapFocus else moveFocus moveFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState moveFocus (dx, dy) rs@RhombusState{rs_focus=(x,y)} = do let foc' = (x + dx, y + dy) if elem foc' (reachableCoords rs) then Just rs { rs_focus = foc' } else Nothing wrapFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState wrapFocus (0, dy) rs@RhombusState{rs_focus=foc} = do let column = sortBy (comparing snd) $ filter ((==) (fst foc) . fst) (reachableCoords rs) i <- elemIndex foc column return rs { rs_focus = column `modIndex` (i + fromIntegral dy) } wrapFocus (dx, 0) rs@RhombusState{rs_focus=foc} = do let column = sortBy (comparing fst) $ filter ((==) (snd foc) . snd) (reachableCoords rs) i <- elemIndex foc column return rs { rs_focus = column `modIndex` (i + fromIntegral dx) } wrapFocus _ _ = Nothing gotoPrevMatch :: RhombusConfig -> RhombusState -> X RhombusState gotoPrevMatch rc rs@RhombusState{rs_focus=foc} = do case reverse (matchingReachableCoords rc rs) of [] -> rc_missAction rc >> return rs xs -> return rs { rs_focus = maybe (head xs) (modIndex xs . (+1)) (foc `elemIndex` xs) } gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState gotoNextMatch rc rs@RhombusState{rs_focus=foc} = do case matchingReachableCoords rc rs of [] -> rc_missAction rc >> return rs xs -> return rs { rs_focus = maybe (head xs) (modIndex xs . (+1)) (foc `elemIndex` xs) } selectFocused :: RhombusState -> String selectFocused rs = -- TODO the rhombus must never "focus" something inexistent fromJust $ lookup (rs_focus rs) $ zip wave (rs_strings rs) incSearchPushChar :: Char -> RhombusState -> X RhombusState incSearchPushChar c rs = return rs { rs_search = rs_search rs ++ [c] } incSearchPopChar :: RhombusState -> X RhombusState -- only rubout if we have at least one char incSearchPopChar rs@RhombusState{rs_search=xs@(_:_)} = return rs { rs_search = init xs } incSearchPopChar rs = return rs redraw :: RhombusConfig -> RhombusState -> X () redraw rc rs = do ss <- gets windowset let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss -- TODO this let is duplicated in newRhombus let scale x = x * cell_w `div` s_width -- TODO use bw cell_w = rc_cellwidth rc cell_h = scale s_height -- txy is the top-left corner of the first (center) cell -- XXX div and (-) are not distributive -- we could round $ (s_* - cell_*) / 2, though... tx = fi $ s_width `div` 2 - cell_w `div` 2 ty = fi $ s_height `div` 2 - cell_h `div` 2 margin = rc_margin rc -- dxy are the outer cell dimensions (i.e. including the border) dx = fi $ cell_w + 2 + margin dy = fi $ cell_h + 2 + margin paint = rc_paint rc xmf = rs_font rs tags = rs_strings rs --currentTag = last tags withDisplay $ \ d -> do -- XXX we cannot use withPixmapAndGC because rc_paint is an X monad p <- io $ createPixmap d (rs_window rs) s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d) g <- io $ createGC d p -- TODO fixme color_black <- stringToPixel d "black" forZipWithM_ tags (reachableCoords rs) $ \tag oxy@(ox, oy) -> do let isFocused = oxy == rs_focus rs isMatched = isXOf (rc_matchmethod rc) (rs_search rs) tag isCurrent = tag == last tags (_b_color, _bg_color, _fg_color) = rc_colors rc isFocused isMatched isCurrent --cell_x = (ox * dx) + x - fi (cell_w `div` 2) --cell_y = (oy * dy) + y - fi (cell_h `div` 2) cell_x = (ox * dx) + tx + 1 cell_y = (oy * dy) + ty + 1 b_color <- stringToPixel d _b_color bg_color <- stringToPixel d _bg_color fg_color <- stringToPixel d _fg_color -- draw background io $ setForeground d g bg_color io $ fillRectangle d p g cell_x cell_y cell_w cell_h -- draw border io $ setForeground d g b_color io $ drawLines d p g [ Point (cell_x - 1) (cell_y - 1) , Point (fi cell_w + 1) 0 , Point 0 (fi cell_h + 1) , Point (-(fi cell_w + 1)) 0 , Point 0 (-(fi cell_h + 1)) ] coordModePrevious -- custom draw paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) isFocused isMatched isCurrent -- paint text -- TODO custom paint text? -- TODO withCopyArea io $ withPixmapAndGC d p s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d) $ \ f_pm f_gc -> do withPixmapAndGC d f_pm s_width s_height 1 $ \ clip_mask clip_gc -> do setForeground d clip_gc 0 setBackground d clip_gc 0 fillRectangle d clip_mask clip_gc 0 0 s_width s_height setForeground d clip_gc 1 let r = Rectangle cell_x cell_y cell_w cell_h printStringCentered d clip_mask xmf clip_gc r tag setForeground d f_gc fg_color setBackground d f_gc color_black -- TODO printStringCentered d f_pm xmf f_gc r tag setClipMask d f_gc clip_mask copyArea d f_pm p f_gc 0 0 s_width s_height 0 0 io $ copyArea d p (rs_window rs) g 0 0 s_width s_height 0 0 io $ freePixmap d p io $ freeGC d g newRhombus :: RhombusConfig -> [String] -> X RhombusState newRhombus rc tags = do ss <- gets windowset let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss (_, def_win_bg, _) = rc_colors rc False True False -- TODO this let is duplicated in redraw let scale x = x * cell_w `div` s_width -- TODO use bw cell_w = rc_cellwidth rc cell_h = scale s_height -- TODO don't delete this let but use it instead of s_{width,height} -- (xcoords, ycoords) = unzip $ take (length tags) wave -- this is reachableCoords -- win_width = (maximum xcoords - minimum xcoords) * dx -- win_height = (maximum ycoords - minimum ycoords) * dy -- txy is the top-left corner of the first (center) cell -- XXX div and (-) are not distributive -- we could round $ (s_* - cell_*) / 2, though... tx = fi $ s_width `div` 2 - cell_w `div` 2 ty = fi $ s_height `div` 2 - cell_h `div` 2 margin = rc_margin rc -- dxy are the outer cell dimensions (i.e. including the border) dx = fi $ cell_w + 2 + margin dy = fi $ cell_h + 2 + margin fn <- initXMF (rc_font rc) win <- createNewWindow (Rectangle 0 0 s_width s_height) Nothing def_win_bg True withDisplay $ \ d -> io $ shapeWindow d win $ \ p g -> forZipWithM_ tags wave $ \ _ (ox, oy) -> fillRectangle d p g (tx + ox * dx) (ty + oy * dy) (fi cell_w + 2) (fi cell_h + 2) return $ RhombusState win "" fn (0,0) tags removeRhombus :: RhombusState -> X () removeRhombus (RhombusState w _ fn _ _) = do deleteWindow w releaseXMF fn wave :: [(Position, Position)] wave = zip (0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])) (concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..]) --where -- wave1 = 0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..]) -- wave2 = concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..] isXOf :: MatchMethod -> String -> String -> Bool isXOf MatchInfix = isInfixOf isXOf MatchPrefix = isPrefixOf modIndex :: Integral i => [a] -> i -> a modIndex xs i = xs `genericIndex` (i `mod` genericLength xs) forZipWithM_ :: Monad m => [a] -> [b] -> (a -> b -> m c) -> m () forZipWithM_ a b f = zipWithM_ f a b withGrabbedKeyboard :: X () -> X () withGrabbedKeyboard f = do XConf { theRoot = root, display = d } <- ask catchX (io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime) >> f) (return ()) io $ ungrabKeyboard d currentTime