diff options
Diffstat (limited to 'XMonad')
| -rw-r--r-- | XMonad/Stockholm/Font.hs | 10 | ||||
| -rw-r--r-- | XMonad/Stockholm/Pager.hs | 27 | ||||
| -rw-r--r-- | XMonad/Stockholm/Rhombus.hs | 121 | ||||
| -rw-r--r-- | XMonad/Stockholm/Submap.hs | 8 |
4 files changed, 75 insertions, 91 deletions
diff --git a/XMonad/Stockholm/Font.hs b/XMonad/Stockholm/Font.hs index b30a1e7..ed801cc 100644 --- a/XMonad/Stockholm/Font.hs +++ b/XMonad/Stockholm/Font.hs @@ -22,8 +22,8 @@ printStringCentered d p xmf gc r s = do text_w <- textWidthXMF d xmf s (text_ascent, _) <- textExtentsXMF xmf s - let text_x = x + round ((fi w - fi text_w) / 2) - text_y = y + round ((fi h + fi text_h) / 2) + let text_x = x + round ((fi w - fi text_w) / (2 :: Double)) + text_y = y + round ((fi h + fi text_h) / (2 :: Double)) text_h = text_ascent printStringXMF' d p xmf gc "" "" text_x text_y s @@ -32,13 +32,13 @@ printStringCentered d p xmf gc r s = do -- from xmonad-contrib's XMonad.Util.Font, (c) 2007 Andrea Rossato and Spencer Janssen printStringXMF' :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String -> Position -> Position -> String -> m () -printStringXMF' d p (Core fs) gc fc bc x y s = io $ do +printStringXMF' d p (Core fs) gc _fc _bc x y s = io $ do setFont d gc $ fontFromFontStruct fs --tv [fc',bc'] <- mapM (stringToPixel d) [fc,bc] --tv setForeground d gc fc' --tv setBackground d gc bc' drawImageString d p gc x y s -printStringXMF' d p (Utf8 fs) gc fc bc x y s = io $ do +printStringXMF' d p (Utf8 fs) gc _fc _bc x y s = io $ do --tv [fc',bc'] <- mapM (stringToPixel d) [fc,bc] --tv setForeground d gc fc' --tv setBackground d gc bc' @@ -59,6 +59,8 @@ printStringXMF' dpy drw fs@(Xft font) gc fc bc x y s = do io $ withXftDraw dpy drw visual colormap $ \draw -> withXftColorName dpy visual colormap fc $ \color -> xftDrawString draw color font x y s +#else +printStringXMF' _ _ (Xft _) _ _ _ _ _ _ = undefined #endif diff --git a/XMonad/Stockholm/Pager.hs b/XMonad/Stockholm/Pager.hs index cdfa432..eb00832 100644 --- a/XMonad/Stockholm/Pager.hs +++ b/XMonad/Stockholm/Pager.hs @@ -1,6 +1,5 @@ module XMonad.Stockholm.Pager - ( defaultPagerConfig - , defaultWindowColors + ( defaultWindowColors , defaultWorkspaceColors , MatchMethod(..) , pager @@ -30,12 +29,12 @@ data PagerConfig = PagerConfig } -defaultPagerConfig :: PagerConfig -defaultPagerConfig = PagerConfig "xft:Sans-8" 100 0 MatchInfix True defaultWorkspaceColors defaultWindowColors +instance Default PagerConfig where + def = PagerConfig "xft:Sans-8" 100 0 MatchInfix True defaultWorkspaceColors defaultWindowColors pager :: PagerConfig -> (String -> X ()) -> [String] -> X () -pager pc = rhombus defaultRhombusConfig +pager pc = rhombus def { rc_font = pc_font pc , rc_cellwidth = pc_cellwidth pc , rc_margin = pc_margin pc @@ -98,7 +97,7 @@ pagerPaint :: -> Bool -> Bool -> X () -pagerPaint pc rc d p gc t r focus match current = do +pagerPaint pc rc _ p gc t r foc match current = do ss <- gets windowset let x = rect_x r @@ -107,14 +106,11 @@ pagerPaint pc rc d p gc t r focus match current = do urgents <- readUrgents let foci = map W.focus $ catMaybes $ map W.stack $ W.workspaces ss - let color = pc_windowColors pc focus match current -- :: Bool -> (String, String) - (_, _, _fg_color) = pc_workspaceColors pc focus match current + let color = pc_windowColors pc foc match current -- :: Bool -> (String, String) + (_, _, _fg_color) = pc_workspaceColors pc foc match current - fg_color <- stringToPixel d _fg_color - - let r = screenRect $ W.screenDetail $ W.current ss - let a = fi (rect_width r) / fi (rect_height r) - let scale = fi (rc_cellwidth rc) / fi (rect_width r) + let sr = screenRect $ W.screenDetail $ W.current ss + let scale = fi (rc_cellwidth rc) / fi (rect_width sr) -- TODO whenNothing print error whenJust (findWorkspace t ss) $ \ ws -> do @@ -129,14 +125,13 @@ pagerPaint pc rc d p gc t r focus match current = do mapM_ (drawMiniWindow d p gc x y color' scale) (W.up s) drawMiniWindow - :: RealFrac a - => Display + :: Display -> Drawable -> GC -> Position -> Position -> (Window -> (String, String)) - -> a + -> Double -> Window -> IO () drawMiniWindow d p gc ox oy color s win = do 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) diff --git a/XMonad/Stockholm/Submap.hs b/XMonad/Stockholm/Submap.hs index 8648e6c..601afba 100644 --- a/XMonad/Stockholm/Submap.hs +++ b/XMonad/Stockholm/Submap.hs @@ -12,8 +12,8 @@ import XMonad hiding (keys) -- | Like 'XMonad.Actions.Submap.submapDefault', but provides the looked up string to the default action. submapString :: (String -> X ()) -> M.Map (KeyMask, KeySym) (X ()) -> X () -submapString def keys = do - XConf { theRoot = root, display = d } <- ask +submapString defAction keys = do + XConf { display = d } <- ask (m, s, str) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do maskEvent d keyPressMask p @@ -22,10 +22,10 @@ submapString def keys = do if isModifierKey keysym then nextkey else do - (mbKeysym, str) <- lookupString (asKeyEvent p) + (_, str) <- lookupString (asKeyEvent p) return (m, keysym, str) -- Remove num lock mask and Xkb group state bits m' <- cleanMask $ m .&. ((1 `shiftL` 12) - 1) - maybe (def str) id (M.lookup (m', s) keys) + maybe (defAction str) id (M.lookup (m', s) keys) |