aboutsummaryrefslogtreecommitdiff
path: root/src/Rahm/Desktop/Keys/Dsl.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rahm/Desktop/Keys/Dsl.hs')
-rw-r--r--src/Rahm/Desktop/Keys/Dsl.hs254
1 files changed, 163 insertions, 91 deletions
diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs
index 7f06a74..03ace1b 100644
--- a/src/Rahm/Desktop/Keys/Dsl.hs
+++ b/src/Rahm/Desktop/Keys/Dsl.hs
@@ -1,12 +1,100 @@
--- Domain-specific language for configuring key/button bindings.
-module Rahm.Desktop.Keys.Dsl where
+{-# 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 (void)
import Control.Monad.State (State (..), execState, get, modify')
import Control.Monad.Writer
import Data.Bits ((.&.))
-import Data.List
+import Data.List hiding (group)
import Data.Map (Map)
import qualified Data.Map as Map
import Text.Printf
@@ -28,7 +116,7 @@ data ButtonBinding
-- Window -> X ()
-type ButtonBindings = Map (KeyMask, Button) ButtonBinding
+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)
@@ -57,8 +145,8 @@ class Binding k b where
rawMask :: KeyMask -> k -> BindingBuilder b ()
rawMask m x = BindingBuilder $ modify' (second ((m, toB x) :))
-instance Binding (Window -> X ()) ButtonBinding where
- toB = ButtonAction
+instance Binding (Window -> X ()) (Documented ButtonBinding) where
+ toB = Documented "" . ButtonAction
instance Binding (X ()) (Documented KeyBinding) where
toB = Documented "" . Action
@@ -72,7 +160,19 @@ instance Binding a (Documented a) where
instance Binding a a where
toB = id
-doc :: (Binding k (Documented KeyBinding)) => String -> k -> Documented KeyBinding
+-- 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
@@ -128,7 +228,7 @@ instance Bindable KeySym where
flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values))
instance Bindable Button where
- type BindableValue Button = ButtonBinding
+ type BindableValue Button = Documented ButtonBinding
type BindableMonad Button = ButtonsM
-- bind :: KeySym -> BindingBuilder (Window -> X ()) a -> ButtonsM l ()
@@ -397,75 +497,47 @@ altgrMod = maskMod altgrMask
BindingBuilder b ()
(-|-) fn1 fn2 f = fn1 f >> fn2 f
-{- Meant for submapping, binds all alphanumeric charactes to (fn c). -}
-mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> KeysM l ()
-mapNumbersAndAlpha km fn = do
- mapNumbers km fn
- mapAlpha km fn
-
-{- Meant for submapping. This binds all numbers to (fn x) where x is the number
- - pressed and fn is the function provided. -}
-mapNumbers :: KeyMask -> (Char -> X ()) -> KeysM l ()
-mapNumbers km fn = do
- mapM_
- (\(key, ch) -> bind key $ rawMask km (fn ch))
- [ (xK_0, '0'),
- (xK_1, '1'),
- (xK_2, '2'),
- (xK_3, '3'),
- (xK_4, '4'),
- (xK_5, '5'),
- (xK_6, '6'),
- (xK_7, '7'),
- (xK_8, '8'),
- (xK_9, '9'),
- -- Programmer Dvorak shifts the numbers so I have to map to their unshifted
- -- form.
- (xK_bracketright, '6'),
- (xK_exclam, '8'),
- (xK_bracketleft, '7'),
- (xK_braceleft, '5'),
- (xK_braceright, '3'),
- (xK_parenleft, '1'),
- (xK_equal, '9'),
- (xK_asterisk, '0'),
- (xK_parenright, '2'),
- (xK_plus, '4')
- ]
-
-{- Meant for submapping. This binds all alpha charactes to (fn c) where c is the
- - character pressed and fn is the function provided. -}
-mapAlpha :: KeyMask -> (Char -> X ()) -> KeysM l ()
-mapAlpha km fn =
- mapM_
- (\(key, ch) -> bind key $ rawMask km (fn ch))
- [ (xK_a, 'a'),
- (xK_b, 'b'),
- (xK_c, 'c'),
- (xK_d, 'd'),
- (xK_e, 'e'),
- (xK_f, 'f'),
- (xK_g, 'g'),
- (xK_h, 'h'),
- (xK_i, 'i'),
- (xK_j, 'j'),
- (xK_k, 'k'),
- (xK_l, 'l'),
- (xK_m, 'm'),
- (xK_n, 'n'),
- (xK_o, 'o'),
- (xK_p, 'p'),
- (xK_q, 'q'),
- (xK_r, 'r'),
- (xK_s, 's'),
- (xK_t, 't'),
- (xK_u, 'u'),
- (xK_v, 'v'),
- (xK_w, 'w'),
- (xK_x, 'x'),
- (xK_y, 'y'),
- (xK_z, 'z')
- ]
+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' ""
@@ -494,17 +566,17 @@ documentation = execWriter . document' ""
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])))
+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])))
generated by cgit (git 2.34.1) at 2026-02-22 18:02:36 +0000