mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-11 11:04:56 +00:00
bots: generate code for TypeScript types module from Haskell tests (#6220)
* bots: generate code for TypeScript types module from Haskell tests * types for API events and command responses * code for chat command types * license, readme * fix array types * fix more types * add response type * add Connect command to docs/ts * update typescript client package to use auto-generated types
This commit is contained in:
Evgeny
@@ -0,0 +1,189 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module API.Docs.Generate.TypeScript where
|
||||
|
||||
import API.Docs.Commands
|
||||
import API.Docs.Events
|
||||
import API.Docs.Generate
|
||||
import API.Docs.Responses
|
||||
import API.Docs.Syntax
|
||||
import API.Docs.Syntax.Types
|
||||
import API.Docs.Types
|
||||
import API.TypeInfo
|
||||
import Data.Char (toUpper)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
commandsCodeFile :: FilePath
|
||||
commandsCodeFile = "./packages/simplex-chat-client/types/typescript/src/commands.ts"
|
||||
|
||||
responsesCodeFile :: FilePath
|
||||
responsesCodeFile = "./packages/simplex-chat-client/types/typescript/src/responses.ts"
|
||||
|
||||
eventsCodeFile :: FilePath
|
||||
eventsCodeFile = "./packages/simplex-chat-client/types/typescript/src/events.ts"
|
||||
|
||||
typesCodeFile :: FilePath
|
||||
typesCodeFile = "./packages/simplex-chat-client/types/typescript/src/types.ts"
|
||||
|
||||
commandsCodeText :: Text
|
||||
commandsCodeText =
|
||||
("// API Commands\n// " <> autoGenerated <> "\n")
|
||||
<> "\nimport * as T from \"./types\"\n"
|
||||
<> "\nimport {CR} from \"./responses\"\n"
|
||||
<> foldMap commandCatCode chatCommandsDocs
|
||||
where
|
||||
commandCatCode CCCategory {categoryName, categoryDescr, commands} =
|
||||
(T.pack $ "\n// " <> categoryName <> "\n// " <> categoryDescr <> "\n")
|
||||
<> foldMap commandCode commands
|
||||
where
|
||||
commandCode CCDoc {commandType = ATUnionMember tag params, commandDescr, syntax, responses, network} =
|
||||
("\n// " <> commandDescr <> "\n")
|
||||
<> ("// Network usage: " <> networkUsage network <> ".\n")
|
||||
<> ("export interface " <> T.pack constrName <> " {\n")
|
||||
<> fieldsCode "" "T." params
|
||||
<> "}\n\n"
|
||||
<> ("export namespace " <> T.pack constrName <> " {\n")
|
||||
<> (" export type Response = " <> constrsCode " " "CR" (("CR." <> ) . T.pack . fstToUpper . memberTag) (map responseType responses))
|
||||
<> (if syntax == "" then "" else funcCode APITypeDef {typeName' = constrName, typeDef = ATDRecord params} syntax)
|
||||
<> "}\n"
|
||||
where
|
||||
constrName = fstToUpper tag
|
||||
|
||||
responsesCodeText :: Text
|
||||
responsesCodeText =
|
||||
("// API Responses\n// " <> autoGenerated <> "\n")
|
||||
<> "\nimport * as T from \"./types\"\n"
|
||||
<> unionTypeCode "CR" "T." chatRespTypeDef chatRespConstrs ""
|
||||
where
|
||||
chatRespTypeDef = APITypeDef {typeName' = "ChatResponse", typeDef = ATDUnion chatRespConstrs}
|
||||
chatRespConstrs = L.fromList $ map responseType chatResponsesDocs
|
||||
|
||||
eventsCodeText :: Text
|
||||
eventsCodeText =
|
||||
("// API Events\n// " <> autoGenerated <> "\n")
|
||||
<> "\nimport * as T from \"./types\"\n"
|
||||
<> unionTypeCode "CEvt" "T." chatEventTypeDef chatEventConstrs ""
|
||||
where
|
||||
chatEventTypeDef = APITypeDef {typeName' = "ChatEvent", typeDef = ATDUnion chatEventConstrs}
|
||||
chatEventConstrs = L.fromList $ concatMap catEvents chatEventsDocs
|
||||
catEvents CECategory {mainEvents, otherEvents} = map eventType $ mainEvents ++ otherEvents
|
||||
|
||||
typesCodeText :: Text
|
||||
typesCodeText = ("// API Types\n// " <> autoGenerated <> "\n") <> foldMap typeCode chatTypesDocs
|
||||
where
|
||||
typeCode CTDoc {typeDef = td@APITypeDef {typeName' = name, typeDef}, typeDescr, typeSyntax} =
|
||||
(if T.null typeDescr then "" else "// " <> typeDescr <> "\n")
|
||||
<> typeDefCode
|
||||
-- <> (if typeSyntax == "" then "" else syntaxText (name, self : typeFields) typeSyntax)
|
||||
where
|
||||
name' = T.pack name
|
||||
constrName tag = case name of
|
||||
"ConnectionMode" -> T.pack $ map toUpper tag
|
||||
"FileProtocol" -> T.pack $ map toUpper tag
|
||||
_ -> T.replace "-" "_" $ T.pack $ fstToUpper tag
|
||||
namespaceFuncCode = "\nexport namespace " <> name' <> " {" <> funcCode td typeSyntax <> "}\n"
|
||||
typeDefCode = case typeDef of
|
||||
ATDRecord fields ->
|
||||
("\nexport interface " <> name' <> " {\n")
|
||||
<> fieldsCode "" "" fields
|
||||
<> "}\n"
|
||||
<> (if typeSyntax == "" then "" else namespaceFuncCode)
|
||||
ATDEnum cs ->
|
||||
("\nexport enum " <> name' <> " {\n")
|
||||
<> foldMap (\m -> " " <> constrName m <> " = \"" <> T.pack m <> "\",\n") cs
|
||||
<> "}\n"
|
||||
<> (if typeSyntax == "" then "" else namespaceFuncCode)
|
||||
ATDUnion cs -> unionTypeCode name' "" td cs typeSyntax
|
||||
|
||||
unionTypeCode :: Text -> String -> APITypeDef -> L.NonEmpty ATUnionMember -> Expr -> Text
|
||||
unionTypeCode unionNamespace typesNamespace td@APITypeDef {typeName' = name} cs cmdSyntax =
|
||||
("\nexport type " <> name' <> " = " <> constrsCode "" name' constrTypeRef (L.toList cs) <> "\n")
|
||||
<> ("export namespace " <> unionNamespace <> " {\n")
|
||||
<> (" export type Tag = " <> constrsCode " " name' constrTag (L.toList cs) <> "\n")
|
||||
<> (" interface Interface {\n type: Tag\n }\n")
|
||||
<> foldMap constrType cs
|
||||
<> (if cmdSyntax == "" then "" else funcCode td cmdSyntax)
|
||||
<> "}\n"
|
||||
where
|
||||
name' = T.pack name
|
||||
constrTypeRef (ATUnionMember tag _) = unionNamespace <> "." <> constrName tag
|
||||
constrTag (ATUnionMember tag _) = T.pack $ "\"" <> tag <> "\""
|
||||
constrType c@(ATUnionMember tag fields) =
|
||||
("\n export interface " <> constrName tag <> " extends Interface {\n")
|
||||
<> " type: " <> constrTag c <> "\n"
|
||||
<> fieldsCode " " typesNamespace fields
|
||||
<> " }\n"
|
||||
constrName tag = T.replace "-" "_" (T.pack $ fstToUpper tag)
|
||||
|
||||
constrsCode :: Text -> Text -> (ATUnionMember -> Text) -> [ATUnionMember] -> Text
|
||||
constrsCode indent name' constr cs
|
||||
| T.length (name' <> " = " <> line) <= 100 = line <> "\n"
|
||||
| otherwise = "\n" <> foldMap (\c -> indent <> " | " <> c <> "\n") cs'
|
||||
where
|
||||
line = T.intercalate " | " cs'
|
||||
cs' = map constr cs
|
||||
|
||||
funcCode :: APITypeDef -> Expr -> Text
|
||||
funcCode td@APITypeDef {typeName' = name, typeDef} cmdSyntax =
|
||||
"\n export function cmdString(" <> param <> ": " <> T.pack name <> "): string {\n return " <> jsSyntaxText True (name, self : typeFields) cmdSyntax <> "\n }\n"
|
||||
where
|
||||
param = if hasParams cmdSyntax then "self" else "_self"
|
||||
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 _ -> []
|
||||
|
||||
fieldsCode :: Text -> String -> [APIRecordField] -> Text
|
||||
fieldsCode indent namespace = foldMap $ (indent <>) . T.pack . fieldText
|
||||
where
|
||||
fieldText (APIRecordField name t) = " " <> name <> optional t <> ": " <> typeText t <> typeComment t <> "\n"
|
||||
optional = \case
|
||||
ATOptional _ -> "?"
|
||||
_ -> ""
|
||||
typeText = \case
|
||||
ATPrim (PT t) -> typeName t
|
||||
ATDef (APITypeDef t _) -> namespace <> t
|
||||
ATRef t -> namespace <> t
|
||||
ATOptional t -> typeText t
|
||||
ATArray {elemType} -> typeText elemType <> "[]"
|
||||
ATMap (PT t) valueType -> "{[key: " <> typeName t <> "]: " <> typeText valueType <> "}"
|
||||
typeName = \case
|
||||
TBool -> "boolean"
|
||||
TInt -> "number"
|
||||
TInt64 -> "number"
|
||||
TWord32 -> "number"
|
||||
TDouble -> "number"
|
||||
TJSONObject -> "object"
|
||||
TUTCTime -> "string"
|
||||
t -> t
|
||||
typeComment t = let c = typeComment' t in if null c then "" else " // " <> c
|
||||
typeComment' = \case
|
||||
ATPrim (PT t) -> typeComment_ t
|
||||
ATOptional (ATPrim (PT t)) -> typeComment_ t
|
||||
ATArray {elemType, nonEmpty}
|
||||
| nonEmpty -> (if null c then "" else c <> ", ") <> "non-empty"
|
||||
| otherwise -> c
|
||||
where
|
||||
c = typeComment' elemType
|
||||
ATMap (PT k) v ->
|
||||
let kc = typeComment_ k
|
||||
vc = typeComment' v
|
||||
tc t c = if null c then t else c
|
||||
in if null kc && null vc then "" else tc (typeName k) kc <> " : " <> tc (typeText v) vc
|
||||
_ -> ""
|
||||
typeComment_ = \case
|
||||
TInt -> "int"
|
||||
TInt64 -> "int64"
|
||||
TWord32 -> "word32"
|
||||
TDouble -> "double"
|
||||
TUTCTime -> "ISO-8601 timestamp"
|
||||
_ -> ""
|
||||
Reference in New Issue
Block a user