Key input handler (#1214)

Ability to code your own input handler routines.  Closes #102 .  Fixes #1210 .

* Adds a new type `key` to represent keypresses
* Adds a primitive function `key : text -> key` which can handle usual letters, numbers, etc. as well as special keys like `"Down"` etc, as well as modifier key prefixes like `key "A-C-Del"`.  `swarm generate keys` generates a list of all recognized special key names.
* New command `installKeyHandler : text -> (key -> cmd unit) -> cmd unit` which sets the "current key handler".  The `text` value is a hint line to display in the secondary key hints menu while the handler is running.  The global shortcut `M-k` toggles the currently installed handler.
* Add a `keyboard` device to provide these commands, as well as a `key` entity (the recipe for a `keyboard` is 16 `key`s + 1 `board`).
* Add a few examples in the `examples` folder.
* Add an installed `keyboard` to the `building-bridges` challenge.

app/Main.hs

@@ -70,6 +70,7 @@ cliParser =
     subparser . mconcat $
       [ command "recipes" (info (pure RecipeGraph) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes")
       , command "editors" (info (EditorKeywords <$> editor <**> helper) $ progDesc "Output editor keywords")
+      , command "keys" (info (pure SpecialKeyNames) $ progDesc "Output list of recognized special key names")
       , command "cheatsheet" (info (CheatSheet <$> address <*> cheatsheet <**> helper) $ progDesc "Output nice Wiki tables")
       , command "pedagogy" (info (pure TutorialCoverage) $ progDesc "Output tutorial coverage")
       ]

data/entities.yaml

@@ -1223,3 +1223,28 @@
     A nanoscale semiconductor particle with a wide range of
     applications.
   properties: [portable]
+
+- name: 'key'
+  display:
+    attr: gold
+    char: 'k'
+  description:
+  - A versatile item, with uses such as opening
+    locked doors, entering input, and retrieving stored values.
+  properties: [portable]
+
+- name: keyboard
+  display:
+    attr: device
+    char: 'K'
+  description:
+  - A small device with multiple keys, adapted for your unique anatomy.
+  - |
+    `installKeyHandler : text -> (key -> cmd unit) -> cmd unit`
+    installs a custom handler function that can be activated to
+    respond to keyboard inputs typed at the REPL.
+  - |
+    `key : text -> key` constructs values of type `key`, for
+    example `key "Down"` or `key "C-S-x"`.
+  properties: [portable]
+  capabilities: [handleinput]

data/recipes.yaml

@@ -829,3 +829,14 @@
   - [1, iron plate]
   out:
   - [1, victrola]
+
+- in:
+  - [1, iron plate]
+  out:
+  - [4, key]
+
+- in:
+  - [1, board]
+  - [16, key]
+  out:
+  - [1, keyboard]

data/scenarios/Challenges/bridge-building.yaml

@@ -157,6 +157,7 @@ robots:
       - counter
       - dictionary
       - grabber
+      - keyboard
       - lambda
       - logger
       - mirror
@@ -689,4 +690,4 @@ world:
     ................../\.....bbbbbbBBBBBBBBBBBBBBBBBBBBBBB.@..@.@
     ........ccc....../--\......bbbbbbbbBBBBBBBBBBBBBBBq@BB.@.@@.@
     ......cccccccc..t|ΩMd........bbbbbbbbbbBBBBBBBBBBB@.@.@.@@...
-    ........cccc.....----........................................
+    ........cccc.....----........................................

editors/emacs/swarm-mode.el

@@ -47,6 +47,7 @@
                "split"
                "charat"
                "tochar"
+               "key"
              ))
              (x-commands '(
                "noop"
@@ -99,6 +100,7 @@
                "try"
                "swap"
                "atomic"
+               "installkeyhandler"
                "teleport"
                "as"
                "robotnamed"

editors/vscode/syntaxes/swarm.tmLanguage.json

@@ -58,7 +58,7 @@
 				},
 				{
 				"name": "keyword.other",
-				"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|noop|wait|selfdestruct|move|turn|grab|harvest|place|give|equip|unequip|make|has|equipped|count|drill|build|salvage|reprogram|say|listen|log|view|appear|create|time|scout|whereami|detect|resonate|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|teleport|as|robotnamed|robotnumbered|knows)\\b"
+				"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|turn|grab|harvest|place|give|equip|unequip|make|has|equipped|count|drill|build|salvage|reprogram|say|listen|log|view|appear|create|time|scout|whereami|detect|resonate|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\\b"
 				}
 			]
 			},

example/multi-key-handler.sw

@@ -0,0 +1,20 @@
+// Proof of concept illustrating the possibility of key
+// handlers that process multi-key sequences.
+
+def cons : a * b -> (a -> b) -> (a -> b) = \p. \k. \a.
+  if (a == fst p) {snd p} {k a}
+end
+
+def nil : a -> cmd unit = \a. return () end
+
+// The delay around the first argument is necessary to prevent
+// infinite recursion
+def handlerB : {key -> cmd unit} -> key -> cmd unit = \hA. \k.
+  cons (key "b", move) nil k;
+  installKeyHandler "" (force hA)
+end
+
+// Typing 'a' then 'b' in sequence will cause the robot to move.
+def handlerA : key -> cmd unit =
+  cons (key "a", installKeyHandler "" (handlerB {handlerA})) nil
+end

example/pilotmode.sw

@@ -0,0 +1,26 @@
+def cons : a * b -> (a -> b) -> (a -> b) = \p. \k. \a.
+  if (a == fst p) {snd p} {k a}
+end
+
+def nil : a -> cmd unit = \a. return () end
+
+// Suitable to use as e.g.
+//   installKeyHandler "(S-)←↓↑→ [Del] [g]rab [h]arvest [d]rill [s]can [b]locked [u]pload" pilot
+def pilot : key -> cmd unit =
+  cons (key "Up",      move) $
+  cons (key "Down",    turn back) $
+  cons (key "Left",    turn left) $
+  cons (key "Right",   turn right) $
+  cons (key "S-Up",    turn north) $
+  cons (key "S-Down",  turn south) $
+  cons (key "S-Left",  turn west) $
+  cons (key "S-Right", turn east) $
+  cons (key "Del",     selfdestruct) $
+  cons (key "g",       res <- grab; log res) $
+  cons (key "h",       res <- harvest; log res) $
+  cons (key "d",       res <- drill forward; case res (\_. return ()) log) $
+  cons (key "s",       res <- scan forward; case res (\_. return ()) log) $
+  cons (key "b",       b <- blocked; if b {log "blocked"} {log "not blocked"}) $
+  cons (key "u",       upload base) $
+  nil
+end

src/Swarm/Doc/Gen.hs

@@ -56,6 +56,7 @@ import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)
 import Swarm.Game.WorldGen (testWorld2Entites)
 import Swarm.Language.Capability (Capability)
 import Swarm.Language.Capability qualified as Capability
+import Swarm.Language.Key (specialKeyNames)
 import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Syntax (Const (..))
 import Swarm.Language.Syntax qualified as Syntax
@@ -78,6 +79,8 @@ data GenerateDocs where
   RecipeGraph :: GenerateDocs
   -- | Keyword lists for editors.
   EditorKeywords :: Maybe EditorType -> GenerateDocs
+  -- | List of special key names recognized by 'key' command
+  SpecialKeyNames :: GenerateDocs
   CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs
   -- | List command introductions by tutorial
   TutorialCoverage :: GenerateDocs
@@ -114,6 +117,7 @@ generateDocs = \case
               putStrLn $ replicate 40 '-'
               generateEditorKeywords et
         mapM_ editorGen listEnums
+  SpecialKeyNames -> generateSpecialKeyNames
   CheatSheet address s -> case s of
     Nothing -> error "Not implemented for all Wikis"
     Just st -> case st of
@@ -193,6 +197,14 @@ operatorNames = T.intercalate "|" $ map (escape . constSyntax) operators
     c -> T.singleton c
   escape = T.concatMap (\c -> if c `elem` special then T.snoc "\\\\" c else slashNotComment c)
 
+-- ----------------------------------------------------------------------------
+-- GENERATE SPECIAL KEY NAMES
+-- ----------------------------------------------------------------------------
+
+generateSpecialKeyNames :: IO ()
+generateSpecialKeyNames =
+  T.putStr . T.unlines . Set.toList $ specialKeyNames
+
 -- ----------------------------------------------------------------------------
 -- GENERATE TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE
 -- ----------------------------------------------------------------------------

src/Swarm/Game/State.hs

@@ -69,6 +69,7 @@ module Swarm.Game.State (
   replNextValueIndex,
   replWorking,
   replActiveType,
+  inputHandler,
   messageQueue,
   lastSeenMessageTime,
   focusedRobotID,
@@ -400,6 +401,7 @@ data GameState = GameState
   , _needsRedraw :: Bool
   , _replStatus :: REPLStatus
   , _replNextValueIndex :: Integer
+  , _inputHandler :: Maybe (Text, Value)
   , _messageQueue :: Seq LogEntry
   , _lastSeenMessageTime :: TickNumber
   , _focusedRobotID :: RID
@@ -584,6 +586,9 @@ replStatus :: Lens' GameState REPLStatus
 -- | The index of the next it{index} value
 replNextValueIndex :: Lens' GameState Integer
 
+-- | The currently installed input handler and hint text.
+inputHandler :: Lens' GameState (Maybe (Text, Value))
+
 -- | A queue of global messages.
 --
 -- Note that we put the newest entry to the right.
@@ -1001,6 +1006,7 @@ initGameState = do
         , _needsRedraw = False
         , _replStatus = REPLDone Nothing
         , _replNextValueIndex = 0
+        , _inputHandler = Nothing
         , _messageQueue = Empty
         , _lastSeenMessageTime = -1
         , _focusedRobotID = 0
@@ -1055,6 +1061,7 @@ scenarioToGameState scenario userSeed toRun g = do
           False -> REPLDone Nothing
           True -> REPLWorking (Typed Nothing PolyUnit mempty)
       , _replNextValueIndex = 0
+      , _inputHandler = Nothing
       , _messageQueue = Empty
       , _focusedRobotID = baseID
       , _ticks = 0

src/Swarm/Game/Step.hs

@@ -79,6 +79,8 @@ import Swarm.Game.Value
 import Swarm.Game.World qualified as W
 import Swarm.Language.Capability
 import Swarm.Language.Context hiding (delete)
+import Swarm.Language.Key (parseKeyComboFull)
+import Swarm.Language.Parse (runParser)
 import Swarm.Language.Pipeline
 import Swarm.Language.Pipeline.QQ (tmQ)
 import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText)
@@ -1715,6 +1717,16 @@ execConst c vs s k = do
     Fail -> case vs of
       [VText msg] -> return $ Up (User msg) s k
       _ -> badConst
+    Key -> case vs of
+      [VText ktxt] -> case runParser parseKeyComboFull ktxt of
+        Right kc -> return $ Out (VKey kc) s k
+        Left _ -> return $ Up (CmdFailed Key (T.unwords ["Unknown key", quote ktxt]) Nothing) s k
+      _ -> badConst
+    InstallKeyHandler -> case vs of
+      [VText hint, handler] -> do
+        inputHandler .= Just (hint, handler)
+        return $ Out VUnit s k
+      _ -> badConst
     Reprogram -> case vs of
       [VRobot childRobotID, VDelay cmd e] -> do
         r <- get
@@ -2539,6 +2551,9 @@ compareValues v1 = case v1 of
   VRcd m1 -> \case
     VRcd m2 -> mconcat <$> (zipWithM compareValues `on` M.elems) m1 m2
     v2 -> incompatCmp v1 v2
+  VKey kc1 -> \case
+    VKey kc2 -> return (compare kc1 kc2)
+    v2 -> incompatCmp v1 v2
   VClo {} -> incomparable v1
   VCApp {} -> incomparable v1
   VDef {} -> incomparable v1

src/Swarm/Language/Capability.hs

@@ -143,6 +143,8 @@ data Capability
     CRecord
   | -- | Debug capability.
     CDebug
+  | -- | Capability to handle keyboard input.
+    CHandleinput
   | -- | God-like capabilities.  For e.g. commands intended only for
     --   checking challenge mode win conditions, and not for use by
     --   players.
@@ -232,6 +234,8 @@ constCaps = \case
   Chirp -> Just CDetectdirection
   Watch -> Just CWakeself
   Heading -> Just COrient
+  Key -> Just CHandleinput
+  InstallKeyHandler -> Just CHandleinput
   -- ----------------------------------------------------------------
   -- Text operations
   Format -> Just CText

src/Swarm/Language/Key.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Parsing and pretty-printing for keys (as in, keys on a keyboard)
+-- and key combos.
+module Swarm.Language.Key (
+  KeyCombo,
+  mkKeyCombo,
+  parseKeyComboFull,
+  parseKeyCombo,
+  prettyKeyCombo,
+  specialKeyNames,
+)
+where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Foldable (asum)
+import Data.List (sort, (\\))
+import Data.Set (Set)
+import Data.Set qualified as S
+import Data.Text (Text)
+import Data.Text qualified as T
+import GHC.Generics hiding (from)
+import Graphics.Vty.Input.Events qualified as V
+import Swarm.Language.Parse
+import Text.Megaparsec
+import Text.Megaparsec.Char (char, string)
+import Text.Megaparsec.Char.Lexer (decimal)
+import Witch (from)
+
+------------------------------------------------------------
+-- Parsing
+
+-- | A keyboard input, represented as a key + modifiers.  Invariant:
+--   the modifier list is always sorted.
+data KeyCombo = KeyCombo V.Key [V.Modifier]
+  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
+
+deriving instance FromJSON V.Key
+deriving instance FromJSON V.Modifier
+deriving instance ToJSON V.Key
+deriving instance ToJSON V.Modifier
+
+-- | Smart constructor for 'KeyCombo'.
+mkKeyCombo :: [V.Modifier] -> V.Key -> KeyCombo
+mkKeyCombo mods k = KeyCombo k (sort mods)
+
+-- | Parse a key combo with nothing after it.
+parseKeyComboFull :: Parser KeyCombo
+parseKeyComboFull = parseKeyCombo <* eof
+
+-- | Parse a key combo like "M-C-F5", "Down", or "C-x".
+parseKeyCombo :: Parser KeyCombo
+parseKeyCombo =
+  mkKeyCombo <$> many (try (parseModifier <* char '-')) <*> parseKey
+
+parseModifier :: Parser V.Modifier
+parseModifier =
+  V.MShift <$ string "S"
+    <|> V.MCtrl <$ string "C"
+    <|> V.MMeta <$ string "M"
+    <|> V.MAlt <$ string "A"
+
+parseKey :: Parser V.Key
+parseKey =
+  -- For an explanation of the 'reverse', see Note [Key names are not prefix-free]
+  (asum . map specialKeyParser . reverse . S.toList $ specialKeyNames)
+    <|> parseFunctionKey
+    <|> parseCharKey
+
+-- Note [Key names are not prefix-free]
+--
+-- The names of special keys are not prefix-free, and in particular
+-- include 'Down', 'DownRight', 'DownLeft', and also 'Up', 'UpRight',
+-- 'UpLeft'.  When we try to parse a particular name with 'string' it
+-- will backtrack as long as the whole string is not consumed, which
+-- means it's OK if key names share a common prefix, like Enter and
+-- Esc.  However, when one key name is a prefix of another we have to
+-- be careful of the order in which we try parsing them, and in
+-- particular we must try parsing the longer one first. If we have
+-- 'Up' come first and then 'UpLeft', for example, given the input
+-- "UpLeft" the 'Up' would succeed, but then the entire parse would
+-- fail since there is input left over.  If we simply reverse the list
+-- of key names (which are sorted alphabetically), it guarantees that
+-- longer names will come before names which are prefixes of them.
+
+parseFunctionKey :: Parser V.Key
+parseFunctionKey = V.KFun <$> try (char 'F' *> decimal)
+
+parseCharKey :: Parser V.Key
+parseCharKey = V.KChar <$> anySingle
+
+specialKeyParser :: Text -> Parser V.Key
+specialKeyParser t = read . ('K' :) . from @Text <$> string t
+
+-- https://stackoverflow.com/questions/51848587/list-constructor-names-using-generics-in-haskell
+specialKeyNames :: Set Text
+specialKeyNames = S.fromList . map T.tail $ (names' @(Rep V.Key) \\ ["KChar", "KFun"])
+
+class Names' (f :: * -> *) where
+  names' :: [Text]
+instance (Names' f) => Names' (M1 D t f) where
+  names' = names' @f
+instance (Names' f, Names' g) => Names' (f :+: g) where
+  names' = names' @f ++ names' @g
+instance (Constructor c) => Names' (C1 c f) where
+  names' = [from @String (conName (undefined :: C1 c f g))]
+
+------------------------------------------------------------
+-- Pretty-printing
+
+-- | Pretty-print a key combo, e.g. "C-M-F5".  Right inverse to
+--   parseKeyCombo.  Left inverse up to reordering of modifiers.
+prettyKeyCombo :: KeyCombo -> Text
+prettyKeyCombo (KeyCombo k mods) = T.append (T.concat (map prettyModifier mods)) (prettyKey k)
+
+prettyModifier :: V.Modifier -> Text
+prettyModifier m = from @String [modifierChar m, '-']
+ where
+  modifierChar = \case
+    V.MAlt -> 'A'
+    V.MCtrl -> 'C'
+    V.MMeta -> 'M'
+    V.MShift -> 'S'
+
+prettyKey :: V.Key -> Text
+prettyKey =
+  from @String . \case
+    V.KChar c -> [c]
+    V.KFun n -> 'F' : show n
+    k -> tail (show k)

src/Swarm/Language/Parse.hs

@@ -89,6 +89,7 @@ reservedWords =
        , "dir"
        , "bool"
        , "actor"
+       , "key"
        , "cmd"
        , "delay"
        , "let"
@@ -220,6 +221,7 @@ parseTypeAtom =
     <|> TyDir <$ reserved "dir"
     <|> TyBool <$ reserved "bool"
     <|> TyActor <$ reserved "actor"
+    <|> TyKey <$ reserved "key"
     <|> TyCmd <$> (reserved "cmd" *> parseTypeAtom)
     <|> TyDelay <$> braces parseType
     <|> TyRcd <$> brackets (parseRecord (symbol ":" *> parseType))

src/Swarm/Language/Pretty.hs

@@ -62,6 +62,7 @@ instance PrettyPrec BaseTy where
   prettyPrec _ BText = "text"
   prettyPrec _ BBool = "bool"
   prettyPrec _ BActor = "actor"
+  prettyPrec _ BKey = "key"
 
 instance PrettyPrec IntVar where
   prettyPrec _ = pretty . mkVarName "u"

src/Swarm/Language/Syntax.hs

@@ -85,7 +85,7 @@ module Swarm.Language.Syntax (
 ) where
 
 import Control.Lens (Plated (..), Traversal', makeLenses, (%~), (^.))
-import Data.Aeson.Types
+import Data.Aeson.Types hiding (Key)
 import Data.Char qualified as C (toLower)
 import Data.Data (Data)
 import Data.Data.Lens (uniplate)
@@ -387,6 +387,12 @@ data Const
     --   that is, no other robots will execute any commands while
     --   the robot is executing @c@.
     Atomic
+  | -- Keyboard input
+
+    -- | Create `key` values.
+    Key
+  | -- | Install a new keyboard input handler.
+    InstallKeyHandler
   | -- God-like commands that are omnipresent or omniscient.
 
     -- | Teleport a robot to the given position.
@@ -739,6 +745,17 @@ constInfo c = case c of
     command 1 Intangible . doc "Execute a block of commands atomically." $
       [ "When executing `atomic c`, a robot will not be interrupted, that is, no other robots will execute any commands while the robot is executing @c@."
       ]
+  Key ->
+    function 1 . doc "Create a key value from a text description." $
+      [ "The key description can optionally start with modifiers like 'C-', 'M-', 'A-', or 'S-', followed by either a regular key, or a special key name like 'Down' or 'End'"
+      , "For example, 'M-C-x', 'Down', or 'S-4'."
+      , "Which key combinations are actually possible to type may vary by keyboard and terminal program."
+      ]
+  InstallKeyHandler ->
+    command 2 Intangible . doc "Install a keyboard input handler." $
+      [ "The first argument is a hint line that will be displayed when the input handler is active."
+      , "The second argument is a function to handle keyboard inputs."
+      ]
   Teleport -> command 2 short "Teleport a robot to the given location."
   As -> command 2 Intangible "Hypothetically run a command as if you were another robot."
   RobotNamed -> command 1 Intangible "Find an actor by name."

src/Swarm/Language/Typecheck.hs

@@ -619,6 +619,8 @@ inferConst c = case c of
   AppF -> [tyQ| (a -> b) -> a -> b |]
   Swap -> [tyQ| text -> cmd text |]
   Atomic -> [tyQ| cmd a -> cmd a |]
+  Key -> [tyQ| text -> key |]
+  InstallKeyHandler -> [tyQ| text -> (key -> cmd unit) -> cmd unit |]
   Teleport -> [tyQ| actor -> (int * int) -> cmd unit |]
   As -> [tyQ| actor -> {cmd a} -> cmd a |]
   RobotNamed -> [tyQ| text -> cmd actor |]

src/Swarm/Language/Types.hs

@@ -26,6 +26,7 @@ module Swarm.Language.Types (
   pattern TyDir,
   pattern TyBool,
   pattern TyActor,
+  pattern TyKey,
   pattern (:+:),
   pattern (:*:),
   pattern (:->:),
@@ -44,6 +45,7 @@ module Swarm.Language.Types (
   pattern UTyDir,
   pattern UTyBool,
   pattern UTyActor,
+  pattern UTyKey,
   pattern UTySum,
   pattern UTyProd,
   pattern UTyFun,
@@ -113,6 +115,8 @@ data BaseTy
     --   in-game name because they could represent other things like
     --   aliens, animals, seeds, ...
     BActor
+  | -- | Keys, i.e. things that can be pressed on the keyboard
+    BKey
   deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON)
 
 -- | A "structure functor" encoding the shape of type expressions.
@@ -300,6 +304,9 @@ pattern TyBool = Fix (TyBaseF BBool)
 pattern TyActor :: Type
 pattern TyActor = Fix (TyBaseF BActor)
 
+pattern TyKey :: Type
+pattern TyKey = Fix (TyBaseF BKey)
+
 infixr 5 :+:
 
 pattern (:+:) :: Type -> Type -> Type
@@ -351,6 +358,9 @@ pattern UTyBool = UTerm (TyBaseF BBool)
 pattern UTyActor :: UType
 pattern UTyActor = UTerm (TyBaseF BActor)
 
+pattern UTyKey :: UType
+pattern UTyKey = UTerm (TyBaseF BKey)
+
 pattern UTySum :: UType -> UType -> UType
 pattern UTySum ty1 ty2 = UTerm (TySumF ty1 ty2)
 

src/Swarm/Language/Value.hs

@@ -26,9 +26,9 @@ import Data.Set.Lens (setOf)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Swarm.Language.Context
+import Swarm.Language.Key (KeyCombo, prettyKeyCombo)
 import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Syntax
-import Prelude
 
 -- | A /value/ is a term that cannot (or does not) take any more
 --   evaluation steps on its own.
@@ -84,6 +84,8 @@ data Value where
   VRef :: Int -> Value
   -- | A record value.
   VRcd :: Map Var Value -> Value
+  -- | A keyboard input.
+  VKey :: KeyCombo -> Value
   -- | A 'requirements' command awaiting execution.
   VRequirements :: Text -> Term -> Env -> Value
   deriving (Eq, Show, Generic, FromJSON, ToJSON)
@@ -119,6 +121,7 @@ valueToTerm (VBind mx c1 c2 _) = TBind mx c1 c2
 valueToTerm (VDelay t _) = TDelay SimpleDelay t
 valueToTerm (VRef n) = TRef n
 valueToTerm (VRcd m) = TRcd (Just . valueToTerm <$> m)
+valueToTerm (VKey kc) = TApp (TConst Key) (TText (prettyKeyCombo kc))
 valueToTerm (VRequirements x t _) = TRequirements x t
 
 -- | An environment is a mapping from variable names to values.

src/Swarm/TUI/Controller.hs

@@ -68,7 +68,7 @@ import Graphics.Vty qualified as V
 import Linear
 import Swarm.Game.Achievement.Definitions
 import Swarm.Game.Achievement.Persistence
-import Swarm.Game.CESK (cancel, emptyStore, initMachine)
+import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec), cancel, emptyStore, initMachine)
 import Swarm.Game.Entity hiding (empty)
 import Swarm.Game.Location
 import Swarm.Game.ResourceLoading (getSwarmHistoryPath)
@@ -79,16 +79,17 @@ import Swarm.Game.Step (finishGameTick, gameTick)
 import Swarm.Game.World qualified as W
 import Swarm.Language.Capability (Capability (CDebug, CMake))
 import Swarm.Language.Context
+import Swarm.Language.Key (KeyCombo, mkKeyCombo)
 import Swarm.Language.Module
 import Swarm.Language.Parse (reservedWords)
 import Swarm.Language.Pipeline
 import Swarm.Language.Pipeline.QQ (tmQ)
 import Swarm.Language.Pretty
 import Swarm.Language.Requirement qualified as R
-import Swarm.Language.Syntax
+import Swarm.Language.Syntax hiding (Key)
 import Swarm.Language.Typed (Typed (..))
 import Swarm.Language.Types
-import Swarm.Language.Value (Value (VUnit), prettyValue, stripVResult)
+import Swarm.Language.Value (Value (VKey, VUnit), prettyValue, stripVResult)
 import Swarm.TUI.Controller.Util
 import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder)
 import Swarm.TUI.List
@@ -911,14 +912,58 @@ handleREPLEvent x = do
       controlMode = repl ^. replControlMode
       uinput = repl ^. replPromptText
   case x of
+    -- Handle Ctrl-c here so we can always cancel the currently running
+    -- base program no matter what REPL control mode we are in.
+    ControlChar 'c' -> do
+      gameState . baseRobot . machine %= cancel
+      uiState . uiREPL . replPromptType .= CmdPrompt []
+      uiState . uiREPL . replPromptText .= ""
+
+    -- Handle M-p and M-k, shortcuts for toggling pilot + key handler modes.
     MetaChar 'p' ->
       onlyCreative $ do
-        if T.null uinput
-          then uiState . uiREPL . replControlMode %= cycleEnum
-          else uiState . uiError ?= "Please clear the REPL first."
+        curMode <- use $ uiState . uiREPL . replControlMode
+        case curMode of
+          Piloting -> uiState . uiREPL . replControlMode .= Typing
+          _ ->
+            if T.null uinput
+              then uiState . uiREPL . replControlMode .= Piloting
+              else uiState . uiError ?= "Please clear the REPL first."
+    MetaChar 'k' -> do
+      when (isJust (s ^. gameState . inputHandler)) $ do
+        curMode <- use $ uiState . uiREPL . replControlMode
+        (uiState . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling
+
+    -- Handle other events in a way appropriate to the current REPL
+    -- control mode.
     _ -> case controlMode of
       Typing -> handleREPLEventTyping x
       Piloting -> handleREPLEventPiloting x
+      Handling -> case x of
+        -- Handle keypresses using the custom installed handler
+        VtyEvent (V.EvKey k mods) -> runInputHandler (mkKeyCombo mods k)
+        -- Handle all other events normally
+        _ -> handleREPLEventTyping x
+
+-- | Run the installed input handler on a key combo entered by the user.
+runInputHandler :: KeyCombo -> EventM Name AppState ()
+runInputHandler kc = do
+  mhandler <- use $ gameState . inputHandler
+  case mhandler of
+    -- Shouldn't be possible to get here if there is no input handler, but
+    -- if we do somehow, just do nothing.
+    Nothing -> return ()
+    Just (_, handler) -> do
+      -- Make sure the base is currently idle; if so, apply the
+      -- installed input handler function to a `key` value
+      -- representing the typed input.
+      working <- use $ gameState . replWorking
+      unless working $ do
+        s <- get
+        let topCtx = topContext s
+            handlerCESK = Out (VKey kc) (topCtx ^. defStore) [FApp handler, FExec]
+        gameState . baseRobot . machine .= handlerCESK
+        gameState %= execState (activateRobot 0)
 
 -- | Handle a user "piloting" input event for the REPL.
 handleREPLEventPiloting :: BrickEvent Name AppEvent -> EventM Name AppState ()
@@ -953,10 +998,6 @@ handleREPLEventPiloting x = case x of
 -- | Handle a user input event for the REPL.
 handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState ()
 handleREPLEventTyping = \case
-  ControlChar 'c' -> do
-    gameState . baseRobot . machine %= cancel
-    uiState . uiREPL . replPromptType .= CmdPrompt []
-    uiState . uiREPL . replPromptText .= ""
   Key V.KEnter -> do
     s <- get
     let topCtx = topContext s

src/Swarm/TUI/Model/Repl.hs

@@ -219,10 +219,15 @@ data REPLPrompt
 defaultPrompt :: REPLPrompt
 defaultPrompt = CmdPrompt []
 
+-- | What is being done with user input to the REPL panel?
 data ReplControlMode
-  = Piloting
-  | Typing
-  deriving (Enum, Bounded, Eq)
+  = -- | The user is typing at the REPL.
+    Typing
+  | -- | The user is driving the base using piloting mode.
+    Piloting
+  | -- | A custom user key handler is processing user input.
+    Handling
+  deriving (Eq, Bounded, Enum)
 
 data REPLState = REPLState
   { _replPromptType :: REPLPrompt
@@ -242,7 +247,16 @@ newREPLEditor t = applyEdit gotoEnd $ editorText REPLInput (Just 1) t
   gotoEnd = if null ls then id else TZ.moveCursor pos
 
 initREPLState :: REPLHistory -> REPLState
-initREPLState = REPLState defaultPrompt (newREPLEditor "") True "" Nothing Typing
+initREPLState hist =
+  REPLState
+    { _replPromptType = defaultPrompt
+    , _replPromptEditor = newREPLEditor ""
+    , _replValid = True
+    , _replLast = ""
+    , _replType = Nothing
+    , _replControlMode = Typing
+    , _replHistory = hist
+    }
 
 makeLensesWith (lensRules & generateSignatures .~ False) ''REPLState
 
@@ -271,7 +285,8 @@ replType :: Lens' REPLState (Maybe Polytype)
 --   This is used to restore the repl form after the user visited the history.
 replLast :: Lens' REPLState Text
 
--- | Piloting or Typing mode
+-- | The current REPL control mode, i.e. how user input to the REPL
+--   panel is being handled.
 replControlMode :: Lens' REPLState ReplControlMode
 
 -- | History of things the user has typed at the REPL, interleaved

src/Swarm/TUI/View.hs

@@ -56,7 +56,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import Data.List.NonEmpty qualified as NE
 import Data.List.Split (chunksOf)
 import Data.Map qualified as M
-import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList)
+import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, maybeToList)
 import Data.Semigroup (sconcat)
 import Data.Sequence qualified as Seq
 import Data.Set qualified as Set (toList)
@@ -92,7 +92,7 @@ import Swarm.TUI.Border
 import Swarm.TUI.Inventory.Sorting (renderSortMethod)
 import Swarm.TUI.Model
 import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow)
-import Swarm.TUI.Model.Repl
+import Swarm.TUI.Model.Repl (lastEntry)
 import Swarm.TUI.Model.UI
 import Swarm.TUI.Panel
 import Swarm.TUI.View.Achievement
@@ -724,7 +724,7 @@ drawModalMenu s = vLimit 1 . hBox $ map (padLeftRight 1 . drawKeyCmd) globalKeyC
       ]
 
 -- | Draw a menu explaining what key commands are available for the
---   current panel.  This menu is displayed as a single line in
+--   current panel.  This menu is displayed as one or two lines in
 --   between the world panel and the REPL.
 --
 -- This excludes the F-key modals that are shown elsewhere.
@@ -734,18 +734,22 @@ drawKeyMenu s =
     hBox
       [ vBox
           [ mkCmdRow globalKeyCmds
-          , padLeft (Pad 2) $ mkCmdRow focusedPanelCmds
+          , padLeft (Pad 2) contextCmds
           ]
       , gameModeWidget
       ]
  where
   mkCmdRow = hBox . map drawPaddedCmd
   drawPaddedCmd = padLeftRight 1 . drawKeyCmd
+  contextCmds
+    | ctrlMode == Handling = txt $ fromMaybe "" (s ^? gameState . inputHandler . _Just . _1)
+    | otherwise = mkCmdRow focusedPanelCmds
   focusedPanelCmds =
     map highlightKeyCmds
       . keyCmdsFor
       . focusGetCurrent
-      $ view (uiState . uiFocusRing) s
+      . view (uiState . uiFocusRing)
+      $ s
 
   isReplWorking = s ^. gameState . replWorking
   isPaused = s ^. gameState . paused
@@ -758,11 +762,17 @@ drawKeyMenu s =
   inventorySort = s ^. uiState . uiInventorySort
   ctrlMode = s ^. uiState . uiREPL . replControlMode
   canScroll = creative || (s ^. gameState . worldScrollable)
+  handlerInstalled = isJust (s ^. gameState . inputHandler)
 
-  renderControlModeSwitch :: ReplControlMode -> T.Text
-  renderControlModeSwitch = \case
+  renderPilotModeSwitch :: ReplControlMode -> T.Text
+  renderPilotModeSwitch = \case
     Piloting -> "REPL"
-    Typing -> "pilot"
+    _ -> "pilot"
+
+  renderHandlerModeSwitch :: ReplControlMode -> T.Text
+  renderHandlerModeSwitch = \case
+    Handling -> "REPL"
+    _ -> "key handler"
 
   gameModeWidget =
     padLeft Max
@@ -793,7 +803,8 @@ drawKeyMenu s =
     ]
       ++ [("Enter", "execute") | not isReplWorking]
       ++ [("^c", "cancel") | isReplWorking]
-      ++ [("M-p", renderControlModeSwitch ctrlMode) | creative]
+      ++ [("M-p", renderPilotModeSwitch ctrlMode) | creative]
+      ++ [("M-k", renderHandlerModeSwitch ctrlMode) | handlerInstalled]
   keyCmdsFor (Just (FocusablePanel WorldPanel)) =
     [ ("←↓↑→ / hjkl", "scroll") | canScroll
     ]
@@ -1165,8 +1176,9 @@ drawREPL s = vBox $ latestHistory <> [currentPrompt] <> mayDebug
   latestHistory :: [Widget n]
   latestHistory = map fmt (getLatestREPLHistoryItems (replHeight - inputLines - debugLines) (repl ^. replHistory))
   currentPrompt :: Widget Name
-  currentPrompt = case isActive <$> base of
-    Just False -> renderREPLPrompt (s ^. uiState . uiFocusRing) repl
+  currentPrompt = case (isActive <$> base, repl ^. replControlMode) of
+    (_, Handling) -> padRight Max $ txt "[key handler running, M-k to toggle]"
+    (Just False, _) -> renderREPLPrompt (s ^. uiState . uiFocusRing) repl
     _running -> padRight Max $ txt "..."
   inputLines = 1
   debugLines = 3 * fromEnum (s ^. uiState . uiShowDebug)

swarm.cabal

@@ -121,6 +121,7 @@ library
                       Swarm.Language.Capability
                       Swarm.Language.Context
                       Swarm.Language.Elaborate
+                      Swarm.Language.Key
                       Swarm.Language.LSP
                       Swarm.Language.LSP.Hover
                       Swarm.Language.LSP.VarUsage
@@ -276,7 +277,8 @@ test-suite swarm-unit
                       mtl,
                       swarm,
                       text,
-                      witch
+                      witch,
+                      vty
     hs-source-dirs:   test/unit
     default-language: Haskell2010
     ghc-options:      -threaded

test/unit/TestCommand.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
@@ -6,28 +7,86 @@
 -- Swarm command implementation unit tests
 module TestCommand where
 
+import Data.Set qualified as S
+import Data.Text (Text)
+import Graphics.Vty.Input.Events qualified as V
 import Swarm.Game.Location
+import Swarm.Language.Key
+import Swarm.Language.Parse (runParser)
 import Swarm.Language.Syntax
+import Test.QuickCheck qualified as QC
 import Test.Tasty
 import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck (testProperty)
+import Witch
 
 testCommands :: TestTree
 testCommands =
   testGroup
-    "Directions"
+    "Command implementations"
     [ testGroup
-        "Relative direction"
-        [ testCase
-            "West to East"
-            $ assertEqual "Incorrect relative dir" (relativeTo DWest DEast) DBack
-        , testCase
-            "South to South"
-            $ assertEqual "Incorrect relative dir" (relativeTo DSouth DSouth) DForward
-        , testCase
-            "South to West"
-            $ assertEqual "Incorrect relative dir" (DSouth `relativeTo` DWest) DLeft
-        , testCase
-            "West to South"
-            $ assertEqual "Incorrect relative dir" (DWest `relativeTo` DSouth) DRight
+        "Directions"
+        [ testGroup
+            "Relative direction"
+            [ testCase
+                "West to East"
+                $ assertEqual "Incorrect relative dir" (relativeTo DWest DEast) DBack
+            , testCase
+                "South to South"
+                $ assertEqual "Incorrect relative dir" (relativeTo DSouth DSouth) DForward
+            , testCase
+                "South to West"
+                $ assertEqual "Incorrect relative dir" (DSouth `relativeTo` DWest) DLeft
+            , testCase
+                "West to South"
+                $ assertEqual "Incorrect relative dir" (DWest `relativeTo` DSouth) DRight
+            ]
+        ]
+    , testGroup
+        "Keys"
+        [ testGroup
+            "Parsing"
+            ( let parseKeyTest input mods k =
+                    assertEqual "" (runParser parseKeyCombo input) (Right (mkKeyCombo mods k))
+               in [ testCase "parse x" $ parseKeyTest "x" [] (V.KChar 'x')
+                  , testCase "parse X" $ parseKeyTest "X" [] (V.KChar 'X')
+                  , testCase "parse C" $ parseKeyTest "C" [] (V.KChar 'C')
+                  , testCase "parse F" $ parseKeyTest "F" [] (V.KChar 'F')
+                  , testCase "parse F3" $ parseKeyTest "F3" [] (V.KFun 3)
+                  , testCase "parse F12" $ parseKeyTest "F12" [] (V.KFun 12)
+                  , testCase "parse Down" $ parseKeyTest "Down" [] V.KDown
+                  , testCase "parse DownLeft" $ parseKeyTest "DownLeft" [] V.KDownLeft
+                  , testCase "parse C-x" $ parseKeyTest "C-x" [V.MCtrl] (V.KChar 'x')
+                  , testCase "parse S-x" $ parseKeyTest "S-x" [V.MShift] (V.KChar 'x')
+                  , testCase "parse A-x" $ parseKeyTest "A-x" [V.MAlt] (V.KChar 'x')
+                  , testCase "parse M-x" $ parseKeyTest "M-x" [V.MMeta] (V.KChar 'x')
+                  , testCase "parse M-C-x" $ parseKeyTest "M-C-x" [V.MCtrl, V.MMeta] (V.KChar 'x')
+                  , testCase "parse C-M-x" $ parseKeyTest "C-M-x" [V.MCtrl, V.MMeta] (V.KChar 'x')
+                  ]
+            )
+        , testGroup
+            "Pretty-printing"
+            [ testProperty
+                "(parse . pretty) key round trip"
+                prop_parse_pretty_key
+            ]
         ]
     ]
+
+instance QC.Arbitrary KeyCombo where
+  arbitrary = mkKeyCombo <$> arbitraryModifiers <*> arbitraryKey
+
+arbitraryKey :: QC.Gen V.Key
+arbitraryKey =
+  QC.frequency $
+    [ (10, V.KChar <$> QC.arbitrary)
+    , (3, V.KFun . QC.getPositive <$> QC.arbitrary)
+    ]
+      ++ map ((1,) . pure . read . ('K' :) . from @Text) (S.toList specialKeyNames)
+
+arbitraryModifiers :: QC.Gen [V.Modifier]
+arbitraryModifiers = QC.sublistOf [V.MAlt, V.MCtrl, V.MMeta, V.MShift]
+
+prop_parse_pretty_key :: KeyCombo -> Bool
+prop_parse_pretty_key kc =
+  runParser parseKeyCombo (prettyKeyCombo kc) == Right kc