Autogenerate scenario schema doc

app/Main.hs

@@ -103,6 +103,7 @@ cliParser =
       , Just Recipes <$ switch (long "recipes" <> help "Generate recipes page (uses data from recipes.yaml)")
       , Just Capabilities <$ switch (long "capabilities" <> help "Generate capabilities page (uses entity map)")
       , Just Commands <$ switch (long "commands" <> help "Generate commands page (uses constInfo, constCaps and inferConst)")
+      , Just Scenario <$ switch (long "scenario" <> help "Generate scenario schema page")
       ]
   seed :: Parser (Maybe Int)
   seed = optional $ option auto (long "seed" <> short 's' <> metavar "INT" <> help "Seed to use for world generation")

data/schema/display.json

@@ -2,7 +2,7 @@
     "$schema": "http://json-schema.org/draft-07/schema#",
     "$id": "https://raw.githubusercontent.com/swarm-game/swarm/main/data/schema/display.json",
     "title": "Swarm entity display",
-    "description": "How to display an entity or robot in the Swarm game",
+    "description": "A display specifies how an entity or a robot (robots are essentially special kinds of entities) is displayed in the world.  It consists of a key-value mapping described by the following table.",
     "type": "object",
     "properties": {
         "char": {

src/Swarm/Doc/Gen.hs

@@ -42,6 +42,7 @@ import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Data.Tuple (swap)
 import Swarm.Doc.Pedagogy
+import Swarm.Doc.Scenario
 import Swarm.Game.Display (displayChar)
 import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)
 import Swarm.Game.Entity qualified as E
@@ -88,7 +89,7 @@ data GenerateDocs where
 data EditorType = Emacs | VSCode
   deriving (Eq, Show, Enum, Bounded)
 
-data SheetType = Entities | Commands | Capabilities | Recipes
+data SheetType = Entities | Commands | Capabilities | Recipes | Scenario
   deriving (Eq, Show, Enum, Bounded)
 
 data PageAddress = PageAddress
@@ -131,6 +132,7 @@ generateDocs = \case
         entities <- loadEntities
         recipes <- loadRecipes entities
         sendIO $ T.putStrLn $ recipePage address recipes
+      Scenario -> genScenarioSchemaDocs
   TutorialCoverage -> renderTutorialProgression >>= putStrLn . T.unpack
 
 -- ----------------------------------------------------------------------------

src/Swarm/Doc/Scenario.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Render a markdown document fragment
+-- from the Scenario JSON schema files.
+module Swarm.Doc.Scenario where
+
+import Control.Applicative ((<|>))
+import Control.Arrow (left, (&&&))
+import Data.Aeson
+import Data.Map.Strict qualified as M
+import Data.Maybe (fromMaybe)
+import Data.Text qualified as T
+import Swarm.Doc.Schema
+import Swarm.Util (quote, showT)
+import System.FilePath ((<.>), (</>))
+import Text.Pandoc
+import Text.Pandoc.Builder
+
+scenariosDir :: FilePath
+scenariosDir = "data/scenarios"
+
+schemasDir :: FilePath
+schemasDir = "data/schema"
+
+inputFiles :: [FilePath]
+inputFiles =
+  [ "scenario"
+  , "combustion"
+  , "display"
+  , "world"
+  ]
+
+columnHeadings :: [T.Text]
+columnHeadings =
+  [ "Key"
+  , "Default?"
+  , "Type"
+  , "Description"
+  ]
+
+makePandocTable :: (String, Schema) -> Pandoc
+makePandocTable (fn, schm) =
+  setTitle (text "JSON Schema for Scenarios") $
+    doc $
+      header 3 (text $ T.toTitle $ T.pack fn) <> para (text $ description schm) <> myTable
+ where
+  genRow :: (T.Text, Prop) -> [Blocks]
+  genRow (k, x) =
+    [ plain $ code k
+    , maybe mempty (plain . code . renderValue) $ _default x
+    , plain . code . fromMaybe "" $ _type x <|> _Sref x
+    , plain . text . fromMaybe "" $ _description x <|> _Sref x
+    ]
+
+  headerRow = map (plain . text) columnHeadings
+  myTable = simpleTable headerRow . map genRow . M.toList $ properties schm
+
+genScenarioSchemaDocs :: IO ()
+genScenarioSchemaDocs = do
+  xs <- mapM (sequenceA . (id &&& eitherDecodeFileStrict . makeSchemaPath)) inputFiles
+  let eitherMarkdown = do
+        schemas <- left T.pack $ traverse sequenceA xs
+        let pd = mconcat $ map makePandocTable schemas
+        left renderError $ runPure (writeMarkdown (def {writerExtensions = extensionsFromList [Ext_pipe_tables]}) pd)
+
+  case eitherMarkdown of
+    Left e -> print $ unwords ["Failed:", T.unpack e]
+    Right md -> writeFile (scenariosDir </> "README_NEW.md") $ T.unpack md
+ where
+  makeSchemaPath bareName = schemasDir </> bareName <.> "json"
+
+renderValue :: Value -> T.Text
+renderValue = \case
+  Object obj -> showT obj
+  Array arr -> showT arr
+  String t -> quote t
+  Number num -> showT num
+  Bool b -> showT b
+  Null -> "null"

src/Swarm/Doc/Schema.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- There are no modern, comprehensive, JSON Schema parsing
+-- libraries in Haskell, as explained in this post:
+-- https://dev.to/sshine/a-review-of-json-schema-libraries-for-haskell-321
+--
+-- Therefore, a parser for a small, custom subset of JSON Schema is implemented here,
+-- simply for rendering Markdown documentation from Swarm's schema.
+module Swarm.Doc.Schema where
+
+import Data.Aeson
+import Data.List.Extra (replace)
+import Data.Map (Map)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+data ArrayItem = ArrayItem
+  { _Aname :: Maybe Text
+  , _Atype :: Text
+  }
+  deriving (Eq, Ord, Show, Generic)
+
+instance FromJSON ArrayItem where
+  parseJSON =
+    genericParseJSON
+      defaultOptions
+        { fieldLabelModifier = drop 2
+        }
+
+schemaJsonOptions :: Options
+schemaJsonOptions =
+  defaultOptions
+    { fieldLabelModifier = replace "S" "$" . tail -- drops leading underscore
+    }
+
+data Prop = Prop
+  { _default :: Maybe Value
+  , _items :: Maybe Value
+  , _description :: Maybe Text
+  , _type :: Maybe Text
+  , _examples :: Maybe [Value]
+  , _Sref :: Maybe Text
+  }
+  deriving (Eq, Ord, Show, Generic)
+
+instance FromJSON Prop where
+  parseJSON = genericParseJSON schemaJsonOptions
+
+data Schema = Schema
+  { description :: Text
+  , title :: Text
+  , properties :: Map Text Prop
+  }
+  deriving (Eq, Ord, Show, Generic, FromJSON)

swarm.cabal

@@ -87,6 +87,8 @@ library
                       Swarm.Constant
                       Swarm.Doc.Gen
                       Swarm.Doc.Pedagogy
+                      Swarm.Doc.Scenario
+                      Swarm.Doc.Schema
                       Swarm.Game.Failure
                       Swarm.Game.Achievement.Attainment
                       Swarm.Game.Achievement.Definitions
@@ -241,6 +243,8 @@ library
                       minimorph                     >= 0.3 && < 0.4,
                       transformers                  >= 0.5 && < 0.7,
                       mtl                           >= 2.2.2 && < 2.4,
+                      pandoc                        >= 3.0 && < 3.2,
+                      pandoc-types                  >= 1.23 && < 1.24,
                       murmur3                       >= 1.0.4 && < 1.1,
                       natural-sort                  >= 0.1.2 && < 0.2,
                       parser-combinators            >= 1.2 && < 1.4,