diff --git a/app/Main.hs b/app/Main.hs index 62d02c607..6d4d3f69b 100644 --- a/app/Main.hs +++ b/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) diff --git a/src/Swarm/Doc/Gen.hs b/src/Swarm/Doc/Gen.hs index 6feb33a1c..4058fa864 100644 --- a/src/Swarm/Doc/Gen.hs +++ b/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 diff --git a/src/Swarm/Game/Robot.hs b/src/Swarm/Game/Robot.hs index 90d847083..51060c137 100644 --- a/src/Swarm/Game/Robot.hs +++ b/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 #-} diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index e1df07813..505346c58 100644 --- a/src/Swarm/Game/State.hs +++ b/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 diff --git a/src/Swarm/Language/Pretty.hs b/src/Swarm/Language/Pretty.hs index ddd510c59..1cfd5e9a4 100644 --- a/src/Swarm/Language/Pretty.hs +++ b/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 diff --git a/src/Swarm/Language/Text/Markdown.hs b/src/Swarm/Language/Text/Markdown.hs index b85c1ea22..d1ee7977a 100644 --- a/src/Swarm/Language/Text/Markdown.hs +++ b/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 diff --git a/src/Swarm/TUI/Model/Goal.hs b/src/Swarm/TUI/Model/Goal.hs index 71c662440..e099b9861 100644 --- a/src/Swarm/TUI/Model/Goal.hs +++ b/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 diff --git a/src/Swarm/TUI/Model/Repl.hs b/src/Swarm/TUI/Model/Repl.hs index f8331fed0..6faa13443 100644 --- a/src/Swarm/TUI/Model/Repl.hs +++ b/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 diff --git a/src/Swarm/Web.hs b/src/Swarm/Web.hs index 0d66ee1fd..c694dc659 100644 --- a/src/Swarm/Web.hs +++ b/src/Swarm/Web.hs @@ -14,6 +14,8 @@ -- See 'SwarmAPI' for the available endpoints. You can also see them in your -- browser on the top level endpoint: -- @lynx localhost:5357 -dump@ +-- or you can output the markdown documentation to your terminal: +-- @cabal run swarm -O0 -- generate endpoints@ -- -- Missing endpoints: -- @@ -23,6 +25,11 @@ module Swarm.Web ( startWebThread, defaultPort, + -- ** Docs + SwarmAPI, + swarmApiHtml, + swarmApiMarkdown, + -- ** Development webMain, ) where @@ -51,6 +58,7 @@ import Network.Wai.Handler.Warp qualified as Warp import Servant import Servant.Docs (ToCapture) import Servant.Docs qualified as SD +import Servant.Docs.Internal qualified as SD (renderCurlBasePath) import Swarm.Game.Robot import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Graph @@ -58,7 +66,7 @@ import Swarm.Game.Scenario.Objective.WinCheck import Swarm.Game.State import Swarm.Language.Module import Swarm.Language.Pipeline -import Swarm.Language.Pretty (prettyString) +import Swarm.Language.Pretty (prettyTextLine) import Swarm.Language.Syntax import Swarm.ReadableIORef import Swarm.TUI.Model @@ -69,21 +77,11 @@ import Text.Read (readEither) import Witch (into) -- ------------------------------------------------------------------ --- Necessary instances +-- Docs -- ------------------------------------------------------------------ newtype RobotID = RobotID Int -instance FromHttpApiData RobotID where - parseUrlPiece = fmap RobotID . left T.pack . readEither . T.unpack - -instance SD.ToSample T.Text where - toSamples _ = SD.noSamples - --- ------------------------------------------------------------------ --- Docs --- ------------------------------------------------------------------ - type SwarmAPI = "robots" :> Get '[JSON] [Robot] :<|> "robot" :> Capture "id" RobotID :> Get '[JSON] (Maybe Robot) @@ -96,12 +94,6 @@ type SwarmAPI = :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text :<|> "repl" :> "history" :> "full" :> Get '[JSON] [REPLHistItem] -instance ToCapture (Capture "id" RobotID) where - toCapture _ = - SD.DocCapture - "id" -- name - "(integer) robot ID" -- description - swarmApi :: Proxy SwarmAPI swarmApi = Proxy @@ -110,17 +102,21 @@ type ToplevelAPI = SwarmAPI :<|> Raw api :: Proxy ToplevelAPI api = Proxy -docsBS :: ByteString -docsBS = +swarmApiHtml :: ByteString +swarmApiHtml = encodeUtf8 . either (error . show) (Mark.renderHtml @()) . Mark.commonmark "" - . T.pack - . SD.markdownWith - ( SD.defRenderingOptions - & SD.requestExamples .~ SD.FirstContentType - & SD.responseExamples .~ SD.FirstContentType - ) + $ T.pack swarmApiMarkdown + +swarmApiMarkdown :: String +swarmApiMarkdown = + SD.markdownWith + ( SD.defRenderingOptions + & SD.requestExamples .~ SD.FirstContentType + & SD.responseExamples .~ SD.FirstContentType + & SD.renderCurlBasePath ?~ "http://localhost:" <> show defaultPort + ) $ SD.docsWithIntros [intro] swarmApi where intro = SD.DocIntro "Swarm Web API" ["All of the valid endpoints are documented below."] @@ -191,7 +187,7 @@ codeRenderHandler :: Text -> Handler Text codeRenderHandler contents = do return $ case processTermEither contents of Right (ProcessedTerm (Module stx@(Syntax' _srcLoc _term _) _) _ _) -> - into @Text . drawTree . fmap prettyString . para Node $ stx + into @Text . drawTree . fmap (T.unpack . prettyTextLine) . para Node $ stx Left x -> x codeRunHandler :: BChan AppEvent -> Text -> Handler Text @@ -232,7 +228,7 @@ webMain baton port appStateRef chan = catch (Warp.runSettings settings app) hand server = mkApp appStateRef chan :<|> Tagged serveDocs where serveDocs _ resp = - resp $ responseLBS ok200 [plain] docsBS + resp $ responseLBS ok200 [plain] swarmApiHtml plain = ("Content-Type", "text/html") app :: Network.Wai.Application @@ -278,3 +274,22 @@ startWebThread userPort appStateRef chan = do Nothing -> case userPort of Just _p -> fail failMsg Nothing -> return . Left $ failMsg <> " (timeout)" + +-- ------------------------------------------------------------------ +-- Necessary instances +-- ------------------------------------------------------------------ + +instance SD.ToSample T.Text where + toSamples _ = SD.noSamples + +instance FromHttpApiData RobotID where + parseUrlPiece = fmap RobotID . left T.pack . readEither . T.unpack + +instance SD.ToSample RobotID where + toSamples _ = SD.samples [RobotID 0, RobotID 1] + +instance ToCapture (Capture "id" RobotID) where + toCapture _ = + SD.DocCapture + "id" -- name + "(integer) robot ID" -- description