summaryrefslogtreecommitdiffstats
path: root/tv/2configs/xserver/xmonad/Util/Pager.hs
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2015-10-29 01:49:27 +0100
committertv <tv@shackspace.de>2015-10-29 01:49:27 +0100
commitbcaf3771d9503f1b0d01a2c15ca0712ee454342f (patch)
treef5827da74911ccbe14ab5c24d1ca2aea5dcb0df1 /tv/2configs/xserver/xmonad/Util/Pager.hs
parent43d3116dc08aefd2ce008b9905811b8d92d88fac (diff)
tv: {2configs/xserver => 5pkgs}/xmonad-tv
Diffstat (limited to 'tv/2configs/xserver/xmonad/Util/Pager.hs')
-rw-r--r--tv/2configs/xserver/xmonad/Util/Pager.hs172
1 files changed, 0 insertions, 172 deletions
diff --git a/tv/2configs/xserver/xmonad/Util/Pager.hs b/tv/2configs/xserver/xmonad/Util/Pager.hs
deleted file mode 100644
index b8168b5b0..000000000
--- a/tv/2configs/xserver/xmonad/Util/Pager.hs
+++ /dev/null
@@ -1,172 +0,0 @@
-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)