diff options
Diffstat (limited to 'XMonad/Stockholm/Rhombus.hs')
| -rw-r--r-- | XMonad/Stockholm/Rhombus.hs | 121 |
1 files changed, 54 insertions, 67 deletions
diff --git a/XMonad/Stockholm/Rhombus.hs b/XMonad/Stockholm/Rhombus.hs index 93ecf07..b4d6861 100644 --- a/XMonad/Stockholm/Rhombus.hs +++ b/XMonad/Stockholm/Rhombus.hs @@ -1,21 +1,19 @@ module XMonad.Stockholm.Rhombus - ( defaultRhombusConfig - , MatchMethod(..) + ( MatchMethod(..) , rhombus , RhombusConfig(..) , RhombusState(..) ) where -import Control.Monad (forM_, zipWithM_) +import Control.Monad (zipWithM_) import Data.Char import Data.List import Data.Ord import Data.Map (fromList) -import Data.Maybe (isJust, fromJust) -import XMonad -import XMonad.StackSet hiding (filter) +import Data.Maybe (fromJust) +import XMonad hiding (keys) +import XMonad.StackSet hiding (filter, tag) import XMonad.Util.Font -import XMonad.Util.Image (drawIcon) import XMonad.Util.XUtils import XMonad.Stockholm.Submap @@ -33,15 +31,25 @@ data RhombusConfig = RhombusConfig , 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 -defaultRhombusConfig = RhombusConfig "xft:Sans-8" 100 0 MatchInfix True stupidColors noPaint - where - stupidColors _ _ _ = ("red", "magenta", "yellow") - noPaint _ _ _ _ _ _ _ _ _ = return () - +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 @@ -81,14 +89,14 @@ rhombus rc viewFunc as = withGrabbedKeyboard $ do 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 def keys + Nothing -> redraw rc rs >> submapString defAction keys Just i -> removeRhombus rs >> viewFunc i where - def (ch:[]) | isPrint ch = + defAction (ch:[]) | isPrint ch = incSearchPushChar ch rs >>= rhombusMode viewFunc rc - def _ = - failbeep >> rhombusMode viewFunc rc rs + defAction _ = + rc_missAction rc >> rhombusMode viewFunc rc rs keys = fromList $ [ ((0 , xK_BackSpace ), incSearchPopChar rs >>= rhombusMode viewFunc rc) @@ -106,57 +114,55 @@ rhombusMode viewFunc rc rs = _S = shiftMask --- TODO make failbeep configurable -failbeep = spawn "beep -l 100 -f 500" - - goto :: RhombusConfig -> (Position, Position) -> RhombusState -> X RhombusState -goto RhombusConfig{rc_wrap=True} xy rs = maybe (failbeep >> return rs) return $ wrapFocus xy rs -goto RhombusConfig{rc_wrap=False} xy rs = maybe (failbeep >> return rs) return $ moveFocus xy rs +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 focus' = (x + dx, y + dy) - if elem focus' (reachableCoords rs) - then Just rs { rs_focus = focus' } + 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=focus} = do - let column = sortBy (comparing snd) $ filter ((==) (fst focus) . fst) (reachableCoords rs) - i <- elemIndex focus column +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=focus} = do - let column = sortBy (comparing fst) $ filter ((==) (snd focus) . snd) (reachableCoords rs) - i <- elemIndex focus column +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=focus} = do +gotoPrevMatch rc rs@RhombusState{rs_focus=foc} = do case reverse (matchingReachableCoords rc rs) of - [] -> failbeep >> return rs + [] -> rc_missAction rc >> return rs xs -> return rs { rs_focus = maybe (head xs) (modIndex xs . (+1)) - (focus `elemIndex` xs) + (foc `elemIndex` xs) } gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState -gotoNextMatch rc rs@RhombusState{rs_focus=focus} = do +gotoNextMatch rc rs@RhombusState{rs_focus=foc} = do case matchingReachableCoords rc rs of - [] -> failbeep >> return rs + [] -> rc_missAction rc >> return rs xs -> return rs { rs_focus = maybe (head xs) (modIndex xs . (+1)) - (focus `elemIndex` xs) + (foc `elemIndex` xs) } @@ -215,12 +221,12 @@ redraw rc rs = do -- TODO fixme color_black <- stringToPixel d "black" - forZipWithM_ tags (reachableCoords rs) $ \ tag oxy@(ox, oy) -> do + forZipWithM_ tags (reachableCoords rs) $ \tag oxy@(ox, oy) -> do - let focus = oxy == rs_focus rs - match = isXOf (rc_matchmethod rc) (rs_search rs) tag - current = tag == last tags - (_b_color, _bg_color, _fg_color) = rc_colors rc focus match current + 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 @@ -246,7 +252,7 @@ redraw rc rs = do coordModePrevious -- custom draw - paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) focus match current + paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) isFocused isMatched isCurrent -- paint text -- TODO custom paint text? @@ -323,12 +329,10 @@ removeRhombus (RhombusState w _ fn _ _) = do 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..] + --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..] -commonPrefix (x:xs) (y:ys) | x == y = x:commonPrefix xs ys -commonPrefix _ _ = [] isXOf :: MatchMethod -> String -> String -> Bool @@ -336,32 +340,15 @@ isXOf MatchInfix = isInfixOf isXOf MatchPrefix = isPrefixOf -findXIndex :: (Eq a) => MatchMethod -> [a] -> [a] -> Maybe Int -findXIndex MatchInfix = findInfixIndex -findXIndex MatchPrefix = findPrefixIndex - - -findInfixIndex :: (Eq a) => [a] -> [a] -> Maybe Int -findInfixIndex needle haystack - = (\x -> if null x then Nothing else Just (fst $ head x)) - . dropWhile (\(_,x) -> not $ isPrefixOf needle x) - $ zip [0..] (tails haystack) - - -findPrefixIndex :: (Eq a) => [a] -> [a] -> Maybe Int -findPrefixIndex needle haystack = - if isPrefixOf needle haystack - then Just 0 - else Nothing - - 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) |