Change appear command to take an optional attribute (#1807)

Also, fix a bug---it didn't work before if an appearance string of length 5 was given.

Closes #1230.

I don't know how to write an automated test for this, but you can see it working by *e.g.*:

- Start a creative game
- Execute e.g. `appear "DNESW" (inr "rock")`
- Observe that the base now looks like a rock-colored `N`
- Now do some `turn` commands (including `turn down`) and observe the appearance changing to e.g. `S` when facing south

data/scenarios/Challenges/Ranching/_beekeeping/queenbee.sw

@@ -206,7 +206,7 @@ def mkBeeName = \structureLoc.
 
 def workerProgramInit = \beename. \hiveIdx. \structureLoc.
     setname beename;
-    appear "B";
+    appear "B" (inl ());
     workerProgram hiveIdx structureLoc;
     end;
 

data/scenarios/Challenges/Ranching/_fishing/shark.sw

@@ -5,13 +5,13 @@ Swims back and forth forever.
 def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
 
 def swim =
-    appear "^";
+    appear "^" (inl ());
     doN 3 (move; wait 3);
     turn back;
     wait 15;
     doN 3 (move; wait 3);
     turn back;
-    appear " ";
+    appear " " (inl ());
     end;
 
 def go =

data/scenarios/Challenges/_gopher/gopher.sw

@@ -99,11 +99,11 @@ def go = \width. \height. \lastTauntIndex. \startingAmount. \dropping.
             say $ snd tauntStage;
         } {};
 
-        appear "o";
+        appear "o" (inl ());
         arrive width height;
 
         place dropping;
-        appear "G";
+        appear "G" (inl ());
         waitWhileHere dropping 150;
         go width height tauntIndex startingAmount dropping;
     } {
@@ -128,4 +128,4 @@ def go = \width. \height. \lastTauntIndex. \startingAmount. \dropping.
 
 let dropping = "mound" in
 startingAmount <- count dropping;
-go 28 18 (-1) startingAmount dropping;
+go 28 18 (-1) startingAmount dropping;

data/scenarios/Testing/201-require/1664-require-system-robot-children.yaml

@@ -33,7 +33,7 @@ robots:
       def createWorker =
           build {
               setname "childbot";
-              appear "B";
+              appear "B" (inl ());
           };
           end;
 

feedback.yaml

@@ -1,3 +1,3 @@
 loops:
-  test: stack test --fast
+  test: stack test swarm:swarm-integration swarm:swarm-unit --fast
   unit: stack test swarm:swarm-unit --fast

src/swarm-engine/Swarm/Game/Step/Const.hs

@@ -829,21 +829,36 @@ execConst runChildProg c vs s k = do
         return $ mkReturn ()
       _ -> badConst
     Appear -> case vs of
-      [VText app] -> do
-        flagRedraw
+      [VText app, VInj hasAttr mattr] -> do
+        -- Set the robot's display character(s)
         case into @String app of
           [dc] -> do
             robotDisplay . defaultChar .= dc
             robotDisplay . orientationMap .= M.empty
-            return $ mkReturn ()
           [dc, nc, ec, sc, wc] -> do
             robotDisplay . defaultChar .= dc
-            robotDisplay . orientationMap . ix DNorth .= nc
-            robotDisplay . orientationMap . ix DEast .= ec
-            robotDisplay . orientationMap . ix DSouth .= sc
-            robotDisplay . orientationMap . ix DWest .= wc
-            return $ mkReturn ()
-          _other -> raise Appear [quote app, "is not a valid appearance string. 'appear' must be given a string with exactly 1 or 5 characters."]
+            robotDisplay . orientationMap
+              .= M.fromList
+                [ (DNorth, nc)
+                , (DEast, ec)
+                , (DSouth, sc)
+                , (DWest, wc)
+                ]
+          _other ->
+            raise
+              Appear
+              [ quote app
+              , "is not a valid appearance string."
+              , "'appear' must be given a string with exactly 1 or 5 characters."
+              ]
+
+        -- Possibly set the display attribute
+        case (hasAttr, mattr) of
+          (True, VText attr) -> robotDisplay . displayAttr .= readAttribute attr
+          _ -> return ()
+
+        flagRedraw
+        return $ mkReturn ()
       _ -> badConst
     Create -> case vs of
       [VText name] -> do
@@ -1348,7 +1363,7 @@ execConst runChildProg c vs s k = do
     T.unlines
       [ "Bad application of execConst:"
       , T.pack (show c)
-      , T.pack (show (reverse vs))
+      , T.pack (show vs)
       , prettyText (Out (VCApp c (reverse vs)) s k)
       ]
 

src/swarm-engine/Swarm/Game/Step/Util/Command.hs

@@ -501,7 +501,7 @@ seedProgram minTime randTime thing =
     try {
       r <- random (1 + $int:randTime);
       wait (r + $int:minTime);
-      appear "|";
+      appear "|" (inl ());
       r <- random (1 + $int:randTime);
       wait (r + $int:minTime);
       place $str:thing;

src/swarm-lang/Swarm/Language/Syntax.hs

@@ -223,7 +223,7 @@ data Const
     Log
   | -- | View a certain robot.
     View
-  | -- | Set what characters are used for display.
+  | -- | Set color and what characters are used for display.
     Appear
   | -- | Create an entity out of thin air. Only
     --   available in creative mode.
@@ -739,9 +739,10 @@ constInfo c = case c of
       [ "This will recenter the map on the target robot and allow its inventory and logs to be inspected."
       ]
   Appear ->
-    command 1 short . doc (Set.singleton $ Mutation Cosmetic) "Set how the robot is displayed." $
-      [ "You can either specify one character or five (for each direction)."
+    command 2 short . doc (Set.singleton $ Mutation Cosmetic) "Set how the robot is displayed." $
+      [ "You can either specify one character or five (one for each direction: down, north, east, south, west)."
       , "The default is \"X^>v<\"."
+      , "The second argument is for optionally setting a display attribute (i.e. color)."
       ]
   Create ->
     command 1 short . doc (Set.fromList [Mutation EntityChange, Mutation $ RobotChange InventoryChange]) "Create an item out of thin air." $

src/swarm-lang/Swarm/Language/Typecheck.hs

@@ -811,7 +811,7 @@ inferConst c = case c of
   Listen -> [tyQ| cmd text |]
   Log -> [tyQ| text -> cmd unit |]
   View -> [tyQ| actor -> cmd unit |]
-  Appear -> [tyQ| text -> cmd unit |]
+  Appear -> [tyQ| text -> (unit + text) -> cmd unit |]
   Create -> [tyQ| text -> cmd unit |]
   Halt -> [tyQ| actor -> cmd unit |]
   Time -> [tyQ| cmd int |]

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

@@ -13,6 +13,7 @@ module Swarm.Game.Display (
   -- * The display record
   Priority,
   Attribute (..),
+  readAttribute,
   Display,
 
   -- ** Fields
@@ -57,14 +58,15 @@ type Priority = Int
 data Attribute = ADefault | ARobot | AEntity | AWorld Text
   deriving (Eq, Ord, Show, Generic, Hashable)
 
+readAttribute :: Text -> Attribute
+readAttribute = \case
+  "robot" -> ARobot
+  "entity" -> AEntity
+  "default" -> ADefault
+  w -> AWorld w
+
 instance FromJSON Attribute where
-  parseJSON =
-    withText "attribute" $
-      pure . \case
-        "robot" -> ARobot
-        "entity" -> AEntity
-        "default" -> ADefault
-        w -> AWorld w
+  parseJSON = withText "attribute" $ pure . readAttribute
 
 instance ToJSON Attribute where
   toJSON = \case

test/bench/Benchmark.hs

@@ -51,7 +51,7 @@ treeProgram =
   {
     r <- random 100;
     wait (r + 300);
-    appear "|";
+    appear "|" (inl ());
     r <- random 100;
     wait (r + 300);
     place "tree";