diff --git a/data/scenarios/doc-fragments/SCHEMA.md b/data/scenarios/doc-fragments/SCHEMA.md index 2420613d20..043b763948 100644 --- a/data/scenarios/doc-fragments/SCHEMA.md +++ b/data/scenarios/doc-fragments/SCHEMA.md @@ -149,6 +149,35 @@ table. | `orientationMap` | `fromList []` | [orientation-map](#orientation-map "Link to object properties") | | | `priority` | `1.0` | `number` | When multiple entities and robots occupy the same cell, the one with the highest priority is drawn. By default, entities have priority `1`, and robots have priority `10`. | +### Recipe + +Recipe describes a process that takes some inputs and produces some +outputs, which robots can access using `make` and `drill`. + +| Key | Default? | Type | Description | +|------------|----------|-----------------------------------------------------|---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------| +| `in` | | [inventory](#inventory "Link to object properties") | A list of ingredients consumed by the recipe. Each ingredient is a tuple consisting of an integer and an entity name, indicating the number of copies of the given entity that are needed. | +| `out` | | [inventory](#inventory "Link to object properties") | A list of outputs produced by the recipe. It is a list of `[count, entity name]` tuples just like `in`. | +| `required` | `[]` | [inventory](#inventory "Link to object properties") | A list of catalysts required by the recipe. They are neither consumed nor produced, but must be present in order for the recipe to be carried out. It is a list of \[count, entity name\] tuples just like in and out. | +| `time` | `1.0` | `number` | The number of ticks the recipe takes to perform. For recipes which take more than 1 tick, the robot will wait for a number of ticks until the recipe is complete. For example, this is used for many drilling recipes. | +| `weight` | `1.0` | `number` | Whenever there are multiple recipes that match the relevant criteria, one of them will be chosen at random, with probability proportional to their weights. For example, suppose there are two recipes that both output a widget, one with weight `1` and the other with weight `9`. When a robot executes `make "widget"`, the first recipe will be chosen 10% of the time, and the second recipe 90% of the time. | + +### Inventory + +A list of `[count, entity name]` pairs, specifying the number of each +entity. + +List of [entity-count](#entity-count "Link to object properties") + +### Entity count + +One row in an inventory list + +| Index | Default? | Type | Description | +|-------|----------|----------|-------------| +| `0` | | `number` | Quantity | +| `1` | | `string` | Entity name | + ### World Description of the world in the Swarm game @@ -225,27 +254,6 @@ Explicit waypoint definition | `loc` | | [planar-loc](#planar-location "Link to object properties") | | | `name` | | `string` | Waypoint name | -### Recipe - -Recipe describes a process that takes some inputs and produces some -outputs, which robots can access using `make` and `drill`. - -| Key | Default? | Type | Description | -|------------|----------|-----------------------------------------------------|---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------| -| `in` | | [inventory](#inventory "Link to object properties") | A list of ingredients consumed by the recipe. Each ingredient is a tuple consisting of an integer and an entity name, indicating the number of copies of the given entity that are needed. | -| `out` | | [inventory](#inventory "Link to object properties") | A list of outputs produced by the recipe. It is a list of `[count, entity name]` tuples just like `in`. | -| `required` | `[]` | [inventory](#inventory "Link to object properties") | A list of catalysts required by the recipe. They are neither consumed nor produced, but must be present in order for the recipe to be carried out. It is a list of \[count, entity name\] tuples just like in and out. | -| `time` | `1.0` | `number` | The number of ticks the recipe takes to perform. For recipes which take more than 1 tick, the robot will wait for a number of ticks until the recipe is complete. For example, this is used for many drilling recipes. | -| `weight` | `1.0` | `number` | Whenever there are multiple recipes that match the relevant criteria, one of them will be chosen at random, with probability proportional to their weights. For example, suppose there are two recipes that both output a widget, one with weight `1` and the other with weight `9`. When a robot executes `make "widget"`, the first recipe will be chosen 10% of the time, and the second recipe 90% of the time. | - -### Inventory - -A list of `[count, entity name]` pairs, specifying the number of each -entity. - -| Key | Default? | Type | Description | -|-----|----------|------|-------------| - ### Objective Scenario goals and their prerequisites. The top-level objectives field @@ -287,8 +295,10 @@ Structure placement x and y coordinates of a location in a particular world -| Key | Default? | Type | Description | -|-----|----------|------|-------------| +| Index | Default? | Type | Description | +|-------|----------|----------|--------------| +| `0` | | `number` | X coordinate | +| `1` | | `number` | Y coordinate | ### Portal @@ -314,15 +324,14 @@ Properties of a portal's exit Prerequisite conditions for an objective. -| Key | Default? | Type | Description | -|-----|----------|------|-------------| - ### Numeric range Min/max range of a value -| Key | Default? | Type | Description | -|-----|----------|------|-------------| +| Index | Default? | Type | Description | +|-------|----------|----------|-------------| +| `0` | | `number` | minimum | +| `1` | | `number` | maximum | ### Structure orientation diff --git a/data/schema/entity-count.json b/data/schema/entity-count.json new file mode 100644 index 0000000000..f04a137429 --- /dev/null +++ b/data/schema/entity-count.json @@ -0,0 +1,17 @@ +{ + "$schema": "http://json-schema.org/draft-07/schema#", + "$id": "https://raw.githubusercontent.com/swarm-game/swarm/main/data/schema/entity-count.json", + "title": "Entity count", + "description": "One row in an inventory list", + "type": "array", + "items": [ + { + "name": "Quantity", + "type": "number" + }, + { + "name": "Entity name", + "type": "string" + } + ] +} \ No newline at end of file diff --git a/data/schema/inventory.json b/data/schema/inventory.json index 70b79caa15..5b67e00a46 100644 --- a/data/schema/inventory.json +++ b/data/schema/inventory.json @@ -5,16 +5,6 @@ "description": "A list of `[count, entity name]` pairs, specifying the number of each entity.", "type": "array", "items": { - "type": "array", - "items": [ - { - "title": "Entity count", - "type": "number" - }, - { - "title": "Entity name", - "type": "string" - } - ] + "$ref": "entity-count.json" } } \ No newline at end of file diff --git a/src/Swarm/Doc/Gen.hs b/src/Swarm/Doc/Gen.hs index 1cc3d631db..84014f0a90 100644 --- a/src/Swarm/Doc/Gen.hs +++ b/src/Swarm/Doc/Gen.hs @@ -43,6 +43,7 @@ import Data.Text.IO qualified as T import Data.Tuple (swap) import Swarm.Doc.Pedagogy import Swarm.Doc.Schema.Render +import Swarm.Doc.Util import Swarm.Game.Display (displayChar) import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities) import Swarm.Game.Entity qualified as E @@ -221,12 +222,6 @@ generateSpecialKeyNames = -- GENERATE TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE -- ---------------------------------------------------------------------------- -wrap :: Char -> Text -> Text -wrap c = T.cons c . flip T.snoc c - -codeQuote :: Text -> Text -codeQuote = wrap '`' - escapeTable :: Text -> Text escapeTable = T.concatMap (\c -> if c == '|' then T.snoc "\\" c else T.singleton c) @@ -241,12 +236,6 @@ listToRow mw xs = wrap '|' . T.intercalate "|" $ zipWith format mw xs maxWidths :: [[Text]] -> [Int] maxWidths = map (maximum . map T.length) . transpose -addLink :: Text -> Text -> Text -addLink l t = T.concat ["[", t, "](", l, ")"] - -tshow :: (Show a) => a -> Text -tshow = T.pack . show - -- --------- -- COMMANDS -- --------- diff --git a/src/Swarm/Doc/Schema/Arrangement.hs b/src/Swarm/Doc/Schema/Arrangement.hs index 6e0c18b20a..8e1697efa5 100644 --- a/src/Swarm/Doc/Schema/Arrangement.hs +++ b/src/Swarm/Doc/Schema/Arrangement.hs @@ -3,12 +3,13 @@ -- -- Graph-based heuristics for arranging the -- order of sections in the schema docs -module Swarm.Doc.Schema.Arrangement (mkSchemaGraph) where +module Swarm.Doc.Schema.Arrangement (sortAndPruneSchemas) where import Data.Graph import Data.Set qualified as Set import Swarm.Doc.Schema.Parse import Swarm.Doc.Schema.Refined +import Swarm.Doc.Schema.SchemaType -- | Sort the schemas in topological order. -- @@ -17,18 +18,16 @@ import Swarm.Doc.Schema.Refined -- (i.e. exclude @entities.json@ and @recipes.json@, -- which are used independently to validate @entities.yaml@ -- and @recipes.yaml@). -mkSchemaGraph :: +sortAndPruneSchemas :: SchemaIdReference -> [SchemaData] -> [SchemaData] -mkSchemaGraph rootSchemaKey schemas = +sortAndPruneSchemas rootSchemaKey schemas = reverse . flattenSCCs . stronglyConnComp $ reachableEdges where rawEdgeList = map getNodeEdgesEntry schemas (graph, _nodeFromVertex, vertexFromKey) = graphFromEdges rawEdgeList - - scenarioVertex = vertexFromKey rootSchemaKey - reachableVertices = Set.fromList $ maybe [] (reachable graph) scenarioVertex + reachableVertices = Set.fromList $ maybe [] (reachable graph) $ vertexFromKey rootSchemaKey reachableEdges = filter f rawEdgeList f (_, k, _) = maybe False (`Set.member` reachableVertices) . vertexFromKey $ k diff --git a/src/Swarm/Doc/Schema/Parse.hs b/src/Swarm/Doc/Schema/Parse.hs index cbdba04d91..75bf3dcab6 100644 --- a/src/Swarm/Doc/Schema/Parse.hs +++ b/src/Swarm/Doc/Schema/Parse.hs @@ -11,17 +11,12 @@ module Swarm.Doc.Schema.Parse where import Control.Applicative ((<|>)) import Data.Aeson -import Data.List.Extra (replace) import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Set (Set) -import Data.Set qualified as Set +import Data.Maybe (fromMaybe) import Data.Text (Text) -import Data.Text qualified as T -import GHC.Generics (Generic) import Swarm.Doc.Schema.Refined -import System.FilePath (takeBaseName) +import Swarm.Doc.Schema.SchemaType +import Swarm.Doc.Schema.Superset import Text.Pandoc -- | Includes everything needed to @@ -32,48 +27,17 @@ data SchemaData = SchemaData , markdownFooters :: [Pandoc] } -schemaJsonOptions :: Options -schemaJsonOptions = - defaultOptions - { fieldLabelModifier = replace "S" "$" . tail -- drops leading underscore - } - -data ItemDescription - = ItemList [SwarmSchema] - | ItemType SwarmSchema +data Members + = ObjectProperties (Map Text SwarmSchema) + | ListMembers (ItemDescription SwarmSchema) + | SimpleType (SingleOrList Text) -- TODO: Currently unused deriving (Eq, Ord, Show) -instance FromJSON ItemDescription where - parseJSON x = - ItemType <$> parseJSON x - <|> ItemList <$> parseJSON x - -data SchemaRaw = SchemaRaw - { _description :: Maybe Text - , _default :: Maybe Value - , _title :: Maybe Text - , _type :: Maybe (SingleOrList Text) - , _properties :: Maybe (Map Text SwarmSchema) - , _items :: Maybe ItemDescription - , _examples :: Maybe [Value] - , _Sref :: Maybe Text - , _oneOf :: Maybe [SchemaRaw] - , _footers :: Maybe [FilePath] - } - deriving (Eq, Ord, Show, Generic) - -instance FromJSON SchemaRaw where - parseJSON = genericParseJSON schemaJsonOptions - --- | A subset of all JSON schemas, conforming to internal Swarm conventions. --- --- TODO: Conveniently, this extra layer of processing --- is able to enforce that all "object" definitions in the schema --- contain the @additionalProperties: false@ property. data ToplevelSchema = ToplevelSchema { title :: Text , description :: Pandoc , content :: SwarmSchema + , members :: Maybe Members , footerPaths :: [FilePath] } deriving (Eq, Ord, Show) @@ -86,71 +50,8 @@ instance FromJSON ToplevelSchema where theTitle <- maybe (fail "Schema requires a title") return $ _title rawSchema theDescription <- maybe (fail "Schema requires a description") return $ objectDescription swarmSchema let theFooters = fromMaybe [] $ _footers rawSchema - return $ ToplevelSchema theTitle theDescription swarmSchema theFooters - --- TODO use this to represent mutual-exclusivity --- between objects and arrays -data Members - = ObjectProperties (Map Text SwarmSchema) - | ListMembers [SwarmSchema] - -data SwarmSchema = SwarmSchema - { schemaType :: SchemaType - , defaultValue :: Maybe Value - , objectDescription :: Maybe Pandoc - , properties :: Maybe (Map Text SwarmSchema) - , examples :: [Value] - } - deriving (Eq, Ord, Show) - -instance FromJSON SwarmSchema where - parseJSON x = do - rawSchema :: rawSchema <- parseJSON x - toSwarmSchema rawSchema - -getMarkdown :: MonadFail m => Text -> m Pandoc -getMarkdown desc = case runPure (readMarkdown def desc) of - Right doc -> return doc - Left err -> fail $ T.unpack $ renderError err - -extractSchemaType :: SchemaRaw -> Maybe SchemaType -extractSchemaType rawSchema = - mkReference <$> _Sref rawSchema - <|> getTypeFromItems - <|> Simple <$> _type rawSchema - <|> Alternatives . mapMaybe extractSchemaType <$> _oneOf rawSchema - where - mkReference = Reference . SchemaIdReference . T.pack . takeBaseName . T.unpack - - getTypeFromItems :: Maybe SchemaType - getTypeFromItems = do - itemsThing <- _items rawSchema - case itemsThing of - ItemList _ -> Nothing - ItemType x -> Just $ ListOf $ schemaType x - -toSwarmSchema :: MonadFail m => SchemaRaw -> m SwarmSchema -toSwarmSchema rawSchema = do - theType <- maybe (fail "Unspecified sub-schema type") return maybeType - markdownDescription <- mapM getMarkdown $ _description rawSchema - return - SwarmSchema - { schemaType = theType - , defaultValue = _default rawSchema - , objectDescription = markdownDescription - , examples = fromMaybe [] $ _examples rawSchema - , properties = _properties rawSchema - } - where - maybeType = extractSchemaType rawSchema - --- * Utilities - --- | Recursively extract references to other schemas -extractReferences :: SwarmSchema -> Set SchemaIdReference -extractReferences s = thisRefList <> otherRefLists - where - thisRefList = Set.fromList . getSchemaReferences $ schemaType s - otherSchemas = maybe [] M.elems (properties s) - otherRefLists = Set.unions $ map extractReferences otherSchemas + let maybeMembers = + ObjectProperties <$> properties swarmSchema + <|> ListMembers <$> itemsDescription swarmSchema + return $ ToplevelSchema theTitle theDescription swarmSchema maybeMembers theFooters diff --git a/src/Swarm/Doc/Schema/Refined.hs b/src/Swarm/Doc/Schema/Refined.hs index 6b6f98261a..8d4b4237d2 100644 --- a/src/Swarm/Doc/Schema/Refined.hs +++ b/src/Swarm/Doc/Schema/Refined.hs @@ -9,40 +9,67 @@ module Swarm.Doc.Schema.Refined where import Control.Applicative ((<|>)) import Data.Aeson -import Data.List (intersperse) +import Data.List.Extra (replace) import Data.Map (Map) import Data.Map qualified as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import GHC.Generics (Generic) +import Swarm.Doc.Schema.SchemaType +import Swarm.Doc.Schema.Superset import System.FilePath (takeBaseName) +import Text.Pandoc import Text.Pandoc.Builder -newtype SingleOrList a = SingleOrList - { getList :: [a] +-- * Basic + +schemaJsonOptions :: Options +schemaJsonOptions = + defaultOptions + { fieldLabelModifier = replace "S" "$" . drop 1 -- drops leading underscore + } + +-- | A single record that encompasses all possible objects +-- in a JSON schema. All fields are optional. +data SchemaRaw = SchemaRaw + { _description :: Maybe Text + , _default :: Maybe Value + , _title :: Maybe Text + , _type :: Maybe (SingleOrList Text) + , _name :: Maybe Text + , _properties :: Maybe (Map Text SwarmSchema) -- TODO Maybe this should be SchemaRaw + , _items :: Maybe (ItemDescription SwarmSchema) -- TODO Maybe this should be SchemaRaw + , _examples :: Maybe [Value] + , _Sref :: Maybe Text + , _oneOf :: Maybe [SchemaRaw] + , _footers :: Maybe [FilePath] + , _additionalProperties :: Maybe Bool } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) -instance (FromJSON a) => FromJSON (SingleOrList a) where - parseJSON x = - SingleOrList <$> do - (pure <$> parseJSON x) <|> parseJSON x +instance FromJSON SchemaRaw where + parseJSON = genericParseJSON schemaJsonOptions -newtype SchemaIdReference = SchemaIdReference Text - deriving (Eq, Ord, Show) +extractSchemaType :: SchemaRaw -> Maybe SchemaType +extractSchemaType rawSchema = + mkReference <$> _Sref rawSchema + <|> getTypeFromItems + <|> Simple <$> _type rawSchema + <|> Alternatives . mapMaybe extractSchemaType <$> _oneOf rawSchema + where + mkReference = Reference . SchemaIdReference . T.pack . takeBaseName . T.unpack -fromFilePath :: FilePath -> SchemaIdReference -fromFilePath = SchemaIdReference . T.pack . takeBaseName - -data SchemaType - = -- | A basic built-in type - Simple (SingleOrList Text) - | -- | Any one of multiple possible schema types - Alternatives [SchemaType] - | -- | A reference to a schema defined elsewhere - Reference SchemaIdReference - | -- | Members of a list, all of the given schema type - ListOf SchemaType - deriving (Eq, Ord, Show) + getTypeFromItems :: Maybe SchemaType + getTypeFromItems = do + itemsThing <- _items rawSchema + case itemsThing of + ItemList _ -> Nothing + ItemType x -> Just $ ListOf $ schemaType x + +-- * Refined getSchemaReferences :: SchemaType -> [SchemaIdReference] getSchemaReferences = \case @@ -51,18 +78,59 @@ getSchemaReferences = \case Reference x -> pure x ListOf x -> getSchemaReferences x -fragmentHref :: Map SchemaIdReference Text -> SchemaIdReference -> Text -fragmentHref titleMap r@(SchemaIdReference ref) = - T.cons '#' . T.toLower . T.replace " " "-" $ x +-- | A subset of all JSON schemas, conforming to internal Swarm conventions. +-- +-- Conveniently, this extra representation layer +-- is able to enforce (via 'toSwarmSchema') that all "object" +-- definitions in the schema contain the @"additionalProperties": true@ attribute. +data SwarmSchema = SwarmSchema + { schemaType :: SchemaType + , defaultValue :: Maybe Value + , objectDescription :: Maybe Pandoc + , properties :: Maybe (Map Text SwarmSchema) + , itemsDescription :: Maybe (ItemDescription SwarmSchema) + , examples :: [Value] + } + deriving (Eq, Ord, Show) + +instance FromJSON SwarmSchema where + parseJSON x = do + rawSchema :: rawSchema <- parseJSON x + toSwarmSchema rawSchema + +getMarkdown :: MonadFail m => Text -> m Pandoc +getMarkdown desc = case runPure (readMarkdown def desc) of + Right d -> return d + Left err -> fail $ T.unpack $ renderError err + +toSwarmSchema :: MonadFail m => SchemaRaw -> m SwarmSchema +toSwarmSchema rawSchema = do + theType <- maybe (fail "Unspecified sub-schema type") return maybeType + markdownDescription <- mapM getMarkdown $ _description rawSchema + + if null (_properties rawSchema) || not (fromMaybe True (_additionalProperties rawSchema)) + then return () + else fail "All objects must specify '\"additionalProperties\": true'" + + return + SwarmSchema + { schemaType = theType + , defaultValue = _default rawSchema + , objectDescription = markdownDescription <|> doc . plain . text <$> _name rawSchema + , examples = fromMaybe [] $ _examples rawSchema + , properties = _properties rawSchema + , itemsDescription = _items rawSchema + } where - x = M.findWithDefault ref r titleMap - -listToText :: Map SchemaIdReference Text -> SchemaType -> Inlines -listToText titleMap = \case - Simple xs -> renderAlternatives $ map code $ getList xs - Alternatives xs -> renderAlternatives $ map (listToText titleMap) xs - Reference r@(SchemaIdReference x) -> schemaLink r x - ListOf x -> text "[" <> listToText titleMap x <> text "]" + maybeType = extractSchemaType rawSchema + +-- * Utilities + +-- | Recursively extract references to other schemas +extractReferences :: SwarmSchema -> Set SchemaIdReference +extractReferences s = thisRefList <> otherRefLists where - renderAlternatives = mconcat . intersperse (text " or ") - schemaLink r = link (fragmentHref titleMap r) "Link to object properties" . text + thisRefList = Set.fromList . getSchemaReferences $ schemaType s + + otherSchemas = maybe [] M.elems $ properties s + otherRefLists = Set.unions $ map extractReferences otherSchemas diff --git a/src/Swarm/Doc/Schema/Render.hs b/src/Swarm/Doc/Schema/Render.hs index 0b7cfb6a0d..4e40c419c5 100644 --- a/src/Swarm/Doc/Schema/Render.hs +++ b/src/Swarm/Doc/Schema/Render.hs @@ -11,14 +11,17 @@ import Control.Arrow (left, (&&&)) import Control.Monad.Except (liftIO, runExceptT) import Control.Monad.Trans.Except (except) import Data.Aeson +import Data.List (intersperse) import Data.Map (Map) import Data.Map.Strict qualified as M -import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Swarm.Doc.Schema.Arrangement import Swarm.Doc.Schema.Parse import Swarm.Doc.Schema.Refined +import Swarm.Doc.Schema.SchemaType +import Swarm.Doc.Schema.Superset +import Swarm.Doc.Util import Swarm.Util (quote, showT) import System.Directory (listDirectory) import System.FilePath (splitExtension, (<.>), ()) @@ -38,35 +41,62 @@ schemasDir = "data/schema" schemaExtension :: String schemaExtension = ".json" -columnHeadings :: [T.Text] -columnHeadings = +propertyColumnHeadings :: [T.Text] +propertyColumnHeadings = [ "Key" , "Default?" , "Type" , "Description" ] +listColumnHeadings :: [T.Text] +listColumnHeadings = + [ "Index" + , "Default?" + , "Type" + , "Description" + ] + makeTitleMap :: [SchemaData] -> Map SchemaIdReference T.Text makeTitleMap = M.fromList . map (fromFilePath . schemaPath &&& title . schemaContent) makePandocTable :: Map SchemaIdReference T.Text -> SchemaData -> Pandoc -makePandocTable titleMap (SchemaData _ (ToplevelSchema theTitle theDescription schm _) parsedFooters) = +makePandocTable titleMap (SchemaData _ (ToplevelSchema theTitle theDescription _schema theMembers _) parsedFooters) = setTitle (text "JSON Schema for Scenarios") $ doc (header 3 (text theTitle)) <> theDescription - <> doc myTable + <> maybe mempty mkTable theMembers <> mconcat parsedFooters where - genRow :: (T.Text, SwarmSchema) -> [Blocks] - genRow (k, x) = - [ plain $ code k - , maybe mempty (plain . code . renderValue) $ defaultValue x - , plain . listToText titleMap $ schemaType x - , fromList $ maybe [] (query id) $ objectDescription x - ] + renderItems someStuff = case someStuff of + ItemType x -> plain $ text "List of " <> listToText titleMap (schemaType x) + ItemList xs -> + makePropsTable listColumnHeadings titleMap + . M.fromList + $ zip (map tshow [0 :: Int ..]) xs + + mkTable x = doc $ case x of + ObjectProperties props -> makePropsTable propertyColumnHeadings titleMap props + ListMembers someStuff -> renderItems someStuff + SimpleType _ -> plain $ text "Simple type" -- FIXME not used yet + +genPropsRow :: Map SchemaIdReference T.Text -> (T.Text, SwarmSchema) -> [Blocks] +genPropsRow titleMap (k, x) = + [ plain $ code k + , maybe mempty (plain . code . renderValue) $ defaultValue x + , plain . listToText titleMap $ schemaType x + , fromList $ maybe [] (query id) $ objectDescription x + ] - headerRow = map (plain . text) columnHeadings - myTable = simpleTable headerRow . map genRow . M.toList . fromMaybe mempty $ properties schm +makePropsTable :: + [T.Text] -> + Map SchemaIdReference T.Text -> + Map T.Text SwarmSchema -> + Blocks +makePropsTable headingsList titleMap = + simpleTable headerRow . map (genPropsRow titleMap) . M.toList + where + headerRow = map (plain . text) headingsList type FileStemAndExtension = (FilePath, String) @@ -84,7 +114,7 @@ genMarkdown schemaThings = pd = mconcat $ map (makePandocTable titleMap) $ - mkSchemaGraph (fromFilePath "scenario") schemaThings + sortAndPruneSchemas (fromFilePath "scenario") schemaThings parseSchemaFile :: FileStemAndExtension -> IO (Either T.Text ToplevelSchema) parseSchemaFile stemAndExtension = @@ -128,3 +158,19 @@ renderValue = \case Number num -> showT num Bool b -> showT b Null -> "null" + +fragmentHref :: Map SchemaIdReference T.Text -> SchemaIdReference -> T.Text +fragmentHref titleMap r@(SchemaIdReference ref) = + T.cons '#' . T.toLower . T.replace " " "-" $ x + where + x = M.findWithDefault ref r titleMap + +listToText :: Map SchemaIdReference T.Text -> SchemaType -> Inlines +listToText titleMap = \case + Simple xs -> renderAlternatives $ map code $ getList xs + Alternatives xs -> renderAlternatives $ map (listToText titleMap) xs + Reference r@(SchemaIdReference x) -> schemaLink r x + ListOf x -> text "[" <> listToText titleMap x <> text "]" + where + renderAlternatives = mconcat . intersperse (text " or ") + schemaLink r = link (fragmentHref titleMap r) "Link to object properties" . text diff --git a/src/Swarm/Doc/Schema/SchemaType.hs b/src/Swarm/Doc/Schema/SchemaType.hs new file mode 100644 index 0000000000..e6d8cd3b7a --- /dev/null +++ b/src/Swarm/Doc/Schema/SchemaType.hs @@ -0,0 +1,36 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Doc.Schema.SchemaType where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Text (Text) +import Data.Text qualified as T +import System.FilePath (takeBaseName) + +newtype SingleOrList a = SingleOrList + { getList :: [a] + } + deriving (Eq, Ord, Show) + +instance (FromJSON a) => FromJSON (SingleOrList a) where + parseJSON x = + fmap SingleOrList $ + pure <$> parseJSON x <|> parseJSON x + +data SchemaType + = -- | A basic built-in type + Simple (SingleOrList Text) + | -- | Any one of multiple possible schema types + Alternatives [SchemaType] + | -- | A reference to a schema defined elsewhere + Reference SchemaIdReference + | -- | Members of a list, all of the given schema type + ListOf SchemaType + deriving (Eq, Ord, Show) + +newtype SchemaIdReference = SchemaIdReference Text + deriving (Eq, Ord, Show) + +fromFilePath :: FilePath -> SchemaIdReference +fromFilePath = SchemaIdReference . T.pack . takeBaseName diff --git a/src/Swarm/Doc/Schema/Superset.hs b/src/Swarm/Doc/Schema/Superset.hs new file mode 100644 index 0000000000..f6edfb5f2d --- /dev/null +++ b/src/Swarm/Doc/Schema/Superset.hs @@ -0,0 +1,22 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Surface-level parsing of a JSON Schema +module Swarm.Doc.Schema.Superset where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Text.Pandoc.Builder + +data ItemDescription a + = ItemList [a] + | ItemType a + deriving (Eq, Ord, Show) + +instance (FromJSON a) => FromJSON (ItemDescription a) where + parseJSON x = + -- TODO Which ordering is preferred? + -- ItemType <$> parseJSON x + -- <|> ItemList <$> parseJSON x + ItemList <$> parseJSON x + <|> ItemType <$> parseJSON x diff --git a/src/Swarm/Doc/Util.hs b/src/Swarm/Doc/Util.hs new file mode 100644 index 0000000000..005457dfae --- /dev/null +++ b/src/Swarm/Doc/Util.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utilities for generating doc markup +module Swarm.Doc.Util where + +import Data.Text (Text) +import Data.Text qualified as T + +wrap :: Char -> Text -> Text +wrap c = T.cons c . flip T.snoc c + +codeQuote :: Text -> Text +codeQuote = wrap '`' + +addLink :: Text -> Text -> Text +addLink l t = T.concat ["[", t, "](", l, ")"] + +tshow :: (Show a) => a -> Text +tshow = T.pack . show diff --git a/swarm.cabal b/swarm.cabal index 2080e7bd1a..5aae6c463f 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -107,6 +107,9 @@ library Swarm.Doc.Schema.Parse Swarm.Doc.Schema.Refined Swarm.Doc.Schema.Render + Swarm.Doc.Schema.SchemaType + Swarm.Doc.Schema.Superset + Swarm.Doc.Util Swarm.Game.Failure Swarm.Game.Achievement.Attainment Swarm.Game.Achievement.Definitions