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, 254 insertions, 0 deletions

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
+        }