summaryrefslogtreecommitdiffstats
path: root/XMonad/Stockholm
diff options
context:
space:
mode:
Diffstat (limited to 'XMonad/Stockholm')
-rw-r--r--XMonad/Stockholm/Font.hs124
-rw-r--r--XMonad/Stockholm/Pager.hs174
-rw-r--r--XMonad/Stockholm/Rhombus.hs369
-rw-r--r--XMonad/Stockholm/Shutdown.hs54
-rw-r--r--XMonad/Stockholm/Submap.hs31
-rw-r--r--XMonad/Stockholm/XUtils.hs47
6 files changed, 799 insertions, 0 deletions
diff --git a/XMonad/Stockholm/Font.hs b/XMonad/Stockholm/Font.hs
new file mode 100644
index 0000000..b30a1e7
--- /dev/null
+++ b/XMonad/Stockholm/Font.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE CPP #-}
+
+module XMonad.Stockholm.Font
+ ( printStringCentered
+ , printStringXMF'
+ ) where
+
+import XMonad
+import XMonad.Util.Font
+
+
+printStringCentered :: (Functor m, MonadIO m)
+ => Display -> Drawable -> XMonadFont
+ -> GC -> Rectangle -> String
+ -> m ()
+printStringCentered d p xmf gc r s = do
+ let x = rect_x r
+ y = rect_y r
+ w = rect_width r
+ h = rect_height r
+
+ 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)
+ text_h = text_ascent
+
+ printStringXMF' d p xmf gc "" "" text_x text_y s
+
+
+-- 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
+ 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
+ --tv [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
+ --tv setForeground d gc fc'
+ --tv setBackground d gc bc'
+ io $ wcDrawImageString d p fs gc x y s
+#ifdef XFT
+printStringXMF' dpy drw fs@(Xft font) gc fc bc x y s = do
+ let screen = defaultScreenOfDisplay dpy
+ colormap = defaultColormapOfScreen screen
+ visual = defaultVisualOfScreen screen
+ --tv bcolor <- stringToPixel dpy bc
+ (a,d) <- textExtentsXMF fs s
+ gi <- io $ xftTextExtents dpy font s
+ --tv io $ setForeground dpy gc bcolor
+ io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))
+ (y - fi a)
+ (fi $ xglyphinfo_xOff gi)
+ (fi $ a + d)
+ io $ withXftDraw dpy drw visual colormap $
+ \draw -> withXftColorName dpy visual colormap fc $
+ \color -> xftDrawString draw color font x y s
+#endif
+
+
+
+
+
+-- --my_printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String
+-- -- -> Position -> Position -> String -> m ()
+-- my_printStringXMF (Core fs) d p gc x y s = do
+-- setFont d gc $ fontFromFontStruct fs
+-- -- [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
+-- -- setForeground d gc fc'
+-- -- setBackground d gc bc'
+-- drawImageString d p gc x y s
+-- my_printStringXMF (Utf8 fs) d p gc x y s = do
+-- -- [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
+-- -- setForeground d gc fc'
+-- -- setBackground d gc bc'
+-- wcDrawImageString d p fs gc x y s
+-- #ifdef XFT
+-- my_printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do
+-- let screen = defaultScreenOfDisplay dpy
+-- colormap = defaultColormapOfScreen screen
+-- visual = defaultVisualOfScreen screen
+-- bcolor <- stringToPixel dpy bc
+-- (a,d) <- textExtentsXMF fs s
+-- gi <- io $ xftTextExtents dpy font s
+-- io $ setForeground dpy gc bcolor
+-- io $ fillRectangle dpy drw gc (x - fromIntegral (xglyphinfo_x gi))
+-- (y - fromIntegral a)
+-- (fromIntegral $ xglyphinfo_xOff gi)
+-- (fromIntegral $ a + d)
+-- io $ withXftDraw dpy drw visual colormap $
+-- \draw -> withXftColorName dpy visual colormap fc $
+-- \color -> xftDrawString draw color font x y s
+-- #endif
+
+
+
+-- --textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int
+-- my_textWidthXMF _ (Utf8 fs) s = return $ fromIntegral $ wcTextEscapement fs s
+-- my_textWidthXMF _ (Core fs) s = return $ fromIntegral $ textWidth fs s
+-- #ifdef XFT
+-- my_TextWidthXMF dpy (Xft xftdraw) s = liftIO $ do
+-- gi <- xftTextExtents dpy xftdraw s
+-- return $ xglyphinfo_xOff gi
+-- #endif
+--
+-- my_textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32)
+-- my_textExtentsXMF (Utf8 fs) s = do
+-- let (_,rl) = wcTextExtents fs s
+-- ascent = fromIntegral $ - (rect_y rl)
+-- descent = fromIntegral $ rect_height rl + (fromIntegral $ rect_y rl)
+-- return (ascent, descent)
+-- my_textExtentsXMF (Core fs) s = do
+-- let (_,a,d,_) = textExtents fs s
+-- return (a,d)
+-- #ifdef XFT
+-- my_textExtentsXMF (Xft xftfont) _ = io $ do
+-- ascent <- fromIntegral `fmap` xftfont_ascent xftfont
+-- descent <- fromIntegral `fmap` xftfont_descent xftfont
+-- return (ascent, descent)
+-- #endif
diff --git a/XMonad/Stockholm/Pager.hs b/XMonad/Stockholm/Pager.hs
new file mode 100644
index 0000000..cdfa432
--- /dev/null
+++ b/XMonad/Stockholm/Pager.hs
@@ -0,0 +1,174 @@
+module XMonad.Stockholm.Pager
+ ( defaultPagerConfig
+ , defaultWindowColors
+ , defaultWorkspaceColors
+ , MatchMethod(..)
+ , pager
+ , PagerConfig(..)
+ ) where
+
+import qualified XMonad.StackSet as W
+
+import Data.List (find)
+import Data.Maybe (catMaybes)
+import Graphics.X11
+import XMonad
+import XMonad.Hooks.UrgencyHook
+import XMonad.Util.Font (fi, stringToPixel)
+
+import XMonad.Stockholm.Rhombus
+
+
+data PagerConfig = PagerConfig
+ { pc_font :: String
+ , pc_cellwidth :: Dimension
+ , pc_margin :: Dimension
+ , pc_matchmethod :: MatchMethod
+ , pc_wrap :: Bool
+ , pc_workspaceColors :: Bool -> Bool -> Bool -> (String, String, String)
+ , pc_windowColors :: Bool -> Bool -> Bool -> Bool -> Bool -> (String, String)
+ }
+
+
+defaultPagerConfig :: PagerConfig
+defaultPagerConfig = PagerConfig "xft:Sans-8" 100 0 MatchInfix True defaultWorkspaceColors defaultWindowColors
+
+
+pager :: PagerConfig -> (String -> X ()) -> [String] -> X ()
+pager pc = rhombus defaultRhombusConfig
+ { rc_font = pc_font pc
+ , rc_cellwidth = pc_cellwidth pc
+ , rc_margin = pc_margin pc
+ , rc_matchmethod = pc_matchmethod pc
+ , rc_wrap = pc_wrap pc
+ , rc_colors = pc_workspaceColors pc
+ , rc_paint = pagerPaint pc
+ }
+
+
+defaultWorkspaceColors :: Bool -- workspace has focus
+ -> Bool -- workspace name matches incremental search
+ -> Bool -- workspace is the current one
+ -> (String, String, String) -- workspace border, background color, and foreground color
+defaultWorkspaceColors False False False = ("#101010","#050505","#202020")
+defaultWorkspaceColors False False True = ("#101010","#050505","#202020")
+defaultWorkspaceColors False True False = ("#404040","#202020","#b0b0b0")
+defaultWorkspaceColors False True True = ("#101010","#050505","#505050")
+defaultWorkspaceColors True _ False = ("#808020","#404010","#f0f0b0")
+defaultWorkspaceColors True _ True = ("#404010","#202005","#909050")
+
+
+defaultWindowColors :: Bool -- window's workspace has focus
+ -> Bool -- window's workspace name matches incremental search
+ -> Bool -- window's workspace the current one
+ -> Bool -- window is urgent
+ -> Bool -- window has focus
+ -> (String, String) -- window border and background color
+
+defaultWindowColors wsf m c u True = ("#802020", snd $ defaultWindowColors wsf m c u False)
+
+defaultWindowColors False False False False _ = ("#111111","#060606")
+defaultWindowColors False False False True _ = ("#802020","#401010")
+defaultWindowColors False False True False _ = ("#101010","#050505")
+defaultWindowColors False False True True _ = ("#401010","#200505")
+defaultWindowColors False True False False _ = ("#202080","#101040")
+defaultWindowColors False True False True _ = ("#802080","#401040")
+defaultWindowColors False True True False _ = ("#101040","#100520")
+defaultWindowColors False True True True _ = ("#401040","#200520")
+
+defaultWindowColors True False False False _ = ("#208020","#104010")
+defaultWindowColors True False False True _ = ("#808020","#404010")
+defaultWindowColors True False True False _ = ("#104010","#052005")
+defaultWindowColors True False True True _ = ("#404010","#202005")
+defaultWindowColors True True False False _ = ("#208080","#104040")
+defaultWindowColors True True False True _ = ("#808080","#404040")
+defaultWindowColors True True True False _ = ("#104040","#102020")
+defaultWindowColors True True True True _ = ("#404040","#202020")
+
+
+pagerPaint ::
+ PagerConfig
+ -> RhombusConfig
+ -> Display
+ -> Drawable
+ -> GC
+ -> WorkspaceId
+ -> Rectangle
+ -> Bool
+ -> Bool
+ -> Bool
+ -> X ()
+pagerPaint pc rc d p gc t r focus match current = do
+ ss <- gets windowset
+
+ let x = rect_x r
+ y = rect_y r
+
+ 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
+
+ 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)
+
+ -- TODO whenNothing print error
+ whenJust (findWorkspace t ss) $ \ ws -> do
+ whenJust (W.stack ws) $ \ s ->
+ withDisplay $ \ d -> io $ do
+
+ let color' w = color (w `elem` urgents) (w `elem` foci)
+
+ -- TODO painting of floating windows is broken
+ mapM_ (drawMiniWindow d p gc x y color' scale) (W.down s)
+ drawMiniWindow d p gc x y color' scale (W.focus s)
+ mapM_ (drawMiniWindow d p gc x y color' scale) (W.up s)
+
+drawMiniWindow
+ :: RealFrac a
+ => Display
+ -> Drawable
+ -> GC
+ -> Position
+ -> Position
+ -> (Window -> (String, String))
+ -> a
+ -> Window
+ -> IO ()
+drawMiniWindow d p gc ox oy color s win = do
+ let scale x = round $ fi x * s
+
+ wa <- getWindowAttributes d win
+
+ let x = ox + (scale $ wa_x wa)
+ y = oy + (scale $ wa_y wa)
+ w = (scale $ wa_width wa)
+ h = (scale $ wa_height wa)
+
+ let (fg, bg) = color win
+
+ fg' <- stringToPixel d fg
+ bg' <- stringToPixel d bg
+
+ setForeground d gc bg'
+ fillRectangle d p gc (x + 1) (y + 1) (w - 2) (h - 2)
+
+ setForeground d gc fg'
+ drawLines d p gc
+ [ Point x y
+ , Point (fi w - 1) 0
+ , Point 0 (fi h - 2)
+ , Point (- fi w + 1) 0
+ , Point 0 (- fi h + 2)
+ ]
+ coordModePrevious
+
+
+
+-- TODO externalize findWorkspace
+findWorkspace :: (Eq i) => i -> W.StackSet i l a sid sd -> Maybe (W.Workspace i l a)
+findWorkspace t ss = find ((==)t . W.tag) (W.workspaces ss)
diff --git a/XMonad/Stockholm/Rhombus.hs b/XMonad/Stockholm/Rhombus.hs
new file mode 100644
index 0000000..93ecf07
--- /dev/null
+++ b/XMonad/Stockholm/Rhombus.hs
@@ -0,0 +1,369 @@
+module XMonad.Stockholm.Rhombus
+ ( defaultRhombusConfig
+ , MatchMethod(..)
+ , rhombus
+ , RhombusConfig(..)
+ , RhombusState(..)
+ ) where
+
+import Control.Monad (forM_, 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 XMonad.Util.Font
+import XMonad.Util.Image (drawIcon)
+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 ()
+ }
+
+
+-- TODO currently xft is broken
+defaultRhombusConfig = RhombusConfig "xft:Sans-8" 100 0 MatchInfix True stupidColors noPaint
+ 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 def keys
+ Just i -> removeRhombus rs >> viewFunc i
+ where
+ def (ch:[]) | isPrint ch =
+ incSearchPushChar ch rs >>= rhombusMode viewFunc rc
+
+ def _ =
+ failbeep >> 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
+
+
+-- 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
+
+
+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' }
+ 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
+ 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
+ return rs { rs_focus = column `modIndex` (i + fromIntegral dx) }
+
+wrapFocus _ _ = Nothing
+
+
+gotoPrevMatch :: RhombusConfig -> RhombusState -> X RhombusState
+gotoPrevMatch rc rs@RhombusState{rs_focus=focus} = do
+ case reverse (matchingReachableCoords rc rs) of
+ [] -> failbeep >> return rs
+ xs -> return rs
+ { rs_focus = maybe (head xs)
+ (modIndex xs . (+1))
+ (focus `elemIndex` xs)
+ }
+
+
+gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState
+gotoNextMatch rc rs@RhombusState{rs_focus=focus} = do
+ case matchingReachableCoords rc rs of
+ [] -> failbeep >> return rs
+ xs -> return rs
+ { rs_focus = maybe (head xs)
+ (modIndex xs . (+1))
+ (focus `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 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
+ --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) focus match current
+
+ -- 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..]
+
+commonPrefix (x:xs) (y:ys) | x == y = x:commonPrefix xs ys
+commonPrefix _ _ = []
+
+
+isXOf :: MatchMethod -> String -> String -> Bool
+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_ a b f = zipWithM_ f a b
+
+
+withGrabbedKeyboard f = do
+ XConf { theRoot = root, display = d } <- ask
+ catchX (io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime) >> f)
+ (return ())
+ io $ ungrabKeyboard d currentTime
diff --git a/XMonad/Stockholm/Shutdown.hs b/XMonad/Stockholm/Shutdown.hs
new file mode 100644
index 0000000..164ddd8
--- /dev/null
+++ b/XMonad/Stockholm/Shutdown.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE LambdaCase #-}
+
+module XMonad.Stockholm.Shutdown
+ ( sendShutdownEvent
+ , handleShutdownEvent
+ , shutdown
+ )
+ where
+
+import qualified Data.Map as Map
+import qualified XMonad.StackSet as W
+import Control.Monad
+import Data.Maybe (catMaybes)
+import Data.Monoid
+import System.Environment (getEnv)
+import System.Exit (exitSuccess)
+import XMonad
+
+sendShutdownEvent :: IO ()
+sendShutdownEvent = do
+ dpy <- openDisplay ""
+ rw <- rootWindow dpy $ defaultScreen dpy
+ a <- internAtom dpy "XMONAD_SHUTDOWN" False
+ allocaXEvent $ \e -> do
+ setEventType e clientMessage
+ setClientMessageEvent e rw a 32 0 currentTime
+ sendEvent dpy rw False structureNotifyMask e
+ sync dpy False
+
+handleShutdownEvent :: Event -> X All
+handleShutdownEvent = \case
+ ClientMessageEvent { ev_message_type = mt } -> do
+ c <- (mt ==) <$> getAtom "XMONAD_SHUTDOWN"
+ when c shutdown
+ return (All c)
+ _ ->
+ return (All True)
+
+shutdown :: X ()
+shutdown = do
+ broadcastMessage ReleaseResources
+ io . flush =<< asks display
+ let wsData = show . W.mapLayout show . windowset
+ maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext)
+ maybeShow (t, Left str) = Just (t, str)
+ maybeShow _ = Nothing
+ extState =
+ return . show . catMaybes . map maybeShow . Map.toList . extensibleState
+ s <- gets (\s -> (wsData s : extState s))
+ _ <- io $ do
+ path <- getEnv "XMONAD_STATE"
+ writeFile path (unlines s)
+ exitSuccess
+ return ()
diff --git a/XMonad/Stockholm/Submap.hs b/XMonad/Stockholm/Submap.hs
new file mode 100644
index 0000000..8648e6c
--- /dev/null
+++ b/XMonad/Stockholm/Submap.hs
@@ -0,0 +1,31 @@
+-- This module is based on Jason Creighton's XMonad.Actions.Submap
+
+module XMonad.Stockholm.Submap
+ ( submapString
+ ) where
+
+import qualified Data.Map as M
+import Control.Monad.Fix (fix)
+import Data.Bits
+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
+
+ (m, s, str) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do
+ maskEvent d keyPressMask p
+ KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p
+ keysym <- keycodeToKeysym d code 0
+ if isModifierKey keysym
+ then nextkey
+ else do
+ (mbKeysym, 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)
diff --git a/XMonad/Stockholm/XUtils.hs b/XMonad/Stockholm/XUtils.hs
new file mode 100644
index 0000000..5b477b8
--- /dev/null
+++ b/XMonad/Stockholm/XUtils.hs
@@ -0,0 +1,47 @@
+module XMonad.Stockholm.XUtils
+ ( shapeWindow
+ , withGC
+ , withPixmap
+ , withPixmapAndGC
+ ) where
+
+import Control.Exception ( bracket )
+import Foreign.C.Types ( CInt )
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+import Graphics.X11.Xshape
+
+
+shapeWindow :: Display -> Window -> (Pixmap -> GC -> IO ()) -> IO ()
+shapeWindow d w f = do
+ wa <- getWindowAttributes d w
+
+ let width = fromIntegral $ wa_width wa
+ height = fromIntegral $ wa_height wa
+
+ withPixmapAndGC d w width height 1 $ \ p g -> do
+
+ setForeground d g 0
+ fillRectangle d p g 0 0 width height
+
+ setForeground d g 1
+
+ f p g
+
+ xshapeCombineMask d w shapeBounding 0 0 p shapeSet
+
+
+withGC :: Display -> Drawable -> (GC -> IO ()) -> IO ()
+withGC d p =
+ bracket (createGC d p) (freeGC d)
+
+
+withPixmap :: Display -> Drawable -> Dimension -> Dimension -> CInt -> (Pixmap -> IO ()) -> IO ()
+withPixmap d p w h depth =
+ bracket (createPixmap d p w h depth) (freePixmap d)
+
+
+withPixmapAndGC :: Display -> Drawable -> Dimension -> Dimension -> CInt -> (Pixmap -> GC -> IO ()) -> IO ()
+withPixmapAndGC d w width height depth f =
+ withPixmap d w width height depth $ \ p ->
+ withGC d p $ \ g -> f p g