stockholm/tv/5pkgs/xmonad-tv/Util/Pager.hs

173 lines
5.9 KiB
Haskell
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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)