Customizable keybindings (#1979)

* create a new `SwarmEvent` enumeration
  * define configuration names (`swarmEvents`)
  * define default keybindings (`defaultSwarmBindings`)
* add `KeyConfig` and `KeyDispatcher`s to `AppState`
  * load custom bindings from an INI file
* migrate key event controller code to use `onEvent`
  * call `handleKey` with handlers
* show the shortcuts in TUI
* check for conflicts between parent/child handler (right now `mainHandler` and the rest)
* generate the INI file (`keybinding --init`) with commented-out (`;`) settings
* allow `brick` version 2.4 to get uppercase keybindings fix

---

* Closes #523
* Closes #1962

app/Main.hs

@@ -6,14 +6,18 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Main where
 
+import Control.Monad (when)
 import Data.Foldable qualified
+import Data.Text.IO qualified as T
 import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry)
 import Options.Applicative
 import Swarm.App (appMain)
+import Swarm.Game.ResourceLoading (getSwarmConfigIniFile)
 import Swarm.Language.Format
 import Swarm.Language.LSP (lspMain)
 import Swarm.Language.Parser.Core (LanguageVersion (..))
 import Swarm.TUI.Model (AppOpts (..), ColorMode (..))
+import Swarm.TUI.Model.KeyBindings (KeybindingPrint (..), showKeybindings)
 import Swarm.TUI.Model.UI (defaultInitLgTicksPerSecond)
 import Swarm.Version
 import Swarm.Web (defaultPort)
@@ -30,6 +34,8 @@ commitInfo = case gitInfo of
 
 data CLI
   = Run AppOpts
+  | -- | Print list of bindings, optionally initializing the INI configuration file.
+    ListKeybinding Bool KeybindingPrint
   | Format FormatConfig
   | LSP
   | Version
@@ -41,6 +47,7 @@ cliParser =
         [ command "format" (info (Format <$> parseFormat) (progDesc "Format a file"))
         , command "lsp" (info (pure LSP) (progDesc "Start the LSP"))
         , command "version" (info (pure Version) (progDesc "Get current and upstream version."))
+        , command "keybindings" (info (ListKeybinding <$> initKeybindingConfig <*> printKeyMode <**> helper) (progDesc "List the keybindings"))
         ]
     )
     <|> Run
@@ -73,6 +80,15 @@ cliParser =
   langVer :: Parser LanguageVersion
   langVer = flag SwarmLangLatest SwarmLang0_5 (long "v0.5" <> help "Read (& convert) code from Swarm version 0.5")
 
+  printKeyMode :: Parser KeybindingPrint
+  printKeyMode =
+    flag' IniPrint (long "ini" <> help "Print in INI format")
+      <|> flag' MarkdownPrint (long "markdown" <> help "Print in Markdown table format")
+      <|> pure TextPrint
+
+  initKeybindingConfig :: Parser Bool
+  initKeybindingConfig = switch (short 'i' <> long "init" <> help "Initialise the keybindings configuration file")
+
   parseFormat :: Parser FormatConfig
   parseFormat = FormatConfig <$> input <*> output <*> optional widthOpt <*> langVer <**> helper
 
@@ -125,11 +141,29 @@ showVersion = do
   up <- getNewerReleaseVersion gitInfo
   either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up
 
+printKeybindings :: Bool -> KeybindingPrint -> IO ()
+printKeybindings initialize p = do
+  kb <- showKeybindings p
+  T.putStrLn kb
+  (iniExists, ini) <- getSwarmConfigIniFile
+  when initialize $ do
+    kbi <- showKeybindings IniPrint
+    T.writeFile ini kbi
+  let iniState
+        | iniExists && initialize = "has been updated"
+        | iniExists = "is"
+        | initialize = "has been created"
+        | otherwise = "can be created (--init)"
+  putStrLn $ replicate 80 '-'
+  putStrLn $ "The configuration file " <> iniState <> " at:"
+  putStrLn ini
+
 main :: IO ()
 main = do
   cli <- execParser cliInfo
   case cli of
     Run opts -> appMain opts
+    ListKeybinding initialize p -> printKeybindings initialize p
     Format cfg -> formatSwarmIO cfg
     LSP -> lspMain
     Version -> showVersion

src/swarm-engine/Swarm/Game/Achievement/Persistence.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
 -- Description: Achievements load/save
@@ -18,17 +16,11 @@ import Data.Yaml qualified as Y
 import Swarm.Game.Achievement.Attainment
 import Swarm.Game.Achievement.Definitions
 import Swarm.Game.Failure
-import Swarm.Game.ResourceLoading (getSwarmXdgDataSubdir)
+import Swarm.Game.ResourceLoading (getSwarmAchievementsPath)
 import Swarm.Util.Effect (forMW)
 import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
 import System.FilePath ((</>))
 
--- | Get a path to the directory where achievement records are
---   stored. If the argument is set to @True@, create the directory if
---   it does not exist.
-getSwarmAchievementsPath :: Bool -> IO FilePath
-getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement"
-
 -- | Load saved info about achievements from XDG data directory.
 --   Returns a list of attained achievements.
 loadAchievementsInfo ::

src/swarm-scenario/Swarm/Constant.hs

@@ -15,6 +15,9 @@ import Data.Text (Text)
 -- By convention, all URL constants include trailing slashes
 -- when applicable.
 
+swarmWebIRC :: Text
+swarmWebIRC = "https://web.libera.chat/?channels=#swarm"
+
 -- | The URL for the Swarm repository.
 swarmRepoUrl :: Text
 swarmRepoUrl = "https://github.com/swarm-game/swarm/"

src/swarm-scenario/Swarm/Game/Failure.hs

@@ -40,7 +40,7 @@ data AssetData = AppAsset | NameGeneration | Entities | Terrain | Recipes | Worl
   deriving (Eq, Show)
 
 -- | Overarching enumeration of various assets we can attempt to load.
-data Asset = Achievement | Data AssetData | History | Save
+data Asset = Achievement | Data AssetData | History | Keybindings | Save
   deriving (Eq, Show)
 
 -- | Enumeration type to distinguish between directories and files.

src/swarm-scenario/Swarm/Game/ResourceLoading.hs

@@ -5,7 +5,22 @@
 -- Description: Fetching game data
 --
 -- Various utilities related to loading game data files.
-module Swarm.Game.ResourceLoading where
+module Swarm.Game.ResourceLoading (
+  -- * Generic data access
+  getDataDirSafe,
+  getDataFileNameSafe,
+
+  -- * Concrete data access
+  getSwarmConfigIniFile,
+  getSwarmSavePath,
+  getSwarmHistoryPath,
+  getSwarmAchievementsPath,
+
+  -- ** Loading text files
+  readAppData,
+  NameGenerator (..),
+  initNameGenerator,
+) where
 
 import Control.Algebra (Has)
 import Control.Effect.Lift (Lift, sendIO)
@@ -23,7 +38,7 @@ import Paths_swarm (getDataDir)
 import Swarm.Game.Failure
 import Swarm.Util
 import System.Directory (
-  XdgDirectory (XdgData),
+  XdgDirectory (..),
   createDirectoryIfMissing,
   doesDirectoryExist,
   doesFileExist,
@@ -83,17 +98,11 @@ getDataFileNameSafe asset name = do
     then return fp
     else throwError $ AssetNotLoaded (Data asset) fp $ DoesNotExist File
 
--- | Get a nice message suggesting to download @data@ directory to 'XdgData'.
-dataNotFound :: FilePath -> IO LoadingFailure
-dataNotFound f = do
-  d <- getSwarmXdgDataSubdir False ""
-  let squotes = squote . T.pack
-  return $
-    CustomMessage $
-      T.unlines
-        [ "Could not find the data: " <> squotes f
-        , "Try downloading the Swarm 'data' directory to: " <> squotes (d </> "data")
-        ]
+getSwarmConfigIniFile :: IO (Bool, FilePath)
+getSwarmConfigIniFile = do
+  ini <- (</> "config.ini") <$> getXdgDirectory XdgConfig "swarm"
+  iniExists <- doesFileExist ini
+  return (iniExists, ini)
 
 -- | Get path to swarm data, optionally creating necessary
 --   directories. This could fail if user has bad permissions
@@ -120,6 +129,12 @@ getSwarmSavePath createDirs = getSwarmXdgDataSubdir createDirs "saves"
 getSwarmHistoryPath :: Bool -> IO FilePath
 getSwarmHistoryPath createDirs = getSwarmXdgDataFile createDirs "history"
 
+-- | Get a path to the directory where achievement records are
+--   stored. If the argument is set to @True@, create the directory if
+--   it does not exist.
+getSwarmAchievementsPath :: Bool -> IO FilePath
+getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement"
+
 -- | Read all the @.txt@ files in the @data/@ directory.
 readAppData ::
   (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>