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