Mic92/stockholm
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

tv: nano really is just vim

Browse Source 
This is required or else we have to modify glorious packages like cvs.
This commit is contained in:
tv 2015-10-24 22:09:55 +02:00
parent a01651485b
commit b2deab26bd
10 changed files with 1059 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
tv/2configs/base.nix
View File

@ -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;

277
tv/2configs/xserver/xmonad-tv/Main.hs Normal file
View File

@ -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:

16
tv/2configs/xserver/xmonad-tv/Util/Debunk.hs Normal file
View File

@ -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

123
tv/2configs/xserver/xmonad-tv/Util/Font.hs Normal file
View File

@ -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

172
tv/2configs/xserver/xmonad-tv/Util/Pager.hs Normal file
View File

@ -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)

370
tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs Normal file
View File

@ -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

31
tv/2configs/xserver/xmonad-tv/Util/Submap.hs Normal file
View File

@ -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)

47
tv/2configs/xserver/xmonad-tv/Util/XUtils.hs Normal file
View File

@ -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

1
tv/2configs/xserver/xmonad-tv/default.nix Normal file
View File

@ -0,0 +1 @@
import ./xmonad-tv.nix

19
tv/2configs/xserver/xmonad-tv/xmonad-tv.cabal Normal file
View File

@ -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