diff options
| -rw-r--r-- | src/Rahm/Desktop/Keys/Dsl2.hs | 133 |
1 files changed, 99 insertions, 34 deletions
diff --git a/src/Rahm/Desktop/Keys/Dsl2.hs b/src/Rahm/Desktop/Keys/Dsl2.hs index b59152e..bfa8b05 100644 --- a/src/Rahm/Desktop/Keys/Dsl2.hs +++ b/src/Rahm/Desktop/Keys/Dsl2.hs @@ -1,3 +1,23 @@ +-- | This module creates a DSL for binding keys in a succinct and expressive +-- way. This DSL follows the pattern: +-- +-- bind <key> $ do +-- <mask> $ <doc string $?> binding +-- <mask> $ <doc string $?> binding +-- <mask> $ <doc string $?> binding +-- +-- for example: +-- +-- bind xK_x $ do +-- justMod $ doc "Kill the current window" (withFocused X.kill) +-- shiftMod $ doc "Restart xmonad" restart +-- +-- bind xK_v $ do +-- justMod $ +-- continuous $ do +-- bind xK_plus $ doc "increase volume" increaseVolume +-- bind xK_minus $ doc "decrease volume" decreaseVolume + module Rahm.Desktop.Keys.Dsl2 where import Control.Monad.Fix (fix) @@ -20,43 +40,63 @@ import Rahm.Desktop.XMobarLog (spawnXMobar) import Rahm.Desktop.XMobarLog.PendingBuffer (pushAddPendingBuffer, pushPendingBuffer) import XMonad +-- | A documented "thing." It is essentially an item with a string attached to +-- it. A glorified tuple (String, t) data Documented t = Documented { docString :: String, undocument :: t } +-- | The Documented type is a functor. +instance Functor Documented where + fmap fn (Documented s t) = Documented s (fn t) + +-- | Type family for an action associated with a type. This type family +-- indicates what type of action a keytype can be bound to. type family Action t where +-- KeySyms are bound to contextless actions with type X () Action KeySym = X () +-- Buttons are associated with actions with type Window -> X (). In other +-- words, actions bound to a button have windows associated with it. Action Button = Window -> X () - Action () = () +-- | An GADT for XConfig that hides the 'l' parameter. This keeps type +-- signatures clean by not having to carry around a superfluous type variable. data XConfigH where XConfigH :: forall l. XConfig l -> XConfigH +-- | A type for binding. These are the type of bindings keys and buttons can be +-- bound to The type 't' refers to the key-type of the binding: either `KeySym` +-- or `Button`. data Binding t - = Action (Action t) - | Submap (forall l. XConfig l -> BindingsMap) - | Repeat (Binding t) (forall l. XConfig l -> BindingsMap) - | NoBinding - + = -- | Just an action. When this key is pressed, just do some action. + -- This uses the type-family defined above to determine what type the action + -- should be. + Action (Action t) + | -- | Sub-bindings. These bindings require another key to resolve. + Submap (forall l. XConfig l -> BindingsMap) + | -- | Like submap, but these bindings are repeatable. This operates as a + -- self-loop in the keybinding graph. + Repeat (Binding t) (forall l. XConfig l -> BindingsMap) + | -- | No action bound to the key. + NoBinding + +-- | Compiled bindings map. This is the type built up by the Binder monad. data BindingsMap = BindingsMap - { key_bindings :: Map (KeyMask, KeySym) (Documented (Binding KeySym)), + { -- | Bindings for keys + key_bindings :: Map (KeyMask, KeySym) (Documented (Binding KeySym)), + -- | Bindings for buttons. button_bindings :: Map (KeyMask, Button) (Documented (Binding Button)), + -- | If no mapping for a key sym exists, this function is called to handle + -- the no match key. no_match_catch_key :: (KeyMask, KeySym, String) -> X (), + -- | If no mapping for a button exists, this function is called to handle + -- the unbound button. 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 - ) - +-- | BindingMaps are combined by combining the bindings map and combining the +-- handling functio instance Semigroup BindingsMap where (BindingsMap mk1 mb1 fk1 fb1) <> (BindingsMap mk2 mb2 fk2 fb2) = BindingsMap @@ -68,53 +108,64 @@ instance Semigroup BindingsMap where 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 +-- | This type is an intermediate monad in the DSL. It binds an action to a key +-- mask. This is all bound to a key or button in the Binder monad. +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 Documentable a (Documented a) where - toDocumented = Documented "" +-- | The ultimate monad for this DSL. This Binder monad builds up a BindingsMap +newtype Binder a = Binder (WriterT BindingsMap (Reader XConfigH) a) + deriving (Functor, Applicative, Monad, MonadWriter BindingsMap, MonadReader XConfigH) +-- | This typeclas esentiallly defines what types can be bound in the DSL. I.e. +-- what types are allowed to be arguments to the xMod, rawMask, etc. functions. class BindingType a where + -- | What key this action belongs to. type BoundTo a :: * - + -- | Convert the action into a Documented binding toBinding :: a -> Documented (Binding (BoundTo a)) +-- | Bindings are trivially a BindingType. instance BindingType (Binding t) where type BoundTo (Binding t) = t toBinding = Documented "" +-- | An X () can be bound to a Binding KeySym instance BindingType (X ()) where type BoundTo (X ()) = KeySym toBinding = Documented "" . Action +-- | A Window -> X () can be bound to a Binding Button. instance BindingType (Window -> X ()) where type BoundTo (Window -> X ()) = Button toBinding = Documented "" . Action +-- | Any Documented BindingType is also a BindingType. instance (BindingType a) => BindingType (Documented a) where type BoundTo (Documented a) = BoundTo a toBinding (Documented s (toBinding -> (Documented _ a))) = Documented s a +-- | This typeclass is responsible for converting a compiled MaskBinder into a +-- BindingsMap using a key type 'k'. class Bind k where doBinding :: k -> Map KeyMask (Documented (Binding k)) -> BindingsMap rawMaskRaw :: KeyMask -> Documented (Binding k) -> MaskBinder k () +-- | For this, it adds the bindings to the buttonMap instance Bind Button where doBinding but mp = mempty {button_bindings = Map.mapKeys (,but) mp} rawMaskRaw mask act = tell (Map.singleton mask act) +-- | For this, it adds the bindings to the keysMap instance Bind KeySym where doBinding key mp = mempty {key_bindings = Map.mapKeys (,key) mp} rawMaskRaw mask act = tell (Map.singleton mask act) @@ -127,6 +178,7 @@ withMod m act = do (XConfigH (modMask -> mm)) <- ask rawMask (mm .|. m) act +-- | Mask bindings. noMod, justMod, shiftMod, controlMod, altMod :: (Bind (BoundTo a), BindingType a) => a -> MaskBinder (BoundTo a) () justMod = withMod 0 noMod = rawMask 0 @@ -134,6 +186,7 @@ shiftMod = withMod shiftMask controlMod = withMod controlMask altMod = withMod mod1Mask +-- | allows easy assigning multiple masks to the same action. (-|-) :: (Bind (BoundTo a), BindingType a) => (a -> MaskBinder (BoundTo a) ()) -> @@ -142,19 +195,24 @@ altMod = withMod mod1Mask MaskBinder (BoundTo a) () m1 -|- m2 = \act -> m1 act >> m2 act +-- | Bind a key to a maksBinder. bind :: (Bind k) => k -> MaskBinder k () -> Binder () bind k h = tell . doBinding k . runReader (execWriterT $ unMaskBinder h) =<< ask +-- | Bind multiple keys to the same mask binder. bindL :: (Bind k) => [k] -> MaskBinder k () -> Binder () bindL ks h = mapM_ (`bind` h) ks +-- | Convenience function for Documented. doc :: String -> a -> Documented a doc = Documented +-- | A concrete-typed version of 'const' noWindow :: X () -> Window -> X () noWindow fn _ = fn +-- | Turn a BindingsMap into two values usable values for the XMonad config. resolveBindings :: BindingsMap -> ( XConfig l -> Map (KeyMask, KeySym) (X ()), @@ -223,6 +281,7 @@ resolveBindings (BindingsMap keyBindings buttonBindings _ _) = pushAddPendingBuffer (str ++ " ") $ fn ev +-- Create a submap in place of an action. subbind :: Binder () -> Binding t subbind (Binder b) = Submap $ \config -> @@ -321,3 +380,9 @@ documentation conf binder = 14 -> "Index Forward" 15 -> "Index Back" b -> "Button " ++ show b + +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}) |