mirror of
https://github.com/swarm-game/swarm.git
synced 2024-08-17 02:20:31 +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 $
|
||||
[ 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")
|
||||
]
|
||||
|
@ -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]
|
||||
|
@ -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]
|
||||
|
@ -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.....----........................................
|
||||
|
@ -47,6 +47,7 @@
|
||||
"split"
|
||||
"charat"
|
||||
"tochar"
|
||||
"key"
|
||||
))
|
||||
(x-commands '(
|
||||
"noop"
|
||||
@ -99,6 +100,7 @@
|
||||
"try"
|
||||
"swap"
|
||||
"atomic"
|
||||
"installkeyhandler"
|
||||
"teleport"
|
||||
"as"
|
||||
"robotnamed"
|
||||
|
@ -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"
|
||||
}
|
||||
]
|
||||
},
|
||||
|
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.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
|
||||
-- ----------------------------------------------------------------------------
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
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"
|
||||
, "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))
|
||||
|
@ -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"
|
||||
|
@ -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."
|
||||
|
@ -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 |]
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user