Replacing existing binder DSL with a better and more expressive DSL.

This new DSL is cleaner and more powerful. This new DSL allows mixing
key and mouse bindings in submappings, which can be very useful.

1 files changed, 78 insertions, 0 deletions

diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index b705a24..9c20381 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -8,19 +8,28 @@ module Rahm.Desktop.Submap
     submap,
     submapDefault,
     submapDefaultWithKey,
+    ButtonOrKeyEvent (..),
+    nextButtonOrKeyEvent,
+    getStringForKey,
     escape,
   )
 where
 
 import Control.Concurrent (threadDelay)
+import Control.Exception (SomeException (SomeException), catch)
+import Control.Monad (when)
 import Control.Monad.Fix (fix)
 import Control.Monad.Trans (MonadTrans (lift))
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
+import Data.Aeson (Result (Error))
+import Data.Bits ((.&.))
+import Data.Char (toUpper)
 import Data.Map (Map)
 import qualified Data.Map as Map (findWithDefault, lookup)
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.Word (Word64)
 import Rahm.Desktop.Common (pointerWindow, runMaybeT_)
+import Rahm.Desktop.Logger (logs)
 import XMonad
   ( Button,
     ButtonMask,
@@ -37,6 +46,7 @@ import XMonad
     XEventPtr,
     allocaXEvent,
     asKeyEvent,
+    asks,
     buttonPressMask,
     checkMaskEvent,
     cleanMask,
@@ -49,14 +59,19 @@ import XMonad
     isModifierKey,
     keyPressMask,
     keycodeToKeysym,
+    keysymToKeycode,
+    keysymToString,
     lookupString,
     maskEvent,
     pointerMotionMask,
+    setKeyEvent,
+    shiftMask,
     ungrabKeyboard,
     ungrabPointer,
     (.|.),
   )
 import qualified XMonad.Util.ExtensibleState as XS
+import XMonad.Util.Loggers (logSp)
 
 newtype Escape = Escape Bool
 
@@ -98,6 +113,51 @@ getMaskEventWithTimeout timeout d mask fn = do
             then return True
             else threadDelay 1000 >> getMaskEventWithTimeout' ptr timeout
 
+data ButtonOrKeyEvent
+  = ButtonPress
+      { event_mask :: KeyMask,
+        event_button :: Button
+      }
+  | KeyPress
+      { event_mask :: KeyMask,
+        event_keysym :: KeySym,
+        event_string :: String
+      }
+
+nextButtonOrKeyEvent :: MaybeT X ButtonOrKeyEvent
+nextButtonOrKeyEvent = do
+  b <- lift getEscape
+  when b (MaybeT (return Nothing))
+
+  XConf {theRoot = root, display = d} <- ask
+  io $ do
+    grabKeyboard d root False grabModeAsync grabModeAsync currentTime
+    grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime
+
+  ret <- MaybeT $
+    io $
+      fix $ \tryAgain -> do
+        ret <-
+          getMaskEventWithTimeout 5000 d (keyPressMask .|. buttonPressMask) $ \p -> do
+            ev <- getEvent p
+            case ev of
+              ButtonEvent {ev_button = b, ev_state = m} ->
+                return $ ButtonPress m b
+              KeyEvent {ev_keycode = code, ev_state = m} -> do
+                keysym <- keycodeToKeysym d code 0
+                (_, str) <- lookupString (asKeyEvent p)
+                return $ KeyPress m keysym str
+        case ret of
+          Just (KeyPress m sym str) | isModifierKey sym -> tryAgain
+          x -> return x
+
+  io $ do
+    ungrabKeyboard d currentTime
+    ungrabPointer d currentTime
+
+  m' <- lift $ cleanMask (event_mask ret)
+  return ret {event_mask = m'}
+
 {-
  - Like submap fram XMonad.Actions.Submap, but sends the string from
  - XLookupString to the function along side the keysym.
@@ -134,6 +194,24 @@ mapNextStringWithKeysym fn = do
   m <- lift $ cleanMask m'
   fn m keysym str
 
+-- getStringForKey :: (KeyMask, KeySym) -> X String
+-- getStringForKey (m, sym) = do
+--   d <- asks display
+--   io $
+--     allocaXEvent
+--       ( \xev -> do
+--           kc <- keysymToKeycode d sym
+--           setKeyEvent xev 0 0 0 m kc False
+--           (_, str) <- lookupString (asKeyEvent xev)
+--           return str
+--       )
+--       `catch` ( \e -> do
+--                   putStrLn $ "Error in getStringForKey: " ++ show (e :: SomeException)
+--                   return "?"
+--               )
+getStringForKey :: (KeyMask, KeySym) -> String
+getStringForKey (m, sym) = (if (m .&. shiftMask) /= 0 then map toUpper else id) (keysymToString sym)
+
 {- Like submap, but on the character typed rather than the kysym. -}
 mapNextString :: (KeyMask -> String -> MaybeT X a) -> MaybeT X a
 mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)