Compeletely change how KeyBindings are done.

Created new KeysM and ButtonsM monads to make configuring
keybindings and button bindings more readable through a DSL.

Before bindings would just be a giant list, but that
made it difficult to read and repetitive.

Now the syntax follows the pattern

bind key-to-bind
  mask1 : action
  mask2 : action

i.e.

bind xK_a $ do
  justMod  $ doSomeAction a b c
  shiftMod $ doSomeOtherAction a b c

This makes it a lot cleaner to see all the bindings allocated
to a specific key. That way, when adding a new binding,
I can easily see what bindings already exist for that key.

1 files changed, 408 insertions, 0 deletions

diff --git a/src/Internal/KeysM.hs b/src/Internal/KeysM.hs
new file mode 100644
index 0000000..de48bee
--- /dev/null
+++ b/src/Internal/KeysM.hs
@@ -0,0 +1,408 @@
+{-# Language GeneralizedNewtypeDeriving, MultiParamTypeClasses,
+   FunctionalDependencies, FlexibleInstances, TypeFamilies #-}
+module Internal.KeysM where
+
+import Control.Arrow (second)
+import Control.Monad (void)
+import Control.Monad.State (State(..), modify', get, execState)
+import XMonad
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+{- Module that defines a DSL for binding keys. -}
+newtype KeysM l a = KeysM (State (XConfig l, Map (KeyMask, KeySym) (X ())) a)
+  deriving (Functor, Applicative, Monad)
+
+newtype ButtonsM l a = ButtonsM (State (XConfig l, Map (KeyMask, Button) (Window -> X ())) 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 ()
+
+runKeys :: KeysM l a -> XConfig l -> Map (KeyMask, KeySym) (X ())
+runKeys (KeysM stateM) config =
+  snd $ execState stateM (config, Map.empty)
+
+runButtons :: ButtonsM l a -> XConfig l -> Map (KeyMask, Button) (Window -> X ())
+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. -}
+naked :: f -> BindingBuilder f ()
+naked = rawMask 0
+
+rawMask :: KeyMask -> f -> BindingBuilder f ()
+rawMask m x = BindingBuilder $ modify' (second ((m, x):))
+
+maskMod :: KeyMask -> f -> BindingBuilder f ()
+maskMod mask action = do
+  modMask <- fst <$> BindingBuilder get
+  rawMask (modMask .|. mask) action
+
+altMask :: KeyMask
+altMask = mod1Mask
+
+hyperMask :: KeyMask
+hyperMask = mod3Mask
+
+altgrMask :: KeyMask
+altgrMask = mod2Mask
+
+superMask :: KeyMask
+superMask = mod4Mask
+
+justMod :: f -> BindingBuilder f ()
+justMod = maskMod 0
+
+instance Bindable KeySym where
+  type BindableValue KeySym = X ()
+  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 = Window -> X ()
+  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 :: f -> BindingBuilder f ()
+shiftControlAltSuperHyperAltgrMod =
+  maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask)
+
+shiftControlAltSuperHyperMod :: f -> BindingBuilder f ()
+shiftControlAltSuperHyperMod =
+  maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask)
+
+shiftControlAltSuperAltgrMod :: f -> BindingBuilder f ()
+shiftControlAltSuperAltgrMod =
+  maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. altgrMask)
+
+shiftControlAltSuperMod :: f -> BindingBuilder f ()
+shiftControlAltSuperMod =
+  maskMod (shiftMask .|. controlMask .|. altMask .|. superMask)
+
+shiftControlAltHyperAltgrMod :: f -> BindingBuilder f ()
+shiftControlAltHyperAltgrMod =
+  maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask .|. altgrMask)
+
+shiftControlAltHyperMod :: f -> BindingBuilder f ()
+shiftControlAltHyperMod =
+  maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask)
+
+shiftControlAltAltgrMod :: f -> BindingBuilder f ()
+shiftControlAltAltgrMod =
+  maskMod (shiftMask .|. controlMask .|. altMask .|. altgrMask)
+
+shiftControlAltMod :: f -> BindingBuilder f ()
+shiftControlAltMod =
+  maskMod (shiftMask .|. controlMask .|. altMask)
+
+shiftControlSuperHyperAltgrMod :: f -> BindingBuilder f ()
+shiftControlSuperHyperAltgrMod =
+  maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask .|. altgrMask)
+
+shiftControlSuperHyperMod :: f -> BindingBuilder f ()
+shiftControlSuperHyperMod =
+  maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask)
+
+shiftControlSuperAltgrMod :: f -> BindingBuilder f ()
+shiftControlSuperAltgrMod =
+  maskMod (shiftMask .|. controlMask .|. superMask .|. altgrMask)
+
+shiftControlSuperMod :: f -> BindingBuilder f ()
+shiftControlSuperMod =
+  maskMod (shiftMask .|. controlMask .|. superMask)
+
+shiftControlHyperAltgrMod :: f -> BindingBuilder f ()
+shiftControlHyperAltgrMod =
+  maskMod (shiftMask .|. controlMask .|. hyperMask .|. altgrMask)
+
+shiftControlHyperMod :: f -> BindingBuilder f ()
+shiftControlHyperMod =
+  maskMod (shiftMask .|. controlMask .|. hyperMask)
+
+shiftControlAltgrMod :: f -> BindingBuilder f ()
+shiftControlAltgrMod =
+  maskMod (shiftMask .|. controlMask .|. altgrMask)
+
+shiftControlMod :: f -> BindingBuilder f ()
+shiftControlMod =
+  maskMod (shiftMask .|. controlMask)
+
+shiftAltSuperHyperAltgrMod :: f -> BindingBuilder f ()
+shiftAltSuperHyperAltgrMod =
+  maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask)
+
+shiftAltSuperHyperMod :: f -> BindingBuilder f ()
+shiftAltSuperHyperMod =
+  maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask)
+
+shiftAltSuperAltgrMod :: f -> BindingBuilder f ()
+shiftAltSuperAltgrMod =
+  maskMod (shiftMask .|. altMask .|. superMask .|. altgrMask)
+
+shiftAltSuperMod :: f -> BindingBuilder f ()
+shiftAltSuperMod =
+  maskMod (shiftMask .|. altMask .|. superMask)
+
+shiftAltHyperAltgrMod :: f -> BindingBuilder f ()
+shiftAltHyperAltgrMod =
+  maskMod (shiftMask .|. altMask .|. hyperMask .|. altgrMask)
+
+shiftAltHyperMod :: f -> BindingBuilder f ()
+shiftAltHyperMod =
+  maskMod (shiftMask .|. altMask .|. hyperMask)
+
+shiftAltAltgrMod :: f -> BindingBuilder f ()
+shiftAltAltgrMod =
+  maskMod (shiftMask .|. altMask .|. altgrMask)
+
+shiftAltMod :: f -> BindingBuilder f ()
+shiftAltMod =
+  maskMod (shiftMask .|. altMask)
+
+shiftSuperHyperAltgrMod :: f -> BindingBuilder f ()
+shiftSuperHyperAltgrMod =
+  maskMod (shiftMask .|. superMask .|. hyperMask .|. altgrMask)
+
+shiftSuperHyperMod :: f -> BindingBuilder f ()
+shiftSuperHyperMod =
+  maskMod (shiftMask .|. superMask .|. hyperMask)
+
+shiftSuperAltgrMod :: f -> BindingBuilder f ()
+shiftSuperAltgrMod =
+  maskMod (shiftMask .|. superMask .|. altgrMask)
+
+shiftSuperMod :: f -> BindingBuilder f ()
+shiftSuperMod =
+  maskMod (shiftMask .|. superMask)
+
+shiftHyperAltgrMod :: f -> BindingBuilder f ()
+shiftHyperAltgrMod =
+  maskMod (shiftMask .|. hyperMask .|. altgrMask)
+
+shiftHyperMod :: f -> BindingBuilder f ()
+shiftHyperMod =
+  maskMod (shiftMask .|. hyperMask)
+
+shiftAltgrMod :: f -> BindingBuilder f ()
+shiftAltgrMod =
+  maskMod (shiftMask .|. altgrMask)
+
+shiftMod :: f -> BindingBuilder f ()
+shiftMod = maskMod shiftMask
+
+controlAltSuperHyperAltgrMod :: f -> BindingBuilder f ()
+controlAltSuperHyperAltgrMod =
+  maskMod (controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask)
+
+controlAltSuperHyperMod :: f -> BindingBuilder f ()
+controlAltSuperHyperMod =
+  maskMod (controlMask .|. altMask .|. superMask .|. hyperMask)
+
+controlAltSuperAltgrMod :: f -> BindingBuilder f ()
+controlAltSuperAltgrMod =
+  maskMod (controlMask .|. altMask .|. superMask .|. altgrMask)
+
+controlAltSuperMod :: f -> BindingBuilder f ()
+controlAltSuperMod =
+  maskMod (controlMask .|. altMask .|. superMask)
+
+controlAltHyperAltgrMod :: f -> BindingBuilder f ()
+controlAltHyperAltgrMod =
+  maskMod (controlMask .|. altMask .|. hyperMask .|. altgrMask)
+
+controlAltHyperMod :: f -> BindingBuilder f ()
+controlAltHyperMod =
+  maskMod (controlMask .|. altMask .|. hyperMask)
+
+controlAltAltgrMod :: f -> BindingBuilder f ()
+controlAltAltgrMod =
+  maskMod (controlMask .|. altMask .|. altgrMask)
+
+controlAltMod :: f -> BindingBuilder f ()
+controlAltMod =
+  maskMod (controlMask .|. altMask)
+
+controlSuperHyperAltgrMod :: f -> BindingBuilder f ()
+controlSuperHyperAltgrMod =
+  maskMod (controlMask .|. superMask .|. hyperMask .|. altgrMask)
+
+controlSuperHyperMod :: f -> BindingBuilder f ()
+controlSuperHyperMod =
+  maskMod (controlMask .|. superMask .|. hyperMask)
+
+controlSuperAltgrMod :: f -> BindingBuilder f ()
+controlSuperAltgrMod =
+  maskMod (controlMask .|. superMask .|. altgrMask)
+
+controlSuperMod :: f -> BindingBuilder f ()
+controlSuperMod =
+  maskMod (controlMask .|. superMask)
+
+controlHyperAltgrMod :: f -> BindingBuilder f ()
+controlHyperAltgrMod =
+  maskMod (controlMask .|. hyperMask .|. altgrMask)
+
+controlHyperMod :: f -> BindingBuilder f ()
+controlHyperMod =
+  maskMod (controlMask .|. hyperMask)
+
+controlAltgrMod :: f -> BindingBuilder f ()
+controlAltgrMod =
+  maskMod (controlMask .|. altgrMask)
+
+controlMod :: f -> BindingBuilder f ()
+controlMod = maskMod controlMask
+
+altSuperHyperAltgrMod :: f -> BindingBuilder f ()
+altSuperHyperAltgrMod =
+  maskMod (altMask .|. superMask .|. hyperMask .|. altgrMask)
+
+altSuperHyperMod :: f -> BindingBuilder f ()
+altSuperHyperMod =
+  maskMod (altMask .|. superMask .|. hyperMask)
+
+altSuperAltgrMod :: f -> BindingBuilder f ()
+altSuperAltgrMod =
+  maskMod (altMask .|. superMask .|. altgrMask)
+
+altSuperMod :: f -> BindingBuilder f ()
+altSuperMod =
+  maskMod (altMask .|. superMask)
+
+altHyperAltgrMod :: f -> BindingBuilder f ()
+altHyperAltgrMod =
+  maskMod (altMask .|. hyperMask .|. altgrMask)
+
+altHyperMod :: f -> BindingBuilder f ()
+altHyperMod =
+  maskMod (altMask .|. hyperMask)
+
+altAltgrMod :: f -> BindingBuilder f ()
+altAltgrMod =
+  maskMod (altMask .|. altgrMask)
+
+altMod :: f -> BindingBuilder f ()
+altMod = maskMod altMask
+
+superHyperAltgrMod :: f -> BindingBuilder f ()
+superHyperAltgrMod =
+  maskMod (superMask .|. hyperMask .|. altgrMask)
+
+superHyperMod :: f -> BindingBuilder f ()
+superHyperMod =
+  maskMod (superMask .|. hyperMask)
+
+superAltgrMod :: f -> BindingBuilder f ()
+superAltgrMod =
+  maskMod (superMask .|. altgrMask)
+
+superMod :: f -> BindingBuilder f ()
+superMod = maskMod superMask
+
+hyperAltgrMod :: f -> BindingBuilder f ()
+hyperAltgrMod =
+  maskMod (hyperMask .|. altgrMask)
+
+hyperMod :: f -> BindingBuilder f ()
+hyperMod = maskMod hyperMask
+
+altgrMod :: f -> BindingBuilder f ()
+altgrMod = maskMod altgrMask
+
+
+{- 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')
+  ]