{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Render a markdown document fragment
-- from the Scenario JSON schema files.
module Swarm.Doc.Schema.Render where

import Control.Arrow (left, (&&&))
import Control.Monad.Except (runExceptT)
import Control.Monad.IO.Class (liftIO)
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.Scientific (FPFormat (..), Scientific, formatScientific)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Vector qualified as V
import Swarm.Doc.Schema.Arrangement
import Swarm.Doc.Schema.Parse
import Swarm.Doc.Schema.Refined
import Swarm.Doc.Schema.SchemaType
import Swarm.Doc.Util
import Swarm.Util (applyWhen, brackets, quote, showT)
import System.Directory (listDirectory)
import System.FilePath (splitExtension, (<.>), (</>))
import Text.Pandoc
import Text.Pandoc.Builder
import Text.Pandoc.Walk (query)

scenariosDir :: FilePath
scenariosDir :: FilePath
scenariosDir = FilePath
"data/scenarios"

docFragmentsDir :: FilePath
docFragmentsDir :: FilePath
docFragmentsDir = FilePath
scenariosDir FilePath -> FilePath -> FilePath
</> FilePath
"doc-fragments"

schemasDir :: FilePath
schemasDir :: FilePath
schemasDir = FilePath
"data/schema"

schemaExtension :: String
schemaExtension :: FilePath
schemaExtension = FilePath
".json"

propertyColumnHeadings :: [T.Text]
propertyColumnHeadings :: [Text]
propertyColumnHeadings =
  [ Text
"Key"
  , Text
"Default?"
  , Text
"Type"
  , Text
"Description"
  ]

listColumnHeadings :: [T.Text]
listColumnHeadings :: [Text]
listColumnHeadings =
  [ Text
"Index"
  , Text
"Type"
  , Text
"Description"
  ]

makeTitleMap :: [SchemaData] -> Map SchemaIdReference T.Text
makeTitleMap :: [SchemaData] -> Map SchemaIdReference Text
makeTitleMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SchemaIdReference
fromFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaData -> FilePath
schemaPath forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ToplevelSchema -> Text
title forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaData -> ToplevelSchema
schemaContent)

makePandocTable :: Map SchemaIdReference T.Text -> SchemaData -> Pandoc
makePandocTable :: Map SchemaIdReference Text -> SchemaData -> Pandoc
makePandocTable Map SchemaIdReference Text
titleMap (SchemaData FilePath
_ (ToplevelSchema Text
theTitle Maybe Pandoc
theDescription SwarmSchema
_schema Maybe Members
theMembers [FilePath]
_) [Pandoc]
parsedFooters) =
  Inlines -> Pandoc -> Pandoc
setTitle (Text -> Inlines
text Text
"JSON Schema for Scenarios") forall a b. (a -> b) -> a -> b
$
    Blocks -> Pandoc
doc (Int -> Inlines -> Blocks
header Int
3 (Text -> Inlines
text Text
theTitle))
      forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe Pandoc
theDescription
      forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Members -> Pandoc
mkTable Maybe Members
theMembers
      forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [Pandoc]
parsedFooters
 where
  renderItems :: ItemDescription SwarmSchema -> Blocks
renderItems ItemDescription SwarmSchema
someStuff = case ItemDescription SwarmSchema
someStuff of
    ItemType SwarmSchema
x -> Inlines -> Blocks
plain forall a b. (a -> b) -> a -> b
$ Text -> Inlines
text Text
"List of " forall a. Semigroup a => a -> a -> a
<> Map SchemaIdReference Text -> SchemaType -> Inlines
listToText Map SchemaIdReference Text
titleMap (SwarmSchema -> SchemaType
schemaType SwarmSchema
x)
    ItemList [SwarmSchema]
xs ->
      Bool
-> [Text]
-> Map SchemaIdReference Text
-> Map Text SwarmSchema
-> Blocks
makePropsTable Bool
False [Text]
listColumnHeadings Map SchemaIdReference Text
titleMap
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
tshow [Int
0 :: Int ..]) [SwarmSchema]
xs

  mkTable :: Members -> Pandoc
mkTable Members
x = Blocks -> Pandoc
doc forall a b. (a -> b) -> a -> b
$ case Members
x of
    ObjectProperties Map Text SwarmSchema
props -> Bool
-> [Text]
-> Map SchemaIdReference Text
-> Map Text SwarmSchema
-> Blocks
makePropsTable Bool
True [Text]
propertyColumnHeadings Map SchemaIdReference Text
titleMap Map Text SwarmSchema
props
    ListMembers ItemDescription SwarmSchema
someStuff -> ItemDescription SwarmSchema -> Blocks
renderItems ItemDescription SwarmSchema
someStuff

genPropsRow :: Bool -> Map SchemaIdReference T.Text -> (T.Text, SwarmSchema) -> [Blocks]
genPropsRow :: Bool
-> Map SchemaIdReference Text -> (Text, SwarmSchema) -> [Blocks]
genPropsRow Bool
includeDefaultColumn Map SchemaIdReference Text
titleMap (Text
k, SwarmSchema
x) =
  Blocks
firstColumn forall a. a -> [a] -> [a]
: forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
includeDefaultColumn (Blocks
defaultColumn forall a. a -> [a] -> [a]
:) [Blocks]
tailColumns
 where
  firstColumn :: Blocks
firstColumn = Inlines -> Blocks
plain forall a b. (a -> b) -> a -> b
$ Text -> Inlines
code Text
k
  defaultColumn :: Blocks
defaultColumn = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Inlines -> Blocks
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inlines
code forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Text
renderValue) forall a b. (a -> b) -> a -> b
$ SwarmSchema -> Maybe Value
defaultValue SwarmSchema
x
  tailColumns :: [Blocks]
tailColumns =
    [ Inlines -> Blocks
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SchemaIdReference Text -> SchemaType -> Inlines
listToText Map SchemaIdReference Text
titleMap forall a b. (a -> b) -> a -> b
$ SwarmSchema -> SchemaType
schemaType SwarmSchema
x
    , forall a. [a] -> Many a
fromList forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
query forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ SwarmSchema -> Maybe Pandoc
objectDescription SwarmSchema
x
    ]

makePropsTable ::
  Bool ->
  [T.Text] ->
  Map SchemaIdReference T.Text ->
  Map T.Text SwarmSchema ->
  Blocks
makePropsTable :: Bool
-> [Text]
-> Map SchemaIdReference Text
-> Map Text SwarmSchema
-> Blocks
makePropsTable Bool
includeDefaultColumn [Text]
headingsList Map SchemaIdReference Text
titleMap =
  [Blocks] -> [[Blocks]] -> Blocks
simpleTable [Blocks]
headerRow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Bool
-> Map SchemaIdReference Text -> (Text, SwarmSchema) -> [Blocks]
genPropsRow Bool
includeDefaultColumn Map SchemaIdReference Text
titleMap) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList
 where
  headerRow :: [Blocks]
headerRow = forall a b. (a -> b) -> [a] -> [b]
map (Inlines -> Blocks
plain forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inlines
text) [Text]
headingsList

type FileStemAndExtension = (FilePath, String)

recombineExtension :: FileStemAndExtension -> FilePath
recombineExtension :: FileStemAndExtension -> FilePath
recombineExtension (FilePath
filenameStem, FilePath
fileExtension) =
  FilePath
filenameStem FilePath -> FilePath -> FilePath
<.> FilePath
fileExtension

genMarkdown :: [SchemaData] -> Either T.Text T.Text
genMarkdown :: [SchemaData] -> Either Text Text
genMarkdown [SchemaData]
schemaThings =
  forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left PandocError -> Text
renderError forall a b. (a -> b) -> a -> b
$
    forall a. PandocPure a -> Either PandocError a
runPure forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeMarkdown (forall a. Default a => a
def {writerExtensions :: Extensions
writerExtensions = [Extension] -> Extensions
extensionsFromList [Extension
Ext_pipe_tables]}) Pandoc
pd
 where
  titleMap :: Map SchemaIdReference Text
titleMap = [SchemaData] -> Map SchemaIdReference Text
makeTitleMap [SchemaData]
schemaThings
  pd :: Pandoc
pd =
    forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (Map SchemaIdReference Text -> SchemaData -> Pandoc
makePandocTable Map SchemaIdReference Text
titleMap) forall a b. (a -> b) -> a -> b
$
        SchemaIdReference -> [SchemaData] -> [SchemaData]
sortAndPruneSchemas (FilePath -> SchemaIdReference
fromFilePath FilePath
"scenario") [SchemaData]
schemaThings

parseSchemaFile :: FileStemAndExtension -> IO (Either T.Text ToplevelSchema)
parseSchemaFile :: FileStemAndExtension -> IO (Either Text ToplevelSchema)
parseSchemaFile FileStemAndExtension
stemAndExtension =
  forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Text -> Text
prependPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => FilePath -> IO (Either FilePath a)
eitherDecodeFileStrict FilePath
fullPath
 where
  prependPath :: Text -> Text
prependPath = (([Text] -> Text
T.unwords [Text
"in", Text -> Text
quote (FilePath -> Text
T.pack FilePath
filename)] forall a. Semigroup a => a -> a -> a
<> Text
": ") forall a. Semigroup a => a -> a -> a
<>)
  filename :: FilePath
filename = FileStemAndExtension -> FilePath
recombineExtension FileStemAndExtension
stemAndExtension
  fullPath :: FilePath
fullPath = FilePath
schemasDir FilePath -> FilePath -> FilePath
</> FilePath
filename

loadFooterContent :: (FilePath, ToplevelSchema) -> IO SchemaData
loadFooterContent :: (FilePath, ToplevelSchema) -> IO SchemaData
loadFooterContent (FilePath
fp, ToplevelSchema
schem) = do
  [Text]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> IO Text
TIO.readFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
scenariosDir FilePath -> FilePath -> FilePath
</>)) forall a b. (a -> b) -> a -> b
$ ToplevelSchema -> [FilePath]
footerPaths ToplevelSchema
schem
  [Pandoc]
parsedFooters <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadFail m => Text -> m Pandoc
getMarkdown [Text]
xs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    FilePath -> ToplevelSchema -> [Pandoc] -> SchemaData
SchemaData
      FilePath
fp
      ToplevelSchema
schem
      [Pandoc]
parsedFooters

genScenarioSchemaDocs :: IO ()
genScenarioSchemaDocs :: IO ()
genScenarioSchemaDocs = do
  [FilePath]
dirContents <- FilePath -> IO [FilePath]
listDirectory FilePath
schemasDir
  let inputFiles :: [FileStemAndExtension]
inputFiles = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== FilePath
schemaExtension) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FileStemAndExtension
splitExtension [FilePath]
dirContents
  [(FilePath, Either Text ToplevelSchema)]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileStemAndExtension -> FilePath
recombineExtension forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& FileStemAndExtension -> IO (Either Text ToplevelSchema)
parseSchemaFile)) [FileStemAndExtension]
inputFiles

  Either Text ()
result <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    [(FilePath, ToplevelSchema)]
schemaTuples <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [(FilePath, Either Text ToplevelSchema)]
xs
    [SchemaData]
things <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath, ToplevelSchema) -> IO SchemaData
loadFooterContent [(FilePath, ToplevelSchema)]
schemaTuples
    Text
myMarkdown <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ [SchemaData] -> Either Text Text
genMarkdown [SchemaData]
things
    Text
docHeader <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
TIO.readFile FilePath
"data/scenarios/doc-fragments/header.md"
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> IO ()
writeFile (FilePath
docFragmentsDir FilePath -> FilePath -> FilePath
</> FilePath
"SCHEMA.md") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack forall a b. (a -> b) -> a -> b
$ Text
docHeader forall a. Semigroup a => a -> a -> a
<> Text
myMarkdown

  case Either Text ()
result of
    Left Text
e -> forall a. Show a => a -> IO ()
print forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath
"Failed:", Text -> FilePath
T.unpack Text
e]
    Right ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

renderValue :: Value -> T.Text
renderValue :: Value -> Text
renderValue = \case
  Object Object
obj -> forall a. Show a => a -> Text
showT Object
obj
  Array Array
arr -> Text -> Text
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
renderValue forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList Array
arr
  String Text
t -> Text -> Text
quote Text
t
  Number Scientific
num -> FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Scientific -> FilePath
formatNumberCompact Scientific
num
  Bool Bool
b -> forall a. Show a => a -> Text
showT Bool
b
  Value
Null -> Text
"null"

fragmentHref :: Map SchemaIdReference T.Text -> SchemaIdReference -> T.Text
fragmentHref :: Map SchemaIdReference Text -> SchemaIdReference -> Text
fragmentHref Map SchemaIdReference Text
titleMap r :: SchemaIdReference
r@(SchemaIdReference Text
ref) =
  Char -> Text -> Text
T.cons Char
'#' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
" " Text
"-" forall a b. (a -> b) -> a -> b
$ Text
x
 where
  x :: Text
x = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Text
ref SchemaIdReference
r Map SchemaIdReference Text
titleMap

listToText :: Map SchemaIdReference T.Text -> SchemaType -> Inlines
listToText :: Map SchemaIdReference Text -> SchemaType -> Inlines
listToText Map SchemaIdReference Text
titleMap = \case
  Simple SingleOrList Text
xs -> [Inlines] -> Inlines
renderAlternatives forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Inlines
code forall a b. (a -> b) -> a -> b
$ forall a. SingleOrList a -> [a]
getList SingleOrList Text
xs
  Alternatives [SchemaType]
xs -> [Inlines] -> Inlines
renderAlternatives forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Map SchemaIdReference Text -> SchemaType -> Inlines
listToText Map SchemaIdReference Text
titleMap) [SchemaType]
xs
  Reference r :: SchemaIdReference
r@(SchemaIdReference Text
x) -> SchemaIdReference -> Text -> Inlines
schemaLink SchemaIdReference
r Text
x
  ListOf SchemaType
x -> Map SchemaIdReference Text -> SchemaType -> Inlines
listToText Map SchemaIdReference Text
titleMap SchemaType
x forall a. Semigroup a => a -> a -> a
<> Text -> Inlines
text Text
" list"
 where
  renderAlternatives :: [Inlines] -> Inlines
renderAlternatives = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (Text -> Inlines
text Text
" or ")
  schemaLink :: SchemaIdReference -> Text -> Inlines
schemaLink SchemaIdReference
r = Text -> Text -> Inlines -> Inlines
link (Map SchemaIdReference Text -> SchemaIdReference -> Text
fragmentHref Map SchemaIdReference Text
titleMap SchemaIdReference
r) Text
"Link to object properties" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inlines
text

-- |
-- Strips trailing zeros and decimal point from a floating-point number
-- when possible.
--
-- Obtained from here: https://stackoverflow.com/a/35980995/105137
formatNumberCompact :: Scientific -> String
formatNumberCompact :: Scientific -> FilePath
formatNumberCompact Scientific
v
  | Scientific
v forall a. Eq a => a -> a -> Bool
== Scientific
0 = FilePath
"0"
  | forall a. Num a => a -> a
abs Scientific
v forall a. Ord a => a -> a -> Bool
< Scientific
1e-5 Bool -> Bool -> Bool
|| forall a. Num a => a -> a
abs Scientific
v forall a. Ord a => a -> a -> Bool
> Scientific
1e10 = FPFormat -> Maybe Int -> Scientific -> FilePath
formatScientific FPFormat
Exponent forall a. Maybe a
Nothing Scientific
v
  | Scientific
v forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (RealFrac a, Integral b) => a -> b
floor Scientific
v :: Integer) forall a. Eq a => a -> a -> Bool
== Scientific
0 = FPFormat -> Maybe Int -> Scientific -> FilePath
formatScientific FPFormat
Fixed (forall a. a -> Maybe a
Just Int
0) Scientific
v
  | Bool
otherwise = FPFormat -> Maybe Int -> Scientific -> FilePath
formatScientific FPFormat
Generic forall a. Maybe a
Nothing Scientific
v