From a9cc087732e805d94f2df9f1f4bfdacafe3d819f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Wed, 24 Jun 2020 14:58:14 +0200
Subject: [PATCH] [ivette] request parameters
---
ivette/api/dive.ts | 44 ++++++++----
ivette/api/kernel/ast.ts | 121 ++++++++++++++++++++++----------
ivette/api/kernel/project.ts | 50 ++++++++-----
ivette/api/kernel/properties.ts | 52 ++++++++++----
ivette/api/kernel/services.ts | 41 ++++++++---
ivette/api/server_tsc.ml | 77 +++++++++++++-------
src/plugins/server/package.ml | 60 +++++++++-------
7 files changed, 298 insertions(+), 147 deletions(-)
diff --git a/ivette/api/dive.ts b/ivette/api/dive.ts
index d00d62b0cba..de058d27793 100644
--- a/ivette/api/dive.ts
+++ b/ivette/api/dive.ts
@@ -32,45 +32,61 @@ export const jVariableName: Json.Loose<variableName> =
/** Natural order for `variableName` */
/** Retrieve the whole graph */
-export const graph: Server.GetRequest = {
+export const graph: Server.GetRequest<null,Json.json> = {
kind: Server.RqKind.GET,
- name: 'dive.graph',
+ name: 'dive.graph',
+ input: Json.jNull,
+ output: Json.jAny,
};
/** Erase the graph and start over with an empty one */
-export const clear: Server.ExecRequest = {
+export const clear: Server.ExecRequest<null,null> = {
kind: Server.RqKind.EXEC,
- name: 'dive.clear',
+ name: 'dive.clear',
+ input: Json.jNull,
+ output: Json.jNull,
};
/** Add a variable to the graph */
-export const addVar: Server.ExecRequest = {
+export const addVar: Server.ExecRequest<variableName,Json.json> = {
kind: Server.RqKind.EXEC,
- name: 'dive.addVar',
+ name: 'dive.addVar',
+ input: jVariableName,
+ output: Json.jAny,
};
/** Add all alarms of the given function */
-export const addFunctionAlarms: Server.ExecRequest = {
+export const addFunctionAlarms: Server.ExecRequest<Json.Key<'#fct'>,Json.json
+ > = {
kind: Server.RqKind.EXEC,
- name: 'dive.addFunctionAlarms',
+ name: 'dive.addFunctionAlarms',
+ input: Json.jKey('#fct'),
+ output: Json.jAny,
};
/** Explore the graph starting from an existing vertex */
-export const explore: Server.ExecRequest = {
+export const explore: Server.ExecRequest<Json.Index<'#dive-node'>,Json.json
+ > = {
kind: Server.RqKind.EXEC,
- name: 'dive.explore',
+ name: 'dive.explore',
+ input: Json.jIndex('#dive-node'),
+ output: Json.jAny,
};
/** Show the dependencies of an existing vertex */
-export const show: Server.ExecRequest = {
+export const show: Server.ExecRequest<Json.Index<'#dive-node'>,Json.json> = {
kind: Server.RqKind.EXEC,
- name: 'dive.show',
+ name: 'dive.show',
+ input: Json.jIndex('#dive-node'),
+ output: Json.jAny,
};
/** Hide the dependencies of an existing vertex */
-export const hide: Server.ExecRequest = {
+export const hide: Server.ExecRequest<Json.Index<'#dive-node'>,Json.json> = {
kind: Server.RqKind.EXEC,
- name: 'dive.hide',
+ name: 'dive.hide',
+ input: Json.jIndex('#dive-node'),
+ output: Json.jAny,
};
/* ------------------------------------- */
diff --git a/ivette/api/kernel/ast.ts b/ivette/api/kernel/ast.ts
index 52d70d3f034..b6016940b3d 100644
--- a/ivette/api/kernel/ast.ts
+++ b/ivette/api/kernel/ast.ts
@@ -9,13 +9,21 @@
import * as Json from 'dome/data/json';
import * as Server from 'frama-c/server';
+import { byTag } from 'api/kernel/data';
+import { byText } from 'api/kernel/data';
+import { jTag } from 'api/kernel/data';
+import { jTagSafe } from 'api/kernel/data';
+import { jText } from 'api/kernel/data';
+import { jTextSafe } from 'api/kernel/data';
import { tag } from 'api/kernel/data';
import { text } from 'api/kernel/data';
/** Ensures that AST is computed */
-export const compute: Server.ExecRequest = {
+export const compute: Server.ExecRequest<null,null> = {
kind: Server.RqKind.EXEC,
- name: 'kernel.ast.compute',
+ name: 'kernel.ast.compute',
+ input: Json.jNull,
+ output: Json.jNull,
};
/** Marker kind */
@@ -50,13 +58,15 @@ export const jMarkerKind: Json.Loose<markerKind> = Json.jEnum(markerKind);
/** Natural order for `markerKind` */
/** Registered tags for the above type. */
-export const markerKindTags: Server.GetRequest = {
+export const markerKindTags: Server.GetRequest<null,tag[]> = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.markerKindTags',
+ name: 'kernel.ast.markerKindTags',
+ input: Json.jNull,
+ output: Json.jList(jTag),
};
/** Markers data */
-export const markerData: State.Array<'markerData',markerDataData> = {
+export const markerData: State.Array<'#markerData',markerDataData> = {
signal: signalMarkerData,
fetch: fetchMarkerData,
reload: reloadMarkerData,
@@ -70,7 +80,7 @@ export const signalMarkerData: Server.Signal = {
/** Data for array rows [`markerData`](#markerdata) */
export interface markerDataData {
/** Entry identifier. */
- key: Json.Key<'markerData'>;
+ key: Json.Key<'#markerData'>;
/** Marker kind */
kind: markerKind;
/** Marker short name */
@@ -80,21 +90,34 @@ export interface markerDataData {
}
/** Data fetcher for array [`markerData`](#markerdata) */
-export const fetchMarkerData: Server.GetRequest = {
+export const fetchMarkerData: Server.GetRequest<number,
+ { pending: number, updated: markerDataData[],
+ removed: Json.Key<'#markerData'>[], reload: boolean }> = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.fetchMarkerData',
+ name: 'kernel.ast.fetchMarkerData',
+ input: Json.jNumber,
+ output: Json.jTry(
+ Json.jObject({
+ pending: Json.jFail(Json.jNumber,'Number expected'),
+ updated: Json.jList(jMarkerDataData),
+ removed: Json.jList(Json.jKey('#markerData')),
+ reload: Json.jFail(Json.jBoolean,'Boolean expected'),
+ })),
};
/** Force full reload for array [`markerData`](#markerdata) */
-export const reloadMarkerData: Server.GetRequest = {
+export const reloadMarkerData: Server.GetRequest<null,null> = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.reloadMarkerData',
+ name: 'kernel.ast.reloadMarkerData',
+ input: Json.jNull,
+ output: Json.jNull,
};
/** Localizable AST markers */
export type marker =
- Json.Key<'stmt'> | Json.Key<'decl'> | Json.Key<'lval'> | Json.Key<'expr'> |
- Json.Key<'term'> | Json.Key<'global'> | Json.Key<'property'>;
+ Json.Key<'#stmt'> | Json.Key<'#decl'> | Json.Key<'#lval'> |
+ Json.Key<'#expr'> | Json.Key<'#term'> | Json.Key<'#global'> |
+ Json.Key<'#property'>;
/** Safe decoder for `marker` */
export const jMarkerSafe: Json.Safe<marker> =
@@ -102,34 +125,38 @@ export const jMarkerSafe: Json.Safe<marker> =
/** Loose decoder for `marker` */
export const jMarker: Json.Loose<marker> =
- Json.jUnion<Json.Key<'stmt'> | Json.Key<'decl'> | Json.Key<'lval'> |
- Json.Key<'expr'> | Json.Key<'term'> | Json.Key<'global'> |
- Json.Key<'property'>>(
- Json.jKey('stmt'),
- Json.jKey('decl'),
- Json.jKey('lval'),
- Json.jKey('expr'),
- Json.jKey('term'),
- Json.jKey('global'),
- Json.jKey('property'),
+ Json.jUnion<Json.Key<'#stmt'> | Json.Key<'#decl'> | Json.Key<'#lval'> |
+ Json.Key<'#expr'> | Json.Key<'#term'> | Json.Key<'#global'> |
+ Json.Key<'#property'>>(
+ Json.jKey('#stmt'),
+ Json.jKey('#decl'),
+ Json.jKey('#lval'),
+ Json.jKey('#expr'),
+ Json.jKey('#term'),
+ Json.jKey('#global'),
+ Json.jKey('#property'),
);
/** Natural order for `marker` */
/** Collect all functions in the AST */
-export const getFunctions: Server.GetRequest = {
+export const getFunctions: Server.GetRequest<null,Json.Key<'#fct'>[]> = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.getFunctions',
+ name: 'kernel.ast.getFunctions',
+ input: Json.jNull,
+ output: Json.jList(Json.jKey('#fct')),
};
/** Print the AST of a function */
-export const printFunction: Server.GetRequest = {
+export const printFunction: Server.GetRequest<Json.Key<'#fct'>,text> = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.printFunction',
+ name: 'kernel.ast.printFunction',
+ input: Json.jKey('#fct'),
+ output: jText,
};
/** AST Functions */
-export const functions: State.Array<'functions',functionsData> = {
+export const functions: State.Array<'#functions',functionsData> = {
signal: signalFunctions,
fetch: fetchFunctions,
reload: reloadFunctions,
@@ -143,7 +170,7 @@ export const signalFunctions: Server.Signal = {
/** Data for array rows [`functions`](#functions) */
export interface functionsData {
/** Entry identifier. */
- key: Json.Key<'functions'>;
+ key: Json.Key<'#functions'>;
/** Name */
name: string;
/** Signature */
@@ -151,33 +178,51 @@ export interface functionsData {
}
/** Data fetcher for array [`functions`](#functions) */
-export const fetchFunctions: Server.GetRequest = {
+export const fetchFunctions: Server.GetRequest<number,
+ { pending: number, updated: functionsData[],
+ removed: Json.Key<'#functions'>[], reload: boolean }> = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.fetchFunctions',
+ name: 'kernel.ast.fetchFunctions',
+ input: Json.jNumber,
+ output: Json.jTry(
+ Json.jObject({
+ pending: Json.jFail(Json.jNumber,'Number expected'),
+ updated: Json.jList(jFunctionsData),
+ removed: Json.jList(Json.jKey('#functions')),
+ reload: Json.jFail(Json.jBoolean,'Boolean expected'),
+ })),
};
/** Force full reload for array [`functions`](#functions) */
-export const reloadFunctions: Server.GetRequest = {
+export const reloadFunctions: Server.GetRequest<null,null> = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.reloadFunctions',
+ name: 'kernel.ast.reloadFunctions',
+ input: Json.jNull,
+ output: Json.jNull,
};
/** Get textual information about a marker */
-export const getInfo: Server.GetRequest = {
+export const getInfo: Server.GetRequest<marker,text> = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.getInfo',
+ name: 'kernel.ast.getInfo',
+ input: jMarker,
+ output: jText,
};
/** Get the currently analyzed source file names */
-export const getFiles: Server.GetRequest = {
+export const getFiles: Server.GetRequest<null,string[]> = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.getFiles',
+ name: 'kernel.ast.getFiles',
+ input: Json.jNull,
+ output: Json.jList(Json.jString),
};
/** Set the source file names to analyze. */
-export const setFiles: Server.SetRequest = {
+export const setFiles: Server.SetRequest<string[],null> = {
kind: Server.RqKind.SET,
- name: 'kernel.ast.setFiles',
+ name: 'kernel.ast.setFiles',
+ input: Json.jList(Json.jString),
+ output: Json.jNull,
};
/* ------------------------------------- */
diff --git a/ivette/api/kernel/project.ts b/ivette/api/kernel/project.ts
index 41a0996a639..5335e9e6cc8 100644
--- a/ivette/api/kernel/project.ts
+++ b/ivette/api/kernel/project.ts
@@ -12,12 +12,12 @@ import * as Server from 'frama-c/server';
/** Project informations */
export type projectInfo =
- { id: Json.Key<'project'>, name: string, current: boolean };
+ { id: Json.Key<'#project'>, name: string, current: boolean };
/** Safe decoder for `projectInfo` */
export const jProjectInfoSafe: Json.Safe<projectInfo> =
Json.jObject({
- id: Json.jFail(Json.jKey('project'),'#project expected'),
+ id: Json.jFail(Json.jKey('#project'),'#project expected'),
name: Json.jFail(Json.jString,'String expected'),
current: Json.jFail(Json.jBoolean,'Boolean expected'),
});
@@ -30,12 +30,12 @@ export const jProjectInfo: Json.Loose<projectInfo> =
/** Request to be executed on the specified project. */
export type projectRequest =
- { project: Json.Key<'project'>, request: string, data: Json.json };
+ { project: Json.Key<'#project'>, request: string, data: Json.json };
/** Safe decoder for `projectRequest` */
export const jProjectRequestSafe: Json.Safe<projectRequest> =
Json.jObject({
- project: Json.jFail(Json.jKey('project'),'#project expected'),
+ project: Json.jFail(Json.jKey('#project'),'#project expected'),
request: Json.jFail(Json.jString,'String expected'),
data: Json.jAny,
});
@@ -47,45 +47,59 @@ export const jProjectRequest: Json.Loose<projectRequest> =
/** Natural order for `projectRequest` */
/** Returns the current project */
-export const getCurrent: Server.GetRequest = {
+export const getCurrent: Server.GetRequest<null,projectInfo> = {
kind: Server.RqKind.GET,
- name: 'kernel.project.getCurrent',
+ name: 'kernel.project.getCurrent',
+ input: Json.jNull,
+ output: jProjectInfo,
};
/** Switches the current project */
-export const setCurrent: Server.SetRequest = {
+export const setCurrent: Server.SetRequest<Json.Key<'#project'>,null> = {
kind: Server.RqKind.SET,
- name: 'kernel.project.setCurrent',
+ name: 'kernel.project.setCurrent',
+ input: Json.jKey('#project'),
+ output: Json.jNull,
};
/** Returns the list of all projects */
-export const getList: Server.GetRequest = {
+export const getList: Server.GetRequest<null,projectInfo[]> = {
kind: Server.RqKind.GET,
- name: 'kernel.project.getList',
+ name: 'kernel.project.getList',
+ input: Json.jNull,
+ output: Json.jList(jProjectInfo),
};
/** Execute a GET request within the given project */
-export const getOn: Server.GetRequest = {
+export const getOn: Server.GetRequest<projectRequest,Json.json> = {
kind: Server.RqKind.GET,
- name: 'kernel.project.getOn',
+ name: 'kernel.project.getOn',
+ input: jProjectRequest,
+ output: Json.jAny,
};
/** Execute a SET request within the given project */
-export const setOn: Server.SetRequest = {
+export const setOn: Server.SetRequest<projectRequest,Json.json> = {
kind: Server.RqKind.SET,
- name: 'kernel.project.setOn',
+ name: 'kernel.project.setOn',
+ input: jProjectRequest,
+ output: Json.jAny,
};
/** Execute an EXEC request within the given project */
-export const execOn: Server.ExecRequest = {
+export const execOn: Server.ExecRequest<projectRequest,Json.json> = {
kind: Server.RqKind.EXEC,
- name: 'kernel.project.execOn',
+ name: 'kernel.project.execOn',
+ input: jProjectRequest,
+ output: Json.jAny,
};
/** Create a new project */
-export const create: Server.SetRequest = {
+export const create: Server.SetRequest<string,projectInfo> = {
kind: Server.RqKind.SET,
- name: 'kernel.project.create',
+ name: 'kernel.project.create',
+ input: Json.jString,
+ output: jProjectInfo,
};
/* ------------------------------------- */
diff --git a/ivette/api/kernel/properties.ts b/ivette/api/kernel/properties.ts
index 05d00856eda..696f28775e0 100644
--- a/ivette/api/kernel/properties.ts
+++ b/ivette/api/kernel/properties.ts
@@ -9,7 +9,13 @@
import * as Json from 'dome/data/json';
import * as Server from 'frama-c/server';
+import { byTag } from 'api/kernel/data';
+import { jTag } from 'api/kernel/data';
+import { jTagSafe } from 'api/kernel/data';
import { tag } from 'api/kernel/data';
+import { bySource } from 'api/kernel/services';
+import { jSource } from 'api/kernel/services';
+import { jSourceSafe } from 'api/kernel/services';
import { source } from 'api/kernel/services';
/** Property Kinds */
@@ -94,9 +100,11 @@ export const jPropKind: Json.Loose<propKind> = Json.jEnum(propKind);
/** Natural order for `propKind` */
/** Registered tags for the above type. */
-export const propKindTags: Server.GetRequest = {
+export const propKindTags: Server.GetRequest<null,tag[]> = {
kind: Server.RqKind.GET,
- name: 'kernel.properties.propKindTags',
+ name: 'kernel.properties.propKindTags',
+ input: Json.jNull,
+ output: Json.jList(jTag),
};
/** Property Status (consolidated) */
@@ -135,9 +143,11 @@ export const jPropStatus: Json.Loose<propStatus> = Json.jEnum(propStatus);
/** Natural order for `propStatus` */
/** Registered tags for the above type. */
-export const propStatusTags: Server.GetRequest = {
+export const propStatusTags: Server.GetRequest<null,tag[]> = {
kind: Server.RqKind.GET,
- name: 'kernel.properties.propStatusTags',
+ name: 'kernel.properties.propStatusTags',
+ input: Json.jNull,
+ output: Json.jList(jTag),
};
/** Alarm Kinds */
@@ -190,13 +200,15 @@ export const jAlarms: Json.Loose<alarms> = Json.jEnum(alarms);
/** Natural order for `alarms` */
/** Registered tags for the above type. */
-export const alarmsTags: Server.GetRequest = {
+export const alarmsTags: Server.GetRequest<null,tag[]> = {
kind: Server.RqKind.GET,
- name: 'kernel.properties.alarmsTags',
+ name: 'kernel.properties.alarmsTags',
+ input: Json.jNull,
+ output: Json.jList(jTag),
};
/** Status of Registered Properties */
-export const status: State.Array<'status',statusData> = {
+export const status: State.Array<'#status',statusData> = {
signal: signalStatus,
fetch: fetchStatus,
reload: reloadStatus,
@@ -210,7 +222,7 @@ export const signalStatus: Server.Signal = {
/** Data for array rows [`status`](#status) */
export interface statusData {
/** Entry identifier. */
- key: Json.Key<'status'>;
+ key: Json.Key<'#status'>;
/** Full description */
descr: string;
/** Kind */
@@ -220,9 +232,9 @@ export interface statusData {
/** Status */
status: propStatus;
/** Function */
- function?: Json.Key<'fct'>;
+ function?: Json.Key<'#fct'>;
/** Instruction */
- kinstr?: Json.Key<'stmt'>;
+ kinstr?: Json.Key<'#stmt'>;
/** Position */
source: source;
/** Alarm name (if the property is an alarm) */
@@ -234,15 +246,27 @@ export interface statusData {
}
/** Data fetcher for array [`status`](#status) */
-export const fetchStatus: Server.GetRequest = {
+export const fetchStatus: Server.GetRequest<number,
+ { pending: number, updated: statusData[], removed: Json.Key<'#status'>[],
+ reload: boolean }> = {
kind: Server.RqKind.GET,
- name: 'kernel.properties.fetchStatus',
+ name: 'kernel.properties.fetchStatus',
+ input: Json.jNumber,
+ output: Json.jTry(
+ Json.jObject({
+ pending: Json.jFail(Json.jNumber,'Number expected'),
+ updated: Json.jList(jStatusData),
+ removed: Json.jList(Json.jKey('#status')),
+ reload: Json.jFail(Json.jBoolean,'Boolean expected'),
+ })),
};
/** Force full reload for array [`status`](#status) */
-export const reloadStatus: Server.GetRequest = {
+export const reloadStatus: Server.GetRequest<null,null> = {
kind: Server.RqKind.GET,
- name: 'kernel.properties.reloadStatus',
+ name: 'kernel.properties.reloadStatus',
+ input: Json.jNull,
+ output: Json.jNull,
};
/* ------------------------------------- */
diff --git a/ivette/api/kernel/services.ts b/ivette/api/kernel/services.ts
index db7c4f085df..56348fad9fc 100644
--- a/ivette/api/kernel/services.ts
+++ b/ivette/api/kernel/services.ts
@@ -9,18 +9,33 @@
import * as Json from 'dome/data/json';
import * as Server from 'frama-c/server';
+import { byTag } from 'api/kernel/data';
+import { jTag } from 'api/kernel/data';
+import { jTagSafe } from 'api/kernel/data';
import { tag } from 'api/kernel/data';
/** Frama-C Kernel configuration */
-export const getConfig: Server.GetRequest = {
+export const getConfig: Server.GetRequest<null,
+ { pluginpath: string[], libdir: string, datadir: string, version: string }
+ > = {
kind: Server.RqKind.GET,
- name: 'kernel.services.getConfig',
+ name: 'kernel.services.getConfig',
+ input: Json.jNull,
+ output: Json.jTry(
+ Json.jObject({
+ pluginpath: Json.jList(Json.jString),
+ libdir: Json.jFail(Json.jString,'String expected'),
+ datadir: Json.jFail(Json.jString,'String expected'),
+ version: Json.jFail(Json.jString,'String expected'),
+ })),
};
/** Load a save file. Returns an error, if not successfull. */
-export const load: Server.SetRequest = {
+export const load: Server.SetRequest<string,string | undefined> = {
kind: Server.RqKind.SET,
- name: 'kernel.services.load',
+ name: 'kernel.services.load',
+ input: Json.jString,
+ output: Json.jString,
};
/** Source file positions. */
@@ -67,9 +82,11 @@ export const jLogkind: Json.Loose<logkind> = Json.jEnum(logkind);
/** Natural order for `logkind` */
/** Registered tags for the above type. */
-export const logkindTags: Server.GetRequest = {
+export const logkindTags: Server.GetRequest<null,tag[]> = {
kind: Server.RqKind.GET,
- name: 'kernel.services.logkindTags',
+ name: 'kernel.services.logkindTags',
+ input: Json.jNull,
+ output: Json.jList(jTag),
};
/** Message event record. */
@@ -102,15 +119,19 @@ export const jLog: Json.Loose<log> = Json.jTry(jLogSafe);
/** Natural order for `log` */
/** Turn logs monitoring on/off */
-export const setLogs: Server.SetRequest = {
+export const setLogs: Server.SetRequest<boolean,null> = {
kind: Server.RqKind.SET,
- name: 'kernel.services.setLogs',
+ name: 'kernel.services.setLogs',
+ input: Json.jBoolean,
+ output: Json.jNull,
};
/** Flush the last emitted logs since last call (max 100) */
-export const getLogs: Server.GetRequest = {
+export const getLogs: Server.GetRequest<null,log[]> = {
kind: Server.RqKind.GET,
- name: 'kernel.services.getLogs',
+ name: 'kernel.services.getLogs',
+ input: Json.jNull,
+ output: Json.jList(jLog),
};
/* ------------------------------------- */
diff --git a/ivette/api/server_tsc.ml b/ivette/api/server_tsc.ml
index a5139d848c6..a50958b176c 100644
--- a/ivette/api/server_tsc.ml
+++ b/ivette/api/server_tsc.ml
@@ -53,11 +53,15 @@ let makeDescr ?(indent="") fmt descr =
if descr <> [] then
Format.fprintf fmt "%s/** @[<hov 0>%a@] */@." indent pp_descr descr
+let getSelf = function
+ | None -> Self.fatal "Unexpected recursive type"
+ | Some id -> id
+
(* -------------------------------------------------------------------------- *)
(* --- Jtype Generator --- *)
(* -------------------------------------------------------------------------- *)
-let makeJtype ~self ~names =
+let makeJtype ?self ~names =
let open Pkg in
let pp_ident fmt id =
match IdMap.find id names with
@@ -65,14 +69,14 @@ let makeJtype ~self ~names =
| exception Not_found -> Self.abort "Undefined '%a'" pp_ident id in
let rec pp fmt = function
| Jany -> Format.pp_print_string fmt "Json.json"
- | Jself -> Format.pp_print_string fmt self.name
+ | Jself -> Format.pp_print_string fmt (getSelf self).name
| Jnull -> Format.pp_print_string fmt "null"
| Jnumber -> Format.pp_print_string fmt "number"
| Jboolean -> Format.pp_print_string fmt "boolean"
| Jstring | Jalpha -> Format.pp_print_string fmt "string"
- | Jkey kd -> Format.fprintf fmt "Json.Key<'%s'>" kd
- | Jindex kd -> Format.fprintf fmt "Json.Index<'%s'>" kd
- | Jdict(kd,js) -> Format.fprintf fmt "Json.Dict<'%s',%a>" kd pp js
+ | Jkey kd -> Format.fprintf fmt "Json.Key<'#%s'>" kd
+ | Jindex kd -> Format.fprintf fmt "Json.Index<'#%s'>" kd
+ | Jdict(kd,js) -> Format.fprintf fmt "Json.Dict<'#%s',%a>" kd pp js
| Jdata id | Jenum id -> pp_ident fmt id
| Joption js -> Format.fprintf fmt "%a |@ undefined" pp js
| Jtuple js ->
@@ -93,8 +97,8 @@ let makeJtype ~self ~names =
(* -------------------------------------------------------------------------- *)
let jprim fmt name = Format.fprintf fmt "Json.%s" name
-let jkey fmt kd = Format.fprintf fmt "Json.jKey('%s')" kd
-let jindex fmt kd = Format.fprintf fmt "Json.jIndex('%s')" kd
+let jkey fmt kd = Format.fprintf fmt "Json.jKey('#%s')" kd
+let jindex fmt kd = Format.fprintf fmt "Json.jIndex('#%s')" kd
let jcall names fmt id =
try Format.pp_print_string fmt (Pkg.IdMap.find id names)
@@ -147,10 +151,10 @@ let jtuple ~makeSafe fmt jts =
Format.fprintf fmt "@]@,)@]" ;
end
-let rec makeDecoder ~safe ~self ~names fmt js =
+let rec makeDecoder ~safe ?self ~names fmt js =
let open Pkg in
- let makeSafe = makeDecoder ~self ~names ~safe:true in
- let makeLoose = makeDecoder ~self ~names ~safe:false in
+ let makeSafe = makeDecoder ?self ~names ~safe:true in
+ let makeLoose = makeDecoder ?self ~names ~safe:false in
match js with
| Jany -> jprim fmt "jAny"
| Jnull -> jprim fmt "jNull"
@@ -158,13 +162,13 @@ let rec makeDecoder ~safe ~self ~names fmt js =
| Jnumber -> jsafe ~safe "Number" jprim fmt "jNumber"
| Jstring | Jalpha -> jsafe ~safe "String" jprim fmt "jString"
| Jkey kd -> jsafe ~safe ("#" ^ kd) jkey fmt kd
- | Jindex kd -> jsafe ~safe ("#0" ^ kd) jindex fmt kd
+ | Jindex kd -> jsafe ~safe ("#" ^ kd) jindex fmt kd
| Jdata id -> jcall names fmt (Pkg.Derived.decode ~safe id)
| Jenum id -> jsafe ~safe (Pkg.name_of_ident id) (jenum names) fmt id
- | Jself -> jcall names fmt (Pkg.Derived.decode ~safe self)
+ | Jself -> jcall names fmt (Pkg.Derived.decode ~safe (getSelf self))
| Joption js -> makeLoose fmt js
| Jdict(kd,js) ->
- Format.fprintf fmt "@[<hov 2>Json.jDict('%s',@,%a)@]" kd makeLoose js
+ Format.fprintf fmt "@[<hov 2>Json.jDict('#%s',@,%a)@]" kd makeLoose js
| Jlist js ->
Format.fprintf fmt "@[<hov 2>Json.jList(%a)@]" makeLoose js
| Jarray js ->
@@ -172,7 +176,7 @@ let rec makeDecoder ~safe ~self ~names fmt js =
then Format.fprintf fmt "@[<hov 2>Json.jArray(%a)@]" makeSafe js
else Format.fprintf fmt "@[<hov 2>Json.jTry(jArray(%a))@]" makeSafe js
| Junion jts ->
- let jtype = makeJtype ~self ~names in
+ let jtype = makeJtype ?self ~names in
jsafe ~safe "Union" (junion ~jtype ~makeLoose) fmt jts
| Jrecord jfs -> jtry ~safe (jrecord ~makeSafe) fmt jfs
| Jtuple jts -> jtry ~safe (jtuple ~makeSafe) fmt jts
@@ -191,6 +195,16 @@ let makeRootDecoder ~safe ~self ~names fmt js =
(String.capitalize_ascii self.name)
| _ -> makeDecoder ~safe ~self ~names fmt js
+(* -------------------------------------------------------------------------- *)
+(* --- Parameter Decoder --- *)
+(* -------------------------------------------------------------------------- *)
+
+let typeOfParam = function
+ | Pkg.P_value js -> js
+ | Pkg.P_named fjs ->
+ let field fd = fd.Pkg.fd_name , fd.Pkg.fd_type in
+ Jrecord (List.map field fjs)
+
(* -------------------------------------------------------------------------- *)
(* --- Declaration Generator --- *)
(* -------------------------------------------------------------------------- *)
@@ -224,20 +238,27 @@ let makeDeclaration fmt names d =
Format.fprintf fmt " %s = '%s';@\n" tag tag ;
) tgs ;
Format.fprintf fmt "}@\n" ;
+ | D_signal ->
+ Format.fprintf fmt "export const %s: Server.Signal = {@\n" self.name ;
+ Format.fprintf fmt " name: '%s',@\n" (Pkg.name_of_ident d.d_ident) ;
+ Format.fprintf fmt "};@\n" ;
| D_request rq ->
let kind = name_of_kind rq.rq_kind in
let prefix = String.capitalize_ascii (String.lowercase_ascii kind) in
- Format.fprintf fmt "export const %s: Server.%sRequest = {@\n"
- self.name prefix ;
+ let input = typeOfParam rq.rq_input in
+ let output = typeOfParam rq.rq_output in
+ let makeParam fmt js = makeDecoder ~safe:false ~names fmt js in
+ Format.fprintf fmt
+ "@[<hov 2>export const %s: Server.%sRequest<@,%a,@,%a@,> = {@]@\n"
+ self.name prefix jtype input jtype output ;
Format.fprintf fmt " kind: Server.RqKind.%s,@\n" kind ;
- Format.fprintf fmt " name: '%s',@\n" (Pkg.name_of_ident d.d_ident) ;
- Format.fprintf fmt "};@\n" ;
- | D_signal ->
- Format.fprintf fmt "export const %s: Server.Signal = {@\n" self.name ;
- Format.fprintf fmt " name: '%s',@\n" (Pkg.name_of_ident d.d_ident) ;
+ Format.fprintf fmt " name: '%s',@\n" (Pkg.name_of_ident d.d_ident) ;
+ Format.fprintf fmt " input: %a,@\n" makeParam input ;
+ Format.fprintf fmt " output: %a,@\n" makeParam output ;
Format.fprintf fmt "};@\n" ;
| D_value js ->
- Format.fprintf fmt "export const %s: State.Value<%a> = {@\n"
+ Format.fprintf fmt
+ "@[<hov 2>export const %s: State.Value<@,%a@,> = {@]@\n"
self.name jtype js ;
Format.fprintf fmt " signal: %a,@\n"
(jcall names) (Pkg.Derived.signal self) ;
@@ -245,7 +266,8 @@ let makeDeclaration fmt names d =
(jcall names) (Pkg.Derived.getter self) ;
Format.fprintf fmt "};@\n" ;
| D_state js ->
- Format.fprintf fmt "export const %s: State.State<%a> = {@\n"
+ Format.fprintf fmt
+ "@[<hov 2>export const %s: State.State<@,%a@,> = {@]@\n"
self.name jtype js ;
Format.fprintf fmt " signal: %a,@\n"
(jcall names) (Pkg.Derived.signal self) ;
@@ -256,7 +278,8 @@ let makeDeclaration fmt names d =
Format.fprintf fmt "};@\n" ;
| D_array kd ->
let data = Pkg.Derived.data self in
- Format.fprintf fmt "export const %s: State.Array<'%s',%a> = {@\n"
+ Format.fprintf fmt
+ "@[<hov 2>export const %s: State.Array<@,'#%s',@,%a@,> = {@]@\n"
self.name kd (jcall names) data ;
Format.fprintf fmt " signal: %a,@\n"
(jcall names) (Pkg.Derived.signal self) ;
@@ -266,11 +289,13 @@ let makeDeclaration fmt names d =
(jcall names) (Pkg.Derived.reload self) ;
Format.fprintf fmt "};@\n" ;
| D_safe(id,js) ->
- Format.fprintf fmt "@[<hov 2>export const %s: Json.Safe<%a> =@ %a;@]\n"
+ Format.fprintf fmt
+ "@[<hov 2>export const %s: Json.Safe<@,%a@,> =@ %a;@]\n"
self.name (jcall names) id
(makeRootDecoder ~safe:true ~self:id ~names) js ;
| D_loose(id,js) ->
- Format.fprintf fmt "@[<hov 2>export const %s: Json.Loose<%a> =@ %a;@]\n"
+ Format.fprintf fmt
+ "@[<hov 2>export const %s: Json.Loose<@,%a@,> =@ %a;@]\n"
self.name (jcall names) id
(makeRootDecoder ~safe:false ~self:id ~names) js ;
| D_order _ -> ()
diff --git a/src/plugins/server/package.ml b/src/plugins/server/package.ml
index 29f47cd79b6..837861f6bb1 100644
--- a/src/plugins/server/package.ml
+++ b/src/plugins/server/package.ml
@@ -250,6 +250,32 @@ let pp_pkgname fmt { p_plugin ; p_package } =
( pp_plugin fmt p_plugin ;
List.iter (pp_step fmt) p_package )
+(* -------------------------------------------------------------------------- *)
+(* --- Derived Names --- *)
+(* -------------------------------------------------------------------------- *)
+
+let derived ?prefix ?suffix id =
+ let capitalize = String.capitalize_ascii in
+ match prefix , suffix with
+ | None , None -> id
+ | Some p , None -> { id with name = p ^ capitalize id.name }
+ | None , Some q -> { id with name = id.name ^ q }
+ | Some p , Some q -> { id with name = p ^ capitalize id.name ^ q }
+
+module Derived =
+struct
+ let signal id = derived ~prefix:"signal" id
+ let getter id = derived ~prefix:"get" id
+ let setter id = derived ~prefix:"set" id
+ let data id = derived ~suffix:"Data" id
+ let fetch id = derived ~prefix:"fetch" id
+ let reload id = derived ~prefix:"reload" id
+ let order id = derived ~prefix:"by" id
+ let loose id = derived ~prefix:"j" id
+ let safe id = derived ~prefix:"j" ~suffix:"Safe" id
+ let decode ~safe:ok id = if ok then safe id else loose id
+end
+
(* -------------------------------------------------------------------------- *)
(* --- Visitors --- *)
(* -------------------------------------------------------------------------- *)
@@ -260,7 +286,13 @@ let rec visit_jtype fn = function
| Joption js | Jdict(_,js) | Jarray js | Jlist js -> visit_jtype fn js
| Jtuple js | Junion js -> List.iter (visit_jtype fn) js
| Jrecord fjs -> List.iter (fun (_,js) -> visit_jtype fn js) fjs
- | Jdata id | Jenum id -> fn id
+ | Jdata id | Jenum id ->
+ begin
+ fn id ;
+ fn (Derived.safe id) ;
+ fn (Derived.loose id) ;
+ fn (Derived.order id) ;
+ end
let visit_field f { fd_type } = visit_jtype f fd_type
@@ -293,32 +325,6 @@ let resolve ?(keywords=[]) pkg =
visit_package_used (Scope.use scope) pkg ;
Scope.resolve scope
-(* -------------------------------------------------------------------------- *)
-(* --- Derived Names --- *)
-(* -------------------------------------------------------------------------- *)
-
-let derived ?prefix ?suffix id =
- let capitalize = String.capitalize_ascii in
- match prefix , suffix with
- | None , None -> id
- | Some p , None -> { id with name = p ^ capitalize id.name }
- | None , Some q -> { id with name = id.name ^ q }
- | Some p , Some q -> { id with name = p ^ capitalize id.name ^ q }
-
-module Derived =
-struct
- let signal id = derived ~prefix:"signal" id
- let getter id = derived ~prefix:"get" id
- let setter id = derived ~prefix:"set" id
- let data id = derived ~suffix:"Data" id
- let fetch id = derived ~prefix:"fetch" id
- let reload id = derived ~prefix:"reload" id
- let order id = derived ~prefix:"by" id
- let loose id = derived ~prefix:"j" id
- let safe id = derived ~prefix:"j" ~suffix:"Safe" id
- let decode ~safe:ok id = if ok then safe id else loose id
-end
-
(* -------------------------------------------------------------------------- *)
(* --- Server API --- *)
(* -------------------------------------------------------------------------- *)
--
GitLab