aboutsummaryrefslogtreecommitdiff
path: root/src/Rahm/Desktop/Keys
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rahm/Desktop/Keys')
-rw-r--r--src/Rahm/Desktop/Keys/Dsl.hs607
-rw-r--r--src/Rahm/Desktop/Keys/Dsl2.hs254
2 files changed, 254 insertions, 607 deletions
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
+ }
generated by cgit (git 2.34.1) at 2026-02-23 09:16:53 +0000