tv: {2configs/xserver => 5pkgs}/xmonad-tv

11 files changed, 1101 insertions, 0 deletions

diff --git a/tv/5pkgs/default.nix b/tv/5pkgs/default.nix
index 3cfa8f863..1ca5e70a2 100644
--- a/tv/5pkgs/default.nix
+++ b/tv/5pkgs/default.nix
@@ -3,4 +3,7 @@
 {
   ff = pkgs.callPackage ./ff {};
   viljetic-pages = pkgs.callPackage ./viljetic-pages {};
+  xmonad-tv =
+    let src = pkgs.writeNixFromCabal "xmonad-tv.nix" ./xmonad-tv; in
+    pkgs.haskellPackages.callPackage src {};
 }
diff --git a/tv/5pkgs/xmonad-tv/.gitignore b/tv/5pkgs/xmonad-tv/.gitignore
new file mode 100644
index 000000000..616204547
--- /dev/null
+++ b/tv/5pkgs/xmonad-tv/.gitignore
@@ -0,0 +1 @@
+/shell.nix
diff --git a/tv/5pkgs/xmonad-tv/Main.hs b/tv/5pkgs/xmonad-tv/Main.hs
new file mode 100644
index 000000000..2cc48efa3
--- /dev/null
+++ b/tv/5pkgs/xmonad-tv/Main.hs
@@ -0,0 +1,277 @@
+{-# LANGUAGE DeriveDataTypeable #-} -- for XS
+{-# LANGUAGE FlexibleContexts #-} -- for xmonad'
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+
+module Main where
+
+import Control.Exception
+import Text.Read (readEither)
+import XMonad
+import System.IO (hPutStrLn, stderr)
+import System.Environment (getArgs, withArgs, getEnv, getEnvironment)
+import System.Posix.Process (executeFile)
+import XMonad.Prompt (defaultXPConfig)
+import XMonad.Actions.DynamicWorkspaces ( addWorkspacePrompt, renameWorkspace
+                                        , removeEmptyWorkspace)
+import XMonad.Actions.GridSelect
+import XMonad.Actions.CycleWS (toggleWS)
+--import XMonad.Actions.CopyWindow ( copy )
+import XMonad.Layout.NoBorders ( smartBorders )
+import qualified XMonad.StackSet as W
+import Data.Map (Map)
+import qualified Data.Map as Map
+-- TODO import XMonad.Layout.WorkspaceDir
+import XMonad.Hooks.UrgencyHook (SpawnUrgencyHook(..), withUrgencyHook)
+-- import XMonad.Layout.Tabbed
+--import XMonad.Layout.MouseResizableTile
+import XMonad.Layout.Reflect (reflectVert)
+import XMonad.Layout.FixedColumn (FixedColumn(..))
+import XMonad.Hooks.Place (placeHook, smart)
+import XMonad.Hooks.FloatNext (floatNextHook)
+import XMonad.Actions.PerWorkspaceKeys (chooseAction)
+import XMonad.Layout.PerWorkspace (onWorkspace)
+--import XMonad.Layout.BinarySpacePartition
+
+--import XMonad.Actions.Submap
+import Util.Pager
+import Util.Rhombus
+import Util.Shutdown
+
+
+myTerm :: String
+myTerm = "urxvtc"
+
+myRootTerm :: String
+myRootTerm = "urxvtc -name root-urxvt -e su -"
+
+myFont :: String
+myFont = "-schumacher-*-*-*-*-*-*-*-*-*-*-*-iso10646-*"
+
+main :: IO ()
+main = getArgs >>= \case
+    ["--shutdown"] -> sendShutdownEvent
+    _ -> mainNoArgs
+
+mainNoArgs :: IO ()
+mainNoArgs = do
+    workspaces0 <- getWorkspaces0
+    xmonad'
+        -- $ withUrgencyHookC dzenUrgencyHook { args = ["-bg", "magenta", "-fg", "magenta", "-h", "2"], duration = 500000 }
+        --                   urgencyConfig { remindWhen = Every 1 }
+        -- $ withUrgencyHook borderUrgencyHook "magenta"
+        -- $ withUrgencyHookC BorderUrgencyHook { urgencyBorderColor = "magenta" } urgencyConfig { suppressWhen = Never }
+        $ withUrgencyHook (SpawnUrgencyHook "echo emit Urgency ")
+        $ defaultConfig
+            { terminal          = myTerm
+            , modMask           = mod4Mask
+            , keys              = myKeys
+            , workspaces        = workspaces0
+            , layoutHook        = smartBorders $ myLayout
+            -- , handleEventHook   = myHandleEventHooks <+> handleTimerEvent
+            --, handleEventHook   = handleTimerEvent
+            , manageHook        = placeHook (smart (1,0)) <+> floatNextHook
+            , startupHook       = spawn "echo emit XMonadStartup"
+            , normalBorderColor  = "#1c1c1c"
+            , focusedBorderColor = "#f000b0"
+            , handleEventHook = handleShutdownEvent
+            }
+  where
+    myLayout =
+        (onWorkspace "im" $ reflectVert $ Mirror $ Tall 1 (3/100) (12/13))
+        (FixedColumn 1 20 80 10 ||| Full)
+
+
+xmonad' :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
+xmonad' conf = do
+    path <- getEnv "XMONAD_STATE"
+    try (readFile path) >>= \case
+        Right content -> do
+            hPutStrLn stderr ("resuming from " ++ path)
+            withArgs ("--resume" : lines content) (xmonad conf)
+        Left e -> do
+            hPutStrLn stderr (displaySomeException e)
+            xmonad conf
+
+getWorkspaces0 :: IO [String]
+getWorkspaces0 =
+    try (getEnv "XMONAD_WORKSPACES0_FILE") >>= \case
+      Left e -> warn (displaySomeException e)
+      Right p -> try (readFile p) >>= \case
+        Left e -> warn (displaySomeException e)
+        Right x -> case readEither x of
+          Left e -> warn e
+          Right y -> return y
+  where
+    warn msg = hPutStrLn stderr ("getWorkspaces0: " ++ msg) >> return []
+
+displaySomeException :: SomeException -> String
+displaySomeException = displayException
+
+
+spawnTermAt :: String -> X ()
+--spawnTermAt _ = floatNext True >> spawn myTerm
+--spawnTermAt "ff" = floatNext True >> spawn myTerm
+--spawnTermAt _    = spawn myTerm
+spawnTermAt ws = do
+    env <- liftIO getEnvironment
+    let env' = ("XMONAD_SPAWN_WORKSPACE", ws) : env
+    xfork (executeFile "urxvtc" True [] (Just env')) >> return ()
+
+myKeys :: XConfig Layout -> Map (KeyMask, KeySym) (X ())
+myKeys conf = Map.fromList $
+    [ ((_4  , xK_Escape ), spawn "/var/setuid-wrappers/slock")
+    , ((_4S , xK_c      ), kill)
+
+    , ((_4  , xK_x      ), chooseAction spawnTermAt)
+    , ((_4C , xK_x      ), spawn myRootTerm)
+    --, ((_4M , xK_x      ), spawn "xterm")
+    --, ((_4M , xK_x      ), mySpawn "xterm")
+
+    --, ((_4  , xK_F1     ), withFocused jojo)
+    --, ((_4  , xK_F1     ), printAllGeometries)
+
+    , ((0   , xK_Menu   ), gets windowset >>= allWorkspaceNames >>= pager pagerConfig (windows . W.view) )
+    , ((_S  , xK_Menu   ), gets windowset >>= allWorkspaceNames >>= pager pagerConfig (windows . W.shift) )
+    , ((_C  , xK_Menu   ), toggleWS)
+    , ((_4  , xK_Menu   ), rhombus horseConfig (liftIO . hPutStrLn stderr) ["Correct", "Horse", "Battery", "Staple", "Stuhl", "Tisch"] )
+    
+    -- %! Rotate through the available layout algorithms
+    , ((_4  , xK_space  ), sendMessage NextLayout)
+    , ((_4S , xK_space  ), setLayout $ XMonad.layoutHook conf) -- reset layout
+
+    ---- BinarySpacePartition
+    --, ((_4  , xK_l), sendMessage $ ExpandTowards R)
+    --, ((_4  , xK_h), sendMessage $ ExpandTowards L)
+    --, ((_4  , xK_j), sendMessage $ ExpandTowards D)
+    --, ((_4  , xK_k), sendMessage $ ExpandTowards U)
+    --, ((_4S , xK_l), sendMessage $ ShrinkFrom R)
+    --, ((_4S , xK_h), sendMessage $ ShrinkFrom L)
+    --, ((_4S , xK_j), sendMessage $ ShrinkFrom D)
+    --, ((_4S , xK_k), sendMessage $ ShrinkFrom U)
+    --, ((_4  , xK_n), sendMessage Rotate)
+    --, ((_4S , xK_n), sendMessage Swap)
+
+    ---- mouseResizableTile
+    --, ((_4    , xK_u), sendMessage ShrinkSlave)
+    --, ((_4    , xK_i), sendMessage ExpandSlave)
+
+    -- move focus up or down the window stack
+    --, ((_4  , xK_m      ), windows W.focusMaster)
+    , ((_4  , xK_j      ), windows W.focusDown)
+    , ((_4  , xK_k      ), windows W.focusUp)
+
+    -- modifying the window order
+    , ((_4S , xK_m      ), windows W.swapMaster)
+    , ((_4S , xK_j      ), windows W.swapDown)
+    , ((_4S , xK_k      ), windows W.swapUp)
+
+    -- resizing the master/slave ratio
+    , ((_4  , xK_h      ), sendMessage Shrink) -- %! Shrink the master area
+    , ((_4  , xK_l      ), sendMessage Expand) -- %! Expand the master area
+
+    -- floating layer support
+    , ((_4  , xK_t      ), withFocused $ windows . W.sink)  -- make tiling
+
+    -- increase or decrease number of windows in the master area
+    , ((_4  , xK_comma  ), sendMessage $ IncMasterN 1)
+    , ((_4  , xK_period ), sendMessage $ IncMasterN (-1))
+
+    , ((_4  , xK_a      ), addWorkspacePrompt defaultXPConfig)
+    , ((_4  , xK_r      ), renameWorkspace defaultXPConfig)
+    , ((_4  , xK_Delete ), removeEmptyWorkspace)
+
+    , ((_4  , xK_Return ), toggleWS)
+    --,  (0   , xK_Menu   ) & \k -> (k, gridselectWorkspace wsGSConfig { gs_navigate = makeGSNav k } W.view)
+    --,  (_4  , xK_v      ) & \k -> (k, gridselectWorkspace wsGSConfig { gs_navigate = makeGSNav k } W.view)
+    --,  (_4S , xK_v      ) & \k -> (k, gridselectWorkspace wsGSConfig { gs_navigate = makeGSNav k } W.shift)
+    --,  (_4  , xK_b      ) & \k -> (k, goToSelected        wGSConfig  { gs_navigate = makeGSNav k })
+    ]
+    where
+    _4 = mod4Mask
+    _C = controlMask
+    _S = shiftMask
+    _M = mod1Mask
+    _4C = _4 .|. _C
+    _4S = _4 .|. _S
+    _4M = _4 .|. _M
+    _4CM = _4 .|. _C .|. _M
+    _4SM = _4 .|. _S .|. _M
+
+
+pagerConfig :: PagerConfig
+pagerConfig = defaultPagerConfig
+    { pc_font           = myFont
+    , pc_cellwidth      = 64
+    --, pc_cellheight     = 36 -- TODO automatically keep screen aspect
+    --, pc_borderwidth    = 1
+    --, pc_matchcolor     = "#f0b000"
+    , pc_matchmethod    = MatchPrefix
+    --, pc_colors         = pagerWorkspaceColors
+    , pc_windowColors   = windowColors
+    }
+    where
+    windowColors _ _ _ True _ = ("#ef4242","#ff2323")
+    windowColors wsf m c u wf = do
+        let def = defaultWindowColors wsf m c u wf
+        if m == False && wf == True
+            then ("#402020", snd def)
+            else def
+
+horseConfig :: RhombusConfig
+horseConfig = defaultRhombusConfig
+    { rc_font           = myFont
+    , rc_cellwidth      = 64
+    --, rc_cellheight     = 36 -- TODO automatically keep screen aspect
+    --, rc_borderwidth    = 1
+    --, rc_matchcolor     = "#f0b000"
+    , rc_matchmethod    = MatchPrefix
+    --, rc_colors         = pagerWorkspaceColors
+    --, rc_paint          = myPaint
+    }
+
+wGSConfig :: GSConfig Window
+wGSConfig = defaultGSConfig
+    { gs_cellheight = 20
+    , gs_cellwidth = 192
+    , gs_cellpadding = 5
+    , gs_font = myFont
+    , gs_navigate = navNSearch
+    }
+
+-- wsGSConfig = defaultGSConfig
+--     { gs_cellheight = 20
+--     , gs_cellwidth = 64
+--     , gs_cellpadding = 5
+--     , gs_font = myFont
+--     , gs_navigate = navNSearch
+--     }
+
+-- custom navNSearch
+--makeGSNav :: (KeyMask, KeySym) -> TwoD a (Maybe a)
+--makeGSNav esc = nav
+--    where
+--    nav = makeXEventhandler $ shadowWithKeymap keyMap navNSearchDefaultHandler
+--    keyMap = Map.fromList
+--        [ (esc              , cancel)
+--        , ((0,xK_Escape)    , cancel)
+--        , ((0,xK_Return)    , select)
+--        , ((0,xK_Left)      , move (-1, 0) >> nav)
+--        , ((0,xK_Right)     , move ( 1, 0) >> nav)
+--        , ((0,xK_Down)      , move ( 0, 1) >> nav)
+--        , ((0,xK_Up)        , move ( 0,-1) >> nav)
+--        , ((0,xK_BackSpace) , transformSearchString (\s -> if (s == "") then "" else init s) >> nav)
+--        ]
+--    -- The navigation handler ignores unknown key symbols, therefore we const
+--    navNSearchDefaultHandler (_,s,_) = do
+--        transformSearchString (++ s)
+--        nav
+
+
+(&) :: a -> (a -> c) -> c
+(&) = flip ($)
+
+allWorkspaceNames :: W.StackSet i l a sid sd -> X [i]
+allWorkspaceNames ws =
+    return $ map W.tag (W.hidden ws) ++ [W.tag $ W.workspace $ W.current ws]
diff --git a/tv/5pkgs/xmonad-tv/Makefile b/tv/5pkgs/xmonad-tv/Makefile
new file mode 100644
index 000000000..cbb0776e6
--- /dev/null
+++ b/tv/5pkgs/xmonad-tv/Makefile
@@ -0,0 +1,6 @@
+.PHONY: ghci
+ghci: shell.nix
+	nix-shell --command 'exec ghci -Wall'
+
+shell.nix: xmonad.cabal
+	cabal2nix --shell . > $@
diff --git a/tv/5pkgs/xmonad-tv/Util/Font.hs b/tv/5pkgs/xmonad-tv/Util/Font.hs
new file mode 100644
index 000000000..5352cf5ad
--- /dev/null
+++ b/tv/5pkgs/xmonad-tv/Util/Font.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE CPP #-}
+module Util.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/tv/5pkgs/xmonad-tv/Util/Pager.hs b/tv/5pkgs/xmonad-tv/Util/Pager.hs
new file mode 100644
index 000000000..b8168b5b0
--- /dev/null
+++ b/tv/5pkgs/xmonad-tv/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)
diff --git a/tv/5pkgs/xmonad-tv/Util/Rhombus.hs b/tv/5pkgs/xmonad-tv/Util/Rhombus.hs
new file mode 100644
index 000000000..9d46e4127
--- /dev/null
+++ b/tv/5pkgs/xmonad-tv/Util/Rhombus.hs
@@ -0,0 +1,369 @@
+module Util.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 Util.Submap
+import Util.XUtils
+import Util.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
+
+