Add extensible key map to configuration

src/Termonad/Keys.hs

@@ -3,23 +3,11 @@ module Termonad.Keys where
 
 import Termonad.Prelude
 
-import Control.Lens (imap)
-import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import GI.Gdk
   ( EventKey
-  , pattern KEY_0
-  , pattern KEY_1
-  , pattern KEY_2
-  , pattern KEY_3
-  , pattern KEY_4
-  , pattern KEY_5
-  , pattern KEY_6
-  , pattern KEY_7
-  , pattern KEY_8
-  , pattern KEY_9
   , ModifierType(..)
   , getEventKeyHardwareKeycode
   , getEventKeyIsModifier
@@ -30,9 +18,14 @@ import GI.Gdk
   , getEventKeyType
   )
 
-import Termonad.Term (altNumSwitchTerm)
-import Termonad.Types (TMState, TMWindowId)
-
+import Termonad.Types
+  ( Key(..)
+  , TMState
+  , TMState'(tmStateConfig)
+  , TMWindowId
+  , TMConfig(keys)
+  , toKey
+  )
 
 showKeys :: EventKey -> IO Bool
 showKeys eventKey = do
@@ -56,42 +49,6 @@ showKeys eventKey = do
 
   pure True
 
-data Key = Key
-  { keyVal :: !Word32
-  , keyMods :: !(Set ModifierType)
-  } deriving (Eq, Ord, Show)
-
-toKey :: Word32 -> Set ModifierType -> Key
-toKey = Key
-
-keyMap :: Map Key (TMState -> TMWindowId -> IO Bool)
-keyMap =
-  let numKeys :: [Word32]
-      numKeys =
-        [ KEY_1
-        , KEY_2
-        , KEY_3
-        , KEY_4
-        , KEY_5
-        , KEY_6
-        , KEY_7
-        , KEY_8
-        , KEY_9
-        , KEY_0
-        ]
-      altNumKeys :: [(Key, TMState -> TMWindowId -> IO Bool)]
-      altNumKeys =
-        imap
-          (\i k ->
-             (toKey k [ModifierTypeMod1Mask], stopProp (altNumSwitchTerm i))
-          )
-          numKeys
-  in
-  Map.fromList altNumKeys
-
-stopProp :: (TMState -> TMWindowId -> IO a) -> TMState -> TMWindowId -> IO Bool
-stopProp callback terState tmWinId = callback terState tmWinId $> True
-
 removeStrangeModifiers :: Key -> Key
 removeStrangeModifiers Key{keyVal, keyMods} =
   let reservedModifiers :: Set ModifierType
@@ -121,7 +78,7 @@ handleKeyPress terState tmWindowId eventKey = do
   modifiers <- getEventKeyState eventKey
   let oldKey = toKey keyval (Set.fromList modifiers)
       newKey = removeStrangeModifiers oldKey
-      maybeAction = Map.lookup newKey keyMap
+  maybeAction <- Map.lookup newKey . keys . tmStateConfig <$> readMVar terState
   case maybeAction of
     Just action -> action terState tmWindowId
     Nothing -> pure False

src/Termonad/Preferences/File.hs

@@ -36,9 +36,10 @@ import System.Directory
 import System.FilePath ((</>))
 import Termonad.Types
   ( ConfigOptions
-  , TMConfig(TMConfig, hooks, options)
+  , TMConfig(TMConfig, hooks, options, keys)
   , defaultConfigHooks
   , defaultConfigOptions
+  , keyMap
   )
 
 -- $setup
@@ -74,7 +75,7 @@ tmConfigFromPreferencesFile = do
         hPutStrLn stderr $ "Error parsing file " <> pack confFile <> ": " <> err
         pure defaultConfigOptions
       Right options -> pure options
-  pure TMConfig { options = options, hooks = defaultConfigHooks }
+  pure TMConfig { options = options, hooks = defaultConfigHooks, keys = keyMap }
 
 -- | Read the 'ConfigOptions' out of a configuration file.
 --

src/Termonad/Term.hs

@@ -159,14 +159,6 @@ import Termonad.Types
   , tmWindowNotebook
   )
 
-focusTerm :: Int -> TMState -> TMWindowId -> IO ()
-focusTerm i mvarTMState tmWinId = do
-  note <- getNotebookFromTMState mvarTMState tmWinId
-  notebookSetCurrentPage note (fromIntegral i)
-
-altNumSwitchTerm :: Int -> TMState -> TMWindowId -> IO ()
-altNumSwitchTerm = focusTerm
-
 -- | Change focus to the next tab.
 termNextPage :: TMState -> TMWindowId -> IO ()
 termNextPage mvarTMState tmWinId = do

src/Termonad/Types.hs

@@ -4,16 +4,32 @@ module Termonad.Types where
 
 import Termonad.Prelude
 
-import Control.Lens (ifoldMap)
+import Control.Lens (ifoldMap, imap)
 import Data.FocusList (FocusList, emptyFL, getFocusItemFL, lengthFL)
 import Data.Foldable (toList)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
 import Data.Unique (Unique, hashUnique, newUnique)
 import Data.Yaml
   ( FromJSON(parseJSON)
   , ToJSON(toJSON)
   , Value(String)
   , withText
   )
+import GI.Gdk
+  ( pattern KEY_0
+  , pattern KEY_1
+  , pattern KEY_2
+  , pattern KEY_3
+  , pattern KEY_4
+  , pattern KEY_5
+  , pattern KEY_6
+  , pattern KEY_7
+  , pattern KEY_8
+  , pattern KEY_9
+  , ModifierType(..)
+  )
 import GI.Gtk
   ( Application
   , ApplicationWindow
@@ -25,6 +41,7 @@ import GI.Gtk
   , notebookGetCurrentPage
   , notebookGetNthPage
   , notebookGetNPages
+  , notebookSetCurrentPage
   )
 import GI.Pango (FontDescription, fontDescriptionGetSize, fontDescriptionGetSizeIsAbsolute, pattern SCALE, fontDescriptionGetFamily, fontDescriptionNew, fontDescriptionSetFamily, fontDescriptionSetSize, fontDescriptionSetAbsoluteSize)
 import GI.Vte (Terminal, CursorBlinkMode(..))
@@ -595,7 +612,11 @@ defaultConfigOptions =
 data TMConfig = TMConfig
   { options :: !ConfigOptions
   , hooks :: !ConfigHooks
-  } deriving Show
+  , keys :: Map Key (TMState -> TMWindowId -> IO Bool)
+  }
+
+instance Show TMConfig where
+  show cfg = (show . options) cfg <> (show . hooks) cfg
 
 -- | The default 'TMConfig'.
 --
@@ -605,8 +626,53 @@ defaultTMConfig =
   TMConfig
     { options = defaultConfigOptions
     , hooks = defaultConfigHooks
+    , keys = keyMap
     }
 
+data Key = Key
+  { keyVal :: !Word32
+  , keyMods :: !(Set ModifierType)
+  } deriving (Eq, Ord, Show)
+
+toKey :: Word32 -> Set ModifierType -> Key
+toKey = Key
+
+keyMap :: Map Key (TMState -> TMWindowId -> IO Bool)
+keyMap =
+  let numKeys :: [Word32]
+      numKeys =
+        [ KEY_1
+        , KEY_2
+        , KEY_3
+        , KEY_4
+        , KEY_5
+        , KEY_6
+        , KEY_7
+        , KEY_8
+        , KEY_9
+        , KEY_0
+        ]
+      altNumKeys :: [(Key, TMState -> TMWindowId -> IO Bool)]
+      altNumKeys =
+        imap
+          (\i k ->
+             (toKey k [ModifierTypeMod1Mask], stopProp (altNumSwitchTerm i))
+          )
+          numKeys
+  in
+  Map.fromList altNumKeys
+
+stopProp :: (TMState -> TMWindowId -> IO a) -> TMState -> TMWindowId -> IO Bool
+stopProp callback terState tmWinId = callback terState tmWinId $> True
+
+focusTerm :: Int -> TMState -> TMWindowId -> IO ()
+focusTerm i mvarTMState tmWinId = do
+  note <- getNotebookFromTMState mvarTMState tmWinId
+  notebookSetCurrentPage note (fromIntegral i)
+
+altNumSwitchTerm :: Int -> TMState -> TMWindowId -> IO ()
+altNumSwitchTerm = focusTerm
+
 ---------------------
 -- ConfigHooks --
 ---------------------