diff options
Diffstat (limited to 'src/Rahm/Desktop')
| -rw-r--r-- | src/Rahm/Desktop/Keys.hs | 354 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Keys/Dsl.hs | 607 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Keys/Dsl2.hs | 254 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Submap.hs | 78 |
4 files changed, 455 insertions, 838 deletions
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 2cc3d79..412d8f5 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -60,29 +60,7 @@ import Rahm.Desktop.History historyForward, jumpToLastLocation, ) -import Rahm.Desktop.Keys.Dsl - ( ButtonBinding (..), - ButtonBindings, - Documented (..), - KeyBinding (..), - KeyBindings, - altMask, - altMod, - altgrMod, - bind, - buttonDocumentation, - controlMod, - doc, - documentation, - getConfig, - justMod, - noMod, - rawMask, - runButtons, - runKeys, - shiftMod, - (-|-), - ) +import Rahm.Desktop.Keys.Dsl2 import Rahm.Desktop.Keys.Wml ( addWindowToSelection, clearWindowSelection, @@ -186,9 +164,6 @@ spawnX = spawn safeSpawnX :: String -> [String] -> X () safeSpawnX = safeSpawn -noWindow :: b -> Window -> b -noWindow = const - selectedWindowsColor = BorderColor "#00ffff" "#00ffff" decreaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ -5%" @@ -249,34 +224,6 @@ button14 = 14 button15 :: Button button15 = 15 -keyBindingToKeymap :: (XConfig l -> KeyBindings) -> KeyMap l -keyBindingToKeymap bindings config = Map.mapWithKey bindingToX (bindings config) - where - bindingToX :: (KeyMask, KeySym) -> Documented KeyBinding -> X () - bindingToX key b = - case b of - Documented _ (Action x) -> x - Documented _ (Submap mapping) -> - -- This is a submap, add it to the pending buffer. - -- - -- This could potentially use the current event in the XState and - -- lookupString to potentially recover the real string typed, but - -- for now, this will do. - pushAddPendingBuffer (keysymToString $ snd key) $ do - submap (Map.mapWithKey bindingToX mapping) - Documented _ (Repeat mapping) -> do - pushAddPendingBuffer (keysymToString $ snd key) $ do - mapM_ (bindingToX key) (Map.lookup key mapping) - fix $ \recur -> do - submap - ( Map.mapWithKey - ( \k b -> do - pushAddPendingBuffer (keysymToString $ snd k) $ - bindingToX k b >> recur - ) - mapping - ) - mapWindows :: (Ord b) => (a -> b) -> W.StackSet i l a s sd -> W.StackSet i l b s sd mapWindows fn (W.StackSet cur vis hidden float) = W.StackSet @@ -290,13 +237,8 @@ mapWindows fn (W.StackSet cur vis hidden float) = data ShiftType = JustShift | ShiftAndFollow | ShiftAndSwap -keymap :: XConfig l -> KeyBindings -keymap = runKeys $ do - config <- getConfig - - let subkeys keysM = Submap (runKeys keysM config) - repeatable keysM = Repeat (runKeys keysM config) - +bindings :: Binder () +bindings = do bind xK_apostrophe $ do justMod $ doc "Jump to a window/tile currently dragging window" $ do @@ -364,33 +306,33 @@ keymap = runKeys $ do doc "Move XMobar to another screen." $ spawnX "pkill -SIGUSR1 xmobar" - bind xK_F1 $ do - justMod $ - doc - "Print this documentation" - ( safeSpawn - "gxmessage" - [ "-fn", - "Source Code Pro", - "Key Bindings\n\n" - ++ documentation (keymap config) - ++ "\n\nButton Bindings\n\n" - ++ buttonDocumentation (mouseMap config) - ] :: - X () - ) - - bind xK_F7 $ do - justMod $ - doc - "Print this documentation to stdout (at LogLevel Info)" - ( logs - Info - "KeyBindings\n\n%s\n\nButtonBindings\n\n%s" - (documentation (keymap config)) - (buttonDocumentation (mouseMap config)) :: - X () - ) + -- bind xK_F1 $ do + -- justMod $ + -- doc + -- "Print this documentation" + -- ( safeSpawn + -- "gxmessage" + -- [ "-fn", + -- "Source Code Pro", + -- "Key Bindings\n\n" + -- ++ documentation (keymap config) + -- ++ "\n\nButton Bindings\n\n" + -- ++ buttonDocumentation (mouseMap config) + -- ] :: + -- X () + -- ) + + -- bind xK_F7 $ do + -- justMod $ + -- doc + -- "Print this documentation to stdout (at LogLevel Info)" + -- ( logs + -- Info + -- "KeyBindings\n\n%s\n\nButtonBindings\n\n%s" + -- (documentation (keymap config)) + -- (buttonDocumentation (mouseMap config)) :: + -- X () + -- ) bind xK_F10 $ do justMod playPauseDoc @@ -423,9 +365,6 @@ keymap = runKeys $ do doc ("Move the current window to screen " ++ show idx) $ withScreen W.shift idx - altgrMod - (logs Info "Test altgr" :: X ()) - bind xK_bracketright $ do justMod $ doc "Increase the gaps between windows." $ @@ -500,7 +439,7 @@ keymap = runKeys $ do bind xK_d $ justMod $ doc "Record (define) macros." $ - subkeys $ do + subbind $ do bind xK_w $ noMod $ doc @@ -746,7 +685,7 @@ keymap = runKeys $ do bind xK_space $ do justMod $ doc "Layout-related bindings" $ - subkeys $ do + subbind $ do bind xK_n $ (noMod -|- justMod) $ doc "Use the next layout in the layout list." $ do @@ -833,7 +772,7 @@ keymap = runKeys $ do bind xK_t $ do justMod $ doc "Spawn a terminal." $ - spawnX (terminal config) + spawnX =<< asks (terminal . config) shiftMod $ doc "Sink the current window into the tiling." $ @@ -843,26 +782,7 @@ keymap = runKeys $ do altMod $ doc "Spawn a floating terminal" $ - spawnX (terminal config ++ " -t Floating\\ Term") - - bind xK_v - $ - -- Allows repeated strokes of M-h and M-l to reduce and increase volume - -- respectively. - justMod - $ doc - "Allows repeated strokes of M-h and M-l to decrease and\n\ - \increase volume respectively" - $ repeatable - $ do - bind xK_h $ - justMod decreaseVolumeDoc - - bind xK_l $ - justMod increaseVolumeDoc - - bind xK_v $ - justMod (return () :: X ()) + spawnX =<< asks ((++ " -t Floating\\ Term") . terminal . config) bind xK_x $ do justMod $ @@ -872,7 +792,7 @@ keymap = runKeys $ do bind xK_z $ do justMod $ doc "Less often used keybindings." $ - subkeys $ do + subbind $ do bind xK_e $ do (justMod -|- noMod) $ doc "Select an emoji" $ @@ -955,7 +875,9 @@ keymap = runKeys $ do logs next "LogLevel set to %s." (show next) bind xF86XK_Calculator $ do - noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" + noMod $ + spawnX + =<< asks ((++ " -t Floating\\ Term -e /usr/bin/env python3") . terminal . config) bind xF86XK_AudioLowerVolume $ do noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ -1%" @@ -990,63 +912,6 @@ keymap = runKeys $ do noMod $ spawnX "set-backlight.sh -0.05" justMod $ spawnX "set-backlight.sh 0.01" rawMask shiftMask $ spawnX "set-backlight.sh 0" - -buttonBindingsToButtonMap :: (XConfig l -> ButtonBindings) -> ButtonsMap l -buttonBindingsToButtonMap bindings config = Map.mapWithKey bindingToX (bindings config) - where - bindingToX :: (ButtonMask, Button) -> Documented ButtonBinding -> (Window -> X ()) - bindingToX click@(mask, btn) = \case - Documented _ (ButtonAction action) -> action - Documented _ (ButtonSubmap sm) -> - pushAddPendingBuffer (printf "b%d " btn) - . submapButtonsWithKey (\_ _ -> return ()) (Map.mapWithKey bindingToX sm) - Documented _ (ButtonContinuous sm) -> \window -> - pushAddPendingBuffer (printf "b%d " btn) $ do - mapM_ (flip (bindingToX click) window) (Map.lookup click sm) - fix $ \recur -> do - submapButtonsWithKey - ( \_ _ -> return () - ) - ( Map.mapWithKey - ( \k b w -> - pushAddPendingBuffer (printf "b%d " (snd k)) $ - bindingToX k b w >> recur - ) - sm - ) - window - -myMouseMoveWindow = - D.mouseMoveWindowAndThen X.focus $ - mconcat - [ D.ifReleased button3 D.sinkOnRelease, - D.ifReleased' button2 $ \w _ -> X.killWindow w - ] - -myMouseResizeAction = - D.mouseResizeWindowAndThen X.focus $ - mconcat - [ D.ifReleased button1 D.sinkOnRelease - ] - -mouseMap :: forall l. XConfig l -> ButtonBindings -mouseMap = runButtons $ do - config <- getConfig - - -- let x button = Map.lookup button (mouseMap config) - - -- let defaultButtons button = - -- fromMaybe (\w -> return ()) $ - -- Map.lookup button (mouseMap config) - let subMouse = ButtonSubmap . flip runButtons config - - continuous buttons = do - let bindingMap = runButtons buttons config - in forM_ (Map.toList bindingMap) $ \((m, b), _) -> do - bind b $ - rawMask m $ - ButtonContinuous bindingMap - bind button1 $ do justMod $ doc @@ -1087,50 +952,63 @@ mouseMap = runButtons $ do doc "Media next" $ noWindow mediaNext - bind button14 $ do - noMod $ - doc "Additional Mouse Bindings" $ - subMouse $ do - bind button3 $ - noMod $ - doc "Drag a workspace to a different screen" $ - noWindow D.dragWorkspace + let button14Binder = do + bind button3 $ + noMod $ + doc "Drag a workspace to a different screen" $ + noWindow D.dragWorkspace + + bind button1 $ + noMod $ + doc "Swap a window with another window by dragging." $ + noWindow D.dragWindow + + bind button14 $ do + noMod $ + doc "Pop the window under the cursor" $ + noWindow $ + click >> sendMessage togglePop + + bind button15 $ do + noMod $ + doc "Spawn 'pavucontrol'" $ + noWindow $ + spawnX "pavucontrol" + + let mediaButtons = + [ (button4, "Increase volume", noWindow increaseVolume), + (button5, "Decrease volume", noWindow decreaseVolume), + (button2, "Play/Pause", noWindow playPause), + (button9, "History Forward", noWindow (viewAdjacentTo pointerWorkspace next)), + (button8, "History Back", noWindow (viewAdjacentTo pointerWorkspace prev)), + (button6, "Media Previous", noWindow mediaPrev), + (button7, "Media Next", noWindow mediaNext) + ] + + continuous $ do + forM_ mediaButtons $ \(b, d, a) -> + bind b $ noMod $ doc d a - bind button1 $ - noMod $ - doc "Swap a window with another window by dragging." $ - noWindow D.dragWindow + bind xK_h $ + justMod decreaseVolumeDoc - bind button14 $ do - noMod $ - doc "Pop the window under the cursor" $ - noWindow $ - click >> sendMessage togglePop + bind xK_l $ + justMod increaseVolumeDoc - bind button15 $ do - noMod $ - doc "Spawn 'pavucontrol'" $ - noWindow $ - spawnX "pavucontrol" - - let mediaButtons = - [ (button4, "Increase volume", noWindow increaseVolume), - (button5, "Decrease volume", noWindow decreaseVolume), - (button2, "Play/Pause", noWindow playPause), - (button9, "History Forward", noWindow (viewAdjacentTo pointerWorkspace next)), - (button8, "History Back", noWindow (viewAdjacentTo pointerWorkspace prev)), - (button6, "Media Previous", noWindow mediaPrev), - (button7, "Media Next", noWindow mediaNext) - ] + bind button14 $ do + noMod $ + doc "Additional Mouse Bindings" $ + subbind button14Binder - continuous $ - forM_ mediaButtons $ \(b, d, a) -> - bind b $ noMod $ doc d a + bind xK_v $ do + justMod $ + doc "Same as button14" $ + subbind button14Binder bind button13 $ noMod $ doc "General Window Management Extra Mouse Bindings" $ - subMouse $ do + subbind $ do bind button1 $ noMod $ doc @@ -1164,10 +1042,10 @@ mouseMap = runButtons $ do bind button13 $ noMod $ - subMouse $ do + subbind $ do bind button13 $ noMod $ - subMouse $ do + subbind $ do bind button13 $ noMod $ doc "Lock the screen" $ @@ -1182,7 +1060,7 @@ mouseMap = runButtons $ do bind button15 $ do noMod $ doc "General navigation extra mouse bindings" $ - subMouse $ do + subbind $ do bind button13 $ noMod $ doc "Goto the accompaning workspace to the current one." $ @@ -1220,7 +1098,7 @@ mouseMap = runButtons $ do bind button14 $ noMod $ - subMouse $ do + subbind $ do bind button1 $ noMod $ doc "Pin the selected windows" $ @@ -1273,19 +1151,42 @@ mouseMap = runButtons $ do ) in windows f >> escape --- Bindings specific to a window. These are set similarly to th ekeymap above, --- but uses a Query monad to tell which windows the keys will apply to. --- --- This is useful to create hotkeys in applications where hot keys are not --- configurable, or to remove keybindings that are irritating (looking at you, --- ctrl+w in Chrome!!). +myMouseMoveWindow = + D.mouseMoveWindowAndThen X.focus $ + mconcat + [ D.ifReleased button3 D.sinkOnRelease, + D.ifReleased' button2 $ \w _ -> X.killWindow w + ] + +myMouseResizeAction = + D.mouseResizeWindowAndThen X.focus $ + mconcat + [ D.ifReleased button1 D.sinkOnRelease + ] + +applyKeys :: XConfig l -> IO (XConfig l) +applyKeys c = + let conf' = withBindings bindings c + in return $ + windowBindings $ + conf' + { keys = + Map.insert + (modMask c .|. shiftMask, xK_q) + (spawnX "xmonad --recompile && xmonad --restart") + . keys conf' + } + windowSpecificBindings :: XConfig l -> WriterT (Map (KeyMask, KeySym) (X ())) Query () windowSpecificBindings config = do w <- lift ask + let altMask = mod1Mask let mods = permuteMods [shiftMask, controlMask, 0] - let configureIf b k = tell =<< lift (b --> return (keyBindingToKeymap (runKeys k) config)) + let configureIf b k = + let (keymap, _) = resolveBindings (runBinder config k) + in tell =<< lift (b --> return (keymap config)) emitKey = flip sendKey w configureIf (flip elem (browsers ++ spotify) <$> className) $ do @@ -1398,20 +1299,11 @@ windowBindings xconfig = map <- execWriterT $ windowSpecificBindings xconfig w <- ask - liftX $ logs Info "For Window: %s" (show w) + liftX $ logs Debug "For Window: %s" (show w) forM_ (Map.toList map) $ \(key, action) -> do - liftX $ logs Info " -- remap: %s" (show key) + liftX $ logs Debug " -- remap: %s" (show key) remapKey key action -applyKeys :: XConfig l -> IO (XConfig l) -applyKeys config = - return $ - windowBindings $ - config - { keys = keyBindingToKeymap keymap, - mouseBindings = buttonBindingsToButtonMap mouseMap - } - modifyWindowBorder :: Integer -> SpacingModifier modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) -> Border (clip $ a + i) (clip $ b + i) (clip $ c + i) (clip $ d + i) diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs deleted file mode 100644 index 1246d3b..0000000 --- a/src/Rahm/Desktop/Keys/Dsl.hs +++ /dev/null @@ -1,607 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} - -module Rahm.Desktop.Keys.Dsl - ( doc, - (-|-), - ButtonBinding (..), - ButtonBindings, - Documented (..), - HasConfig, - KeyBinding (..), - KeyBindings, - altAltgrMod, - altHyperAltgrMod, - altHyperMod, - altMask, - altMod, - altSuperAltgrMod, - altSuperHyperAltgrMod, - altSuperHyperMod, - altSuperMod, - altgrMask, - altgrMod, - bind, - buttonDocumentation, - controlAltAltgrMod, - controlAltHyperAltgrMod, - controlAltHyperMod, - controlAltMod, - controlAltSuperAltgrMod, - controlAltSuperHyperAltgrMod, - controlAltSuperHyperMod, - controlAltSuperMod, - controlAltgrMod, - controlHyperAltgrMod, - controlHyperMod, - controlMod, - controlSuperAltgrMod, - controlSuperHyperAltgrMod, - controlSuperHyperMod, - controlSuperMod, - documentation, - getConfig, - hyperAltgrMod, - hyperMask, - hyperMod, - justMod, - maskMod, - noMod, - rawMask, - runButtons, - runKeys, - shiftAltAltgrMod, - shiftAltHyperAltgrMod, - shiftAltHyperMod, - shiftAltMod, - shiftAltSuperAltgrMod, - shiftAltSuperHyperAltgrMod, - shiftAltSuperHyperMod, - shiftAltSuperMod, - shiftAltgrMod, - shiftControlAltAltgrMod, - shiftControlAltHyperAltgrMod, - shiftControlAltHyperMod, - shiftControlAltMod, - shiftControlAltSuperAltgrMod, - shiftControlAltSuperHyperAltgrMod, - shiftControlAltSuperHyperMod, - shiftControlAltSuperMod, - shiftControlAltgrMod, - shiftControlHyperAltgrMod, - shiftControlHyperMod, - shiftControlMod, - shiftControlSuperAltgrMod, - shiftControlSuperHyperAltgrMod, - shiftControlSuperHyperMod, - shiftControlSuperMod, - shiftHyperAltgrMod, - shiftHyperMod, - shiftMod, - shiftSuperAltgrMod, - shiftSuperHyperAltgrMod, - shiftSuperHyperMod, - shiftSuperMod, - superAltgrMod, - superHyperAltgrMod, - superHyperMod, - superMask, - superMod, - ) -where - -import Control.Arrow (first, second) -import Control.Monad.State (State, execState, modify') -import Control.Monad.Writer - ( MonadWriter (tell), - execWriter, - forM_, - when, - ) -import Data.Bits ((.&.)) -import Data.List (intercalate, sortOn) -import Data.Map (Map) -import qualified Data.Map as Map - ( empty, - fromList, - fromListWith, - toList, - ) -import Text.Printf (printf) -import XMonad - ( Button, - ButtonMask, - KeyMask, - KeySym, - MonadState (get), - Window, - X, - XConfig (modMask), - controlMask, - keysymToString, - mod1Mask, - mod3Mask, - mod4Mask, - shiftMask, - (.|.), - ) - -data Documented t = Documented String t - -data KeyBinding - = Action (X ()) - | Submap KeyBindings - | Repeat KeyBindings - -type KeyBindings = Map (KeyMask, KeySym) (Documented KeyBinding) - -data ButtonBinding - = ButtonAction (Window -> X ()) - | ButtonSubmap ButtonBindings - | ButtonContinuous ButtonBindings - --- Window -> X () - -type ButtonBindings = Map (KeyMask, Button) (Documented ButtonBinding) - -{- Module that defines a DSL for binding keys. -} -newtype KeysM l a = KeysM (State (XConfig l, KeyBindings) a) - deriving (Functor, Applicative, Monad) - -newtype ButtonsM l a = ButtonsM (State (XConfig l, ButtonBindings) a) - deriving (Functor, Applicative, Monad) - -newtype BindingBuilder b a = BindingBuilder (State (KeyMask, [(KeyMask, b)]) a) - deriving (Functor, Applicative, Monad) - -class HasConfig m where - getConfig :: m l (XConfig l) - -class Bindable k where - type BindableValue k :: * - type BindableMonad k :: (* -> *) -> * -> * - - bind :: k -> BindingBuilder (BindableValue k) a -> BindableMonad k l () - --- section :: String -> BindableMonad k l () -> BindableMonad k l () - -class Binding k b where - toB :: k -> b - - rawMask :: KeyMask -> k -> BindingBuilder b () - rawMask m x = BindingBuilder $ modify' (second ((m, toB x) :)) - -instance Binding (Window -> X ()) (Documented ButtonBinding) where - toB = Documented "" . ButtonAction - -instance Binding (X ()) (Documented KeyBinding) where - toB = Documented "" . Action - -instance Binding KeyBindings (Documented KeyBinding) where - toB = Documented "" . Submap - -instance Binding a (Documented a) where - toB = Documented "" - -instance Binding a a where - toB = id - --- Relationships to witness which types can be used with the "doc" function, --- which is used to document actions in a safe and programmable way.. -class Relation k b | k -> b - -instance Relation (X ()) KeyBinding - -instance Relation KeyBinding KeyBinding - -instance Relation ButtonBinding ButtonBinding - -instance Relation (Window -> X ()) ButtonBinding - -doc :: (Relation k b, Binding k (Documented b)) => String -> k -> Documented b -doc str k = let (Documented _ t) = toB k in Documented str t - -runKeys :: KeysM l a -> XConfig l -> KeyBindings -runKeys (KeysM stateM) config = - snd $ execState stateM (config, Map.empty) - -runButtons :: ButtonsM l a -> XConfig l -> ButtonBindings -runButtons (ButtonsM stateM) config = - snd $ execState stateM (config, Map.empty) - -instance HasConfig KeysM where - getConfig = fst <$> KeysM get - -instance HasConfig ButtonsM where - getConfig = fst <$> ButtonsM get - -{- Generally it is assumed that the mod key shoud be pressed, but not always. -} -noMod :: (Binding k b) => k -> BindingBuilder b () -noMod = rawMask 0 - -maskMod :: (Binding k b) => KeyMask -> k -> BindingBuilder b () -maskMod mask action = do - modMask <- fst <$> BindingBuilder get - rawMask (modMask .|. mask) action - -altMask :: KeyMask -altMask = mod1Mask - -hyperMask :: KeyMask -hyperMask = mod3Mask - -altgrMask :: KeyMask -altgrMask = 0x80 - -superMask :: KeyMask -superMask = mod4Mask - -justMod :: (Binding k b) => k -> BindingBuilder b () -justMod = maskMod 0 - -instance Bindable KeySym where - type BindableValue KeySym = Documented KeyBinding - type BindableMonad KeySym = KeysM - - -- bind :: KeySym -> BindingBuilder (X x) a -> KeysM l () - bind key (BindingBuilder stM) = do - m <- modMask <$> getConfig - let (_, values) = execState stM (m, []) - - KeysM $ - modify' $ - second $ - flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values)) - -instance Bindable Button where - type BindableValue Button = Documented ButtonBinding - type BindableMonad Button = ButtonsM - - -- bind :: KeySym -> BindingBuilder (Window -> X ()) a -> ButtonsM l () - bind button (BindingBuilder stM) = do - m <- modMask <$> getConfig - let (_, values) = execState stM (m, []) - - ButtonsM $ - modify' $ - second $ - flip (<>) (Map.fromList (map (\(m, v) -> ((m, button), v)) values)) - -shiftControlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltSuperHyperAltgrMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) - -shiftControlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltSuperHyperMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask) - -shiftControlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltSuperAltgrMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. altgrMask) - -shiftControlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltSuperMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. superMask) - -shiftControlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltHyperAltgrMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask .|. altgrMask) - -shiftControlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltHyperMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask) - -shiftControlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltAltgrMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. altgrMask) - -shiftControlAltMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltMod = - maskMod (shiftMask .|. controlMask .|. altMask) - -shiftControlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlSuperHyperAltgrMod = - maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask .|. altgrMask) - -shiftControlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlSuperHyperMod = - maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask) - -shiftControlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlSuperAltgrMod = - maskMod (shiftMask .|. controlMask .|. superMask .|. altgrMask) - -shiftControlSuperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlSuperMod = - maskMod (shiftMask .|. controlMask .|. superMask) - -shiftControlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlHyperAltgrMod = - maskMod (shiftMask .|. controlMask .|. hyperMask .|. altgrMask) - -shiftControlHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlHyperMod = - maskMod (shiftMask .|. controlMask .|. hyperMask) - -shiftControlAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltgrMod = - maskMod (shiftMask .|. controlMask .|. altgrMask) - -shiftControlMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlMod = - maskMod (shiftMask .|. controlMask) - -shiftAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltSuperHyperAltgrMod = - maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) - -shiftAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltSuperHyperMod = - maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask) - -shiftAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltSuperAltgrMod = - maskMod (shiftMask .|. altMask .|. superMask .|. altgrMask) - -shiftAltSuperMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltSuperMod = - maskMod (shiftMask .|. altMask .|. superMask) - -shiftAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltHyperAltgrMod = - maskMod (shiftMask .|. altMask .|. hyperMask .|. altgrMask) - -shiftAltHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltHyperMod = - maskMod (shiftMask .|. altMask .|. hyperMask) - -shiftAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltAltgrMod = - maskMod (shiftMask .|. altMask .|. altgrMask) - -shiftAltMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltMod = - maskMod (shiftMask .|. altMask) - -shiftSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftSuperHyperAltgrMod = - maskMod (shiftMask .|. superMask .|. hyperMask .|. altgrMask) - -shiftSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftSuperHyperMod = - maskMod (shiftMask .|. superMask .|. hyperMask) - -shiftSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftSuperAltgrMod = - maskMod (shiftMask .|. superMask .|. altgrMask) - -shiftSuperMod :: (Binding k b) => k -> BindingBuilder b () -shiftSuperMod = - maskMod (shiftMask .|. superMask) - -shiftHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftHyperAltgrMod = - maskMod (shiftMask .|. hyperMask .|. altgrMask) - -shiftHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftHyperMod = - maskMod (shiftMask .|. hyperMask) - -shiftAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltgrMod = - maskMod (shiftMask .|. altgrMask) - -shiftMod :: (Binding k b) => k -> BindingBuilder b () -shiftMod = maskMod shiftMask - -controlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltSuperHyperAltgrMod = - maskMod (controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) - -controlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -controlAltSuperHyperMod = - maskMod (controlMask .|. altMask .|. superMask .|. hyperMask) - -controlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltSuperAltgrMod = - maskMod (controlMask .|. altMask .|. superMask .|. altgrMask) - -controlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () -controlAltSuperMod = - maskMod (controlMask .|. altMask .|. superMask) - -controlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltHyperAltgrMod = - maskMod (controlMask .|. altMask .|. hyperMask .|. altgrMask) - -controlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () -controlAltHyperMod = - maskMod (controlMask .|. altMask .|. hyperMask) - -controlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltAltgrMod = - maskMod (controlMask .|. altMask .|. altgrMask) - -controlAltMod :: (Binding k b) => k -> BindingBuilder b () -controlAltMod = - maskMod (controlMask .|. altMask) - -controlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlSuperHyperAltgrMod = - maskMod (controlMask .|. superMask .|. hyperMask .|. altgrMask) - -controlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -controlSuperHyperMod = - maskMod (controlMask .|. superMask .|. hyperMask) - -controlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlSuperAltgrMod = - maskMod (controlMask .|. superMask .|. altgrMask) - -controlSuperMod :: (Binding k b) => k -> BindingBuilder b () -controlSuperMod = - maskMod (controlMask .|. superMask) - -controlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlHyperAltgrMod = - maskMod (controlMask .|. hyperMask .|. altgrMask) - -controlHyperMod :: (Binding k b) => k -> BindingBuilder b () -controlHyperMod = - maskMod (controlMask .|. hyperMask) - -controlAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltgrMod = - maskMod (controlMask .|. altgrMask) - -controlMod :: (Binding k b) => k -> BindingBuilder b () -controlMod = maskMod controlMask - -altSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -altSuperHyperAltgrMod = - maskMod (altMask .|. superMask .|. hyperMask .|. altgrMask) - -altSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -altSuperHyperMod = - maskMod (altMask .|. superMask .|. hyperMask) - -altSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -altSuperAltgrMod = - maskMod (altMask .|. superMask .|. altgrMask) - -altSuperMod :: (Binding k b) => k -> BindingBuilder b () -altSuperMod = - maskMod (altMask .|. superMask) - -altHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -altHyperAltgrMod = - maskMod (altMask .|. hyperMask .|. altgrMask) - -altHyperMod :: (Binding k b) => k -> BindingBuilder b () -altHyperMod = - maskMod (altMask .|. hyperMask) - -altAltgrMod :: (Binding k b) => k -> BindingBuilder b () -altAltgrMod = - maskMod (altMask .|. altgrMask) - -altMod :: (Binding k b) => k -> BindingBuilder b () -altMod = maskMod altMask - -superHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -superHyperAltgrMod = - maskMod (superMask .|. hyperMask .|. altgrMask) - -superHyperMod :: (Binding k b) => k -> BindingBuilder b () -superHyperMod = - maskMod (superMask .|. hyperMask) - -superAltgrMod :: (Binding k b) => k -> BindingBuilder b () -superAltgrMod = - maskMod (superMask .|. altgrMask) - -superMod :: (Binding k b) => k -> BindingBuilder b () -superMod = maskMod superMask - -hyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -hyperAltgrMod = - maskMod (hyperMask .|. altgrMask) - -hyperMod :: (Binding k b) => k -> BindingBuilder b () -hyperMod = maskMod hyperMask - -altgrMod :: (Binding k b) => k -> BindingBuilder b () -altgrMod = maskMod altgrMask - -{- Can combine two or more of the functions above to apply the same action to - - multiple masks. -} -(-|-) :: - (Binding k b) => - (k -> BindingBuilder b ()) -> - (k -> BindingBuilder b ()) -> - k -> - BindingBuilder b () -(-|-) fn1 fn2 f = fn1 f >> fn2 f - -buttonDocumentation :: ButtonBindings -> String -buttonDocumentation = execWriter . document' "" - where - document' pref keybindings = - forM_ (sortOn (map (\(a, b) -> (b, a)) . snd . snd) $ Map.toList (keyBindingsToList keybindings)) $ \(doc, (thing, keys)) -> do - when (not (null doc) || hasSubmap thing) $ - tell $ printf "%s%s: %s\n" pref (intercalate " or " $ map prettyShow keys) doc - case thing of - ButtonAction _ -> return () - ButtonSubmap submap -> document' (pref ++ " ") submap - ButtonContinuous submap -> do - tell pref - tell " (repeatable):\n" - document' (pref ++ " ") submap - - keyBindingsToList :: ButtonBindings -> Map String (ButtonBinding, [(ButtonMask, Button)]) - keyBindingsToList b = - (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list)) - <$> group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b) - - prettyShow :: (ButtonMask, Button) -> String - prettyShow (mask, button) = printf "%s%s" (showMask mask) (buttonToString button) - - buttonToString = \case - 1 -> "Left Click" - 2 -> "Middle Click" - 3 -> "Right Click" - 4 -> "Wheel Up" - 5 -> "Wheel Down" - 6 -> "Wheel Left" - 7 -> "Wheel Right" - 8 -> "Browser Back" - 9 -> "Browser Forward" - 13 -> "Thumb Target" - 14 -> "Index Forward" - 15 -> "Index Back" - b -> "Button " ++ show b - - hasSubmap b = case b of - ButtonAction _ -> False - _ -> True - -documentation :: KeyBindings -> String -documentation = execWriter . document' "" - where - document' pref keybindings = - forM_ (sortOn (map (\(a, b) -> (b, a)) . snd . snd) $ Map.toList (keyBindingsToList keybindings)) $ \(doc, (thing, keys)) -> do - when (not (null doc) || hasSubmap thing) $ - tell $ printf "%s%s: %s\n" pref (intercalate " or " $ map prettyShow keys) doc - case thing of - Action _ -> return () - Submap submap -> document' (pref ++ " ") submap - Repeat submap -> do - tell pref - tell " (repeatable):\n" - document' (pref ++ " ") submap - - keyBindingsToList :: KeyBindings -> Map String (KeyBinding, [(KeyMask, KeySym)]) - keyBindingsToList b = - (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list)) - <$> group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b) - - prettyShow :: (KeyMask, KeySym) -> String - prettyShow (mask, key) = printf "%s%s" (showMask mask) (keysymToString key) - - hasSubmap b = case b of - Action _ -> False - _ -> True - -showMask :: KeyMask -> String -showMask mask = - let masks = - [ (shiftMask, "S"), - (altMask, "A"), - (mod3Mask, "H"), - (mod4Mask, "M"), - (altgrMask, "AGr"), - (controlMask, "C") - ] - in concatMap ((++ "-") . snd) $ filter ((/= 0) . (.&. mask) . fst) masks - -group :: (Ord b) => (a -> b) -> [a] -> Map b [a] -group fn = Map.fromListWith (++) . map (first fn . (\a -> (a, [a]))) diff --git a/src/Rahm/Desktop/Keys/Dsl2.hs b/src/Rahm/Desktop/Keys/Dsl2.hs new file mode 100644 index 0000000..3debc48 --- /dev/null +++ b/src/Rahm/Desktop/Keys/Dsl2.hs @@ -0,0 +1,254 @@ +module Rahm.Desktop.Keys.Dsl2 where + +import Control.Monad.Fix (fix) +import Control.Monad.RWS (MonadTrans (lift), MonadWriter, forM_) +import Control.Monad.Reader (Reader, ask, runReader) +import Control.Monad.State (MonadTrans, StateT (StateT)) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Control.Monad.Trans.Writer (Writer, WriterT, execWriter, execWriterT) +import Control.Monad.Writer.Class (tell) +import Data.Functor.Identity (Identity) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Rahm.Desktop.Common (pointerWindow, runMaybeT_) +import Rahm.Desktop.Logger (LogLevel (Debug), logs) +import Rahm.Desktop.Submap (ButtonOrKeyEvent (ButtonPress, KeyPress), getStringForKey, nextButtonOrKeyEvent) +import Rahm.Desktop.XMobarLog (spawnXMobar) +import Rahm.Desktop.XMobarLog.PendingBuffer (pushAddPendingBuffer, pushPendingBuffer) +import XMonad + +data Documented t = Documented + { docString :: String, + undocument :: t + } + +type family Action t where + Action KeySym = X () + Action Button = Window -> X () + +data XConfigH where + XConfigH :: forall l. XConfig l -> XConfigH + +data Binding t + = Action (Action t) + | Submap (forall l. XConfig l -> BindingsMap) + | Repeat (Binding t) (forall l. XConfig l -> BindingsMap) + | NoBinding + +data BindingsMap = BindingsMap + { key_bindings :: Map (KeyMask, KeySym) (Documented (Binding KeySym)), + button_bindings :: Map (KeyMask, Button) (Documented (Binding Button)), + no_match_catch_key :: (KeyMask, KeySym, String) -> X (), + no_match_catch_button :: (KeyMask, Button) -> Window -> X () + } + +newtype MaskBinder k a = MaskBinder + { unMaskBinder :: WriterT (Map KeyMask (Documented (Binding k))) (Reader XConfigH) a + } + deriving + ( Functor, + Applicative, + Monad, + MonadWriter (Map KeyMask (Documented (Binding k))), + MonadReader XConfigH + ) + +instance Semigroup BindingsMap where + (BindingsMap mk1 mb1 _ _) <> (BindingsMap mk2 mb2 fk fb) = + BindingsMap (mk1 <> mk2) (mb1 <> mb2) fk fb + +instance Monoid BindingsMap where + mempty = BindingsMap mempty mempty (\_ -> return ()) (\_ _ -> return ()) + +newtype Binder a = Binder (WriterT BindingsMap (Reader XConfigH) a) + deriving (Functor, Applicative, Monad, MonadWriter BindingsMap, MonadReader XConfigH) + +bindOtherKeys :: ((KeyMask, KeySym, String) -> X ()) -> Binder () +bindOtherKeys fn = Binder $ tell (mempty {no_match_catch_key = fn}) + +bindOtherButtons :: ((KeyMask, Button) -> Window -> X ()) -> Binder () +bindOtherButtons fn = Binder $ tell (mempty {no_match_catch_button = fn}) + +class Documentable a b where + toDocumented :: a -> b + +instance Documentable (Documented a) (Documented a) where + toDocumented = id + +instance Documentable a (Documented a) where + toDocumented = Documented "" + +class BindingType a where + type BoundTo a :: * + + toBinding :: a -> Documented (Binding (BoundTo a)) + +instance BindingType (Binding t) where + type BoundTo (Binding t) = t + toBinding = Documented "" + +instance BindingType (X ()) where + type BoundTo (X ()) = KeySym + toBinding = Documented "" . Action + +instance BindingType (Window -> X ()) where + type BoundTo (Window -> X ()) = Button + toBinding = Documented "" . Action + +instance (BindingType a) => BindingType (Documented a) where + type BoundTo (Documented a) = BoundTo a + toBinding (Documented s (toBinding -> (Documented _ a))) = Documented s a + +class Bind k where + doBinding :: k -> Map KeyMask (Documented (Binding k)) -> BindingsMap + rawMaskRaw :: KeyMask -> Documented (Binding k) -> MaskBinder k () + +instance Bind Button where + doBinding but mp = mempty {button_bindings = Map.mapKeys (,but) mp} + rawMaskRaw mask act = tell (Map.singleton mask act) + +instance Bind KeySym where + doBinding key mp = mempty {key_bindings = Map.mapKeys (,key) mp} + rawMaskRaw mask act = tell (Map.singleton mask act) + +rawMask :: (Bind (BoundTo a), BindingType a) => KeyMask -> a -> MaskBinder (BoundTo a) () +rawMask mask act = rawMaskRaw mask (toBinding act) + +withMod :: (Bind (BoundTo a), BindingType a) => KeyMask -> a -> MaskBinder (BoundTo a) () +withMod m act = do + (XConfigH (modMask -> mm)) <- ask + rawMask (mm .|. m) act + +noMod, justMod, shiftMod, controlMod, altMod :: (Bind (BoundTo a), BindingType a) => a -> MaskBinder (BoundTo a) () +justMod = withMod 0 +noMod = rawMask 0 +shiftMod = withMod shiftMask +controlMod = withMod controlMask +altMod = withMod mod1Mask + +(-|-) :: + (Bind (BoundTo a), BindingType a) => + (a -> MaskBinder (BoundTo a) ()) -> + (a -> MaskBinder (BoundTo a) ()) -> + a -> + MaskBinder (BoundTo a) () +m1 -|- m2 = \act -> m1 act >> m2 act + +bind :: (Bind k) => k -> MaskBinder k () -> Binder () +bind k h = + tell . doBinding k . runReader (execWriterT $ unMaskBinder h) =<< ask + +bindL :: (Bind k) => [k] -> MaskBinder k () -> Binder () +bindL ks h = mapM_ (`bind` h) ks + +doc :: String -> a -> Documented a +doc = Documented + +noWindow :: X () -> Window -> X () +noWindow fn _ = fn + +resolveBindings :: + BindingsMap -> + ( XConfig l -> Map (KeyMask, KeySym) (X ()), + XConfig l -> Map (ButtonMask, Button) (Window -> X ()) + ) +resolveBindings (BindingsMap keyBindings buttonBindings _ _) = + ( \c -> Map.mapWithKey (\k -> pushK k (bindingToX c) . undocument) keyBindings, + \c -> Map.mapWithKey (\k -> pushB k (bindingToWinX c) . undocument) buttonBindings + ) + where + pushB :: (ButtonMask, Button) -> (Binding Button -> Window -> X ()) -> Binding Button -> Window -> X () + pushB (_, b) fn binding win = + if isRepeatOrSubmap binding + then pushPendingBuffer ("b" ++ show b ++ " ") $ fn binding win + else fn binding win + + pushK (m, k) fn binding = + if isRepeatOrSubmap binding + then do + let s = getStringForKey (m, k) + pushPendingBuffer (s ++ " ") $ fn binding + else fn binding + + bindingToX :: forall l. XConfig l -> Binding KeySym -> X () + bindingToX conf = \case + NoBinding -> return () + Action a -> a + Submap sm -> doSubmap conf (sm conf) (return ()) + Repeat a sm -> bindingToX conf a >> fix (doSubmap conf (sm conf)) + + bindingToWinX :: forall l. XConfig l -> Binding Button -> Window -> X () + bindingToWinX conf binding win = case binding of + NoBinding -> return () + Action fn -> fn win + Submap sm -> doSubmap conf (sm conf) (return ()) + Repeat a sm -> bindingToWinX conf a win >> fix (doSubmap conf (sm conf)) + + doSubmap :: forall l. XConfig l -> BindingsMap -> X () -> X () + doSubmap conf (BindingsMap kbind bbind _ _) after = runMaybeT_ $ do + nextPressEvent $ + \case + (ButtonPress m b) -> do + binding <- hoist $ Map.lookup (m, b) bbind + lift $ do + win <- pointerWindow + bindingToWinX conf (undocument binding) win + after + (KeyPress m k s) -> do + binding <- hoist $ Map.lookup (m, k) kbind + lift $ do + bindingToX conf (undocument binding) + after + + isRepeatOrSubmap = \case + Repeat {} -> True + Submap {} -> True + _ -> False + + nextPressEvent fn = do + ev <- nextButtonOrKeyEvent + let str = case ev of + ButtonPress m b -> "b" ++ show b + KeyPress _ _ s -> s + lift $ + pushAddPendingBuffer (str ++ " ") $ + runMaybeT_ $ + fn ev + + hoist = MaybeT . return + +subbind :: Binder () -> Binding t +subbind (Binder b) = + Submap $ \config -> + runReader (execWriterT b) (XConfigH config) + +repeatable :: Binder () -> Binding t +repeatable (Binder b) = + Repeat NoBinding $ \config -> + runReader (execWriterT b) (XConfigH config) + +-- Similar to repeatable, but all the keys in the binder start the loop. +continuous :: Binder () -> Binder () +continuous (Binder b) = do + conf <- ask + let bm@(BindingsMap keyBinds mouseBinds _ _) = + runReader (execWriterT b) conf + + forM_ (Map.toList keyBinds) $ \((m, k), Documented _ b) -> + bind k $ rawMask m $ Repeat b $ const bm + + forM_ (Map.toList mouseBinds) $ \((m, k), Documented _ b) -> + bind k $ rawMask m $ Repeat b $ const bm + +runBinder :: XConfig l -> Binder a -> BindingsMap +runBinder conf (Binder binder) = runReader (execWriterT binder) (XConfigH conf) + +withBindings :: Binder a -> XConfig l -> XConfig l +withBindings b config = + let (keyBinds, buttonBinds) = + resolveBindings $ runBinder config b + in config + { keys = keyBinds, + mouseBindings = buttonBinds + } 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) |