summaryrefslogtreecommitdiffstats
path: root/XMonad/Stockholm/Rhombus.hs
diff options
context:
space:
mode:
Diffstat (limited to 'XMonad/Stockholm/Rhombus.hs')
-rw-r--r--XMonad/Stockholm/Rhombus.hs121
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)