aboutsummaryrefslogtreecommitdiff
path: root/src/Rahm/Desktop
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rahm/Desktop')
-rw-r--r--src/Rahm/Desktop/Keys.hs53
-rw-r--r--src/Rahm/Desktop/Keys/Dsl2.hs109
2 files changed, 115 insertions, 47 deletions
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 412d8f5..8945201 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -306,33 +306,26 @@ bindings = 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 ()
- -- )
+ let getDoc :: X String
+ getDoc = do
+ config <- asks config
+ return $
+ "Key and Mouse Bindings:\n\n"
+ ++ documentation config bindings
+
+ bind xK_F1 $ do
+ justMod
+ $ doc
+ "Print this documentation"
+ $ do
+ doc <- getDoc
+ safeSpawn "gxmessage" ["-fn", "Source Code Pro", doc]
+
+ bind xK_F7 $ do
+ justMod $
+ doc
+ "Print this documentation to stdout (at LogLevel Info)"
+ (logs Info "%s" =<< getDoc)
bind xK_F10 $ do
justMod playPauseDoc
@@ -846,6 +839,12 @@ bindings = do
noMod mediaNextDoc
rawMask shiftMask mediaSeekFDoc
+ bindOtherKeys $ \(_, _, s) ->
+ logs Info "Unhandled key pressed: %s" s
+
+ bindOtherButtons $ \(_, b) ->
+ logs Info "Unhandled button press: %s" (show b)
+
-- Centers the current focused window. i.e. toggles the Zoom layout
-- modifier.
shiftMod $
diff --git a/src/Rahm/Desktop/Keys/Dsl2.hs b/src/Rahm/Desktop/Keys/Dsl2.hs
index 3debc48..b59152e 100644
--- a/src/Rahm/Desktop/Keys/Dsl2.hs
+++ b/src/Rahm/Desktop/Keys/Dsl2.hs
@@ -1,13 +1,15 @@
module Rahm.Desktop.Keys.Dsl2 where
import Control.Monad.Fix (fix)
-import Control.Monad.RWS (MonadTrans (lift), MonadWriter, forM_)
+import Control.Monad.RWS (MonadTrans (lift), MonadWriter, forM_, when)
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.Trans.Writer (Writer, WriterT, execWriter, execWriterT, runWriter)
import Control.Monad.Writer.Class (tell)
+import Data.Bits ((.&.))
import Data.Functor.Identity (Identity)
+import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
@@ -26,6 +28,7 @@ data Documented t = Documented
type family Action t where
Action KeySym = X ()
Action Button = Window -> X ()
+ Action () = ()
data XConfigH where
XConfigH :: forall l. XConfig l -> XConfigH
@@ -55,8 +58,12 @@ newtype MaskBinder k a = MaskBinder
)
instance Semigroup BindingsMap where
- (BindingsMap mk1 mb1 _ _) <> (BindingsMap mk2 mb2 fk fb) =
- BindingsMap (mk1 <> mk2) (mb1 <> mb2) fk fb
+ (BindingsMap mk1 mb1 fk1 fb1) <> (BindingsMap mk2 mb2 fk2 fb2) =
+ BindingsMap
+ (mk1 <> mk2)
+ (mb1 <> mb2)
+ (\a -> fk1 a >> fk2 a)
+ (\a b -> fb1 a b >> fb2 a b)
instance Monoid BindingsMap where
mempty = BindingsMap mempty mempty (\_ -> return ()) (\_ _ -> return ())
@@ -158,7 +165,6 @@ resolveBindings (BindingsMap keyBindings buttonBindings _ _) =
\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
@@ -186,37 +192,36 @@ resolveBindings (BindingsMap keyBindings buttonBindings _ _) =
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
+ doSubmap conf (BindingsMap kbind bbind catk catb) after = do
nextPressEvent $
\case
(ButtonPress m b) -> do
- binding <- hoist $ Map.lookup (m, b) bbind
- lift $ do
- win <- pointerWindow
- bindingToWinX conf (undocument binding) win
- after
+ win <- pointerWindow
+ case Map.lookup (m, b) bbind of
+ (Just binding) -> do
+ bindingToWinX conf (undocument binding) win
+ after
+ Nothing -> catb (m, b) win
(KeyPress m k s) -> do
- binding <- hoist $ Map.lookup (m, k) kbind
- lift $ do
- bindingToX conf (undocument binding)
- after
+ case Map.lookup (m, k) kbind of
+ (Just binding) -> do
+ bindingToX conf (undocument binding)
+ after
+ Nothing -> catk (m, k, s)
isRepeatOrSubmap = \case
Repeat {} -> True
Submap {} -> True
_ -> False
- nextPressEvent fn = do
+ nextPressEvent fn = runMaybeT_ $ 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
+ fn ev
subbind :: Binder () -> Binding t
subbind (Binder b) =
@@ -252,3 +257,67 @@ withBindings b config =
{ keys = keyBinds,
mouseBindings = buttonBinds
}
+
+documentation :: XConfig l -> Binder () -> String
+documentation conf binder =
+ documentation' $ runBinder conf binder
+ where
+ documentation' :: BindingsMap -> String
+ documentation' (BindingsMap kmap bmap _ _) = execWriter $ do
+ forM_
+ ( Map.toList $
+ invert $
+ Map.union
+ (Map.map documentBinding (Map.mapKeys keyToStr kmap))
+ (Map.map documentBinding (Map.mapKeys buttonToStr bmap))
+ )
+ $ \(doc, keys) ->
+ when (doc /= "") $ do
+ when (length keys > 1) (tell "\n")
+ tell (intercalate ",\n" keys)
+ tell " -> "
+ tell (tindent doc)
+ when (length keys > 1) (tell "\n")
+
+ documentBinding :: Documented (Binding r) -> String
+ documentBinding = \case
+ (Documented s (Action _)) -> s
+ (Documented s (Submap mp)) ->
+ s ++ "\n" ++ indent (documentation' (mp conf))
+ (Documented s (Repeat _ mp)) ->
+ s ++ " (repeatable)\n" ++ indent (documentation' (mp conf))
+ _ -> ""
+
+ indent = unlines . map (" " ++) . lines
+ tindent (lines -> (h : t)) = unlines (h : map (" " ++) t)
+ tindent x = x
+
+ keyToStr (m, k) = showMask m ++ keysymToString k
+ showMask mask =
+ let masks =
+ [ (shiftMask, "S"),
+ (mod1Mask, "A"),
+ (mod3Mask, "H"),
+ (mod4Mask, "M"),
+ (controlMask, "C")
+ ]
+ in concatMap ((++ "-") . snd) $ filter ((/= 0) . (.&. mask) . fst) masks
+
+ invert :: (Ord a, Ord b) => Map a b -> Map b [a]
+ invert = Map.fromListWith (++) . map (\(a, b) -> (b, [a])) . Map.toList
+
+ buttonToStr (m, b) = showMask m ++ buttonNumToStr b
+ buttonNumToStr = \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
generated by cgit (git 2.34.1) at 2026-02-22 14:16:20 +0000