Web API docs improvements (#1529)

* generate Web API endpoint docs in CLI - `swarm generate endpoints`
* use default port in API docs using `renderCurlBasePath`
* fix code rendering in Web API so that the tree nodes try to fit one line
* try adding some API samples
* hand craft `ToJSON Robot` instance to match `FromJSONE` more closely
  * default values are skipped
  * inventory and devices are shortened to names and counts

app/Main.hs

@@ -87,6 +87,7 @@ cliParser =
       , 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")
+      , command "endpoints" (info (pure WebAPIEndpoints) $ progDesc "Generate markdown Web API documentation.")
       ]
 
   editor :: Parser (Maybe EditorType)

src/Swarm/Doc/Gen.hs

@@ -61,6 +61,7 @@ import Swarm.Language.Text.Markdown as Markdown (docToMark)
 import Swarm.Language.Typecheck (inferConst)
 import Swarm.Util (both, listEnums, quote)
 import Swarm.Util.Effect (simpleErrorHandle)
+import Swarm.Web (swarmApiMarkdown)
 import Text.Dot (Dot, NodeId, (.->.))
 import Text.Dot qualified as Dot
 
@@ -84,6 +85,8 @@ data GenerateDocs where
   CheatSheet :: PageAddress -> Maybe SheetType -> GenerateDocs
   -- | List command introductions by tutorial
   TutorialCoverage :: GenerateDocs
+  -- | Web API endpoints
+  WebAPIEndpoints :: GenerateDocs
   deriving (Eq, Show)
 
 -- | An enumeration of the editors supported by Swarm (currently,
@@ -136,6 +139,7 @@ generateDocs = \case
         recipes <- loadRecipes entities
         sendIO $ T.putStrLn $ recipePage address recipes
   TutorialCoverage -> renderTutorialProgression >>= putStrLn . T.unpack
+  WebAPIEndpoints -> putStrLn swarmApiMarkdown
 
 -- ----------------------------------------------------------------------------
 -- GENERATE KEYWORDS: LIST OF WORDS TO BE HIGHLIGHTED

src/Swarm/Game/Robot.hs

@@ -80,11 +80,11 @@ module Swarm.Game.Robot (
 ) where
 
 import Control.Lens hiding (Const, contains)
-import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson qualified as Ae (FromJSON, Key, KeyValue, ToJSON (..), object, (.=))
 import Data.Hashable (hashWithSalt)
 import Data.Kind qualified
 import Data.Map (Map)
-import Data.Maybe (fromMaybe, isNothing)
+import Data.Maybe (catMaybes, fromMaybe, isNothing)
 import Data.Sequence (Seq)
 import Data.Sequence qualified as Seq
 import Data.Set (Set)
@@ -101,6 +101,7 @@ import Swarm.Game.Location (Heading, Location, toDirection)
 import Swarm.Game.Universe
 import Swarm.Language.Capability (Capability)
 import Swarm.Language.Context qualified as Ctx
+import Swarm.Language.Pipeline.QQ (tmQ)
 import Swarm.Language.Requirement (ReqCtx)
 import Swarm.Language.Syntax (Const, Syntax)
 import Swarm.Language.Text.Markdown (Document)
@@ -129,7 +130,7 @@ data RobotContext = RobotContext
   -- ^ A store containing memory cells allocated to hold
   --   definitions.
   }
-  deriving (Eq, Show, Generic, FromJSON, ToJSON)
+  deriving (Eq, Show, Generic, Ae.FromJSON, Ae.ToJSON)
 
 makeLenses ''RobotContext
 
@@ -179,7 +180,19 @@ data ActivityCounts = ActivityCounts
   , _lifetimeStepCount :: Int
   , _activityWindow :: WindowedCounter TickNumber
   }
-  deriving (Eq, Show, Generic, FromJSON, ToJSON)
+  deriving (Eq, Show, Generic, Ae.FromJSON, Ae.ToJSON)
+
+emptyActivityCount :: ActivityCounts
+emptyActivityCount =
+  ActivityCounts
+    { _tickStepBudget = 0
+    , _tangibleCommandCount = 0
+    , _commandsHistogram = mempty
+    , _lifetimeStepCount = 0
+    , -- NOTE: This value was chosen experimentally.
+      -- TODO(#1341): Make this dynamic based on game speed.
+      _activityWindow = mkWindow 64
+    }
 
 makeLensesNoSigs ''ActivityCounts
 
@@ -279,8 +292,6 @@ data RobotR (phase :: RobotPhase) = RobotR
 deriving instance (Show (RobotLocation phase), Show (RobotID phase)) => Show (RobotR phase)
 deriving instance (Eq (RobotLocation phase), Eq (RobotID phase)) => Eq (RobotR phase)
 
-deriving instance (ToJSON (RobotLocation phase), ToJSON (RobotID phase)) => ToJSON (RobotR phase)
-
 -- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/
 -- for the approach used here with lenses.
 
@@ -294,7 +305,25 @@ type TRobot = RobotR 'TemplateRobot
 type Robot = RobotR 'ConcreteRobot
 
 instance ToSample Robot where
-  toSamples _ = SD.noSamples
+  toSamples _ = SD.singleSample sampleBase
+   where
+    sampleBase :: Robot
+    sampleBase =
+      mkRobot
+        0
+        Nothing
+        "base"
+        "The starting robot."
+        defaultCosmicLocation
+        zero
+        defaultRobotDisplay
+        (initMachine [tmQ| move |] mempty emptyStore)
+        []
+        []
+        False
+        False
+        mempty
+        0
 
 -- In theory we could make all these lenses over (RobotR phase), but
 -- that leads to lots of type ambiguity problems later.  In practice
@@ -529,16 +558,7 @@ mkRobot rid pid name descr loc dir disp m devs inv sys heavy unwalkables ts =
     , _machine = m
     , _systemRobot = sys
     , _selfDestruct = False
-    , _activityCounts =
-        ActivityCounts
-          { _tickStepBudget = 0
-          , _tangibleCommandCount = 0
-          , _commandsHistogram = mempty
-          , _lifetimeStepCount = 0
-          , -- NOTE: This value was chosen experimentally.
-            -- TODO(#1341): Make this dynamic based on game speed.
-            _activityWindow = mkWindow 64
-          }
+    , _activityCounts = emptyActivityCount
     , _runningAtomic = False
     , _unwalkableEntities = unwalkables
     }
@@ -572,6 +592,41 @@ instance FromJSONE EntityMap TRobot where
     mkMachine Nothing = Out VUnit emptyStore []
     mkMachine (Just pt) = initMachine pt mempty emptyStore
 
+(.=?) :: (Ae.KeyValue a, Ae.ToJSON v, Eq v) => Ae.Key -> v -> v -> Maybe a
+(.=?) n v defaultVal = if defaultVal /= v then Just $ n Ae..= v else Nothing
+
+(.==) :: (Ae.KeyValue a, Ae.ToJSON v) => Ae.Key -> v -> Maybe a
+(.==) n v = Just $ n Ae..= v
+
+instance Ae.ToJSON Robot where
+  toJSON r =
+    Ae.object $
+      catMaybes
+        [ "id" .== (r ^. robotID)
+        , "name" .== (r ^. robotEntity . entityDisplay)
+        , "description" .=? (r ^. robotEntity . entityDescription) $ mempty
+        , "loc" .== (r ^. robotLocation)
+        , "dir" .=? (r ^. robotEntity . entityOrientation) $ zero
+        , "display" .=? (r ^. robotDisplay) $ (defaultRobotDisplay & invisible .~ sys)
+        , "program" .== (r ^. machine)
+        , "devices" .=? (map (^. _2 . entityName) . elems $ r ^. equippedDevices) $ []
+        , "inventory" .=? (map (_2 %~ view entityName) . elems $ r ^. robotInventory) $ []
+        , "system" .=? sys $ False
+        , "heavy" .=? (r ^. robotHeavy) $ False
+        , "log" .=? (r ^. robotLog) $ mempty
+        , -- debug
+          "capabilities" .=? (r ^. robotCapabilities) $ mempty
+        , "logUpdated" .=? (r ^. robotLogUpdated) $ False
+        , "context" .=? (r ^. robotContext) $ emptyRobotContext
+        , "parent" .=? (r ^. robotParentID) $ Nothing
+        , "createdAt" .=? (r ^. robotCreatedAt) $ 0
+        , "selfDestruct" .=? (r ^. selfDestruct) $ False
+        , "activity" .=? (r ^. activityCounts) $ emptyActivityCount
+        , "runningAtomic" .=? (r ^. runningAtomic) $ False
+        ]
+   where
+    sys = r ^. systemRobot
+
 -- | Is the robot actively in the middle of a computation?
 isActive :: Robot -> Bool
 {-# INLINE isActive #-}

src/Swarm/Game/State.hs

@@ -290,7 +290,11 @@ data WinCondition
 makePrisms ''WinCondition
 
 instance ToSample WinCondition where
-  toSamples _ = SD.noSamples
+  toSamples _ =
+    SD.samples
+      [ NoWinCondition
+      -- TODO: #1552 add simple objective sample
+      ]
 
 -- | A data type to keep track of the pause mode.
 data RunStatus

src/Swarm/Language/Pretty.hs

@@ -52,6 +52,10 @@ docToText = RT.renderStrict . layoutPretty defaultLayoutOptions
 prettyText :: (PrettyPrec a) => a -> Text
 prettyText = docToText . ppr
 
+-- | Pretty-print something and render it as (preferably) one line @Text@.
+prettyTextLine :: (PrettyPrec a) => a -> Text
+prettyTextLine = RT.renderStrict . layoutPretty (LayoutOptions Unbounded) . group . ppr
+
 -- | Render a pretty-printed document as a @String@.
 docToString :: Doc a -> String
 docToString = RS.renderString . layoutPretty defaultLayoutOptions

src/Swarm/Language/Text/Markdown.hs

@@ -52,11 +52,9 @@ import Data.Tuple.Extra (both, first)
 import Data.Vector (toList)
 import Data.Yaml
 import GHC.Exts qualified (IsList (..), IsString (..))
-import Prettyprinter (LayoutOptions (..), PageWidth (..), group, layoutPretty)
-import Prettyprinter.Render.Text qualified as RT
 import Swarm.Language.Parse (readTerm)
 import Swarm.Language.Pipeline (processParsedTerm)
-import Swarm.Language.Pretty (PrettyPrec (..), ppr, prettyText, prettyTypeErrText)
+import Swarm.Language.Pretty (PrettyPrec (..), prettyText, prettyTextLine, prettyTypeErrText)
 import Swarm.Language.Syntax (Syntax)
 
 -- | The top-level markdown document.
@@ -312,11 +310,9 @@ class ToStream a where
 instance PrettyPrec a => ToStream (Node a) where
   toStream = \case
     LeafText a t -> [TextNode a t]
-    LeafCode t -> [CodeNode (pprOneLine t)]
+    LeafCode t -> [CodeNode (prettyTextLine t)]
     LeafRaw s t -> [RawNode s t]
     LeafCodeBlock _i t -> [CodeNode (prettyText t)]
-   where
-    pprOneLine = RT.renderStrict . layoutPretty (LayoutOptions Unbounded) . group . ppr
 
 instance PrettyPrec a => ToStream (Paragraph a) where
   toStream = concatMap toStream . nodes

src/Swarm/TUI/Model/Goal.hs

@@ -69,7 +69,11 @@ data GoalTracking = GoalTracking
   deriving (Generic, ToJSON)
 
 instance ToSample GoalTracking where
-  toSamples _ = SD.noSamples
+  toSamples _ =
+    SD.samples
+      [ GoalTracking mempty mempty
+      -- TODO: #1552 add simple objective sample
+      ]
 
 data GoalDisplay = GoalDisplay
   { _goalsContent :: GoalTracking

src/Swarm/TUI/Model/Repl.hs

@@ -83,7 +83,13 @@ data REPLHistItem
   deriving (Eq, Ord, Show, Read)
 
 instance ToSample REPLHistItem where
-  toSamples _ = SD.noSamples
+  toSamples _ =
+    SD.samples
+      [ REPLEntry "grab"
+      , REPLOutput "it0 : text = \"tree\""
+      , REPLEntry "place tree"
+      , REPLError "1:7: Unbound variable tree"
+      ]
 
 instance ToJSON REPLHistItem where
   toJSON e = case e of