diff options
Diffstat (limited to 'tv/2configs/xserver/xmonad/Util/Pager.hs')
| -rw-r--r-- | tv/2configs/xserver/xmonad/Util/Pager.hs | 172 |
1 files changed, 172 insertions, 0 deletions
diff --git a/tv/2configs/xserver/xmonad/Util/Pager.hs b/tv/2configs/xserver/xmonad/Util/Pager.hs new file mode 100644 index 0000000..b8168b5 --- /dev/null +++ b/tv/2configs/xserver/xmonad/Util/Pager.hs @@ -0,0 +1,172 @@ +module Util.Pager + ( defaultPagerConfig + , defaultWindowColors + , defaultWorkspaceColors + , MatchMethod(..) + , pager + , PagerConfig(..) + ) where + +import Data.List ( find ) +import Data.Maybe ( catMaybes ) +import Graphics.X11 +import Util.Rhombus +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Hooks.UrgencyHook +import XMonad.Util.Font ( fi, stringToPixel ) + + +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) |