From 9270ff8eb957393f49986002c06572b9a6cd954e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= <44544735+xsebek@users.noreply.github.com> Date: Tue, 10 Sep 2024 13:12:48 +0200 Subject: [PATCH] Refactor capabilities (#1553) * add `CExecute Const` * remove all capabilities for constants * update YAML to mention each capability for constant explicitly * uses [`generic-data`](https://hackage.haskell.org/package/generic-data-1.1.0.0/docs/Generic-Data.html#t:FiniteEnumeration) package to get `Enum` and `Bounded` ```Haskell deriving (Enum, Bounded) via (FiniteEnumeration Capability) ``` * closes #1548 * closes #2018 --- data/entities.yaml | 61 ++-- .../Challenges/Ranching/beekeeping.yaml | 2 +- .../Challenges/Ranching/powerset.yaml | 2 +- .../Challenges/Sliding Puzzles/3x3.yaml | 8 +- .../Testing/1218-stride-command.yaml | 2 +- .../Testing/508-capability-subset.yaml | 4 +- src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs | 6 +- src/swarm-engine/Swarm/Game/Exception.hs | 8 +- src/swarm-engine/Swarm/Game/Step.hs | 2 +- src/swarm-engine/Swarm/Game/Step/Const.hs | 6 +- .../Swarm/Game/Step/Util/Command.hs | 6 +- src/swarm-lang/Swarm/Language/Capability.hs | 296 +++--------------- .../Swarm/Language/Requirements/Type.hs | 2 +- .../Swarm/Language/Syntax/Constants.hs | 3 +- src/swarm-scenario/Swarm/Game/Device.hs | 2 +- src/swarm-tui/Swarm/TUI/Model/Event.hs | 26 +- src/swarm-tui/Swarm/TUI/View.hs | 2 +- swarm.cabal | 5 + test/unit/TestRequirements.hs | 5 +- 19 files changed, 127 insertions(+), 321 deletions(-) diff --git a/data/entities.yaml b/data/entities.yaml index aa53ab8a5..c492aa884 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -103,7 +103,7 @@ description: - A medium-sized rock... that looks a little different. It seems to react to iron and surprisingly also to naturally growing bits. properties: [pickable] - capabilities: [negation] + capabilities: [not] - name: beaglepuss display: attr: rubber @@ -361,7 +361,7 @@ in "Number of widgets: " ++ format numWidgets ``` properties: [pickable] - capabilities: [concat] + capabilities: ["++"] - name: caliper display: attr: silver @@ -374,7 +374,7 @@ ``` computes the number of characters in a `Text`{=type} value. properties: [pickable] - capabilities: [charcount] + capabilities: [chars] - name: wedge display: attr: silver @@ -416,7 +416,7 @@ `split : Int -> Text -> Text * Text` splits a `Text`{=type} value into two pieces, one before the given index and one after. properties: [pickable] - capabilities: [format, concat, charcount, split] + capabilities: [format, '++', chars, split] - name: decoder ring display: attr: silver @@ -433,7 +433,7 @@ `toChar : Int -> Text` creates a singleton (length-1) `Text`{=type} value containing a character with the given numeric code. properties: [pickable] - capabilities: [code] + capabilities: [charat, tochar] - name: lambda display: attr: flower @@ -588,7 +588,7 @@ `floorplan : Text -> Cmd (Int * Int)` - Gets the dimensions of a structure template. properties: [pickable] - capabilities: [structure] + capabilities: [structure, floorplan] - name: drill bit display: attr: entity @@ -743,7 +743,7 @@ char: '%' description: - Tank treads work like treads, but are large enough to move even heavy robots around. - capabilities: [move, turn, moveheavy] + capabilities: [move, turn, move heavy robot] properties: [pickable] - name: tape drive display: @@ -791,7 +791,7 @@ char: 'B' description: - Allows one to `scout` for other robots - capabilities: [recondir] + capabilities: [scout] properties: [pickable] - name: welder display: @@ -921,7 +921,7 @@ if (x > 3) {move} {turn right; move} ``` properties: [pickable] - capabilities: [cond] + capabilities: [if, '&&', '||'] - name: detonator display: attr: fire @@ -942,11 +942,20 @@ attr: device char: '$' description: - - "With a scanner device, robots can use the `scan` command to learn about their surroundings. Simply give `scan` a direction in which to scan, and information about the scanned item (if any) will be added to the robot's inventory." - - "A scanner also enables `blocked : Cmd Bool`, which returns a boolean value indicating whether the robot's path is blocked (i.e. whether executing a `move` command would fail); `ishere : Text -> Cmd Bool` for checking whether the current cell contains a particular entity; and `isempty : Cmd Bool` for checking whether the current cell is empty of entities. Note that `ishere` and `isempty` do not detect robots, only entities." - - "Finally, robots can use the `upload` command to copy their accumulated knowledge to another nearby robot; for example, `upload base`." + - | + With a scanner device, robots can use the `scan` command to learn about their surroundings. + Simply give `scan` a direction in which to scan, and information about the scanned item (if any) + will be added to the robot's inventory. + - | + A scanner also enables `blocked : Cmd Bool`, which returns a boolean value indicating whether the robot's path is blocked + (i.e. whether executing a `move` command would fail); `ishere : Text -> Cmd Bool` for checking whether the current cell + contains a particular entity; and `isempty : Cmd Bool` for checking whether the current cell is empty of entities. + Note that `ishere` and `isempty` do not detect robots, only entities." + - | + Finally, robots can use the `upload` command to copy their accumulated knowledge to another nearby robot; + for example, `upload base`." properties: [pickable] - capabilities: [scan, sensefront, sensehere] + capabilities: [scan, blocked, ishere, isempty, upload] - name: olfactometer display: char: 'N' @@ -955,7 +964,7 @@ - | `sniff : Text -> Cmd Int` returns the distance to the nearest specified entity. properties: [pickable] - capabilities: [detectdistance] + capabilities: [sniff] - name: flash memory display: attr: device @@ -975,7 +984,7 @@ - "A mirror enables the `whoami` command, which returns the robot's name as a string." - "It also enables the special `self` variable, which gives a robot a reference to itself." properties: [pickable] - capabilities: [whoami] + capabilities: [whoami, self] - name: logger display: attr: device @@ -1019,7 +1028,7 @@ description: - "A calculator allows a robot to do basic arithmetic calculations: addition, subtraction, multiplication, division, and exponentiation." properties: [pickable] - capabilities: [arith] + capabilities: ['+', '-', neg, '*', '/', '^'] - name: ADT calculator display: attr: device @@ -1052,7 +1061,7 @@ example, `case (inl 3) (\x. 2*x) (\y. 3*y) == 6`, and `case (inr 3) (\x. 2*x) (\y. 3*y) == 9`. properties: [pickable] - capabilities: [arith, sum, prod] + capabilities: ['+', '-', neg, '*', '/', '^', sum, prod] - name: hyperloop display: attr: device @@ -1067,7 +1076,7 @@ `t = T(t)`{=snippet}. For exmple, `rec l. Unit + Int * l`{=type} is the type of lists of integers. properties: [pickable] - capabilities: [arith, sum, prod, rectype] + capabilities: ['+', '-', neg, '*', '/', '^', sum, prod, rectype] - name: compass display: attr: device @@ -1085,7 +1094,7 @@ - | `d <- heading; turn east; move; turn d` properties: [pickable] - capabilities: [orient] + capabilities: [orient, heading] - name: clock display: attr: device @@ -1097,7 +1106,7 @@ - | `wait : Int -> Cmd Unit` causes a robot to sleep for a specified amount of time (measured in game ticks). properties: [pickable] - capabilities: [timeabs, timerel] + capabilities: [time, wait] - name: hourglass display: attr: device @@ -1107,7 +1116,7 @@ - | `wait : Int -> Cmd Unit` causes a robot to sleep for a specified amount of time (measured in game ticks). properties: [pickable] - capabilities: [timerel] + capabilities: [wait] - name: rolex display: char: R @@ -1118,7 +1127,7 @@ `watch : Dir -> Cmd Unit` will mark an adjacent (in the specified direction) location of interest to monitor for placement or removal of items. A subsequent call to `wait` will be interrupted upon a change to the location. properties: [pickable] - capabilities: [timerel, wakeself] + capabilities: [time, wait, watch] - name: comparator display: attr: device @@ -1127,7 +1136,7 @@ - "A comparator allows comparing two values to see whether the first is less, equal, or greater than the second." - "Valid comparison operators are <, <=, >, >=, ==, and !=." properties: [pickable] - capabilities: [compare] + capabilities: ['<', '<=', '>', '>=', '==', '!='] - name: I/O cable display: attr: device @@ -1186,7 +1195,7 @@ `meetAll : Cmd (rec l. Unit + Actor * l)` returns a list of all the nearby actors other than oneself. properties: [pickable] - capabilities: [meet] + capabilities: [meet, meetAll] - name: GPS receiver display: attr: device @@ -1197,7 +1206,7 @@ some convenient satellite signals, enabling the command `whereami : Cmd (Int * Int)`. properties: [pickable] - capabilities: [senseloc] + capabilities: [whereami] - name: tweezers display: attr: device @@ -1259,7 +1268,7 @@ `key : Text -> Key` constructs values of type `Key`{=type}, for example `key "Down"` or `key "C-S-x"`. properties: [pickable] - capabilities: [handleinput] + capabilities: [key, installKeyHandler] - name: halting oracle display: attr: device diff --git a/data/scenarios/Challenges/Ranching/beekeeping.yaml b/data/scenarios/Challenges/Ranching/beekeeping.yaml index 4625126ce..fb2e924fd 100644 --- a/data/scenarios/Challenges/Ranching/beekeeping.yaml +++ b/data/scenarios/Challenges/Ranching/beekeeping.yaml @@ -193,7 +193,7 @@ entities: description: - Senses direction to nectar-producing flowers properties: [known, pickable] - capabilities: [detectdirection, structure] + capabilities: [chirp, structure] - name: honey display: char: 'h' diff --git a/data/scenarios/Challenges/Ranching/powerset.yaml b/data/scenarios/Challenges/Ranching/powerset.yaml index e777dc5a7..7b8ff63e5 100644 --- a/data/scenarios/Challenges/Ranching/powerset.yaml +++ b/data/scenarios/Challenges/Ranching/powerset.yaml @@ -99,7 +99,7 @@ entities: description: - Allows one to `stride` across multiple cells properties: [known, pickable] - capabilities: [movemultiple] + capabilities: [stride] - name: bell display: char: 'B' diff --git a/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml b/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml index 0854182d1..5c5e2f8f2 100644 --- a/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml +++ b/data/scenarios/Challenges/Sliding Puzzles/3x3.yaml @@ -157,16 +157,16 @@ entities: display: char: 'G' description: - - Generates a magnetic field gradient that allows the use of `resonate` + - Generates a magnetic field gradient that allows the use of `resonate` and `density`. properties: [known] - capabilities: [detectcount] + capabilities: [resonate, density] - name: locator display: char: '{' description: - - Enables the `detect` command + - Enables the `detect` command. properties: [known] - capabilities: [detectloc] + capabilities: [detect] - name: border display: char: '▒' diff --git a/data/scenarios/Testing/1218-stride-command.yaml b/data/scenarios/Testing/1218-stride-command.yaml index 368611605..f741fe5b3 100644 --- a/data/scenarios/Testing/1218-stride-command.yaml +++ b/data/scenarios/Testing/1218-stride-command.yaml @@ -75,7 +75,7 @@ entities: description: - Allows one to "stride" across multiple cells properties: [known, pickable] - capabilities: [movemultiple] + capabilities: [stride] known: [tree, flower, boulder, water] world: palette: diff --git a/data/scenarios/Testing/508-capability-subset.yaml b/data/scenarios/Testing/508-capability-subset.yaml index 8e77e4868..3e6b86010 100644 --- a/data/scenarios/Testing/508-capability-subset.yaml +++ b/data/scenarios/Testing/508-capability-subset.yaml @@ -61,7 +61,7 @@ entities: description: - A satellite navigation device. properties: [known, pickable] - capabilities: [senseloc] + capabilities: [whereami] - name: Tardis display: attr: water @@ -69,4 +69,4 @@ entities: description: - Bigger on the inside. properties: [known, pickable] - capabilities: [senseloc, teleport] + capabilities: [whereami, teleport] diff --git a/src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs b/src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs index 17d7a58fb..9db17ed77 100644 --- a/src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs +++ b/src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs @@ -188,7 +188,11 @@ capabilityTable a em cs = T.unlines $ header <> map (listToRow mw) capabilityRow header = [listToRow mw capabilityHeader, separatingLine mw] capabilityPage :: PageAddress -> EntityMap -> Text -capabilityPage a em = capabilityTable a em enumerate +capabilityPage a em = capabilityTable a em $ filter usedCapability enumerate + where + usedCapability c = case c of + Capability.CExecute con -> Capability.constCaps con == Just c + _ -> True -- ** Entities diff --git a/src/swarm-engine/Swarm/Game/Exception.hs b/src/swarm-engine/Swarm/Game/Exception.hs index 976e0a62b..487f0f04d 100644 --- a/src/swarm-engine/Swarm/Game/Exception.hs +++ b/src/swarm-engine/Swarm/Game/Exception.hs @@ -142,8 +142,8 @@ formatIncapableFix = \case -- >>> import Swarm.Game.Failure (LoadingFailure) -- >>> import qualified Data.Set as S -- >>> :set -XTypeApplications --- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" mempty mempty (S.singleton CAppear) --- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" mempty mempty (S.singleton CAppear) +-- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" mempty mempty (S.singleton $ CExecute Appear) +-- >>> r = mkEntity (defaultEntityDisplay 'o') "the one ring" mempty mempty (S.singleton $ CExecute Appear) -- >>> m = fromRight mempty . run . runThrow @LoadingFailure $ buildEntityMap [w,r] -- >>> incapableError cs t = putStr . unpack $ formatIncapable m FixByEquip cs t -- @@ -152,13 +152,13 @@ formatIncapableFix = \case -- 'as' -- If God in troth thou wantest to play, try thou a Creative game. -- --- >>> incapableError (R.singletonCap CAppear) (TConst Appear) +-- >>> incapableError (R.singletonCap $ CExecute Appear) (TConst Appear) -- You do not have the device required for: -- 'appear' -- Please equip: -- - magic wand or the one ring -- --- >>> incapableError (R.singletonCap CRandom) (TConst Random) +-- >>> incapableError (R.singletonCap $ CExecute Random) (TConst Random) -- Missing the random capability for: -- 'random' -- but no device yet provides it. See diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs index 266c7cae0..5fd0eaf7b 100644 --- a/src/swarm-engine/Swarm/Game/Step.hs +++ b/src/swarm-engine/Swarm/Game/Step.hs @@ -837,7 +837,7 @@ stepCESK cesk = case cesk of -- -- HOWEVER, we have to make sure to check that the robot has the -- 'log' capability which is required to collect and view logs. - h <- hasCapability CLog + h <- hasCapability $ CExecute Log em <- use $ landscape . terrainAndEntities . entityMap when h $ void $ traceLog RobotError (exnSeverity exn) (formatExn em exn) return $ case menv of diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index 9c5377e97..36f96b532 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -778,8 +778,8 @@ execConst runChildProg c vs s k = do let addToRobotLog :: (Has (State GameState) sgn m) => Robot -> m () addToRobotLog r = do maybeRidLoc <- evalState r $ do - hasLog <- hasCapability CLog - hasListen <- hasCapability CListen + hasLog <- hasCapability $ CExecute Log + hasListen <- hasCapability $ CExecute Listen loc' <- use robotLocation rid <- use robotID return $ do @@ -1258,7 +1258,7 @@ execConst runChildProg c vs s k = do doDrill d = do ins <- use equippedDevices - let equippedDrills = extantElemsWithCapability CDrill ins + let equippedDrills = extantElemsWithCapability (CExecute Drill) ins -- Heuristic: choose the drill with the more elaborate name. -- E.g. "metal drill" vs. "drill" preferredDrill = listToMaybe $ sortOn (Down . T.length . (^. entityName)) equippedDrills diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs index 88486fa3c..a6dd19d87 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs @@ -269,11 +269,11 @@ grantAchievement a = do -- be other exceptions added in the future. constCapsFor :: Const -> Robot -> Maybe Capability constCapsFor Move r - | r ^. robotHeavy = Just CMoveheavy + | r ^. robotHeavy = Just CMoveHeavy constCapsFor Backup r - | r ^. robotHeavy = Just CMoveheavy + | r ^. robotHeavy = Just CMoveHeavy constCapsFor Stride r - | r ^. robotHeavy = Just CMoveheavy + | r ^. robotHeavy = Just CMoveHeavy constCapsFor c _ = constCaps c -- | Requires that the target location is within one cell. diff --git a/src/swarm-lang/Swarm/Language/Capability.hs b/src/swarm-lang/Swarm/Language/Capability.hs index a9f80d390..99f242abd 100644 --- a/src/swarm-lang/Swarm/Language/Capability.hs +++ b/src/swarm-lang/Swarm/Language/Capability.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -11,6 +12,7 @@ module Swarm.Language.Capability ( Capability (..), capabilityName, + parseCapability, constCaps, constByCaps, ) where @@ -19,7 +21,9 @@ import Control.Arrow ((&&&)) import Data.Aeson (FromJSONKey, ToJSONKey) import Data.Char (toLower) import Data.Data (Data) +import Data.Foldable (find) import Data.Hashable (Hashable) +import Data.List.Extra (enumerate) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Maybe (mapMaybe) @@ -28,151 +32,30 @@ import Data.Text qualified as T import Data.Tuple (swap) import Data.Yaml import GHC.Generics (Generic) -import Swarm.Language.Syntax.Constants (Const (..), allConst) +import Generic.Data (FiniteEnumeration (..)) +import Swarm.Language.Syntax.Constants (Const (..), allConst, constInfo, syntax) import Swarm.Util (binTuples, failT) -import Text.Read (readMaybe) import Witch (from) import Prelude hiding (lookup) -- | Various capabilities which robots can have. data Capability - = -- | Be powered, i.e. execute anything at all + = -- | Execute the command or function. + CExecute Const + | -- | Be powered, i.e. execute anything at all CPower - | -- | Execute the 'Move' command - CMove - | -- | Execute the 'Backup' command - CBackup - | -- | Execute the 'Volume' command - CVolume - | -- | Execute the 'Path' command - CPath - | -- | Execute the 'Push' command - CPush - | -- | Execute the 'Stride' command - CMovemultiple - | -- | Execute the 'Move' command for a heavy robot - CMoveheavy - | -- | Execute the 'Turn' command - -- - -- NOTE: using cardinal directions is separate 'COrient' capability - CTurn - | -- | Execute the 'Selfdestruct' command - CSelfdestruct - | -- | Execute the 'Grab' command - CGrab - | -- | Execute the 'Harvest' command - CHarvest - | -- | Execute the 'Sow' command - CSow - | -- | Execute the 'Ignite' command - CIgnite - | -- | Execute the 'Place' command - CPlace - | -- | Execute the 'Ping' command - CPing - | -- | Execute the 'Give' command - CGive - | -- | Execute the 'Equip' command - CEquip - | -- | Execute the 'Unequip' command - CUnequip - | -- | Execute the 'Make' command - CMake - | -- | Execute the 'Count' command - CCount - | -- | Execute the 'Scout' command. Reconnaissance along a line in a direction. - CRecondir - | -- | Execute the 'Build' command - CBuild - | -- | Execute the 'Salvage' command - CSalvage - | -- | Execute the 'Drill' command - CDrill - | -- | Execute the 'Waypoint' command - CWaypoint - | -- | Execute the 'Structure' and 'Floorplan' commands - CStructure - | -- | Execute the 'HasTag' command - CHastag - | -- | Execute the 'TagMembers' command - CTagmembers - | -- | Execute the 'Whereami' command - CSenseloc - | -- | Execute the 'Blocked' command - CSensefront - | -- | Execute the 'Ishere' and 'Isempty' commands - CSensehere - | -- | Execute the 'Detect' command - CDetectloc - | -- | Execute the 'Resonate' and 'Density' commands - CDetectcount - | -- | Execute the 'Sniff' command - CDetectdistance - | -- | Execute the 'Chirp' command - CDetectdirection - | -- | Execute the 'Watch' command - CWakeself - | -- | Execute the 'Scan' command - CScan - | -- | Execute the 'Random' command - CRandom - | -- | Execute the 'Appear' command - CAppear - | -- | Execute the 'Create' command - CCreate - | -- | Execute the 'Listen' command and passively log messages if also has 'CLog' - CListen - | -- | Execute the 'Log' command - CLog - | -- | Format values as text - CFormat - | -- | Split text into two pieces - CConcat - | -- | Join two text values into one - CSplit - | -- | Count the characters in a text value - CCharcount - | -- | Convert between characters/text and Unicode values - CCode - | -- | Don't drown in liquid + | -- | Allow a heavy robot to perform movements (e.g. move, backup and stride). + CMoveHeavy + | -- | Don't drown in liquid. CFloat - | -- | Evaluate conditional expressions - CCond - | -- | Negate boolean value - CNegation - | -- | Evaluate comparison operations - CCompare - | -- | Use cardinal direction constants. + | -- | Allow using absolute directions. COrient - | -- | Evaluate arithmetic operations - CArith | -- | Store and look up definitions in an environment CEnv | -- | Interpret lambda abstractions CLambda | -- | Enable recursive definitions CRecursion - | -- | Execute the 'Reprogram' command - CReprogram - | -- | Execute the `meet` and `meetAll` commands. - CMeet - | -- | Capability to introspect and see its own name - CWhoami - | -- | Capability to set its own name - CSetname - | -- | Capability to move unrestricted to any place - CTeleport - | -- | Capability to run commands atomically - CAtomic - | -- | Capability to execute swap (grab and place atomically at the same time). - CSwap - | -- | Capability to obtain absolute time, namely via the `time` command. - CTimeabs - | -- | Capability to utilize relative passage of time, namely via the `wait` command. - -- This is strictly weaker than "CTimeAbs". - CTimerel - | -- | Capability to execute `try`. - CTry | -- | Capability for working with sum types. CSum | -- | Capability for working with product types. @@ -181,20 +64,31 @@ data Capability CRecord | -- | Debug capability. CDebug - | -- | Capability to handle keyboard input. - CHandleinput - | -- | Capability to make other robots halt. - CHalt | -- | Capability to handle recursive types. CRectype | -- | God-like capabilities. For e.g. commands intended only for -- checking challenge mode win conditions, and not for use by -- players. CGod - deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data, FromJSONKey, ToJSONKey) + deriving (Eq, Ord, Show, Generic, Hashable, Data, FromJSONKey, ToJSONKey) + deriving (Enum, Bounded) via (FiniteEnumeration Capability) +-- | Get the name of the capability for use in UI and YAML. capabilityName :: Capability -> Text -capabilityName = from @String . map toLower . drop 1 . show +capabilityName = \case + CExecute con -> case con of + Neg -> "neg" + _ -> syntax $ constInfo con + CMoveHeavy -> "move heavy robot" + cap -> from @String . map toLower . drop 1 $ show cap + +-- | Parse the capability name - inverse of 'capabilityName'. +-- +-- >>> import Data.List.Extra (enumerate) +-- >>> all (\c -> Just c == parseCapability (capabilityName c)) enumerate +-- True +parseCapability :: Text -> Maybe Capability +parseCapability t = find (\c -> capabilityName c == T.toLower t) enumerate instance ToJSON Capability where toJSON = String . capabilityName @@ -203,7 +97,7 @@ instance FromJSON Capability where parseJSON = withText "Capability" tryRead where tryRead :: Text -> Parser Capability - tryRead t = case readMaybe . from . T.cons 'C' . T.toTitle $ t of + tryRead t = case parseCapability t of Just c -> return c Nothing -> failT ["Unknown capability", t] @@ -212,141 +106,41 @@ constCaps :: Const -> Maybe Capability constCaps = \case -- ---------------------------------------------------------------- -- Some built-in constants that don't require any special capability. - Noop -> Nothing AppF -> Nothing + Base -> Nothing + Equipped -> Nothing + Fail -> Nothing Force -> Nothing - Return -> Nothing + Has -> Nothing + Knows -> Nothing + Noop -> Nothing Parent -> Nothing - Base -> Nothing + Return -> Nothing + Say -> Nothing -- speaking is natural to robots (unlike listening) Setname -> Nothing Undefined -> Nothing - Fail -> Nothing - Has -> Nothing - Equipped -> Nothing - -- speaking is natural to robots (unlike listening) - Say -> Nothing + Use -> Nothing -- Recipes alone shall dictate whether things can be "used" + View -> Nothing -- TODO: #17 should require equipping an antenna -- TODO: #495 -- the require command will be inlined once the Issue is fixed -- so the capabilities of the run commands will be checked instead Run -> Nothing - -- ---------------------------------------------------------------- - -- Some straightforward ones. - Listen -> Just CListen - Log -> Just CLog - Selfdestruct -> Just CSelfdestruct - Move -> Just CMove - Backup -> Just CBackup - Volume -> Just CVolume - Path -> Just CPath - Push -> Just CPush - Stride -> Just CMovemultiple - Turn -> Just CTurn - Grab -> Just CGrab - Harvest -> Just CHarvest - Sow -> Just CSow - Ignite -> Just CIgnite - Place -> Just CPlace - Ping -> Just CPing - Give -> Just CGive - Equip -> Just CEquip - Unequip -> Just CUnequip - Make -> Just CMake - Count -> Just CCount - If -> Just CCond - Blocked -> Just CSensefront - Scan -> Just CScan - Ishere -> Just CSensehere - Isempty -> Just CSensehere - Upload -> Just CScan - Build -> Just CBuild - Salvage -> Just CSalvage - Reprogram -> Just CReprogram - Meet -> Just CMeet - MeetAll -> Just CMeet - Drill -> Just CDrill - Use -> Nothing -- Recipes alone shall dictate whether things can be "used" - Neg -> Just CArith - Add -> Just CArith - Sub -> Just CArith - Mul -> Just CArith - Div -> Just CArith - Exp -> Just CArith - Whoami -> Just CWhoami - Self -> Just CWhoami - Swap -> Just CSwap - Atomic -> Just CAtomic - Instant -> Just CGod - Time -> Just CTimeabs - Wait -> Just CTimerel - Scout -> Just CRecondir - Whereami -> Just CSenseloc - Waypoint -> Just CWaypoint - Structure -> Just CStructure - Floorplan -> Just CStructure - HasTag -> Just CHastag - TagMembers -> Just CTagmembers - Detect -> Just CDetectloc - Resonate -> Just CDetectcount - Density -> Just CDetectcount - Sniff -> Just CDetectdistance - Chirp -> Just CDetectdirection - Watch -> Just CWakeself - Heading -> Just COrient - Key -> Just CHandleinput - InstallKeyHandler -> Just CHandleinput - Halt -> Just CHalt - -- ---------------------------------------------------------------- - -- Text operations - Format -> Just CFormat - Concat -> Just CConcat - Split -> Just CSplit - Chars -> Just CCharcount - CharAt -> Just CCode - ToChar -> Just CCode - -- ---------------------------------------------------------------- -- Some God-like abilities. As -> Just CGod + Create -> Just CGod + Instant -> Just CGod RobotNamed -> Just CGod RobotNumbered -> Just CGod - Create -> Just CGod Surveil -> Just CGod -- ---------------------------------------------------------------- - -- arithmetic - Eq -> Just CCompare - Neq -> Just CCompare - Lt -> Just CCompare - Gt -> Just CCompare - Leq -> Just CCompare - Geq -> Just CCompare - -- ---------------------------------------------------------------- - -- boolean logic - And -> Just CCond - Or -> Just CCond - Not -> Just CNegation - -- ---------------------------------------------------------------- - -- exceptions - Try -> Just CTry - -- ---------------------------------------------------------------- -- type-level arithmetic Inl -> Just CSum Inr -> Just CSum Case -> Just CSum + -- TODO: #563 pair syntax (1,2,3...) should require CProd too Fst -> Just CProd Snd -> Just CProd - -- TODO: #563 pair syntax (1,2,3...) should require CProd too - - -- ---------------------------------------------------------------- - -- Some additional straightforward ones, which however currently - -- cannot be used in classic mode since there is no craftable item - -- which conveys their capability. TODO: #26 - Teleport -> Just CTeleport -- Some space-time machine like Tardis? - Appear -> Just CAppear -- paint? - Random -> Just CRandom -- randomness device (with bitcoins)? - -- ---------------------------------------------------------------- - -- Some more constants which *ought* to have their own capability but - -- currently don't. - View -> Nothing -- TODO: #17 should require equipping an antenna - Knows -> Nothing + c -> Just (CExecute c) -- | Inverts the 'constCaps' mapping. constByCaps :: Map Capability (NE.NonEmpty Const) diff --git a/src/swarm-lang/Swarm/Language/Requirements/Type.hs b/src/swarm-lang/Swarm/Language/Requirements/Type.hs index cff812bb9..5d74bc3b5 100644 --- a/src/swarm-lang/Swarm/Language/Requirements/Type.hs +++ b/src/swarm-lang/Swarm/Language/Requirements/Type.hs @@ -61,7 +61,7 @@ data Requirement -- of entity @"e"@ and later requiring 7 is the same as requiring -- 12. ReqInv Int Text - deriving (Eq, Ord, Show, Read, Generic, Hashable, Data, FromJSON, ToJSON) + deriving (Eq, Ord, Show, Generic, Hashable, Data, FromJSON, ToJSON) -- | It is tempting to define @Requirements = Set Requirement@, but -- that would be wrong, since two identical 'ReqInv' should have diff --git a/src/swarm-lang/Swarm/Language/Syntax/Constants.hs b/src/swarm-lang/Swarm/Language/Syntax/Constants.hs index 4e92039fc..58666dd37 100644 --- a/src/swarm-lang/Swarm/Language/Syntax/Constants.hs +++ b/src/swarm-lang/Swarm/Language/Syntax/Constants.hs @@ -29,6 +29,7 @@ module Swarm.Language.Syntax.Constants ( import Data.Aeson.Types hiding (Key) import Data.Data (Data) +import Data.Hashable (Hashable) import Data.Int (Int32) import Data.List.Extra (enumerate) import Data.Set (Set) @@ -309,7 +310,7 @@ data Const RobotNumbered | -- | Check if an entity is known. Knows - deriving (Eq, Ord, Enum, Bounded, Data, Show, Generic, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + deriving (Eq, Ord, Enum, Bounded, Data, Show, Generic, Hashable, FromJSON, ToJSON, FromJSONKey, ToJSONKey) allConst :: [Const] allConst = enumerate diff --git a/src/swarm-scenario/Swarm/Game/Device.hs b/src/swarm-scenario/Swarm/Game/Device.hs index 8999dc2c5..c669628c8 100644 --- a/src/swarm-scenario/Swarm/Game/Device.hs +++ b/src/swarm-scenario/Swarm/Game/Device.hs @@ -71,7 +71,7 @@ data CapabilityCost e = CapabilityCost -- Otherwise, parse as a Map from capabilities to ingredients. instance (FromJSON e) => FromJSON (SingleEntityCapabilities e) where parseJSON x = - simpleList <|> (Capabilities <$> costMap) + (Capabilities <$> costMap) <|> simpleList where simpleList = zeroCostCapabilities <$> parseJSON x costMap = withArray "Capabilities" (fmap (M.fromList . map toMapEntry) . mapM parseJSON . V.toList) x diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 89087e727..6a6467877 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -20,17 +21,21 @@ import Control.Arrow ((&&&)) import Data.Bifunctor (first) import Data.List.Extra (enumerate) import Data.Text (Text) +import GHC.Generics (Generic) +import Generic.Data (FiniteEnumeration (..)) import Graphics.Vty qualified as V import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..), directionSyntax) +-- | Swarm named TUI event type. +-- -- See Note [how Swarm event handlers work] - data SwarmEvent = Main MainEvent | REPL REPLEvent | World WorldEvent | Robot RobotEvent - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + deriving (Enum, Bounded) via (FiniteEnumeration SwarmEvent) swarmEvents :: KeyEvents SwarmEvent swarmEvents = @@ -167,21 +172,8 @@ data WorldEvent = ViewBaseEvent | ShowFpsEvent | MoveViewEvent AbsoluteDir - deriving (Eq, Ord, Show) - -instance Enum WorldEvent where - fromEnum = \case - ViewBaseEvent -> 0 - ShowFpsEvent -> 1 - MoveViewEvent d -> 2 + fromEnum d - toEnum = \case - 0 -> ViewBaseEvent - 1 -> ShowFpsEvent - n -> MoveViewEvent . toEnum $ n - 2 - -instance Bounded WorldEvent where - minBound = ViewBaseEvent - maxBound = MoveViewEvent maxBound + deriving (Eq, Ord, Show, Generic) + deriving (Enum, Bounded) via (FiniteEnumeration WorldEvent) worldPanelEvents :: KeyEvents WorldEvent worldPanelEvents = allKeyEvents $ \case diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs index 9d2215615..b0d6286c8 100644 --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -1094,7 +1094,7 @@ explainEntry s e = , explainRecipes s e ] <> [drawRobotMachine s False | CDebug `M.member` getMap (e ^. entityCapabilities)] - <> [drawRobotLog s | CLog `M.member` getMap (e ^. entityCapabilities)] + <> [drawRobotLog s | CExecute Log `M.member` getMap (e ^. entityCapabilities)] displayProperties :: [EntityProperty] -> Widget Name displayProperties = displayList . mapMaybe showProperty diff --git a/swarm.cabal b/swarm.cabal index 08967a931..ba9d40f38 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -209,6 +209,9 @@ common fused-effects-lens common fuzzy build-depends: fuzzy >=0.1 && <0.2 +common generic-data + build-depends: generic-data >=1.0 && <1.2 + common githash build-depends: githash >=0.1.6 && <0.2 @@ -399,6 +402,7 @@ library swarm-lang extra, free, fused-effects, + generic-data, hashable, lens, lsp, @@ -963,6 +967,7 @@ library swarm-tui filepath, fused-effects, fuzzy, + generic-data, githash, lens, linear, diff --git a/test/unit/TestRequirements.hs b/test/unit/TestRequirements.hs index a14ac264a..25c6cc9c6 100644 --- a/test/unit/TestRequirements.hs +++ b/test/unit/TestRequirements.hs @@ -14,6 +14,7 @@ import Swarm.Language.Context qualified as Ctx import Swarm.Language.Pipeline import Swarm.Language.Requirements.Analysis (requirements) import Swarm.Language.Requirements.Type (ReqCtx, Requirements, capReqs) +import Swarm.Language.Syntax.Constants (Const (Move)) import Swarm.Language.Syntax.Util (eraseS) import Test.Tasty import Test.Tasty.HUnit @@ -26,7 +27,7 @@ testRequirements = [ testGroup "Basic capabilities" [ testCase "solar panel" $ "noop" `requiresCap` CPower - , testCase "move" $ "move" `requiresCap` CMove + , testCase "move" $ "move" `requiresCap` CExecute Move , testCase "lambda" $ "\\x. x" `requiresCap` CLambda , testCase "inl" $ "inl 3" `requiresCap` CSum , testCase "cap from type" $ "inl () : rec t. Unit + t" `requiresCap` CRectype @@ -36,7 +37,7 @@ testRequirements = [ testCase "global var requirement does not apply to local var (#1914)" $ checkReqCtx "def m = move end; def y = \\m. log (format m) end" - (maybe False ((CMove `S.notMember`) . capReqs) . Ctx.lookup "y") + (maybe False ((CExecute Move `S.notMember`) . capReqs) . Ctx.lookup "y") ] ]