From a01651485b21501df2f602c67381a1f5e9ce656b Mon Sep 17 00:00:00 2001 From: tv Date: Sat, 24 Oct 2015 21:15:54 +0200 Subject: tv: import ~/.Xresources --- tv/2configs/xserver/Xresources.nix | 214 +++++++++++++++++++++++++++++++++++++ 1 file changed, 214 insertions(+) create mode 100644 tv/2configs/xserver/Xresources.nix (limited to 'tv') diff --git a/tv/2configs/xserver/Xresources.nix b/tv/2configs/xserver/Xresources.nix new file mode 100644 index 000000000..f8414b861 --- /dev/null +++ b/tv/2configs/xserver/Xresources.nix @@ -0,0 +1,214 @@ +{ config, lib, pkgs, ... }: + +with lib; + +pkgs.writeText "Xresources" '' + !URxvt*background: #050505 + + ! 2013-02-25 \e was reas escape before + ! *VT100.Translations: #override\ + ! :: string("\e[5~")\n\ + ! :: string("\e[6~") + + ! XTerm*VT100*Translations: #override \ + ! ShiftReturn: string(" &") string(0x0A) \n\ + ! MetaReturn: string(" | less") string(0x0A) \n\ + ! ~ShiftPrior: scroll-back(1,page) \n\ + ! ~ShiftNext: scroll-forw(1,page) \n\ + ! ShiftPrior: scroll-back(1) \n\ + ! ShiftNext: scroll-forw(1) \n\ + ! Delete: string(0x1b) string("[2~") + ! \n\ + ! BackSpace: string(0x7f) + + ! 2013-02-2013-02-25 + ! ! : load bash-completion (if not already) + ! URxvt*VT100*Translations: #override\ + ! Metac:\ + ! string("\eOH# \eOF\n+compl\n\eOA\eOA\eOH\e[3~\e[3~\eOF")\ + ! string(0x7)\n + + ! do not scroll automatically on output: + ! XTerm*scrollTtyOutput: false + URxvt*cutchars: "\\`\"'&()*,;<=>?@[]^{|}‘’" + ! URxvt*secondaryScreen: false + + ! URxvt*loginShell: true + + URxvt*eightBitInput: false + ! *eightBitOutput: 1 + ! URxvt*decTerminalID: 220 + ! URxvt*utf8: 1 + ! URxvt*locale: UTF-8 + ! XTerm*customization: -color + URxvt*SaveLines: 4096 + URxvt*font: -*-clean-*-*-*-*-*-*-*-*-*-*-iso10646-1 + URxvt*boldFont: -*-clean-*-*-*-*-*-*-*-*-*-*-iso10646-1 + + ! 2013-05-23 if this does not work try + ! xset +fp /usr/share/fonts/local/ + ! xset fp rehash + ! URxvt*font: -*-termsynu-edium-*-*-*-12-*-*-*-*-*-iso10646-1 + ! URxvt*boldFont: -*-termsynu-bold-*-*-*-12-*-*-*-*-*-iso10646-1 + ! + !-misc-termsynu-medium-r-normal--12-87-100-100-c-70-iso10646-1 + + ! XTerm*font: -misc-fixed-medium-r-normal--13-120-75-75-c-80-iso10646-1 + URxvt*scrollBar: false + + ! XTerm*font:-nil-profont-medium-r-normal--11-110-72-72-c-60-iso8859-1 + ! URxvt*boldFont:-nil-profont-medium-r-normal--11-110-72-72-c-60-iso8859-1 + + URxvt*background: #050505 + ! URxvt*background: #041204 + + !URxvt.depth: 32 + !URxvt*background: rgba:0500/0500/0500/cccc + + ! URxvt*background: #080810 + URxvt*foreground: #d0d7d0 + ! URxvt*background: black + ! URxvt*foreground: white + ! URxvt*background: rgb:00/00/40 + ! URxvt*foreground: rgb:a0/a0/d0 + ! XTerm*cursorColor: rgb:00/00/60 + URxvt*cursorColor: #f042b0 + URxvt*cursorColor2: #f0b000 + URxvt*cursorBlink: off + ! URxvt*cursorUnderline: true + ! URxvt*highlightColor: #232323 + ! URxvt*highlightTextColor: #b0ffb0 + + URxvt*.pointerBlank: true + URxvt*.pointerBlankDelay: 987654321 + URxvt*.pointerColor: #f042b0 + URxvt*.pointerColor2: #050505 + + ! URxvt*fading: 50 + ! URxvt*fadeColor: #0f0f0f + + ! XTerm*colorMode: on + ! URxvt*dynamicColors: on + ! URxvt*boldColors: off + + URxvt*jumpScroll: true + + ! allow synthetic events for fvwm, so pass window specific keys + ! XTerm*allowSendEvents: true + URxvt*allowSendEvents: false + + ! better double/tripple clicking in xterms + ! Format: csv, [low-]high:value + ! + ! extend character class 48 due they are used in urls + ! (see: man xterm; /CHARACTER CLASSES) + ! ! % -./ @ & = ? + URxvt*charClass: 33:48,37:48,45-47:48,64:48,38:48,61:48,63:48 + URxvt*cutNewline: False + URxvt*cutToBeginningOfLine: False + + ! BLACK for indigo background + URxvt*color0: #232342 + + ! TODO: man xterm; /ACTIONS + + ! *VT100*colorULMode: on + ! XTerm*underLine: on + ! + ! URxvt*color0: black + ! URxvt*color1: red3 + ! URxvt*color2: green3 + ! URxvt*color3: yellow3 + ! URxvt*color4: blue2 + ! URxvt*color5: magenta3 + ! URxvt*color6: cyan3 + ! URxvt*color7: gray90 + ! URxvt*color8: burlywood1 + ! URxvt*color9: sienna1 + ! URxvt*color10: PaleVioletRed1 + ! URxvt*color11: LightSkyBlue + ! URxvt*color12: white + ! URxvt*color13: white + ! URxvt*color14: white + ! URxvt*color33: #f0b0f0 + + + ! URxvt*color0: #000000 + ! URxvt*color1: #c00000 + ! URxvt*color2: #80c070 + URxvt*color3: #c07000 + ! URxvt*color4: #0000c0 + URxvt*color4: #4040c0 + ! URxvt*color5: #c000c0 + ! URxvt*color6: #008080 + URxvt*color7: #c0c0c0 + + URxvt*color8: #707070 + URxvt*color9: #ff6060 + URxvt*color10: #70ff70 + URxvt*color11: #ffff70 + URxvt*color12: #7070ff + URxvt*color13: #ff50ff + URxvt*color14: #70ffff + URxvt*color15: #ffffff + + ! XTerm*color91: #000070 + ! XTerm*color92: #000080 + ! XTerm*color93: #000090 + ! XTerm*color94: #0000a0 + ! XTerm*color95: #0000b0 + ! XTerm*color96: #0000c0 + ! XTerm*color97: #0000d0 + ! XTerm*color98: #0000e0 + ! XTerm*color99: #0000f0 + + ! !! vim-create-colorscheme {{{ + ! !! Question cterm=none + ! XTerm*color20: #f0b000 + ! !! }}} + ! + ! + ! #include ".xrdb/look-zenburn.xrdb" + ! #include ".xrdb/xterm.xrdb" + + + + ! URxvt.perl-ext: matcher + ! URxvt.urlLauncher: cr + ! URxvt.underlineColor: blue + + ! URxvt.matcher.button: 1 + ! URxvt.perl-ext: default,matcher + ! URxvt.urlLauncher: cr + ! URxvt.matcher.pattern.1: \\bwww\\.[\\w-]+\\.[\\w./?&@#-]*[\\w/-] + ! URxvt.underlineColor: blue + + ! 2014-05-12 von lass + !URxvt.perl-ext-common: default,clipboard,url-select,keyboard-select + !URxvt.url-select.launcher: /home/tv/bin/ff -new-tab + !URxvt.url-select.underline: true + !URxvt.keysym.M-u: perl:url-select:select_next + !URxvt.keysym.M-Escape: perl:keyboard-select:activate + !URxvt.keysym.M-s: perl:keyboard-select:search + + + + + ! 2013-02-25 I neve use this + URxvt*iso14755: False + + URxvt*urgentOnBell: True + URxvt*visualBell: True + + ! ref https://github.com/muennich/urxvt-perls + URxvt*perl-ext: default,url-select + URxvt*keysym.M-u: perl:url-select:select_next + !URxvt*url-select.launcher: /home/tv/free/firefox -new-tab + ! 2014-05-12 nix: + !URxvt.url-select.launcher: /home/tv/bin/ff -new-tab + ! 2015-07-26 stockholm: + URxvt*url-select.launcher: ff -new-tab + URxvt*url-select.underline: true + URxvt*colorUL: #4682B4 + URxvt.perl-lib: ${pkgs.urxvt_perls}/lib/urxvt/perl +'' -- cgit v1.2.3 From b2deab26bd52a994003cafc33872b6c084cdd716 Mon Sep 17 00:00:00 2001 From: tv Date: Sat, 24 Oct 2015 22:09:55 +0200 Subject: tv: nano really is just vim This is required or else we have to modify glorious packages like cvs. --- tv/2configs/base.nix | 7 +- tv/2configs/xserver/xmonad-tv/Main.hs | 277 +++++++++++++++++++ tv/2configs/xserver/xmonad-tv/Util/Debunk.hs | 16 ++ tv/2configs/xserver/xmonad-tv/Util/Font.hs | 123 +++++++++ tv/2configs/xserver/xmonad-tv/Util/Pager.hs | 172 ++++++++++++ tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs | 370 ++++++++++++++++++++++++++ tv/2configs/xserver/xmonad-tv/Util/Submap.hs | 31 +++ tv/2configs/xserver/xmonad-tv/Util/XUtils.hs | 47 ++++ tv/2configs/xserver/xmonad-tv/default.nix | 1 + tv/2configs/xserver/xmonad-tv/xmonad-tv.cabal | 19 ++ 10 files changed, 1059 insertions(+), 4 deletions(-) create mode 100644 tv/2configs/xserver/xmonad-tv/Main.hs create mode 100644 tv/2configs/xserver/xmonad-tv/Util/Debunk.hs create mode 100644 tv/2configs/xserver/xmonad-tv/Util/Font.hs create mode 100644 tv/2configs/xserver/xmonad-tv/Util/Pager.hs create mode 100644 tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs create mode 100644 tv/2configs/xserver/xmonad-tv/Util/Submap.hs create mode 100644 tv/2configs/xserver/xmonad-tv/Util/XUtils.hs create mode 100644 tv/2configs/xserver/xmonad-tv/default.nix create mode 100644 tv/2configs/xserver/xmonad-tv/xmonad-tv.cabal (limited to 'tv') diff --git a/tv/2configs/base.nix b/tv/2configs/base.nix index 4de980cf1..0a8dbdcc2 100644 --- a/tv/2configs/base.nix +++ b/tv/2configs/base.nix @@ -153,10 +153,9 @@ in } { - nixpkgs.config.packageOverrides = pkgs: - { - nano = pkgs.runCommand "empty" {} "mkdir -p $out"; - }; + nixpkgs.config.packageOverrides = pkgs: { + nano = pkgs.vim; + }; services.cron.enable = false; services.nscd.enable = false; diff --git a/tv/2configs/xserver/xmonad-tv/Main.hs b/tv/2configs/xserver/xmonad-tv/Main.hs new file mode 100644 index 000000000..a298d72e7 --- /dev/null +++ b/tv/2configs/xserver/xmonad-tv/Main.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE DeriveDataTypeable #-} -- for XS + + +module Main where + +import XMonad +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.Debunk + + +--data MyState = MyState deriving Typeable + +myTerm :: String +myTerm = "urxvtc" + +myRootTerm :: String +myRootTerm = "XENVIRONMENT=\"$HOME/.Xdefaults/root-urxvt\" urxvtc -e su -" + +-- TODO execRootTerm = exec (shlex "urxvtc -e su -") +-- [ ("XENVIRONMENT", HOME ++ "/.Xdefaults/root-urxvt") ] + + +myFont :: String +myFont = "-schumacher-*-*-*-*-*-*-*-*-*-*-*-iso10646-*" + +main :: IO () +main = do + -- TODO exec (shlex "xrdb -merge" ++ [HOME ++ "/.Xresources"]) + -- TODO exec (shlex "xsetroot -solid '#1c1c1c'") + --spawn "xrdb -merge \"$HOME/.Xresources\"" + --spawn "xsetroot -solid '#1c1c1c'" + 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 = + [ "Dashboard" -- we start here + , "23" + , "cr" + , "ff" + , "hack" + , "im" + , "mail" + , "zalora", "zjournal", "zskype" + ] + , layoutHook = smartBorders $ myLayout + -- , handleEventHook = myHandleEventHooks <+> handleTimerEvent + --, handleEventHook = handleTimerEvent + , manageHook = placeHook (smart (1,0)) <+> floatNextHook + , startupHook = spawn "echo emit XMonadStartup" + , normalBorderColor = "#1c1c1c" + , focusedBorderColor = "#f000b0" + } + where + myLayout = + (onWorkspace "im" $ reflectVert $ Mirror $ Tall 1 (3/100) (12/13)) + (FixedColumn 1 20 80 10 ||| Full) + + +spawnTermAt :: String -> X () +--spawnTermAt _ = floatNext True >> spawn myTerm +--spawnTermAt "ff" = floatNext True >> spawn myTerm +spawnTermAt _ = spawn myTerm + + + +--jojo w = withDisplay $ \d -> liftIO $ do +-- wa <- getWindowAttributes d w +-- printToErrors (wa_width wa, wa_height wa, wa_x wa, wa_y wa) + + --sh <- getWMNormalHints d w + --bw <- fmap (fi . wa_border_width) $ getWindowAttributes d w + --return $ applySizeHints bw sh + + +--data WindowDetails = WindowDetails +-- { wd_name :: Maybe String +-- , wd_rect :: Rectangle +-- } deriving (Show) + +-- urxvtc +-- -title sets {,_NET_}WM_NAME but not WM_CLASS and {,_NET_}WM_ICON_NAME res: title +-- -name sets all res: +--mySpawn cmd = do +-- p <- xfork $ executeFile "/run/current-system/sw/bin/urxvtc" False [] Nothing +-- liftIO $ printToErrors $ (cmd, p) + + +myKeys :: XConfig Layout -> Map (KeyMask, KeySym) (X ()) +myKeys conf = Map.fromList $ + [ ((_4C , xK_Delete ), spawn "make -C $HOME/.xmonad reload") + , ((_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 . printToErrors) ["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] + +-- vim:set fdm=marker: diff --git a/tv/2configs/xserver/xmonad-tv/Util/Debunk.hs b/tv/2configs/xserver/xmonad-tv/Util/Debunk.hs new file mode 100644 index 000000000..b4772e582 --- /dev/null +++ b/tv/2configs/xserver/xmonad-tv/Util/Debunk.hs @@ -0,0 +1,16 @@ +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-tv/Util/Font.hs b/tv/2configs/xserver/xmonad-tv/Util/Font.hs new file mode 100644 index 000000000..5352cf5ad --- /dev/null +++ b/tv/2configs/xserver/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/2configs/xserver/xmonad-tv/Util/Pager.hs b/tv/2configs/xserver/xmonad-tv/Util/Pager.hs new file mode 100644 index 000000000..b8168b5b0 --- /dev/null +++ b/tv/2configs/xserver/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/2configs/xserver/xmonad-tv/Util/Rhombus.hs b/tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs new file mode 100644 index 000000000..5f43cb28a --- /dev/null +++ b/tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs @@ -0,0 +1,370 @@ +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.Debunk +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-tv/Util/Submap.hs b/tv/2configs/xserver/xmonad-tv/Util/Submap.hs new file mode 100644 index 000000000..b09b97cc2 --- /dev/null +++ b/tv/2configs/xserver/xmonad-tv/Util/Submap.hs @@ -0,0 +1,31 @@ +-- 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-tv/Util/XUtils.hs b/tv/2configs/xserver/xmonad-tv/Util/XUtils.hs new file mode 100644 index 000000000..de1d8247c --- /dev/null +++ b/tv/2configs/xserver/xmonad-tv/Util/XUtils.hs @@ -0,0 +1,47 @@ +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-tv/default.nix b/tv/2configs/xserver/xmonad-tv/default.nix new file mode 100644 index 000000000..f0cb8e08d --- /dev/null +++ b/tv/2configs/xserver/xmonad-tv/default.nix @@ -0,0 +1 @@ +import ./xmonad-tv.nix diff --git a/tv/2configs/xserver/xmonad-tv/xmonad-tv.cabal b/tv/2configs/xserver/xmonad-tv/xmonad-tv.cabal new file mode 100644 index 000000000..72494abe1 --- /dev/null +++ b/tv/2configs/xserver/xmonad-tv/xmonad-tv.cabal @@ -0,0 +1,19 @@ +Author: tv +Build-Type: Simple +Cabal-Version: >= 1.2 +License: MIT +Name: xmonad-tv +Version: 0 + +Executable xmonad + Build-Depends: + base, + containers, + filepath, + scanner, + X11, + X11-xshape, + xmonad, + xmonad-contrib + GHC-Options: -Wall -O3 -threaded -rtsopts + Main-Is: Main.hs -- cgit v1.2.3 From 0306ec4294f6d825ca65c7b0c98a80a3bced8fdf Mon Sep 17 00:00:00 2001 From: tv Date: Sat, 24 Oct 2015 22:31:10 +0200 Subject: tv: lol display-manager --- tv/1systems/wu.nix | 3 +- tv/2configs/synaptics.nix | 14 - tv/2configs/urlwatch.nix | 4 + tv/2configs/xserver.nix | 41 --- tv/2configs/xserver/default.nix | 126 +++++++++ tv/2configs/xserver/xmonad-tv/Main.hs | 277 ------------------- tv/2configs/xserver/xmonad-tv/Util/Debunk.hs | 16 -- tv/2configs/xserver/xmonad-tv/Util/Font.hs | 123 --------- tv/2configs/xserver/xmonad-tv/Util/Pager.hs | 172 ------------ tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs | 370 -------------------------- tv/2configs/xserver/xmonad-tv/Util/Submap.hs | 31 --- tv/2configs/xserver/xmonad-tv/Util/XUtils.hs | 47 ---- tv/2configs/xserver/xmonad-tv/default.nix | 1 - tv/2configs/xserver/xmonad-tv/xmonad-tv.cabal | 19 -- tv/2configs/xserver/xmonad/Main.hs | 277 +++++++++++++++++++ tv/2configs/xserver/xmonad/Util/Debunk.hs | 16 ++ tv/2configs/xserver/xmonad/Util/Font.hs | 123 +++++++++ tv/2configs/xserver/xmonad/Util/Pager.hs | 172 ++++++++++++ tv/2configs/xserver/xmonad/Util/Rhombus.hs | 370 ++++++++++++++++++++++++++ tv/2configs/xserver/xmonad/Util/Submap.hs | 31 +++ tv/2configs/xserver/xmonad/Util/XUtils.hs | 47 ++++ tv/2configs/xserver/xmonad/xmonad.cabal | 18 ++ tv/2configs/xserver/xserver.conf.nix | 40 +++ 23 files changed, 1225 insertions(+), 1113 deletions(-) delete mode 100644 tv/2configs/synaptics.nix delete mode 100644 tv/2configs/xserver.nix create mode 100644 tv/2configs/xserver/default.nix delete mode 100644 tv/2configs/xserver/xmonad-tv/Main.hs delete mode 100644 tv/2configs/xserver/xmonad-tv/Util/Debunk.hs delete mode 100644 tv/2configs/xserver/xmonad-tv/Util/Font.hs delete mode 100644 tv/2configs/xserver/xmonad-tv/Util/Pager.hs delete mode 100644 tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs delete mode 100644 tv/2configs/xserver/xmonad-tv/Util/Submap.hs delete mode 100644 tv/2configs/xserver/xmonad-tv/Util/XUtils.hs delete mode 100644 tv/2configs/xserver/xmonad-tv/default.nix delete mode 100644 tv/2configs/xserver/xmonad-tv/xmonad-tv.cabal create mode 100644 tv/2configs/xserver/xmonad/Main.hs create mode 100644 tv/2configs/xserver/xmonad/Util/Debunk.hs create mode 100644 tv/2configs/xserver/xmonad/Util/Font.hs create mode 100644 tv/2configs/xserver/xmonad/Util/Pager.hs create mode 100644 tv/2configs/xserver/xmonad/Util/Rhombus.hs create mode 100644 tv/2configs/xserver/xmonad/Util/Submap.hs create mode 100644 tv/2configs/xserver/xmonad/Util/XUtils.hs create mode 100644 tv/2configs/xserver/xmonad/xmonad.cabal create mode 100644 tv/2configs/xserver/xserver.conf.nix (limited to 'tv') diff --git a/tv/1systems/wu.nix b/tv/1systems/wu.nix index 89ad257f0..987748de0 100644 --- a/tv/1systems/wu.nix +++ b/tv/1systems/wu.nix @@ -29,8 +29,7 @@ with lib; #../2configs/consul-client.nix ../2configs/git.nix ../2configs/mail-client.nix - ../2configs/xserver.nix - ../2configs/synaptics.nix # TODO w110er if xserver is enabled + ../2configs/xserver ../2configs/test.nix { environment.systemPackages = with pkgs; [ diff --git a/tv/2configs/synaptics.nix b/tv/2configs/synaptics.nix deleted file mode 100644 index c47cb9deb..000000000 --- a/tv/2configs/synaptics.nix +++ /dev/null @@ -1,14 +0,0 @@ -{ config, pkgs, ... }: - -{ - # TODO this is host specific - services.xserver.synaptics = { - enable = true; - twoFingerScroll = true; - accelFactor = "0.035"; - additionalOptions = '' - Option "FingerHigh" "60" - Option "FingerLow" "60" - ''; - }; -} diff --git a/tv/2configs/urlwatch.nix b/tv/2configs/urlwatch.nix index 373803cc6..8189f6345 100644 --- a/tv/2configs/urlwatch.nix +++ b/tv/2configs/urlwatch.nix @@ -47,6 +47,10 @@ # ref , services.openssh.knownHosts.github* https://help.github.com/articles/what-ip-addresses-does-github-use-that-i-should-whitelist/ + + # + # is derived from `configFile` in: + https://raw.githubusercontent.com/NixOS/nixpkgs/master/nixos/modules/services/x11/xserver.nix ]; }; } diff --git a/tv/2configs/xserver.nix b/tv/2configs/xserver.nix deleted file mode 100644 index 7fc07f927..000000000 --- a/tv/2configs/xserver.nix +++ /dev/null @@ -1,41 +0,0 @@ -{ config, pkgs, ... }: - -{ - imports = [ - ../2configs/urxvt.nix # TODO via xserver - ]; - - services.xserver.enable = true; - - - #fonts.enableFontConfig = true; - #fonts.enableFontDir = true; - fonts.fonts = [ - pkgs.xlibs.fontschumachermisc - ]; - #services.xfs.enable = true; - #services.xserver.useXFS = "unix/:7100"; - - services.xserver.displayManager.desktopManagerHandlesLidAndPower = true; - - #services.xserver.display = 11; - #services.xserver.tty = 11; - # services.xserver.layout = "us"; - # services.xserver.xkbOptions = "eurosign:e"; - - #services.xserver.multitouch.enable = true; - - services.xserver.windowManager.xmonad.extraPackages = hspkgs: with hspkgs; [ - X11-xshape - ]; - services.xserver.windowManager.xmonad.enable = true; - services.xserver.windowManager.xmonad.enableContribAndExtras = true; - services.xserver.windowManager.default = "xmonad"; - services.xserver.desktopManager.default = "none"; - services.xserver.desktopManager.xterm.enable = false; - - services.xserver.displayManager.slim.enable = true; - #services.xserver.displayManager.auto.enable = true; - #services.xserver.displayManager.auto.user = "tv"; - #services.xserver.displayManager.job.logsXsession = true; -} diff --git a/tv/2configs/xserver/default.nix b/tv/2configs/xserver/default.nix new file mode 100644 index 000000000..b590fbd64 --- /dev/null +++ b/tv/2configs/xserver/default.nix @@ -0,0 +1,126 @@ +{ config, lib, pkgs, ... }@args: + +with lib; + +let + # TODO krebs.build.user + user = config.users.users.tv; + + out = { + services.xserver.display = 11; + services.xserver.tty = 11; + + services.xserver.synaptics = { + enable = true; + twoFingerScroll = true; + accelFactor = "0.035"; + }; + + fonts.fonts = [ + pkgs.xlibs.fontschumachermisc + ]; + + systemd.services.urxvtd = { + wantedBy = [ "multi-user.target" ]; + reloadIfChanged = true; + serviceConfig = { + ExecReload = need-reload "urxvtd.service"; + ExecStart = "${pkgs.rxvt_unicode}/bin/urxvtd"; + Restart = "always"; + RestartSec = "2s"; + StartLimitBurst = 0; + User = user.name; + }; + }; + + environment.systemPackages = [ + pkgs.slock + ]; + + security.setuidPrograms = [ + "slock" + ]; + + systemd.services.display-manager = mkForce {}; + + services.xserver.enable = true; + systemd.services.xmonad = { + wantedBy = [ "multi-user.target" ]; + requires = [ "xserver.service" ]; + serviceConfig = { + ExecStart = "${xmonad}/bin/xmonad"; + User = user.name; + WorkingDirectory = user.home; + }; + }; + + systemd.services.xserver = { + after = [ + "systemd-udev-settle.service" + "local-fs.target" + "acpid.service" + ]; + reloadIfChanged = true; + environment = xserver-environment; + serviceConfig = { + ExecReload = need-reload "xserver.service"; + ExecStart = "${xserver}/bin/xserver"; + }; + }; + }; + + xmonad = let + pkg = pkgs.haskellPackages.callPackage src {}; + src = pkgs.runCommand "xmonad-package" {} '' + ${pkgs.cabal2nix}/bin/cabal2nix ${./xmonad} > $out + ''; + in pkgs.writeScriptBin "xmonad" '' + #! /bin/sh + set -efu + export DISPLAY; DISPLAY=:${toString config.services.xserver.display} + export PATH; PATH=${makeSearchPath "bin" [ + pkgs.rxvt_unicode + ]} + settle() {( + # Use PATH for a clean journal + command=''${1##*/} + PATH=''${1%/*}; export PATH + shift + until "$command" "$@"; do + ${pkgs.coreutils}/bin/sleep 1 + done + )&} + 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 ${pkg}/bin/xmonad + ''; + + xserver-environment = { + XKB_BINDIR = "${pkgs.xorg.xkbcomp}/bin"; # Needed for the Xkb extension. + XORG_DRI_DRIVER_PATH = "/run/opengl-driver/lib/dri"; # !!! Depends on the driver selected at runtime. + LD_LIBRARY_PATH = concatStringsSep ":" ( + [ "${pkgs.xorg.libX11}/lib" "${pkgs.xorg.libXext}/lib" ] + ++ concatLists (catAttrs "libPath" config.services.xserver.drivers)); + }; + + xserver = pkgs.writeScriptBin "xserver" '' + #! /bin/sh + set -efu + exec ${pkgs.xorg.xorgserver}/bin/X \ + :${toString config.services.xserver.display} \ + vt${toString config.services.xserver.tty} \ + -config ${import ./xserver.conf.nix args} \ + -logfile /var/log/X.${toString config.services.xserver.display}.log \ + -nolisten tcp \ + -xkbdir ${pkgs.xkeyboard_config}/etc/X11/xkb \ + ''; + + need-reload = s: let + pkg = pkgs.writeScriptBin "need-reload" '' + #! /bin/sh + echo "$*" + ''; + in "${pkg}/bin/need-reload ${s}"; + +in out diff --git a/tv/2configs/xserver/xmonad-tv/Main.hs b/tv/2configs/xserver/xmonad-tv/Main.hs deleted file mode 100644 index a298d72e7..000000000 --- a/tv/2configs/xserver/xmonad-tv/Main.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -- for XS - - -module Main where - -import XMonad -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.Debunk - - ---data MyState = MyState deriving Typeable - -myTerm :: String -myTerm = "urxvtc" - -myRootTerm :: String -myRootTerm = "XENVIRONMENT=\"$HOME/.Xdefaults/root-urxvt\" urxvtc -e su -" - --- TODO execRootTerm = exec (shlex "urxvtc -e su -") --- [ ("XENVIRONMENT", HOME ++ "/.Xdefaults/root-urxvt") ] - - -myFont :: String -myFont = "-schumacher-*-*-*-*-*-*-*-*-*-*-*-iso10646-*" - -main :: IO () -main = do - -- TODO exec (shlex "xrdb -merge" ++ [HOME ++ "/.Xresources"]) - -- TODO exec (shlex "xsetroot -solid '#1c1c1c'") - --spawn "xrdb -merge \"$HOME/.Xresources\"" - --spawn "xsetroot -solid '#1c1c1c'" - 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 = - [ "Dashboard" -- we start here - , "23" - , "cr" - , "ff" - , "hack" - , "im" - , "mail" - , "zalora", "zjournal", "zskype" - ] - , layoutHook = smartBorders $ myLayout - -- , handleEventHook = myHandleEventHooks <+> handleTimerEvent - --, handleEventHook = handleTimerEvent - , manageHook = placeHook (smart (1,0)) <+> floatNextHook - , startupHook = spawn "echo emit XMonadStartup" - , normalBorderColor = "#1c1c1c" - , focusedBorderColor = "#f000b0" - } - where - myLayout = - (onWorkspace "im" $ reflectVert $ Mirror $ Tall 1 (3/100) (12/13)) - (FixedColumn 1 20 80 10 ||| Full) - - -spawnTermAt :: String -> X () ---spawnTermAt _ = floatNext True >> spawn myTerm ---spawnTermAt "ff" = floatNext True >> spawn myTerm -spawnTermAt _ = spawn myTerm - - - ---jojo w = withDisplay $ \d -> liftIO $ do --- wa <- getWindowAttributes d w --- printToErrors (wa_width wa, wa_height wa, wa_x wa, wa_y wa) - - --sh <- getWMNormalHints d w - --bw <- fmap (fi . wa_border_width) $ getWindowAttributes d w - --return $ applySizeHints bw sh - - ---data WindowDetails = WindowDetails --- { wd_name :: Maybe String --- , wd_rect :: Rectangle --- } deriving (Show) - --- urxvtc --- -title sets {,_NET_}WM_NAME but not WM_CLASS and {,_NET_}WM_ICON_NAME res: title --- -name sets all res: ---mySpawn cmd = do --- p <- xfork $ executeFile "/run/current-system/sw/bin/urxvtc" False [] Nothing --- liftIO $ printToErrors $ (cmd, p) - - -myKeys :: XConfig Layout -> Map (KeyMask, KeySym) (X ()) -myKeys conf = Map.fromList $ - [ ((_4C , xK_Delete ), spawn "make -C $HOME/.xmonad reload") - , ((_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 . printToErrors) ["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 ), send