simplex-chat/bots/src/API/Docs/Generate.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module API.Docs.Generate where

import API.Docs.Commands
import API.Docs.Events
import API.Docs.Responses
import API.Docs.Syntax
import API.Docs.Syntax.Types
import API.Docs.Types
import API.TypeInfo
import Data.Char (isSpace, isUpper, toLower, toUpper)
import qualified Data.List.NonEmpty as L
import Data.Text (Text)
import qualified Data.Text as T

commandsDocFile :: FilePath
commandsDocFile = "./bots/api/COMMANDS.md"

eventsDocFile :: FilePath
eventsDocFile = "./bots/api/EVENTS.md"

typesDocFile :: FilePath
typesDocFile = "./bots/api/TYPES.md"

commandsDocText :: Text
commandsDocText =
  ("# API Commands and Responses\n\n" <> autoGenerated <> "\n")
    <> foldMap commandCatTOC chatCommandsDocs
    <> "\n---\n"
    <> foldMap commandCatText chatCommandsDocs
  where
    commandCatTOC CCCategory {categoryName, commands} =
      (T.pack $ "\n" <> withLink "" categoryName <> "\n")
        <> foldMap commandTOC commands
      where
        commandTOC CCDoc {commandType = ATUnionMember tag _} = T.pack $ "- " <> withLink "" (fstToUpper tag) <> "\n"
    commandCatText CCCategory {categoryName, categoryDescr, commands} =
      (T.pack $ "\n\n## " <> categoryName <> "\n\n" <> categoryDescr <> "\n")
        <> foldMap commandDocText commands
      where
        commandDocText CCDoc {commandType = ATUnionMember tag params, commandDescr, network, syntax, responses, errors} =
          ("\n\n### " <> T.pack (fstToUpper tag) <> "\n\n" <> commandDescr <> "\n\n*Network usage*: " <> networkUsage network <> ".\n")
            <> (if null params then "" else paramsText)
            <> (if syntax == "" then "" else syntaxText (tag, params) syntax)
            <> (if length responses > 1 then "\n**Responses**:\n" else "\n**Response**:\n")
            <> foldMap responseText responses
            <> (if null errors then "" else "\n**Errors**:\n")
            <> foldMap errorText errors
            <> "\n---\n"
          where
            paramsText = "\n**Parameters**:\n" <> fieldsText "./TYPES.md" params
        responseText CRDoc {responseType = ATUnionMember tag fields, responseDescr} =
          (T.pack $ "\n" <> fstToUpper tag <> ": " <> respDescr <> ".\n")
            <> ("- type: \"" <> T.pack tag <> "\"\n")
            <> fieldsText "./TYPES.md" fields
          where
            respDescr = if null responseDescr then camelToSpace tag else responseDescr
        errorText (TD err descr) =
          let descr' = if null descr then camelToSpace err else descr
           in T.pack $ "- " <> fstToUpper err <> ": " <> descr' <> ".\n"

networkUsage :: Maybe UsesNetwork -> Text
networkUsage = \case
  Nothing -> "no"
  Just UNInteractive -> "interactive"
  Just UNBackground -> "background"

syntaxText :: TypeAndFields -> Expr -> Text
syntaxText r syntax =
  "\n**Syntax**:\n"
    <> "\n```\n" <> docSyntaxText r syntax <> "\n```\n"
    <> (if isConst syntax then "" else "\n```javascript\n" <> jsSyntaxText False "" r syntax <> " // JavaScript\n```\n")
    <> (if isConst syntax then "" else "\n```python\n" <> pySyntaxText r syntax <> " # Python\n```\n")

camelToSpace :: String -> String
camelToSpace [] = []
camelToSpace (x : xs) = toUpper x : go xs
  where
    go [] = []
    go (y : ys)
      | isUpper y = ' ' : toLower y : go ys
      | otherwise = y : go ys

eventsDocText :: Text
eventsDocText =
  ("# API Events\n\n" <> autoGenerated <> "\n")
    <> foldMap eventCatTOC chatEventsDocs
    <> "\n---\n"
    <> foldMap eventCatText chatEventsDocs
  where
    eventCatTOC CECategory {categoryName, mainEvents, otherEvents} =
      (T.pack $ "\n" <> withLink "" categoryName <> "\n")
        <> (if hasOthers then "- Main event" <> plural mainEvents <> "\n" else "")
        <> foldMap eventTOC mainEvents
        <> (if hasOthers then "- Other event" <> plural otherEvents <> "\n" <> foldMap eventTOC otherEvents else "")
      where
        eventTOC CEDoc {eventType = ATUnionMember tag _} = T.pack $ indent <> "- " <> withLink "" (fstToUpper tag) <> "\n"
        hasOthers = not $ null otherEvents
        indent = if hasOthers then "  " else ""
    eventCatText CECategory {categoryName, categoryDescr, mainEvents, otherEvents} =
      (T.pack $ "\n\n## " <> categoryName <> "\n\n" <> categoryDescr <> "\n")
        <> foldMap eventDocText (mainEvents ++ otherEvents)
      where
        eventDocText CEDoc {eventType = ATUnionMember tag fields, eventDescr} =
          (T.pack $ "\n\n### " <> fstToUpper tag <> "\n\n" <> evtDescr)
            <> "\n\n**Record type**:\n"
            <> ("- type: \"" <> T.pack tag <> "\"\n")
            <> fieldsText "./TYPES.md" fields
            <> "\n---\n"
          where
            evtDescr = if null eventDescr then camelToSpace tag <> "." else eventDescr
    plural evts = if length evts == 1 then "" else "s"

typesDocText :: Text
typesDocText =
  ("# API Types\n\n" <> autoGenerated <> "\n")
    <> (foldMap (\t -> T.pack $ "\n- " <> withLink "" (docTypeName t)) chatTypesDocs <> "\n")
    <> foldMap typeDocText chatTypesDocs
  where
    typeDocText CTDoc {typeDef = td@APITypeDef {typeName' = name, typeDef}, typeDescr, typeSyntax} =
      ("\n\n---\n\n## " <> T.pack name <> "\n")
        <> (if T.null typeDescr then "" else "\n" <> typeDescr <> "\n")
        <> typeDefText typeDef
        <> (if typeSyntax == "" then "" else syntaxText (name, self : typeFields) typeSyntax)
      where
        self = APIRecordField "self" (ATDef td)
        typeFields = case typeDef of
          ATDRecord fs -> fs
          ATDUnion ms -> APIRecordField "type" tagType : concatMap (\(ATUnionMember _ fs) -> fs) ms
            where
              tagType = ATDef $ APITypeDef (name <> ".type") $ ATDEnum tags
              tags = L.map (\(ATUnionMember tag _) -> tag) ms
          ATDEnum _ -> []
    typeDefText = \case
      ATDRecord fields -> "\n**Record type**:\n" <> fieldsText "" fields
      ATDEnum cs -> "\n**Enum type**:\n" <> foldMap (\m -> "- \"" <> T.pack m <> "\"\n") cs
      ATDUnion cs -> "\n**Discriminated union type**:\n" <> foldMap constrText cs
        where
          constrText (ATUnionMember tag fields) =
            ("\n" <> T.pack (fstToUpper tag) <> ":\n")
              <> ("- type: \"" <> T.pack tag <> "\"\n")
              <> fieldsText "" fields

fieldsText :: FilePath -> [APIRecordField] -> Text
fieldsText docPath = foldMap $ T.pack . fieldText
  where
    fieldText (APIRecordField name t) = "- " <> name <> ": " <> typeText t <> "\n"
    typeText = \case
      ATPrim (PT t) -> t
      ATDef (APITypeDef t _) -> withLink docPath t
      ATRef t -> withLink docPath t
      ATOptional t -> typeText t <> "?"
      ATArray {elemType} -> "[" <> typeText elemType <> "]"
      ATMap (PT t) valueType -> "{" <> t <> " : " <> typeText valueType <> "}"

autoGenerated :: Text
autoGenerated = "This file is generated automatically."

withLink :: FilePath -> String -> String
withLink docPath s = "[" <> s <> "](" <> docPath <> "#" <> headerAnchor s <> ")"
  where
    headerAnchor = map $ \c -> if isSpace c then '-' else toLower c