summaryrefslogtreecommitdiffstats
path: root/tv/2configs/xserver/xmonad/Util/Pager.hs
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2015-10-24 22:31:10 +0200
committertv <tv@shackspace.de>2015-10-24 22:31:10 +0200
commit0306ec4294f6d825ca65c7b0c98a80a3bced8fdf (patch)
treeeb9e3772407963c25a4d6bd8125b3a2a72bb29ca /tv/2configs/xserver/xmonad/Util/Pager.hs
parentb2deab26bd52a994003cafc33872b6c084cdd716 (diff)
tv: lol display-manager
Diffstat (limited to 'tv/2configs/xserver/xmonad/Util/Pager.hs')
-rw-r--r--tv/2configs/xserver/xmonad/Util/Pager.hs172
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 000000000..b8168b5b0
--- /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)