mirror of
https://github.com/swarm-game/swarm.git
synced 2024-09-11 14:46:33 +03:00
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.
This commit is contained in:
parent
11165df7c0
commit
599225f4d6
@ -70,6 +70,7 @@ cliParser =
|
|||||||
subparser . mconcat $
|
subparser . mconcat $
|
||||||
[ command "recipes" (info (pure RecipeGraph) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes")
|
[ 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 "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 "cheatsheet" (info (CheatSheet <$> address <*> cheatsheet <**> helper) $ progDesc "Output nice Wiki tables")
|
||||||
, command "pedagogy" (info (pure TutorialCoverage) $ progDesc "Output tutorial coverage")
|
, command "pedagogy" (info (pure TutorialCoverage) $ progDesc "Output tutorial coverage")
|
||||||
]
|
]
|
||||||
|
@ -1223,3 +1223,28 @@
|
|||||||
A nanoscale semiconductor particle with a wide range of
|
A nanoscale semiconductor particle with a wide range of
|
||||||
applications.
|
applications.
|
||||||
properties: [portable]
|
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]
|
||||||
|
@ -829,3 +829,14 @@
|
|||||||
- [1, iron plate]
|
- [1, iron plate]
|
||||||
out:
|
out:
|
||||||
- [1, victrola]
|
- [1, victrola]
|
||||||
|
|
||||||
|
- in:
|
||||||
|
- [1, iron plate]
|
||||||
|
out:
|
||||||
|
- [4, key]
|
||||||
|
|
||||||
|
- in:
|
||||||
|
- [1, board]
|
||||||
|
- [16, key]
|
||||||
|
out:
|
||||||
|
- [1, keyboard]
|
||||||
|
@ -157,6 +157,7 @@ robots:
|
|||||||
- counter
|
- counter
|
||||||
- dictionary
|
- dictionary
|
||||||
- grabber
|
- grabber
|
||||||
|
- keyboard
|
||||||
- lambda
|
- lambda
|
||||||
- logger
|
- logger
|
||||||
- mirror
|
- mirror
|
||||||
@ -689,4 +690,4 @@ world:
|
|||||||
................../\.....bbbbbbBBBBBBBBBBBBBBBBBBBBBBB.@..@.@
|
................../\.....bbbbbbBBBBBBBBBBBBBBBBBBBBBBB.@..@.@
|
||||||
........ccc....../--\......bbbbbbbbBBBBBBBBBBBBBBBq@BB.@.@@.@
|
........ccc....../--\......bbbbbbbbBBBBBBBBBBBBBBBq@BB.@.@@.@
|
||||||
......cccccccc..t|ΩMd........bbbbbbbbbbBBBBBBBBBBB@.@.@.@@...
|
......cccccccc..t|ΩMd........bbbbbbbbbbBBBBBBBBBBB@.@.@.@@...
|
||||||
........cccc.....----........................................
|
........cccc.....----........................................
|
||||||
|
@ -47,6 +47,7 @@
|
|||||||
"split"
|
"split"
|
||||||
"charat"
|
"charat"
|
||||||
"tochar"
|
"tochar"
|
||||||
|
"key"
|
||||||
))
|
))
|
||||||
(x-commands '(
|
(x-commands '(
|
||||||
"noop"
|
"noop"
|
||||||
@ -99,6 +100,7 @@
|
|||||||
"try"
|
"try"
|
||||||
"swap"
|
"swap"
|
||||||
"atomic"
|
"atomic"
|
||||||
|
"installkeyhandler"
|
||||||
"teleport"
|
"teleport"
|
||||||
"as"
|
"as"
|
||||||
"robotnamed"
|
"robotnamed"
|
||||||
|
@ -58,7 +58,7 @@
|
|||||||
},
|
},
|
||||||
{
|
{
|
||||||
"name": "keyword.other",
|
"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"
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
},
|
},
|
||||||
|
20
example/multi-key-handler.sw
Normal file
20
example/multi-key-handler.sw
Normal file
@ -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
|
26
example/pilotmode.sw
Normal file
26
example/pilotmode.sw
Normal file
@ -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
|
@ -56,6 +56,7 @@ import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)
|
|||||||
import Swarm.Game.WorldGen (testWorld2Entites)
|
import Swarm.Game.WorldGen (testWorld2Entites)
|
||||||
import Swarm.Language.Capability (Capability)
|
import Swarm.Language.Capability (Capability)
|
||||||
import Swarm.Language.Capability qualified as Capability
|
import Swarm.Language.Capability qualified as Capability
|
||||||
|
import Swarm.Language.Key (specialKeyNames)
|
||||||
import Swarm.Language.Pretty (prettyText)
|
import Swarm.Language.Pretty (prettyText)
|
||||||
import Swarm.Language.Syntax (Const (..))
|
import Swarm.Language.Syntax (Const (..))
|
||||||
import Swarm.Language.Syntax qualified as Syntax
|
import Swarm.Language.Syntax qualified as Syntax
|
||||||
@ -78,6 +79,8 @@ data GenerateDocs where
|
|||||||
RecipeGraph :: GenerateDocs
|
RecipeGraph :: GenerateDocs
|
||||||
-- | Keyword lists for editors.
|
-- | Keyword lists for editors.
|
||||||
EditorKeywords :: Maybe EditorType -> GenerateDocs
|
EditorKeywords :: Maybe EditorType -> GenerateDocs
|
||||||
|
-- | List of special key names recognized by 'key' command
|
||||||
|
SpecialKeyNames :: GenerateDocs
|
||||||
CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs
|
CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs
|
||||||
-- | List command introductions by tutorial
|
-- | List command introductions by tutorial
|
||||||
TutorialCoverage :: GenerateDocs
|
TutorialCoverage :: GenerateDocs
|
||||||
@ -114,6 +117,7 @@ generateDocs = \case
|
|||||||
putStrLn $ replicate 40 '-'
|
putStrLn $ replicate 40 '-'
|
||||||
generateEditorKeywords et
|
generateEditorKeywords et
|
||||||
mapM_ editorGen listEnums
|
mapM_ editorGen listEnums
|
||||||
|
SpecialKeyNames -> generateSpecialKeyNames
|
||||||
CheatSheet address s -> case s of
|
CheatSheet address s -> case s of
|
||||||
Nothing -> error "Not implemented for all Wikis"
|
Nothing -> error "Not implemented for all Wikis"
|
||||||
Just st -> case st of
|
Just st -> case st of
|
||||||
@ -193,6 +197,14 @@ operatorNames = T.intercalate "|" $ map (escape . constSyntax) operators
|
|||||||
c -> T.singleton c
|
c -> T.singleton c
|
||||||
escape = T.concatMap (\c -> if c `elem` special then T.snoc "\\\\" c else slashNotComment 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
|
-- GENERATE TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
|
@ -69,6 +69,7 @@ module Swarm.Game.State (
|
|||||||
replNextValueIndex,
|
replNextValueIndex,
|
||||||
replWorking,
|
replWorking,
|
||||||
replActiveType,
|
replActiveType,
|
||||||
|
inputHandler,
|
||||||
messageQueue,
|
messageQueue,
|
||||||
lastSeenMessageTime,
|
lastSeenMessageTime,
|
||||||
focusedRobotID,
|
focusedRobotID,
|
||||||
@ -400,6 +401,7 @@ data GameState = GameState
|
|||||||
, _needsRedraw :: Bool
|
, _needsRedraw :: Bool
|
||||||
, _replStatus :: REPLStatus
|
, _replStatus :: REPLStatus
|
||||||
, _replNextValueIndex :: Integer
|
, _replNextValueIndex :: Integer
|
||||||
|
, _inputHandler :: Maybe (Text, Value)
|
||||||
, _messageQueue :: Seq LogEntry
|
, _messageQueue :: Seq LogEntry
|
||||||
, _lastSeenMessageTime :: TickNumber
|
, _lastSeenMessageTime :: TickNumber
|
||||||
, _focusedRobotID :: RID
|
, _focusedRobotID :: RID
|
||||||
@ -584,6 +586,9 @@ replStatus :: Lens' GameState REPLStatus
|
|||||||
-- | The index of the next it{index} value
|
-- | The index of the next it{index} value
|
||||||
replNextValueIndex :: Lens' GameState Integer
|
replNextValueIndex :: Lens' GameState Integer
|
||||||
|
|
||||||
|
-- | The currently installed input handler and hint text.
|
||||||
|
inputHandler :: Lens' GameState (Maybe (Text, Value))
|
||||||
|
|
||||||
-- | A queue of global messages.
|
-- | A queue of global messages.
|
||||||
--
|
--
|
||||||
-- Note that we put the newest entry to the right.
|
-- Note that we put the newest entry to the right.
|
||||||
@ -1001,6 +1006,7 @@ initGameState = do
|
|||||||
, _needsRedraw = False
|
, _needsRedraw = False
|
||||||
, _replStatus = REPLDone Nothing
|
, _replStatus = REPLDone Nothing
|
||||||
, _replNextValueIndex = 0
|
, _replNextValueIndex = 0
|
||||||
|
, _inputHandler = Nothing
|
||||||
, _messageQueue = Empty
|
, _messageQueue = Empty
|
||||||
, _lastSeenMessageTime = -1
|
, _lastSeenMessageTime = -1
|
||||||
, _focusedRobotID = 0
|
, _focusedRobotID = 0
|
||||||
@ -1055,6 +1061,7 @@ scenarioToGameState scenario userSeed toRun g = do
|
|||||||
False -> REPLDone Nothing
|
False -> REPLDone Nothing
|
||||||
True -> REPLWorking (Typed Nothing PolyUnit mempty)
|
True -> REPLWorking (Typed Nothing PolyUnit mempty)
|
||||||
, _replNextValueIndex = 0
|
, _replNextValueIndex = 0
|
||||||
|
, _inputHandler = Nothing
|
||||||
, _messageQueue = Empty
|
, _messageQueue = Empty
|
||||||
, _focusedRobotID = baseID
|
, _focusedRobotID = baseID
|
||||||
, _ticks = 0
|
, _ticks = 0
|
||||||
|
@ -79,6 +79,8 @@ import Swarm.Game.Value
|
|||||||
import Swarm.Game.World qualified as W
|
import Swarm.Game.World qualified as W
|
||||||
import Swarm.Language.Capability
|
import Swarm.Language.Capability
|
||||||
import Swarm.Language.Context hiding (delete)
|
import Swarm.Language.Context hiding (delete)
|
||||||
|
import Swarm.Language.Key (parseKeyComboFull)
|
||||||
|
import Swarm.Language.Parse (runParser)
|
||||||
import Swarm.Language.Pipeline
|
import Swarm.Language.Pipeline
|
||||||
import Swarm.Language.Pipeline.QQ (tmQ)
|
import Swarm.Language.Pipeline.QQ (tmQ)
|
||||||
import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText)
|
import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText)
|
||||||
@ -1715,6 +1717,16 @@ execConst c vs s k = do
|
|||||||
Fail -> case vs of
|
Fail -> case vs of
|
||||||
[VText msg] -> return $ Up (User msg) s k
|
[VText msg] -> return $ Up (User msg) s k
|
||||||
_ -> badConst
|
_ -> 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
|
Reprogram -> case vs of
|
||||||
[VRobot childRobotID, VDelay cmd e] -> do
|
[VRobot childRobotID, VDelay cmd e] -> do
|
||||||
r <- get
|
r <- get
|
||||||
@ -2539,6 +2551,9 @@ compareValues v1 = case v1 of
|
|||||||
VRcd m1 -> \case
|
VRcd m1 -> \case
|
||||||
VRcd m2 -> mconcat <$> (zipWithM compareValues `on` M.elems) m1 m2
|
VRcd m2 -> mconcat <$> (zipWithM compareValues `on` M.elems) m1 m2
|
||||||
v2 -> incompatCmp v1 v2
|
v2 -> incompatCmp v1 v2
|
||||||
|
VKey kc1 -> \case
|
||||||
|
VKey kc2 -> return (compare kc1 kc2)
|
||||||
|
v2 -> incompatCmp v1 v2
|
||||||
VClo {} -> incomparable v1
|
VClo {} -> incomparable v1
|
||||||
VCApp {} -> incomparable v1
|
VCApp {} -> incomparable v1
|
||||||
VDef {} -> incomparable v1
|
VDef {} -> incomparable v1
|
||||||
|
@ -143,6 +143,8 @@ data Capability
|
|||||||
CRecord
|
CRecord
|
||||||
| -- | Debug capability.
|
| -- | Debug capability.
|
||||||
CDebug
|
CDebug
|
||||||
|
| -- | Capability to handle keyboard input.
|
||||||
|
CHandleinput
|
||||||
| -- | God-like capabilities. For e.g. commands intended only for
|
| -- | God-like capabilities. For e.g. commands intended only for
|
||||||
-- checking challenge mode win conditions, and not for use by
|
-- checking challenge mode win conditions, and not for use by
|
||||||
-- players.
|
-- players.
|
||||||
@ -232,6 +234,8 @@ constCaps = \case
|
|||||||
Chirp -> Just CDetectdirection
|
Chirp -> Just CDetectdirection
|
||||||
Watch -> Just CWakeself
|
Watch -> Just CWakeself
|
||||||
Heading -> Just COrient
|
Heading -> Just COrient
|
||||||
|
Key -> Just CHandleinput
|
||||||
|
InstallKeyHandler -> Just CHandleinput
|
||||||
-- ----------------------------------------------------------------
|
-- ----------------------------------------------------------------
|
||||||
-- Text operations
|
-- Text operations
|
||||||
Format -> Just CText
|
Format -> Just CText
|
||||||
|
136
src/Swarm/Language/Key.hs
Normal file
136
src/Swarm/Language/Key.hs
Normal file
@ -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)
|
@ -89,6 +89,7 @@ reservedWords =
|
|||||||
, "dir"
|
, "dir"
|
||||||
, "bool"
|
, "bool"
|
||||||
, "actor"
|
, "actor"
|
||||||
|
, "key"
|
||||||
, "cmd"
|
, "cmd"
|
||||||
, "delay"
|
, "delay"
|
||||||
, "let"
|
, "let"
|
||||||
@ -220,6 +221,7 @@ parseTypeAtom =
|
|||||||
<|> TyDir <$ reserved "dir"
|
<|> TyDir <$ reserved "dir"
|
||||||
<|> TyBool <$ reserved "bool"
|
<|> TyBool <$ reserved "bool"
|
||||||
<|> TyActor <$ reserved "actor"
|
<|> TyActor <$ reserved "actor"
|
||||||
|
<|> TyKey <$ reserved "key"
|
||||||
<|> TyCmd <$> (reserved "cmd" *> parseTypeAtom)
|
<|> TyCmd <$> (reserved "cmd" *> parseTypeAtom)
|
||||||
<|> TyDelay <$> braces parseType
|
<|> TyDelay <$> braces parseType
|
||||||
<|> TyRcd <$> brackets (parseRecord (symbol ":" *> parseType))
|
<|> TyRcd <$> brackets (parseRecord (symbol ":" *> parseType))
|
||||||
|
@ -62,6 +62,7 @@ instance PrettyPrec BaseTy where
|
|||||||
prettyPrec _ BText = "text"
|
prettyPrec _ BText = "text"
|
||||||
prettyPrec _ BBool = "bool"
|
prettyPrec _ BBool = "bool"
|
||||||
prettyPrec _ BActor = "actor"
|
prettyPrec _ BActor = "actor"
|
||||||
|
prettyPrec _ BKey = "key"
|
||||||
|
|
||||||
instance PrettyPrec IntVar where
|
instance PrettyPrec IntVar where
|
||||||
prettyPrec _ = pretty . mkVarName "u"
|
prettyPrec _ = pretty . mkVarName "u"
|
||||||
|
@ -85,7 +85,7 @@ module Swarm.Language.Syntax (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Lens (Plated (..), Traversal', makeLenses, (%~), (^.))
|
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.Char qualified as C (toLower)
|
||||||
import Data.Data (Data)
|
import Data.Data (Data)
|
||||||
import Data.Data.Lens (uniplate)
|
import Data.Data.Lens (uniplate)
|
||||||
@ -387,6 +387,12 @@ data Const
|
|||||||
-- that is, no other robots will execute any commands while
|
-- that is, no other robots will execute any commands while
|
||||||
-- the robot is executing @c@.
|
-- the robot is executing @c@.
|
||||||
Atomic
|
Atomic
|
||||||
|
| -- Keyboard input
|
||||||
|
|
||||||
|
-- | Create `key` values.
|
||||||
|
Key
|
||||||
|
| -- | Install a new keyboard input handler.
|
||||||
|
InstallKeyHandler
|
||||||
| -- God-like commands that are omnipresent or omniscient.
|
| -- God-like commands that are omnipresent or omniscient.
|
||||||
|
|
||||||
-- | Teleport a robot to the given position.
|
-- | 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." $
|
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@."
|
[ "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."
|
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."
|
As -> command 2 Intangible "Hypothetically run a command as if you were another robot."
|
||||||
RobotNamed -> command 1 Intangible "Find an actor by name."
|
RobotNamed -> command 1 Intangible "Find an actor by name."
|
||||||
|
@ -619,6 +619,8 @@ inferConst c = case c of
|
|||||||
AppF -> [tyQ| (a -> b) -> a -> b |]
|
AppF -> [tyQ| (a -> b) -> a -> b |]
|
||||||
Swap -> [tyQ| text -> cmd text |]
|
Swap -> [tyQ| text -> cmd text |]
|
||||||
Atomic -> [tyQ| cmd a -> cmd a |]
|
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 |]
|
Teleport -> [tyQ| actor -> (int * int) -> cmd unit |]
|
||||||
As -> [tyQ| actor -> {cmd a} -> cmd a |]
|
As -> [tyQ| actor -> {cmd a} -> cmd a |]
|
||||||
RobotNamed -> [tyQ| text -> cmd actor |]
|
RobotNamed -> [tyQ| text -> cmd actor |]
|
||||||
|
@ -26,6 +26,7 @@ module Swarm.Language.Types (
|
|||||||
pattern TyDir,
|
pattern TyDir,
|
||||||
pattern TyBool,
|
pattern TyBool,
|
||||||
pattern TyActor,
|
pattern TyActor,
|
||||||
|
pattern TyKey,
|
||||||
pattern (:+:),
|
pattern (:+:),
|
||||||
pattern (:*:),
|
pattern (:*:),
|
||||||
pattern (:->:),
|
pattern (:->:),
|
||||||
@ -44,6 +45,7 @@ module Swarm.Language.Types (
|
|||||||
pattern UTyDir,
|
pattern UTyDir,
|
||||||
pattern UTyBool,
|
pattern UTyBool,
|
||||||
pattern UTyActor,
|
pattern UTyActor,
|
||||||
|
pattern UTyKey,
|
||||||
pattern UTySum,
|
pattern UTySum,
|
||||||
pattern UTyProd,
|
pattern UTyProd,
|
||||||
pattern UTyFun,
|
pattern UTyFun,
|
||||||
@ -113,6 +115,8 @@ data BaseTy
|
|||||||
-- in-game name because they could represent other things like
|
-- in-game name because they could represent other things like
|
||||||
-- aliens, animals, seeds, ...
|
-- aliens, animals, seeds, ...
|
||||||
BActor
|
BActor
|
||||||
|
| -- | Keys, i.e. things that can be pressed on the keyboard
|
||||||
|
BKey
|
||||||
deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON)
|
deriving (Eq, Ord, Show, Data, Generic, FromJSON, ToJSON)
|
||||||
|
|
||||||
-- | A "structure functor" encoding the shape of type expressions.
|
-- | A "structure functor" encoding the shape of type expressions.
|
||||||
@ -300,6 +304,9 @@ pattern TyBool = Fix (TyBaseF BBool)
|
|||||||
pattern TyActor :: Type
|
pattern TyActor :: Type
|
||||||
pattern TyActor = Fix (TyBaseF BActor)
|
pattern TyActor = Fix (TyBaseF BActor)
|
||||||
|
|
||||||
|
pattern TyKey :: Type
|
||||||
|
pattern TyKey = Fix (TyBaseF BKey)
|
||||||
|
|
||||||
infixr 5 :+:
|
infixr 5 :+:
|
||||||
|
|
||||||
pattern (:+:) :: Type -> Type -> Type
|
pattern (:+:) :: Type -> Type -> Type
|
||||||
@ -351,6 +358,9 @@ pattern UTyBool = UTerm (TyBaseF BBool)
|
|||||||
pattern UTyActor :: UType
|
pattern UTyActor :: UType
|
||||||
pattern UTyActor = UTerm (TyBaseF BActor)
|
pattern UTyActor = UTerm (TyBaseF BActor)
|
||||||
|
|
||||||
|
pattern UTyKey :: UType
|
||||||
|
pattern UTyKey = UTerm (TyBaseF BKey)
|
||||||
|
|
||||||
pattern UTySum :: UType -> UType -> UType
|
pattern UTySum :: UType -> UType -> UType
|
||||||
pattern UTySum ty1 ty2 = UTerm (TySumF ty1 ty2)
|
pattern UTySum ty1 ty2 = UTerm (TySumF ty1 ty2)
|
||||||
|
|
||||||
|
@ -26,9 +26,9 @@ import Data.Set.Lens (setOf)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Swarm.Language.Context
|
import Swarm.Language.Context
|
||||||
|
import Swarm.Language.Key (KeyCombo, prettyKeyCombo)
|
||||||
import Swarm.Language.Pretty (prettyText)
|
import Swarm.Language.Pretty (prettyText)
|
||||||
import Swarm.Language.Syntax
|
import Swarm.Language.Syntax
|
||||||
import Prelude
|
|
||||||
|
|
||||||
-- | A /value/ is a term that cannot (or does not) take any more
|
-- | A /value/ is a term that cannot (or does not) take any more
|
||||||
-- evaluation steps on its own.
|
-- evaluation steps on its own.
|
||||||
@ -84,6 +84,8 @@ data Value where
|
|||||||
VRef :: Int -> Value
|
VRef :: Int -> Value
|
||||||
-- | A record value.
|
-- | A record value.
|
||||||
VRcd :: Map Var Value -> Value
|
VRcd :: Map Var Value -> Value
|
||||||
|
-- | A keyboard input.
|
||||||
|
VKey :: KeyCombo -> Value
|
||||||
-- | A 'requirements' command awaiting execution.
|
-- | A 'requirements' command awaiting execution.
|
||||||
VRequirements :: Text -> Term -> Env -> Value
|
VRequirements :: Text -> Term -> Env -> Value
|
||||||
deriving (Eq, Show, Generic, FromJSON, ToJSON)
|
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 (VDelay t _) = TDelay SimpleDelay t
|
||||||
valueToTerm (VRef n) = TRef n
|
valueToTerm (VRef n) = TRef n
|
||||||
valueToTerm (VRcd m) = TRcd (Just . valueToTerm <$> m)
|
valueToTerm (VRcd m) = TRcd (Just . valueToTerm <$> m)
|
||||||
|
valueToTerm (VKey kc) = TApp (TConst Key) (TText (prettyKeyCombo kc))
|
||||||
valueToTerm (VRequirements x t _) = TRequirements x t
|
valueToTerm (VRequirements x t _) = TRequirements x t
|
||||||
|
|
||||||
-- | An environment is a mapping from variable names to values.
|
-- | An environment is a mapping from variable names to values.
|
||||||
|
@ -68,7 +68,7 @@ import Graphics.Vty qualified as V
|
|||||||
import Linear
|
import Linear
|
||||||
import Swarm.Game.Achievement.Definitions
|
import Swarm.Game.Achievement.Definitions
|
||||||
import Swarm.Game.Achievement.Persistence
|
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.Entity hiding (empty)
|
||||||
import Swarm.Game.Location
|
import Swarm.Game.Location
|
||||||
import Swarm.Game.ResourceLoading (getSwarmHistoryPath)
|
import Swarm.Game.ResourceLoading (getSwarmHistoryPath)
|
||||||
@ -79,16 +79,17 @@ import Swarm.Game.Step (finishGameTick, gameTick)
|
|||||||
import Swarm.Game.World qualified as W
|
import Swarm.Game.World qualified as W
|
||||||
import Swarm.Language.Capability (Capability (CDebug, CMake))
|
import Swarm.Language.Capability (Capability (CDebug, CMake))
|
||||||
import Swarm.Language.Context
|
import Swarm.Language.Context
|
||||||
|
import Swarm.Language.Key (KeyCombo, mkKeyCombo)
|
||||||
import Swarm.Language.Module
|
import Swarm.Language.Module
|
||||||
import Swarm.Language.Parse (reservedWords)
|
import Swarm.Language.Parse (reservedWords)
|
||||||
import Swarm.Language.Pipeline
|
import Swarm.Language.Pipeline
|
||||||
import Swarm.Language.Pipeline.QQ (tmQ)
|
import Swarm.Language.Pipeline.QQ (tmQ)
|
||||||
import Swarm.Language.Pretty
|
import Swarm.Language.Pretty
|
||||||
import Swarm.Language.Requirement qualified as R
|
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.Typed (Typed (..))
|
||||||
import Swarm.Language.Types
|
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.Controller.Util
|
||||||
import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder)
|
import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder)
|
||||||
import Swarm.TUI.List
|
import Swarm.TUI.List
|
||||||
@ -911,14 +912,58 @@ handleREPLEvent x = do
|
|||||||
controlMode = repl ^. replControlMode
|
controlMode = repl ^. replControlMode
|
||||||
uinput = repl ^. replPromptText
|
uinput = repl ^. replPromptText
|
||||||
case x of
|
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' ->
|
MetaChar 'p' ->
|
||||||
onlyCreative $ do
|
onlyCreative $ do
|
||||||
if T.null uinput
|
curMode <- use $ uiState . uiREPL . replControlMode
|
||||||
then uiState . uiREPL . replControlMode %= cycleEnum
|
case curMode of
|
||||||
else uiState . uiError ?= "Please clear the REPL first."
|
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
|
_ -> case controlMode of
|
||||||
Typing -> handleREPLEventTyping x
|
Typing -> handleREPLEventTyping x
|
||||||
Piloting -> handleREPLEventPiloting 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.
|
-- | Handle a user "piloting" input event for the REPL.
|
||||||
handleREPLEventPiloting :: BrickEvent Name AppEvent -> EventM Name AppState ()
|
handleREPLEventPiloting :: BrickEvent Name AppEvent -> EventM Name AppState ()
|
||||||
@ -953,10 +998,6 @@ handleREPLEventPiloting x = case x of
|
|||||||
-- | Handle a user input event for the REPL.
|
-- | Handle a user input event for the REPL.
|
||||||
handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState ()
|
handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState ()
|
||||||
handleREPLEventTyping = \case
|
handleREPLEventTyping = \case
|
||||||
ControlChar 'c' -> do
|
|
||||||
gameState . baseRobot . machine %= cancel
|
|
||||||
uiState . uiREPL . replPromptType .= CmdPrompt []
|
|
||||||
uiState . uiREPL . replPromptText .= ""
|
|
||||||
Key V.KEnter -> do
|
Key V.KEnter -> do
|
||||||
s <- get
|
s <- get
|
||||||
let topCtx = topContext s
|
let topCtx = topContext s
|
||||||
|
@ -219,10 +219,15 @@ data REPLPrompt
|
|||||||
defaultPrompt :: REPLPrompt
|
defaultPrompt :: REPLPrompt
|
||||||
defaultPrompt = CmdPrompt []
|
defaultPrompt = CmdPrompt []
|
||||||
|
|
||||||
|
-- | What is being done with user input to the REPL panel?
|
||||||
data ReplControlMode
|
data ReplControlMode
|
||||||
= Piloting
|
= -- | The user is typing at the REPL.
|
||||||
| Typing
|
Typing
|
||||||
deriving (Enum, Bounded, Eq)
|
| -- | 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
|
data REPLState = REPLState
|
||||||
{ _replPromptType :: REPLPrompt
|
{ _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
|
gotoEnd = if null ls then id else TZ.moveCursor pos
|
||||||
|
|
||||||
initREPLState :: REPLHistory -> REPLState
|
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
|
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.
|
-- This is used to restore the repl form after the user visited the history.
|
||||||
replLast :: Lens' REPLState Text
|
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
|
replControlMode :: Lens' REPLState ReplControlMode
|
||||||
|
|
||||||
-- | History of things the user has typed at the REPL, interleaved
|
-- | History of things the user has typed at the REPL, interleaved
|
||||||
|
@ -56,7 +56,7 @@ import Data.List.NonEmpty (NonEmpty (..))
|
|||||||
import Data.List.NonEmpty qualified as NE
|
import Data.List.NonEmpty qualified as NE
|
||||||
import Data.List.Split (chunksOf)
|
import Data.List.Split (chunksOf)
|
||||||
import Data.Map qualified as M
|
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.Semigroup (sconcat)
|
||||||
import Data.Sequence qualified as Seq
|
import Data.Sequence qualified as Seq
|
||||||
import Data.Set qualified as Set (toList)
|
import Data.Set qualified as Set (toList)
|
||||||
@ -92,7 +92,7 @@ import Swarm.TUI.Border
|
|||||||
import Swarm.TUI.Inventory.Sorting (renderSortMethod)
|
import Swarm.TUI.Inventory.Sorting (renderSortMethod)
|
||||||
import Swarm.TUI.Model
|
import Swarm.TUI.Model
|
||||||
import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow)
|
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.Model.UI
|
||||||
import Swarm.TUI.Panel
|
import Swarm.TUI.Panel
|
||||||
import Swarm.TUI.View.Achievement
|
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
|
-- | 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.
|
-- between the world panel and the REPL.
|
||||||
--
|
--
|
||||||
-- This excludes the F-key modals that are shown elsewhere.
|
-- This excludes the F-key modals that are shown elsewhere.
|
||||||
@ -734,18 +734,22 @@ drawKeyMenu s =
|
|||||||
hBox
|
hBox
|
||||||
[ vBox
|
[ vBox
|
||||||
[ mkCmdRow globalKeyCmds
|
[ mkCmdRow globalKeyCmds
|
||||||
, padLeft (Pad 2) $ mkCmdRow focusedPanelCmds
|
, padLeft (Pad 2) contextCmds
|
||||||
]
|
]
|
||||||
, gameModeWidget
|
, gameModeWidget
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
mkCmdRow = hBox . map drawPaddedCmd
|
mkCmdRow = hBox . map drawPaddedCmd
|
||||||
drawPaddedCmd = padLeftRight 1 . drawKeyCmd
|
drawPaddedCmd = padLeftRight 1 . drawKeyCmd
|
||||||
|
contextCmds
|
||||||
|
| ctrlMode == Handling = txt $ fromMaybe "" (s ^? gameState . inputHandler . _Just . _1)
|
||||||
|
| otherwise = mkCmdRow focusedPanelCmds
|
||||||
focusedPanelCmds =
|
focusedPanelCmds =
|
||||||
map highlightKeyCmds
|
map highlightKeyCmds
|
||||||
. keyCmdsFor
|
. keyCmdsFor
|
||||||
. focusGetCurrent
|
. focusGetCurrent
|
||||||
$ view (uiState . uiFocusRing) s
|
. view (uiState . uiFocusRing)
|
||||||
|
$ s
|
||||||
|
|
||||||
isReplWorking = s ^. gameState . replWorking
|
isReplWorking = s ^. gameState . replWorking
|
||||||
isPaused = s ^. gameState . paused
|
isPaused = s ^. gameState . paused
|
||||||
@ -758,11 +762,17 @@ drawKeyMenu s =
|
|||||||
inventorySort = s ^. uiState . uiInventorySort
|
inventorySort = s ^. uiState . uiInventorySort
|
||||||
ctrlMode = s ^. uiState . uiREPL . replControlMode
|
ctrlMode = s ^. uiState . uiREPL . replControlMode
|
||||||
canScroll = creative || (s ^. gameState . worldScrollable)
|
canScroll = creative || (s ^. gameState . worldScrollable)
|
||||||
|
handlerInstalled = isJust (s ^. gameState . inputHandler)
|
||||||
|
|
||||||
renderControlModeSwitch :: ReplControlMode -> T.Text
|
renderPilotModeSwitch :: ReplControlMode -> T.Text
|
||||||
renderControlModeSwitch = \case
|
renderPilotModeSwitch = \case
|
||||||
Piloting -> "REPL"
|
Piloting -> "REPL"
|
||||||
Typing -> "pilot"
|
_ -> "pilot"
|
||||||
|
|
||||||
|
renderHandlerModeSwitch :: ReplControlMode -> T.Text
|
||||||
|
renderHandlerModeSwitch = \case
|
||||||
|
Handling -> "REPL"
|
||||||
|
_ -> "key handler"
|
||||||
|
|
||||||
gameModeWidget =
|
gameModeWidget =
|
||||||
padLeft Max
|
padLeft Max
|
||||||
@ -793,7 +803,8 @@ drawKeyMenu s =
|
|||||||
]
|
]
|
||||||
++ [("Enter", "execute") | not isReplWorking]
|
++ [("Enter", "execute") | not isReplWorking]
|
||||||
++ [("^c", "cancel") | isReplWorking]
|
++ [("^c", "cancel") | isReplWorking]
|
||||||
++ [("M-p", renderControlModeSwitch ctrlMode) | creative]
|
++ [("M-p", renderPilotModeSwitch ctrlMode) | creative]
|
||||||
|
++ [("M-k", renderHandlerModeSwitch ctrlMode) | handlerInstalled]
|
||||||
keyCmdsFor (Just (FocusablePanel WorldPanel)) =
|
keyCmdsFor (Just (FocusablePanel WorldPanel)) =
|
||||||
[ ("←↓↑→ / hjkl", "scroll") | canScroll
|
[ ("←↓↑→ / hjkl", "scroll") | canScroll
|
||||||
]
|
]
|
||||||
@ -1165,8 +1176,9 @@ drawREPL s = vBox $ latestHistory <> [currentPrompt] <> mayDebug
|
|||||||
latestHistory :: [Widget n]
|
latestHistory :: [Widget n]
|
||||||
latestHistory = map fmt (getLatestREPLHistoryItems (replHeight - inputLines - debugLines) (repl ^. replHistory))
|
latestHistory = map fmt (getLatestREPLHistoryItems (replHeight - inputLines - debugLines) (repl ^. replHistory))
|
||||||
currentPrompt :: Widget Name
|
currentPrompt :: Widget Name
|
||||||
currentPrompt = case isActive <$> base of
|
currentPrompt = case (isActive <$> base, repl ^. replControlMode) of
|
||||||
Just False -> renderREPLPrompt (s ^. uiState . uiFocusRing) repl
|
(_, Handling) -> padRight Max $ txt "[key handler running, M-k to toggle]"
|
||||||
|
(Just False, _) -> renderREPLPrompt (s ^. uiState . uiFocusRing) repl
|
||||||
_running -> padRight Max $ txt "..."
|
_running -> padRight Max $ txt "..."
|
||||||
inputLines = 1
|
inputLines = 1
|
||||||
debugLines = 3 * fromEnum (s ^. uiState . uiShowDebug)
|
debugLines = 3 * fromEnum (s ^. uiState . uiShowDebug)
|
||||||
|
@ -121,6 +121,7 @@ library
|
|||||||
Swarm.Language.Capability
|
Swarm.Language.Capability
|
||||||
Swarm.Language.Context
|
Swarm.Language.Context
|
||||||
Swarm.Language.Elaborate
|
Swarm.Language.Elaborate
|
||||||
|
Swarm.Language.Key
|
||||||
Swarm.Language.LSP
|
Swarm.Language.LSP
|
||||||
Swarm.Language.LSP.Hover
|
Swarm.Language.LSP.Hover
|
||||||
Swarm.Language.LSP.VarUsage
|
Swarm.Language.LSP.VarUsage
|
||||||
@ -276,7 +277,8 @@ test-suite swarm-unit
|
|||||||
mtl,
|
mtl,
|
||||||
swarm,
|
swarm,
|
||||||
text,
|
text,
|
||||||
witch
|
witch,
|
||||||
|
vty
|
||||||
hs-source-dirs: test/unit
|
hs-source-dirs: test/unit
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -threaded
|
ghc-options: -threaded
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- SPDX-License-Identifier: BSD-3-Clause
|
-- SPDX-License-Identifier: BSD-3-Clause
|
||||||
@ -6,28 +7,86 @@
|
|||||||
-- Swarm command implementation unit tests
|
-- Swarm command implementation unit tests
|
||||||
module TestCommand where
|
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.Game.Location
|
||||||
|
import Swarm.Language.Key
|
||||||
|
import Swarm.Language.Parse (runParser)
|
||||||
import Swarm.Language.Syntax
|
import Swarm.Language.Syntax
|
||||||
|
import Test.QuickCheck qualified as QC
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.HUnit
|
import Test.Tasty.HUnit
|
||||||
|
import Test.Tasty.QuickCheck (testProperty)
|
||||||
|
import Witch
|
||||||
|
|
||||||
testCommands :: TestTree
|
testCommands :: TestTree
|
||||||
testCommands =
|
testCommands =
|
||||||
testGroup
|
testGroup
|
||||||
"Directions"
|
"Command implementations"
|
||||||
[ testGroup
|
[ testGroup
|
||||||
"Relative direction"
|
"Directions"
|
||||||
[ testCase
|
[ testGroup
|
||||||
"West to East"
|
"Relative direction"
|
||||||
$ assertEqual "Incorrect relative dir" (relativeTo DWest DEast) DBack
|
[ testCase
|
||||||
, testCase
|
"West to East"
|
||||||
"South to South"
|
$ assertEqual "Incorrect relative dir" (relativeTo DWest DEast) DBack
|
||||||
$ assertEqual "Incorrect relative dir" (relativeTo DSouth DSouth) DForward
|
, testCase
|
||||||
, testCase
|
"South to South"
|
||||||
"South to West"
|
$ assertEqual "Incorrect relative dir" (relativeTo DSouth DSouth) DForward
|
||||||
$ assertEqual "Incorrect relative dir" (DSouth `relativeTo` DWest) DLeft
|
, testCase
|
||||||
, testCase
|
"South to West"
|
||||||
"West to South"
|
$ assertEqual "Incorrect relative dir" (DSouth `relativeTo` DWest) DLeft
|
||||||
$ assertEqual "Incorrect relative dir" (DWest `relativeTo` DSouth) DRight
|
, 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
|
||||||
|
Loading…
Reference in New Issue
Block a user