summaryrefslogtreecommitdiffstats
path: root/tv/2configs
diff options
context:
space:
mode:
Diffstat (limited to 'tv/2configs')
-rw-r--r--tv/2configs/xserver/default.nix7
-rw-r--r--tv/2configs/xserver/xmonad/.gitignore1
-rw-r--r--tv/2configs/xserver/xmonad/Main.hs277
-rw-r--r--tv/2configs/xserver/xmonad/Makefile6
-rw-r--r--tv/2configs/xserver/xmonad/Util/Font.hs123
-rw-r--r--tv/2configs/xserver/xmonad/Util/Pager.hs172
-rw-r--r--tv/2configs/xserver/xmonad/Util/Rhombus.hs369
-rw-r--r--tv/2configs/xserver/xmonad/Util/Shutdown.hs53
-rw-r--r--tv/2configs/xserver/xmonad/Util/Submap.hs31
-rw-r--r--tv/2configs/xserver/xmonad/Util/XUtils.hs47
-rw-r--r--tv/2configs/xserver/xmonad/xmonad.cabal19
11 files changed, 2 insertions, 1103 deletions
diff --git a/tv/2configs/xserver/default.nix b/tv/2configs/xserver/default.nix
index 388a33bbe..4d2fe9e45 100644
--- a/tv/2configs/xserver/default.nix
+++ b/tv/2configs/xserver/default.nix
@@ -80,9 +80,6 @@ let
'';
};
- xmonad-pkg = pkgs.haskellPackages.callPackage xmonad-src {};
- xmonad-src = pkgs.writeNixFromCabal "xmonad.nix" ./xmonad;
-
xmonad-environment = {
DISPLAY = ":${toString config.services.xserver.display}";
XMONAD_STATE = "/tmp/xmonad.state";
@@ -119,12 +116,12 @@ let
settle ${pkgs.xorg.xhost}/bin/xhost +LOCAL:
settle ${pkgs.xorg.xrdb}/bin/xrdb -merge ${import ./Xresources.nix args}
settle ${pkgs.xorg.xsetroot}/bin/xsetroot -solid '#1c1c1c'
- exec ${xmonad-pkg}/bin/xmonad
+ exec ${pkgs.xmonad-tv}/bin/xmonad
'';
xmonad-stop = pkgs.writeScriptBin "xmonad-stop" ''
#! /bin/sh
- exec ${xmonad-pkg}/bin/xmonad --shutdown
+ exec ${pkgs.xmonad-tv}/bin/xmonad --shutdown
'';
xserver-environment = {
diff --git a/tv/2configs/xserver/xmonad/.gitignore b/tv/2configs/xserver/xmonad/.gitignore
deleted file mode 100644
index 616204547..000000000
--- a/tv/2configs/xserver/xmonad/.gitignore
+++ /dev/null
@@ -1 +0,0 @@
-/shell.nix
diff --git a/tv/2configs/xserver/xmonad/Main.hs b/tv/2configs/xserver/xmonad/Main.hs
deleted file mode 100644
index 2cc48efa3..000000000
--- a/tv/2configs/xserver/xmonad/Main.hs
+++ /dev/null
@@ -1,277 +0,0 @@
-{-# 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/2configs/xserver/xmonad/Makefile b/tv/2configs/xserver/xmonad/Makefile
deleted file mode 100644
index cbb0776e6..000000000
--- a/tv/2configs/xserver/xmonad/Makefile
+++ /dev/null
@@ -1,6 +0,0 @@
-.PHONY: ghci
-ghci: shell.nix
- nix-shell --command 'exec ghci -Wall'
-
-shell.nix: xmonad.cabal
- cabal2nix --shell . > $@
diff --git a/tv/2configs/xserver/xmonad/Util/Font.hs b/tv/2configs/xserver/xmonad/Util/Font.hs
deleted file mode 100644
index 5352cf5ad..000000000
--- a/tv/2configs/xserver/xmonad/Util/Font.hs
+++ /dev/null
@@ -1,123 +0,0 @@
-{-# 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/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)
diff --git a/tv/2configs/xserver/xmonad/Util/Rhombus.hs b/tv/2configs/xserver/xmonad/Util/Rhombus.hs
deleted file mode 100644
index 9d46e4127..000000000
--- a/tv/2configs/xserver/xmonad/Util/Rhombus.hs
+++ /dev/null
@@ -1,369 +0,0 @@
-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