Merge branch 'v017' of git.josher.dev:rde into v017

5 files changed, 254 insertions, 16 deletions

diff --git a/package.yaml b/package.yaml
index b07f2df..7cfb52c 100644
--- a/package.yaml
+++ b/package.yaml
@@ -22,3 +22,4 @@ dependencies:
   - mtl
   - transformers
   - monad-loops
+  - data-default
diff --git a/src/Internal/Intercept.hs b/src/Internal/Intercept.hs
new file mode 100644
index 0000000..c99ce09
--- /dev/null
+++ b/src/Internal/Intercept.hs
@@ -0,0 +1,152 @@
+
+-- Module for intercepting key presses not explicity mapped in the key bindings.
+-- This uses some deep magic with grabKey and windows and everything else, but
+-- it makes window-specific key bindings awesome!
+module Internal.Intercept where
+
+import XMonad
+
+import Text.Printf
+import Data.Monoid (Endo(..))
+import Control.Monad.Trans.Class (lift)
+import Control.Monad (forM, forM_)
+import Data.Default (Default, def)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified XMonad.Util.ExtensibleState as XS
+import Data.Monoid (All(..))
+
+import Internal.Logger
+
+type WindowHook = Query ()
+
+newtype NoPersist a = NoPersist a
+  deriving (Typeable)
+
+instance Show (NoPersist a) where
+  show (NoPersist _) = show ()
+
+instance (Default a) => Read (NoPersist a) where
+  readsPrec i s = map (\(_, s) -> (NoPersist def, s)) (readsPrec i s :: [((), String)])
+
+instance (Default a) => Default (NoPersist a) where
+  def = NoPersist def
+
+instance (Default a, Typeable a) => ExtensionClass (NoPersist a) where
+  initialValue = NoPersist def
+
+
+data InterceptState = InterceptState (NoPersist (Map (KeyMask, KeySym) (X ())))
+
+data RemapState = RemapState (NoPersist (Map (Window, (KeyMask, KeySym)) (X ())))
+
+instance ExtensionClass InterceptState where
+  initialValue = InterceptState def
+
+instance ExtensionClass RemapState where
+  initialValue = RemapState def
+
+remapHook :: Event -> X All
+remapHook event = do
+  RemapState (NoPersist map) <- XS.get
+
+  case event of
+    KeyEvent { ev_window = win, ev_event_type = typ, ev_keycode = code, ev_state = m }
+        | typ == keyPress-> do
+      XConf {display = dpy, theRoot = rootw} <- ask
+      keysym <- io $ keycodeToKeysym dpy code 0
+
+      case Map.lookup (win, (m, keysym)) map of
+
+        Just xdo -> do
+          xdo
+          return (All False)
+
+        Nothing -> return (All True)
+
+    _ -> return (All True)
+
+interceptHook :: Event -> X All
+interceptHook event = do
+  InterceptState (NoPersist map) <- XS.get
+  case event of
+    KeyEvent { ev_event_type = typ, ev_keycode = code, ev_state = m }
+        | typ == keyPress-> do
+      XConf {display = dpy, theRoot = rootw} <- ask
+      keysym <- io $ keycodeToKeysym dpy code 0
+
+      case Map.lookup (m, keysym) map of
+
+        Just xdo -> do
+          xdo
+          mapM_ (\m' -> io $ ungrabKey dpy code (m .|. m') rootw)
+              =<< extraModifiers
+          return (All False)
+
+        Nothing -> return (All True)
+
+    _ -> return (All True)
+
+setIntercept :: (KeyMask, KeySym) -> X () -> X ()
+setIntercept (keyMask, keysym) action = do
+  XS.modify $ \(InterceptState (NoPersist m)) -> InterceptState $ NoPersist $
+    Map.insert (keyMask, keysym) action m
+  XConf { display = dpy, theRoot = rootw } <- ask
+
+  doGrab dpy rootw (keyMask, keysym)
+
+
+getKeyCodesForKeysym :: Display -> KeySym -> IO [KeyCode]
+getKeyCodesForKeysym dpy keysym = do
+  let (minCode, maxCode) = displayKeycodes dpy
+      allCodes = [fromIntegral minCode .. fromIntegral maxCode]
+
+  syms <- forM allCodes $ \code -> keycodeToKeysym dpy code 0
+  let keysymMap' = Map.fromListWith (++) (zip syms [[code] | code <- allCodes])
+
+  -- keycodeToKeysym returns noSymbol for all unbound keycodes, and we don't
+  -- want to grab those whenever someone accidentally uses def :: KeySym
+  let keysymMap = Map.delete noSymbol keysymMap'
+  let keysymToKeycodes sym = Map.findWithDefault [] keysym keysymMap
+
+  return $ keysymToKeycodes keysym
+
+
+doGrab :: Display -> Window -> (KeyMask, KeySym) -> X ()
+doGrab dpy win (keyMask, keysym) = do
+  let grab kc m = io $ grabKey dpy kc m win True grabModeAsync grabModeAsync
+
+  codes <- io $ getKeyCodesForKeysym dpy keysym
+
+  forM_ codes $ \kc ->
+    mapM_ (grab kc . (keyMask .|.)) =<< extraModifiers
+
+disableKey :: (KeyMask, KeySym) -> WindowHook
+disableKey key = remapKey key (return ())
+
+remapKey :: (KeyMask, KeySym) -> X () -> WindowHook
+remapKey keyFrom action = do
+  window <- ask
+  Query $ lift $ do
+    XConf { display = disp, theRoot = rootw } <- ask
+    doGrab disp window keyFrom
+
+    XS.modify $ \(RemapState (NoPersist keyMap)) -> RemapState $ NoPersist $
+      Map.insert (window, keyFrom) action keyMap
+
+rebindKey :: (KeyMask, KeySym) -> (KeyMask, KeySym) -> WindowHook
+rebindKey keyFrom keyTo = do
+  window <- ask
+  remapKey keyFrom $ do
+    XConf { display = disp, theRoot = rootw } <- ask
+    codes <- io $ getKeyCodesForKeysym disp (snd keyTo)
+    case codes of
+      (keyCode:_) -> do
+        io $ allocaXEvent $ \xEv -> do
+          setEventType xEv keyPress
+          setKeyEvent xEv window rootw none (fst keyTo) keyCode True
+          sendEvent disp window True keyPressMask xEv
+          setEventType xEv keyRelease
+          sendEvent disp window True keyPressMask xEv
+
+      _ -> return ()
diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index 58d2ecb..ed10952 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE RankNTypes #-}
 module Internal.Keys (applyKeys) where
 
+import Internal.Intercept (setIntercept)
 import Control.Monad.Loops (iterateWhile)
 import Control.Monad.Fix (fix)
 import Graphics.X11.ExtraTypes.XF86;
@@ -45,6 +46,7 @@ import Internal.Lib
 import Internal.DMenu
 import Internal.PassMenu
 import Internal.Logger
+import Internal.ScreenRotate (screenRotateForward, screenRotateBackward)
 
 type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ())
 type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ())
@@ -245,6 +247,12 @@ keymap = runKeys $ do
             then mediaPrev
             else mediaNext
 
+      bind xK_t $
+
+        (justMod -|- noMod) $
+          setIntercept (modMask config, xK_i) $
+            logs $ "Intercepted!"
+ 
   bind xK_r $ do
     justMod runDMenu
     shiftMod $ sendMessage DoRotate
@@ -385,6 +393,17 @@ mouseMap = runButtons $ do
           Map.lookup button (mouseMap config)
       subMouse = submapButtonsWithKey defaultButtons . flip runButtons config
 
+
+  let continuous :: [(Button, X ())] -> Button -> Window -> X ()
+      continuous actions button w = do
+        case find ((==button) . fst) actions of
+          Just (_, action) -> action
+          Nothing -> return ()
+
+        (subMouse $
+          forM_ (map fst actions) $ \b ->
+            bind b $ noMod $ \w -> continuous actions b w) w
+
   bind button1 $ do
     justMod $ \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster
 
@@ -415,6 +434,9 @@ mouseMap = runButtons $ do
       bind button14 $ do
         noMod $ \_ -> click >> sendMessage ToggleZoom
 
+      bind button15 $ do
+        noMod $ \_ -> spawn "pavucontrol"
+
       let mediaButtons = [
             (button4, increaseVolume),
             (button5, decreaseVolume),
@@ -425,19 +447,32 @@ mouseMap = runButtons $ do
             (button7, mediaNext)
             ]
 
+      forM_ (map fst mediaButtons) $ \b ->
+        bind b $ noMod $ continuous mediaButtons b
 
-      let continuous :: [(Button, X ())] -> Button -> Window -> X ()
-          continuous actions button w = do
-            case find ((==button) . fst) actions of
-              Just (_, action) -> action
-              Nothing -> return ()
+  bind button15 $ do
 
-            (subMouse $
-              forM_ (map fst mediaButtons) $ \b ->
-                bind b $ noMod $ \w -> continuous actions b w) w
+    noMod $ subMouse $ do
+      
+      bind button15 $ do
+        noMod $ \_ -> jumpToLast
 
-      forM_ (map fst mediaButtons) $ \b ->
-        bind b $ noMod $ continuous mediaButtons b
+
+      let workspaceButtons = [
+            (button2, swapMaster),
+
+            (button9, relativeWorkspaceShift next),
+            (button8, relativeWorkspaceShift prev),
+
+            (button4, windows W.focusUp),
+            (button5, windows W.focusDown),
+
+            (button7, windows screenRotateForward),
+            (button6, windows screenRotateBackward)
+            ]
+
+      forM_ (map fst workspaceButtons) $ \b ->
+        bind b $ noMod $ continuous workspaceButtons b
 
 applyKeys :: XConfig l -> IO (XConfig l)
 applyKeys config =
@@ -451,4 +486,7 @@ click = do
 
 modifyWindowBorder :: Integer -> SpacingModifier
 modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) ->
-  Border (a + i) (b + i) (c + i) (d + i)
+  Border (clip $ a + i) (clip $ b + i) (clip $ c + i) (clip $ d + i)
+
+  where clip i | i < 0 = 0
+        clip i | otherwise = i
diff --git a/src/Internal/ScreenRotate.hs b/src/Internal/ScreenRotate.hs
new file mode 100644
index 0000000..ff6417c
--- /dev/null
+++ b/src/Internal/ScreenRotate.hs
@@ -0,0 +1,19 @@
+module Internal.ScreenRotate where
+
+import XMonad.StackSet as W
+
+screenRotateForward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd
+screenRotateForward (W.StackSet current visible others floating) = do
+  let screens = current : visible
+      workspaces = tail $ cycle $ map W.workspace screens
+      (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces
+      in W.StackSet current' visible' others floating
+
+screenRotateBackward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd
+screenRotateBackward (W.StackSet current visible others floating) = do
+  let screens = current : visible
+      workspaces = rcycle $ map W.workspace screens
+      (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces
+      in W.StackSet current' visible' others floating
+
+  where rcycle l = last l : l
diff --git a/src/Main.hs b/src/Main.hs
index cda3ae2..19050ab 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,6 +1,7 @@
 import XMonad
 
 import Control.Monad.Trans.Class
+import Control.Monad.Reader
 import XMonad.Hooks.ManageDocks (docks)
 import System.Directory (getHomeDirectory)
 import System.FilePath ((</>))
@@ -15,10 +16,13 @@ import Internal.Keys
 import Internal.Layout
 import Internal.Logger
 import Internal.DMenu (menuCommandString)
+import Internal.Intercept
+import XMonad.Actions.WithAll (withAll)
 
 import qualified XMonad as X
 import qualified XMonad.StackSet as W
 
+
 main = do
 
   -- Execute some commands.
@@ -31,7 +35,17 @@ main = do
   xmobar <- spawnXMobar
 
   (=<<) X.xmonad $
-    applyKeys $ ewmh $ docks $ def
+    applyKeys $ ewmh $ docks $ windowHooks (composeAll [
+           className =? "Google-chrome" --> composeAll [
+             -- The geniuses that made chrome decided that Ctrl+W should kill
+             -- the current tab! This makes it consistent with the rest of the
+             -- world ... ctrl+w deletes the last word (ctrl+backspace).
+             rebindKey (controlMask, xK_w) (controlMask, xK_BackSpace)
+           , rebindKey (controlMask, xK_h) (0, xK_BackSpace)
+           , rebindKey (controlMask, xK_u) (controlMask .|. shiftMask, xK_BackSpace)
+           , rebindKey (controlMask, xK_b) (controlMask, xK_w)
+           ]
+        ]) $ def
        { terminal    = "alacritty"
        , modMask     = mod3Mask
        , borderWidth = 2
@@ -39,7 +53,7 @@ main = do
        , focusedBorderColor = "#ff6c00"
        , normalBorderColor = "#404040"
        , layoutHook = myLayout
-       , startupHook = spawn fp  
+       , startupHook = spawn fp
        , manageHook = composeAll [
            isFullscreen --> doFullFloat
          , className =? "Tilda" --> doFloat
@@ -48,13 +62,15 @@ main = do
          , title =? "Event Tester" --> doFloat
          , title =? "Floating Term" --> doCenterFloat
          , title =? "Notes" --> doCenterFloat
-         , title =? "xmessage" --> doFloat
-         , title =? "gxmessage" --> doFloat
+         , title =? "xmessage" --> doCenterFloat
+         , title =? "gxmessage" --> doCenterFloat
+         , title =? "Volume Control" --> doCenterFloat
          , className =? "mpv" --> doFloat
          , className =? "gnubby_ssh_prompt" --> doFloat
          ]
        , workspaces = map return (['0'..'9'] ++ ['a'..'z'])
-       , handleEventHook = fullscreenEventHook
+       , handleEventHook =
+           composeAll [fullscreenEventHook, interceptHook, remapHook]
        , focusFollowsMouse = False
        , clickJustFocuses = False
        , logHook = xMobarLogHook xmobar
@@ -66,3 +82,15 @@ doCenterFloat =
 
 centerRect :: W.RationalRect -> W.RationalRect
 centerRect (W.RationalRect x y w h) = W.RationalRect ((1 - w) / 2) ((1 - h) / 2) w h
+
+
+windowHooks :: WindowHook -> XConfig l -> XConfig l
+windowHooks (Query readerT) config = do
+
+  config {
+    startupHook = do
+      withAll $ \w -> runReaderT readerT w
+      startupHook config,
+
+    manageHook = mappend (Query readerT >> return (Endo id)) (manageHook config)
+  }