From e5ac86ee44c4e7a5784cef1569873d246352e4fe Mon Sep 17 00:00:00 2001 From: tv Date: Mon, 26 Oct 2015 11:27:02 +0100 Subject: tv xmonad: provide XMONAD_SPAWN_WORKSPACE --- tv/2configs/xserver/xmonad/Main.hs | 10 +++++++--- tv/2configs/xserver/xmonad/xmonad.cabal | 1 + 2 files changed, 8 insertions(+), 3 deletions(-) (limited to 'tv/2configs/xserver/xmonad') diff --git a/tv/2configs/xserver/xmonad/Main.hs b/tv/2configs/xserver/xmonad/Main.hs index 186a5e22c..cc958155e 100644 --- a/tv/2configs/xserver/xmonad/Main.hs +++ b/tv/2configs/xserver/xmonad/Main.hs @@ -8,7 +8,8 @@ module Main where import Control.Exception import Text.Read (readEither) import XMonad -import System.Environment (getArgs, getEnv) +import System.Environment (getArgs, getEnv, getEnvironment) +import System.Posix.Process (executeFile) import XMonad.Prompt (defaultXPConfig) import XMonad.Actions.DynamicWorkspaces ( addWorkspacePrompt, renameWorkspace , removeEmptyWorkspace) @@ -100,8 +101,11 @@ displaySomeException = displayException spawnTermAt :: String -> X () --spawnTermAt _ = floatNext True >> spawn myTerm --spawnTermAt "ff" = floatNext True >> spawn myTerm -spawnTermAt _ = 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 $ diff --git a/tv/2configs/xserver/xmonad/xmonad.cabal b/tv/2configs/xserver/xmonad/xmonad.cabal index 00acf1704..cc72d3953 100644 --- a/tv/2configs/xserver/xmonad/xmonad.cabal +++ b/tv/2configs/xserver/xmonad/xmonad.cabal @@ -10,6 +10,7 @@ Executable xmonad base, containers, filepath, + unix, X11, X11-xshape, xmonad, -- cgit v1.2.3 From b7d9c3476bd015ddb1a1d6cd66ebdd1b96003b2a Mon Sep 17 00:00:00 2001 From: tv Date: Wed, 28 Oct 2015 16:12:54 +0100 Subject: tv xmonad: make [ghci] --- tv/2configs/xserver/xmonad/Makefile | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 tv/2configs/xserver/xmonad/Makefile (limited to 'tv/2configs/xserver/xmonad') diff --git a/tv/2configs/xserver/xmonad/Makefile b/tv/2configs/xserver/xmonad/Makefile new file mode 100644 index 000000000..cbb0776e6 --- /dev/null +++ b/tv/2configs/xserver/xmonad/Makefile @@ -0,0 +1,6 @@ +.PHONY: ghci +ghci: shell.nix + nix-shell --command 'exec ghci -Wall' + +shell.nix: xmonad.cabal + cabal2nix --shell . > $@ -- cgit v1.2.3 From 737922a20e1b15ef5a8d11956c9395f7fede735c Mon Sep 17 00:00:00 2001 From: tv Date: Wed, 28 Oct 2015 20:18:31 +0100 Subject: tv xmonad: s/concatMap (++"\n")/unlines/ --- tv/2configs/xserver/xmonad/Util/Shutdown.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tv/2configs/xserver/xmonad') diff --git a/tv/2configs/xserver/xmonad/Util/Shutdown.hs b/tv/2configs/xserver/xmonad/Util/Shutdown.hs index c5a3edb80..89e22b4e7 100644 --- a/tv/2configs/xserver/xmonad/Util/Shutdown.hs +++ b/tv/2configs/xserver/xmonad/Util/Shutdown.hs @@ -48,6 +48,6 @@ shutdown = do s <- gets (\s -> (wsData s : extState s)) _ <- io $ do path <- getEnv "XMONAD_STATE" - writeFile path (concatMap (++"\n") s) + writeFile path (unlines s) exitSuccess return () -- cgit v1.2.3 From 057c4836c10eebf3141d7b20a9e942518357606c Mon Sep 17 00:00:00 2001 From: tv Date: Wed, 28 Oct 2015 21:00:29 +0100 Subject: tv xmonad: resume by reading state from file --- tv/2configs/xserver/xmonad/Main.hs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) (limited to 'tv/2configs/xserver/xmonad') diff --git a/tv/2configs/xserver/xmonad/Main.hs b/tv/2configs/xserver/xmonad/Main.hs index cc958155e..fe7304904 100644 --- a/tv/2configs/xserver/xmonad/Main.hs +++ b/tv/2configs/xserver/xmonad/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -- for XS +{-# LANGUAGE FlexibleContexts #-} -- for xmonad' {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,7 +9,7 @@ module Main where import Control.Exception import Text.Read (readEither) import XMonad -import System.Environment (getArgs, getEnv, getEnvironment) +import System.Environment (getArgs, withArgs, getEnv, getEnvironment) import System.Posix.Process (executeFile) import XMonad.Prompt (defaultXPConfig) import XMonad.Actions.DynamicWorkspaces ( addWorkspacePrompt, renameWorkspace @@ -56,7 +57,7 @@ main = getArgs >>= \case mainNoArgs :: IO () mainNoArgs = do workspaces0 <- getWorkspaces0 - xmonad + xmonad' -- $ withUrgencyHookC dzenUrgencyHook { args = ["-bg", "magenta", "-fg", "magenta", "-h", "2"], duration = 500000 } -- urgencyConfig { remindWhen = Every 1 } -- $ withUrgencyHook borderUrgencyHook "magenta" @@ -82,6 +83,17 @@ mainNoArgs = do (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 + putStrLn ("resuming from " ++ path) + withArgs ("--resume" : lines content) (xmonad conf) + Left e -> do + putStrLn (displaySomeException e) + xmonad conf + getWorkspaces0 :: IO [String] getWorkspaces0 = try (getEnv "XMONAD_WORKSPACES0_FILE") >>= \case -- cgit v1.2.3 From 00d03622d187397fd0cb46c17fe1f6750883d774 Mon Sep 17 00:00:00 2001 From: tv Date: Wed, 28 Oct 2015 21:21:27 +0100 Subject: tv xmonad: print stuff to stderr everywhere --- tv/2configs/xserver/xmonad/Main.hs | 10 +++++----- tv/2configs/xserver/xmonad/Util/Debunk.hs | 16 ---------------- tv/2configs/xserver/xmonad/Util/Rhombus.hs | 1 - 3 files changed, 5 insertions(+), 22 deletions(-) delete mode 100644 tv/2configs/xserver/xmonad/Util/Debunk.hs (limited to 'tv/2configs/xserver/xmonad') diff --git a/tv/2configs/xserver/xmonad/Main.hs b/tv/2configs/xserver/xmonad/Main.hs index fe7304904..2cc48efa3 100644 --- a/tv/2configs/xserver/xmonad/Main.hs +++ b/tv/2configs/xserver/xmonad/Main.hs @@ -9,6 +9,7 @@ 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) @@ -36,7 +37,6 @@ import XMonad.Layout.PerWorkspace (onWorkspace) --import XMonad.Actions.Submap import Util.Pager import Util.Rhombus -import Util.Debunk import Util.Shutdown @@ -88,10 +88,10 @@ xmonad' conf = do path <- getEnv "XMONAD_STATE" try (readFile path) >>= \case Right content -> do - putStrLn ("resuming from " ++ path) + hPutStrLn stderr ("resuming from " ++ path) withArgs ("--resume" : lines content) (xmonad conf) Left e -> do - putStrLn (displaySomeException e) + hPutStrLn stderr (displaySomeException e) xmonad conf getWorkspaces0 :: IO [String] @@ -104,7 +104,7 @@ getWorkspaces0 = Left e -> warn e Right y -> return y where - warn msg = putStrLn ("getWorkspaces0: " ++ msg) >> return [] + warn msg = hPutStrLn stderr ("getWorkspaces0: " ++ msg) >> return [] displaySomeException :: SomeException -> String displaySomeException = displayException @@ -135,7 +135,7 @@ myKeys conf = Map.fromList $ , ((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 . printToErrors) ["Correct", "Horse", "Battery", "Staple", "Stuhl", "Tisch"] ) + , ((_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) diff --git a/tv/2configs/xserver/xmonad/Util/Debunk.hs b/tv/2configs/xserver/xmonad/Util/Debunk.hs deleted file mode 100644 index b4772e582..000000000 --- a/tv/2configs/xserver/xmonad/Util/Debunk.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Util.Debunk - ( printToErrors - ) where - -import XMonad -import System.FilePath ( () ) -import Control.Exception ( bracket ) -import System.IO ( hPrint, stderr, openFile, hClose, IOMode( AppendMode ) ) - - -printToErrors x = do - dir <- getXMonadDir - let base = dir "xmonad" - err = base ++ ".errors" - bracket (openFile err AppendMode) hClose $ \h -> hPrint h x - diff --git a/tv/2configs/xserver/xmonad/Util/Rhombus.hs b/tv/2configs/xserver/xmonad/Util/Rhombus.hs index 5f43cb28a..9d46e4127 100644 --- a/tv/2configs/xserver/xmonad/Util/Rhombus.hs +++ b/tv/2configs/xserver/xmonad/Util/Rhombus.hs @@ -18,7 +18,6 @@ import XMonad.Util.Font import XMonad.Util.Image ( drawIcon ) import XMonad.Util.XUtils -import Util.Debunk import Util.Submap import Util.XUtils import Util.Font -- cgit v1.2.3 From bcaf3771d9503f1b0d01a2c15ca0712ee454342f Mon Sep 17 00:00:00 2001 From: tv Date: Thu, 29 Oct 2015 01:49:27 +0100 Subject: tv: {2configs/xserver => 5pkgs}/xmonad-tv --- tv/2configs/xserver/xmonad/.gitignore | 1 - tv/2configs/xserver/xmonad/Main.hs | 277 --------------------- tv/2configs/xserver/xmonad/Makefile | 6 - tv/2configs/xserver/xmonad/Util/Font.hs | 123 ---------- tv/2configs/xserver/xmonad/Util/Pager.hs | 172 ------------- tv/2configs/xserver/xmonad/Util/Rhombus.hs | 369 ---------------------------- tv/2configs/xserver/xmonad/Util/Shutdown.hs | 53 ---- tv/2configs/xserver/xmonad/Util/Submap.hs | 31 --- tv/2configs/xserver/xmonad/Util/XUtils.hs | 47 ---- tv/2configs/xserver/xmonad/xmonad.cabal | 19 -- 10 files changed, 1098 deletions(-) delete mode 100644 tv/2configs/xserver/xmonad/.gitignore delete mode 100644 tv/2configs/xserver/xmonad/Main.hs delete mode 100644 tv/2configs/xserver/xmonad/Makefile delete mode 100644 tv/2configs/xserver/xmonad/Util/Font.hs delete mode 100644 tv/2configs/xserver/xmonad/Util/Pager.hs delete mode 100644 tv/2configs/xserver/xmonad/Util/Rhombus.hs delete mode 100644 tv/2configs/xserver/xmonad/Util/Shutdown.hs delete mode 100644 tv/2configs/xserver/xmonad/Util/Submap.hs delete mode 100644 tv/2configs/xserver/xmonad/Util/XUtils.hs delete mode 100644 tv/2configs/xserver/xmonad/xmonad.cabal (limited to 'tv/2configs/xserver/xmonad') 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 - - setForeground d f_gc fg_color - setBackground d f_gc color_black -- TODO - - printStringCentered d f_pm xmf f_gc r tag - - setClipMask d f_gc clip_mask - - copyArea d f_pm p f_gc 0 0 s_width s_height 0 0 - - io $ copyArea d p (rs_window rs) g 0 0 s_width s_height 0 0 - io $ freePixmap d p - io $ freeGC d g - - -newRhombus :: RhombusConfig -> [String] -> X RhombusState -newRhombus rc tags = do - ss <- gets windowset - - let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss - (_, def_win_bg, _) = rc_colors rc False True False - - -- TODO this let is duplicated in redraw - let scale x = x * cell_w `div` s_width -- TODO use bw - cell_w = rc_cellwidth rc - cell_h = scale s_height - - -- TODO don't delete this let but use it instead of s_{width,height} - -- (xcoords, ycoords) = unzip $ take (length tags) wave -- this is reachableCoords - -- win_width = (maximum xcoords - minimum xcoords) * dx - -- win_height = (maximum ycoords - minimum ycoords) * dy - - -- 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 - - fn <- initXMF (rc_font rc) - win <- createNewWindow (Rectangle 0 0 s_width s_height) Nothing def_win_bg True - - withDisplay $ \ d -> - io $ shapeWindow d win $ \ p g -> - forZipWithM_ tags wave $ \ _ (ox, oy) -> - fillRectangle d p g (tx + ox * dx) (ty + oy * dy) (fi cell_w + 2) (fi cell_h + 2) - - return $ RhombusState win "" fn (0,0) tags - - -removeRhombus :: RhombusState -> X () -removeRhombus (RhombusState w _ fn _ _) = do - deleteWindow w - releaseXMF fn - -wave :: [(Position, Position)] -wave = zip (0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])) (concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..]) - where - wave1 = 0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..]) - wave2 = concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..] - -commonPrefix (x:xs) (y:ys) | x == y = x:commonPrefix xs ys -commonPrefix _ _ = [] - - -isXOf :: MatchMethod -> String -> String -> Bool -isXOf MatchInfix = isInfixOf -isXOf MatchPrefix = isPrefixOf - - -findXIndex :: (Eq a) => MatchMethod -> [a] -> [a] -> Maybe Int -findXIndex MatchInfix = findInfixIndex -findXIndex MatchPrefix = findPrefixIndex - - -findInfixIndex :: (Eq a) => [a] -> [a] -> Maybe Int -findInfixIndex needle haystack - = (\x -> if null x then Nothing else Just (fst $ head x)) - . dropWhile (\(_,x) -> not $ isPrefixOf needle x) - $ zip [0..] (tails haystack) - - -findPrefixIndex :: (Eq a) => [a] -> [a] -> Maybe Int -findPrefixIndex needle haystack = - if isPrefixOf needle haystack - then Just 0 - else Nothing - - -modIndex :: Integral i => [a] -> i -> a -modIndex xs i = xs `genericIndex` (i `mod` genericLength xs) - - -forZipWithM_ a b f = zipWithM_ f a b - - -withGrabbedKeyboard f = do - XConf { theRoot = root, display = d } <- ask - catchX (io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime) >> f) - (return ()) - io $ ungrabKeyboard d currentTime diff --git a/tv/2configs/xserver/xmonad/Util/Shutdown.hs b/tv/2configs/xserver/xmonad/Util/Shutdown.hs deleted file mode 100644 index 89e22b4e7..000000000 --- a/tv/2configs/xserver/xmonad/Util/Shutdown.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -module Util.Shutdown - ( sendShutdownEvent - , handleShutdownEvent - , shutdown - ) - where - -import Control.Monad -import Data.Monoid -import Data.Maybe (catMaybes) -import qualified Data.Map as Map -import System.Environment (getEnv) -import System.Exit (exitSuccess) -import XMonad -import qualified XMonad.StackSet as W - -sendShutdownEvent :: IO () -sendShutdownEvent = do - dpy <- openDisplay "" - rw <- rootWindow dpy $ defaultScreen dpy - a <- internAtom dpy "XMONAD_SHUTDOWN" False - allocaXEvent $ \e -> do - setEventType e clientMessage - setClientMessageEvent e rw a 32 0 currentTime - sendEvent dpy rw False structureNotifyMask e - sync dpy False - -handleShutdownEvent :: Event -> X All -handleShutdownEvent = \case - ClientMessageEvent { ev_message_type = mt } -> do - c <- (mt ==) <$> getAtom "XMONAD_SHUTDOWN" - when c shutdown - return (All c) - _ -> - return (All True) - -shutdown :: X () -shutdown = do - broadcastMessage ReleaseResources - io . flush =<< asks display - let wsData = show . W.mapLayout show . windowset - maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext) - maybeShow (t, Left str) = Just (t, str) - maybeShow _ = Nothing - extState = - return . show . catMaybes . map maybeShow . Map.toList . extensibleState - s <- gets (\s -> (wsData s : extState s)) - _ <- io $ do - path <- getEnv "XMONAD_STATE" - writeFile path (unlines s) - exitSuccess - return () diff --git a/tv/2configs/xserver/xmonad/Util/Submap.hs b/tv/2configs/xserver/xmonad/Util/Submap.hs deleted file mode 100644 index b09b97cc2..000000000 --- a/tv/2configs/xserver/xmonad/Util/Submap.hs +++ /dev/null @@ -1,31 +0,0 @@ --- This module is based on Jason Creighton's XMonad.Actions.Submap - -module Util.Submap - ( submapString - ) where - -import Data.Bits -import XMonad hiding (keys) -import qualified Data.Map as M -import Control.Monad.Fix (fix) - - --- | Like 'XMonad.Actions.Submap.submapDefault', but provides the looked up string to the default action. -submapString :: (String -> X ()) -> M.Map (KeyMask, KeySym) (X ()) -> X () -submapString def keys = do - XConf { theRoot = root, display = d } <- ask - - (m, s, str) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do - maskEvent d keyPressMask p - KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p - keysym <- keycodeToKeysym d code 0 - if isModifierKey keysym - then nextkey - else do - (mbKeysym, str) <- lookupString (asKeyEvent p) - return (m, keysym, str) - - -- Remove num lock mask and Xkb group state bits - m' <- cleanMask $ m .&. ((1 `shiftL` 12) - 1) - - maybe (def str) id (M.lookup (m', s) keys) diff --git a/tv/2configs/xserver/xmonad/Util/XUtils.hs b/tv/2configs/xserver/xmonad/Util/XUtils.hs deleted file mode 100644 index de1d8247c..000000000 --- a/tv/2configs/xserver/xmonad/Util/XUtils.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Util.XUtils - ( shapeWindow - , withGC - , withPixmap - , withPixmapAndGC - ) where - -import Control.Exception ( bracket ) -import Foreign.C.Types ( CInt ) -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xshape - - -shapeWindow :: Display -> Window -> (Pixmap -> GC -> IO ()) -> IO () -shapeWindow d w f = do - wa <- getWindowAttributes d w - - let width = fromIntegral $ wa_width wa - height = fromIntegral $ wa_height wa - - withPixmapAndGC d w width height 1 $ \ p g -> do - - setForeground d g 0 - fillRectangle d p g 0 0 width height - - setForeground d g 1 - - f p g - - xshapeCombineMask d w shapeBounding 0 0 p shapeSet - - -withGC :: Display -> Drawable -> (GC -> IO ()) -> IO () -withGC d p = - bracket (createGC d p) (freeGC d) - - -withPixmap :: Display -> Drawable -> Dimension -> Dimension -> CInt -> (Pixmap -> IO ()) -> IO () -withPixmap d p w h depth = - bracket (createPixmap d p w h depth) (freePixmap d) - - -withPixmapAndGC :: Display -> Drawable -> Dimension -> Dimension -> CInt -> (Pixmap -> GC -> IO ()) -> IO () -withPixmapAndGC d w width height depth f = - withPixmap d w width height depth $ \ p -> - withGC d p $ \ g -> f p g diff --git a/tv/2configs/xserver/xmonad/xmonad.cabal b/tv/2configs/xserver/xmonad/xmonad.cabal deleted file mode 100644 index cc72d3953..000000000 --- a/tv/2configs/xserver/xmonad/xmonad.cabal +++ /dev/null @@ -1,19 +0,0 @@ -Author: tv -Build-Type: Simple -Cabal-Version: >= 1.2 -License: MIT -Name: xmonad-tv -Version: 0 - -Executable xmonad - Build-Depends: - base, - containers, - filepath, - unix, - X11, - X11-xshape, - xmonad, - xmonad-contrib - GHC-Options: -Wall -O3 -threaded -rtsopts - Main-Is: Main.hs -- cgit v1.2.3