diff --git a/ivette/api/dive.ts b/ivette/api/dive.ts
index 0e8f18121069d8f9902b039ca76d81442185c6ce..d00d62b0cba5e65d9b258fac46bf7a162d491d6e 100644
--- a/ivette/api/dive.ts
+++ b/ivette/api/dive.ts
@@ -1,6 +1,7 @@
/* --- Generated Frama-C Server API --- */
-/** Dive Services
+/**
+ Dive Services
@packageDocumentation
@module frama-c/dive
*/
@@ -17,6 +18,18 @@ export interface variableName {
varName: string;
}
+/** Safe decoder for `variableName` */
+export const jVariableNameSafe: Json.Safe<variableName> =
+ Json.jObject({
+ funName: Json.jString,
+ varName: Json.jFail(Json.jString,'String expected'),
+ });
+
+/** Loose decoder for `variableName` */
+export const jVariableName: Json.Loose<variableName> =
+ Json.jTry(jVariableNameSafe);
+
+/** Natural order for `variableName` */
/** Retrieve the whole graph */
export const graph: Server.GetRequest = {
@@ -24,44 +37,40 @@ export const graph: Server.GetRequest = {
name: 'dive.graph',
};
-
/** Erase the graph and start over with an empty one */
export const clear: Server.ExecRequest = {
kind: Server.RqKind.EXEC,
name: 'dive.clear',
};
-
/** Add a variable to the graph */
export const addVar: Server.ExecRequest = {
kind: Server.RqKind.EXEC,
name: 'dive.addVar',
};
-
/** Add all alarms of the given function */
export const addFunctionAlarms: Server.ExecRequest = {
kind: Server.RqKind.EXEC,
name: 'dive.addFunctionAlarms',
};
-
/** Explore the graph starting from an existing vertex */
export const explore: Server.ExecRequest = {
kind: Server.RqKind.EXEC,
name: 'dive.explore',
};
-
/** Show the dependencies of an existing vertex */
export const show: Server.ExecRequest = {
kind: Server.RqKind.EXEC,
name: 'dive.show',
};
-
/** Hide the dependencies of an existing vertex */
export const hide: Server.ExecRequest = {
kind: Server.RqKind.EXEC,
name: 'dive.hide',
};
+
+/* ------------------------------------- */
diff --git a/ivette/api/kernel/ast.ts b/ivette/api/kernel/ast.ts
index 3bc9a01edcc37fad1bdbabcd4dd2199059519ee8..52d70d3f034154cadebaaa7e7821f1fe956009cc 100644
--- a/ivette/api/kernel/ast.ts
+++ b/ivette/api/kernel/ast.ts
@@ -1,23 +1,23 @@
/* --- Generated Frama-C Server API --- */
-/** Ast Services
+/**
+ Ast Services
@packageDocumentation
@module frama-c/kernel/ast
*/
import * as Json from 'dome/data/json';
import * as Server from 'frama-c/server';
+
import { tag } from 'api/kernel/data';
import { text } from 'api/kernel/data';
-
/** Ensures that AST is computed */
export const compute: Server.ExecRequest = {
kind: Server.RqKind.EXEC,
name: 'kernel.ast.compute',
};
-
/** Marker kind */
export enum markerKind {
/** Expression */
@@ -40,27 +40,35 @@ export enum markerKind {
property = 'property';
}
+/** Safe decoder for `markerKind` */
+export const jMarkerKindSafe: Json.Safe<markerKind> =
+ Json.jFail(Json.jEnum(markerKind),'kernel.ast.markerKind expected');
-/** Returns all registered tags for the above type. */
+/** Loose decoder for `markerKind` */
+export const jMarkerKind: Json.Loose<markerKind> = Json.jEnum(markerKind);
+
+/** Natural order for `markerKind` */
+
+/** Registered tags for the above type. */
export const markerKindTags: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.ast.markerKindTags',
};
-
/** Markers data */
-
-
-/** Signal for array [`markerData`](#markerdata)
- */
-export const markerDataSig: Server.Signal = {
- name: 'kernel.ast.markerDataSig',
+export const markerData: State.Array<'markerData',markerDataData> = {
+ signal: signalMarkerData,
+ fetch: fetchMarkerData,
+ reload: reloadMarkerData,
};
+/** Signal for array [`markerData`](#markerdata) */
+export const signalMarkerData: Server.Signal = {
+ name: 'kernel.ast.signalMarkerData',
+};
-/** Data rows for array [`markerData`](#markerdata)
- */
-export interface markerDataRow {
+/** Data for array rows [`markerData`](#markerdata) */
+export interface markerDataData {
/** Entry identifier. */
key: Json.Key<'markerData'>;
/** Marker kind */
@@ -71,28 +79,42 @@ export interface markerDataRow {
descr: string;
}
-
-/** Data fetcher for array [`markerData`](#markerdata)
- */
-export const markerDataFetch: Server.GetRequest = {
+/** Data fetcher for array [`markerData`](#markerdata) */
+export const fetchMarkerData: Server.GetRequest = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.markerDataFetch',
+ name: 'kernel.ast.fetchMarkerData',
};
-
-/** Force full reload for array [`markerData`](#markerdata)
- */
-export const markerDataReload: Server.GetRequest = {
+/** Force full reload for array [`markerData`](#markerdata) */
+export const reloadMarkerData: Server.GetRequest = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.markerDataReload',
+ name: 'kernel.ast.reloadMarkerData',
};
-
/** 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'>;
+/** Safe decoder for `marker` */
+export const jMarkerSafe: Json.Safe<marker> =
+ Json.jFail(jMarker,'Marker expected');
+
+/** 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'),
+ );
+
+/** Natural order for `marker` */
/** Collect all functions in the AST */
export const getFunctions: Server.GetRequest = {
@@ -100,27 +122,26 @@ export const getFunctions: Server.GetRequest = {
name: 'kernel.ast.getFunctions',
};
-
/** Print the AST of a function */
export const printFunction: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.ast.printFunction',
};
-
/** AST Functions */
-
-
-/** Signal for array [`functions`](#functions)
- */
-export const functionsSig: Server.Signal = {
- name: 'kernel.ast.functionsSig',
+export const functions: State.Array<'functions',functionsData> = {
+ signal: signalFunctions,
+ fetch: fetchFunctions,
+ reload: reloadFunctions,
};
+/** Signal for array [`functions`](#functions) */
+export const signalFunctions: Server.Signal = {
+ name: 'kernel.ast.signalFunctions',
+};
-/** Data rows for array [`functions`](#functions)
- */
-export interface functionsRow {
+/** Data for array rows [`functions`](#functions) */
+export interface functionsData {
/** Entry identifier. */
key: Json.Key<'functions'>;
/** Name */
@@ -129,39 +150,34 @@ export interface functionsRow {
signature: string;
}
-
-/** Data fetcher for array [`functions`](#functions)
- */
-export const functionsFetch: Server.GetRequest = {
+/** Data fetcher for array [`functions`](#functions) */
+export const fetchFunctions: Server.GetRequest = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.functionsFetch',
+ name: 'kernel.ast.fetchFunctions',
};
-
-/** Force full reload for array [`functions`](#functions)
- */
-export const functionsReload: Server.GetRequest = {
+/** Force full reload for array [`functions`](#functions) */
+export const reloadFunctions: Server.GetRequest = {
kind: Server.RqKind.GET,
- name: 'kernel.ast.functionsReload',
+ name: 'kernel.ast.reloadFunctions',
};
-
/** Get textual information about a marker */
export const getInfo: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.ast.getInfo',
};
-
/** Get the currently analyzed source file names */
export const getFiles: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.ast.getFiles',
};
-
/** Set the source file names to analyze. */
export const setFiles: Server.SetRequest = {
kind: Server.RqKind.SET,
name: 'kernel.ast.setFiles',
};
+
+/* ------------------------------------- */
diff --git a/ivette/api/kernel/data.ts b/ivette/api/kernel/data.ts
index 4e8e6ac0c721c38f91904fa4b9b39b753a969eb5..9ea5ff796429f00cf74c134f0475b109e9f58d57 100644
--- a/ivette/api/kernel/data.ts
+++ b/ivette/api/kernel/data.ts
@@ -1,6 +1,7 @@
/* --- Generated Frama-C Server API --- */
-/** Informations
+/**
+ Informations
@packageDocumentation
@module frama-c/kernel/data
*/
@@ -12,10 +13,45 @@ import * as Server from 'frama-c/server';
/** Markdown (inlined) text. */
export type markdown = string;
+/** Safe decoder for `markdown` */
+export const jMarkdownSafe: Json.Safe<markdown> =
+ Json.jFail(Json.jString,'String expected');
+
+/** Loose decoder for `markdown` */
+export const jMarkdown: Json.Loose<markdown> = Json.jString;
+
+/** Natural order for `markdown` */
/** Rich text format uses `[tag; …text ]` to apply the tag `tag` to the enclosed text. Empty tag `""` can also used to simply group text together. */
export type text = null | string | text[];
+/** Safe decoder for `text` */
+export const jTextSafe: Json.Safe<text> = Json.jFail(jText,'Text expected');
+
+/** Loose decoder for `text` */
+export const jText: Json.Loose<text> =
+ Json.jUnion<null | string | text[]>(
+ Json.jNull,
+ Json.jString,
+ Json.jList(jText),
+ );
+
+/** Natural order for `text` */
/** Enum Tag Description */
export type tag = { name: string, label: markdown, descr: markdown };
+
+/** Safe decoder for `tag` */
+export const jTagSafe: Json.Safe<tag> =
+ Json.jObject({
+ name: Json.jFail(Json.jString,'String expected'),
+ label: jMarkdownSafe,
+ descr: jMarkdownSafe,
+ });
+
+/** Loose decoder for `tag` */
+export const jTag: Json.Loose<tag> = Json.jTry(jTagSafe);
+
+/** Natural order for `tag` */
+
+/* ------------------------------------- */
diff --git a/ivette/api/kernel/project.ts b/ivette/api/kernel/project.ts
index e26fc66c7ee86f0fcd8b7d22ceeae2fe5e3fc73c..41a0996a639004c1ee68884fd3bd0a8b7f280e69 100644
--- a/ivette/api/kernel/project.ts
+++ b/ivette/api/kernel/project.ts
@@ -1,6 +1,7 @@
/* --- Generated Frama-C Server API --- */
-/** Project Management
+/**
+ Project Management
@packageDocumentation
@module frama-c/kernel/project
*/
@@ -13,11 +14,37 @@ import * as Server from 'frama-c/server';
export type projectInfo =
{ 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'),
+ name: Json.jFail(Json.jString,'String expected'),
+ current: Json.jFail(Json.jBoolean,'Boolean expected'),
+ });
+
+/** Loose decoder for `projectInfo` */
+export const jProjectInfo: Json.Loose<projectInfo> =
+ Json.jTry(jProjectInfoSafe);
+
+/** Natural order for `projectInfo` */
/** Request to be executed on the specified project. */
export type projectRequest =
{ 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'),
+ request: Json.jFail(Json.jString,'String expected'),
+ data: Json.jAny,
+ });
+
+/** Loose decoder for `projectRequest` */
+export const jProjectRequest: Json.Loose<projectRequest> =
+ Json.jTry(jProjectRequestSafe);
+
+/** Natural order for `projectRequest` */
/** Returns the current project */
export const getCurrent: Server.GetRequest = {
@@ -25,44 +52,40 @@ export const getCurrent: Server.GetRequest = {
name: 'kernel.project.getCurrent',
};
-
/** Switches the current project */
export const setCurrent: Server.SetRequest = {
kind: Server.RqKind.SET,
name: 'kernel.project.setCurrent',
};
-
/** Returns the list of all projects */
export const getList: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.project.getList',
};
-
/** Execute a GET request within the given project */
export const getOn: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.project.getOn',
};
-
/** Execute a SET request within the given project */
export const setOn: Server.SetRequest = {
kind: Server.RqKind.SET,
name: 'kernel.project.setOn',
};
-
/** Execute an EXEC request within the given project */
export const execOn: Server.ExecRequest = {
kind: Server.RqKind.EXEC,
name: 'kernel.project.execOn',
};
-
/** Create a new project */
export const create: Server.SetRequest = {
kind: Server.RqKind.SET,
name: 'kernel.project.create',
};
+
+/* ------------------------------------- */
diff --git a/ivette/api/kernel/properties.ts b/ivette/api/kernel/properties.ts
index 807ed404695a4209d413526bf4b6cb78327b91b3..05d00856eda9c55faf7a029ff863448cc64de3d2 100644
--- a/ivette/api/kernel/properties.ts
+++ b/ivette/api/kernel/properties.ts
@@ -1,16 +1,17 @@
/* --- Generated Frama-C Server API --- */
-/** Property Services
+/**
+ Property Services
@packageDocumentation
@module frama-c/kernel/properties
*/
import * as Json from 'dome/data/json';
import * as Server from 'frama-c/server';
+
import { tag } from 'api/kernel/data';
import { source } from 'api/kernel/services';
-
/** Property Kinds */
export enum propKind {
/** Contract behavior */
@@ -83,14 +84,21 @@ export enum propKind {
prop:<prop> = 'prop:<prop>';
}
+/** Safe decoder for `propKind` */
+export const jPropKindSafe: Json.Safe<propKind> =
+ Json.jFail(Json.jEnum(propKind),'kernel.properties.propKind expected');
+
+/** Loose decoder for `propKind` */
+export const jPropKind: Json.Loose<propKind> = Json.jEnum(propKind);
-/** Returns all registered tags for the above type. */
+/** Natural order for `propKind` */
+
+/** Registered tags for the above type. */
export const propKindTags: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.properties.propKindTags',
};
-
/** Property Status (consolidated) */
export enum propStatus {
/** Unknown status */
@@ -117,14 +125,21 @@ export enum propStatus {
unknown_but_dead = 'unknown_but_dead';
}
+/** Safe decoder for `propStatus` */
+export const jPropStatusSafe: Json.Safe<propStatus> =
+ Json.jFail(Json.jEnum(propStatus),'kernel.properties.propStatus expected');
-/** Returns all registered tags for the above type. */
+/** Loose decoder for `propStatus` */
+export const jPropStatus: Json.Loose<propStatus> = Json.jEnum(propStatus);
+
+/** Natural order for `propStatus` */
+
+/** Registered tags for the above type. */
export const propStatusTags: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.properties.propStatusTags',
};
-
/** Alarm Kinds */
export enum alarms {
/** Integer division by zero */
@@ -165,27 +180,35 @@ export enum alarms {
bool_value = 'bool_value';
}
+/** Safe decoder for `alarms` */
+export const jAlarmsSafe: Json.Safe<alarms> =
+ Json.jFail(Json.jEnum(alarms),'kernel.properties.alarms expected');
+
+/** Loose decoder for `alarms` */
+export const jAlarms: Json.Loose<alarms> = Json.jEnum(alarms);
-/** Returns all registered tags for the above type. */
+/** Natural order for `alarms` */
+
+/** Registered tags for the above type. */
export const alarmsTags: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.properties.alarmsTags',
};
-
/** Status of Registered Properties */
-
-
-/** Signal for array [`status`](#status)
- */
-export const statusSig: Server.Signal = {
- name: 'kernel.properties.statusSig',
+export const status: State.Array<'status',statusData> = {
+ signal: signalStatus,
+ fetch: fetchStatus,
+ reload: reloadStatus,
};
+/** Signal for array [`status`](#status) */
+export const signalStatus: Server.Signal = {
+ name: 'kernel.properties.signalStatus',
+};
-/** Data rows for array [`status`](#status)
- */
-export interface statusRow {
+/** Data for array rows [`status`](#status) */
+export interface statusData {
/** Entry identifier. */
key: Json.Key<'status'>;
/** Full description */
@@ -210,18 +233,16 @@ export interface statusRow {
predicate?: string;
}
-
-/** Data fetcher for array [`status`](#status)
- */
-export const statusFetch: Server.GetRequest = {
+/** Data fetcher for array [`status`](#status) */
+export const fetchStatus: Server.GetRequest = {
kind: Server.RqKind.GET,
- name: 'kernel.properties.statusFetch',
+ name: 'kernel.properties.fetchStatus',
};
-
-/** Force full reload for array [`status`](#status)
- */
-export const statusReload: Server.GetRequest = {
+/** Force full reload for array [`status`](#status) */
+export const reloadStatus: Server.GetRequest = {
kind: Server.RqKind.GET,
- name: 'kernel.properties.statusReload',
+ name: 'kernel.properties.reloadStatus',
};
+
+/* ------------------------------------- */
diff --git a/ivette/api/kernel/services.ts b/ivette/api/kernel/services.ts
index d14b2be23074dbb022ab3f73f383efe0c83ec0bb..db7c4f085dfe468c2f6bff849cc8f1c67741e93f 100644
--- a/ivette/api/kernel/services.ts
+++ b/ivette/api/kernel/services.ts
@@ -1,14 +1,15 @@
/* --- Generated Frama-C Server API --- */
-/** Kernel Services
+/**
+ Kernel Services
@packageDocumentation
@module frama-c/kernel/services
*/
import * as Json from 'dome/data/json';
import * as Server from 'frama-c/server';
-import { tag } from 'api/kernel/data';
+import { tag } from 'api/kernel/data';
/** Frama-C Kernel configuration */
export const getConfig: Server.GetRequest = {
@@ -16,18 +17,29 @@ export const getConfig: Server.GetRequest = {
name: 'kernel.services.getConfig',
};
-
/** Load a save file. Returns an error, if not successfull. */
export const load: Server.SetRequest = {
kind: Server.RqKind.SET,
name: 'kernel.services.load',
};
-
/** Source file positions. */
export type source =
{ dir: string, base: string, file: string, line: number };
+/** Safe decoder for `source` */
+export const jSourceSafe: Json.Safe<source> =
+ Json.jObject({
+ dir: Json.jFail(Json.jString,'String expected'),
+ base: Json.jFail(Json.jString,'String expected'),
+ file: Json.jFail(Json.jString,'String expected'),
+ line: Json.jFail(Json.jNumber,'Number expected'),
+ });
+
+/** Loose decoder for `source` */
+export const jSource: Json.Loose<source> = Json.jTry(jSourceSafe);
+
+/** Natural order for `source` */
/** Log messages categories. */
export enum logkind {
@@ -45,14 +57,21 @@ export enum logkind {
DEBUG = 'DEBUG';
}
+/** Safe decoder for `logkind` */
+export const jLogkindSafe: Json.Safe<logkind> =
+ Json.jFail(Json.jEnum(logkind),'kernel.services.logkind expected');
+
+/** Loose decoder for `logkind` */
+export const jLogkind: Json.Loose<logkind> = Json.jEnum(logkind);
-/** Returns all registered tags for the above type. */
+/** Natural order for `logkind` */
+
+/** Registered tags for the above type. */
export const logkindTags: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.services.logkindTags',
};
-
/** Message event record. */
export interface log {
/** Message kind */
@@ -67,6 +86,20 @@ export interface log {
source?: source;
}
+/** Safe decoder for `log` */
+export const jLogSafe: Json.Safe<log> =
+ Json.jObject({
+ kind: Json.jFail(Json.jEnum(logkind),'kernel.services.logkind expected'),
+ plugin: Json.jFail(Json.jString,'String expected'),
+ message: Json.jFail(Json.jString,'String expected'),
+ category: Json.jString,
+ source: jSource,
+ });
+
+/** Loose decoder for `log` */
+export const jLog: Json.Loose<log> = Json.jTry(jLogSafe);
+
+/** Natural order for `log` */
/** Turn logs monitoring on/off */
export const setLogs: Server.SetRequest = {
@@ -74,9 +107,10 @@ export const setLogs: Server.SetRequest = {
name: 'kernel.services.setLogs',
};
-
/** Flush the last emitted logs since last call (max 100) */
export const getLogs: Server.GetRequest = {
kind: Server.RqKind.GET,
name: 'kernel.services.getLogs',
};
+
+/* ------------------------------------- */
diff --git a/ivette/api/server_tsc.ml b/ivette/api/server_tsc.ml
index 9028a35c14ae21e3bbfb346cb7ad8b75d326cec7..a5139d848c6c14899a316a138c8aace0cc1bc415 100644
--- a/ivette/api/server_tsc.ml
+++ b/ivette/api/server_tsc.ml
@@ -49,6 +49,10 @@ let name_of_kind = function
| `SET -> "SET"
| `EXEC -> "EXEC"
+let makeDescr ?(indent="") fmt descr =
+ if descr <> [] then
+ Format.fprintf fmt "%s/** @[<hov 0>%a@] */@." indent pp_descr descr
+
(* -------------------------------------------------------------------------- *)
(* --- Jtype Generator --- *)
(* -------------------------------------------------------------------------- *)
@@ -61,15 +65,15 @@ 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
+ | Jself -> Format.pp_print_string fmt self.name
| Jnull -> Format.pp_print_string fmt "null"
| Jnumber -> Format.pp_print_string fmt "number"
| Jboolean -> Format.pp_print_string fmt "boolean"
- | Jstring -> Format.pp_print_string fmt "string"
- | Jtag tag -> Format.fprintf fmt "'%s'" tag
+ | 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
- | Jdata id -> pp_ident fmt id
+ | 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 ->
Pretty_utils.pp_list ~pre:"@[<hov 2>[ " ~sep:",@ " ~suf:"@ ]@]" pp fmt js
@@ -77,31 +81,134 @@ let makeJtype ~self ~names =
Pretty_utils.pp_list ~pre:"@[<hov 0>" ~sep:" |@ " ~suf:"@]" protect fmt js
| Jrecord fjs ->
Pretty_utils.pp_list ~pre:"@[<hov 2>{ " ~sep:",@ " ~suf:"@ }@]" field fmt fjs
- | Jarray js -> Format.fprintf fmt "%a[]" protect js
- | Jassoc (kd,js) -> Format.fprintf fmt "Json.Dict<'%s',%a>" kd pp js
+ | Jarray js | Jlist js -> Format.fprintf fmt "%a[]" protect js
and protect fmt js = match js with
| Junion _ | Joption _ -> Format.fprintf fmt "@[<hov 2>(%a)@]" pp js
| _ -> pp fmt js
and field fmt (fd,js) = Format.fprintf fmt "@[<hov 4>%s:@ %a@]" fd pp js
in pp
+(* -------------------------------------------------------------------------- *)
+(* --- Jtype Decoder --- *)
+(* -------------------------------------------------------------------------- *)
+
+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 jcall names fmt id =
+ try Format.pp_print_string fmt (Pkg.IdMap.find id names)
+ with Not_found -> Self.abort "Undefined identifier '%a'" Pkg.pp_ident id
+
+let jsafe ~safe msg pp fmt d =
+ if safe then
+ Format.fprintf fmt "@[<hov 2>Json.jFail(@,%a,@,'%s expected')@]" pp d msg
+ else
+ pp fmt d
+
+let jtry ~safe pp fmt d =
+ if safe then
+ pp fmt d
+ else
+ Format.fprintf fmt "@[<hov 2>Json.jTry(@,%a)@]" pp d
+
+let jenum names fmt id = Format.fprintf fmt "Json.jEnum(%a)" (jcall names) id
+
+let junion ~jtype ~makeLoose fmt jts =
+ begin
+ Format.fprintf fmt "@[<hv 0>@[<hv 2>Json.jUnion<%a>("
+ jtype (Pkg.Junion jts) ;
+ List.iter
+ (fun js -> Format.fprintf fmt "@ @[<hov 2>%a@]," makeLoose js) jts ;
+ Format.fprintf fmt "@]@,)@]" ;
+ end
+
+let jrecord ~makeSafe fmt jts =
+ begin
+ Format.fprintf fmt "@[<hv 0>@[<hv 2>Json.jObject({" ;
+ List.iter
+ (fun (fd,js) ->
+ Format.fprintf fmt "@ @[<hov 2>%s: %a@]," fd makeSafe js) jts ;
+ Format.fprintf fmt "@]@,})@]" ;
+ end
+
+let jtuple ~makeSafe fmt jts =
+ begin
+ let name = match List.length jts with
+ | 2 -> "jPair"
+ | 3 -> "jTriple"
+ | 4 -> "jTuple4"
+ | 5 -> "jTuple5"
+ | n -> Self.fatal "No jTuple%d defined" n
+ in
+ Format.fprintf fmt "@[<hv 0>@[<hv 2>Json.%s(" name ;
+ List.iter
+ (fun js -> Format.fprintf fmt "@ @[<hov 2>%a@]," makeSafe js) jts ;
+ Format.fprintf fmt "@]@,)@]" ;
+ end
+
+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
+ match js with
+ | Jany -> jprim fmt "jAny"
+ | Jnull -> jprim fmt "jNull"
+ | Jboolean -> jsafe ~safe "Boolean" jprim fmt "jBoolean"
+ | 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
+ | 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)
+ | Joption js -> makeLoose fmt js
+ | Jdict(kd,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 ->
+ if safe
+ 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
+ jsafe ~safe "Union" (junion ~jtype ~makeLoose) fmt jts
+ | Jrecord jfs -> jtry ~safe (jrecord ~makeSafe) fmt jfs
+ | Jtuple jts -> jtry ~safe (jtuple ~makeSafe) fmt jts
+
+let makeRootDecoder ~safe ~self ~names fmt js =
+ let open Pkg in
+ match js with
+ | Joption _ | Jdict _ | Jlist _ when safe ->
+ jcall names fmt (Pkg.Derived.loose self)
+ | Jrecord _ | Jtuple _ | Jarray _ when not safe ->
+ Format.fprintf fmt "Json.jTry(%a)"
+ (jcall names) (Pkg.Derived.safe self)
+ | Junion _ when safe ->
+ Format.fprintf fmt "Json.jFail(%a,'%s expected')"
+ (jcall names) (Pkg.Derived.loose self)
+ (String.capitalize_ascii self.name)
+ | _ -> makeDecoder ~safe ~self ~names fmt js
+
(* -------------------------------------------------------------------------- *)
(* --- Declaration Generator --- *)
(* -------------------------------------------------------------------------- *)
let makeDeclaration fmt names d =
let open Pkg in
- Format.fprintf fmt "@\n@\n/** %a */@\n" pp_descr d.d_descr ;
- let self = d.d_ident.name in
+ Format.pp_print_newline fmt () ;
+ makeDescr fmt d.d_descr ;
+ let self = d.d_ident in
let jtype = makeJtype ~self ~names in
match d.d_kind with
| D_type js ->
- Format.fprintf fmt "@[<hv 2>export type %s =@ %a;@]@\n" self jtype js ;
+ Format.fprintf fmt "@[<hv 2>export type %s =@ %a;@]@\n" self.name jtype js ;
| D_record fjs ->
- Format.fprintf fmt "export interface %s {@\n" self ;
+ Format.fprintf fmt "export interface %s {@\n" self.name ;
List.iter
(fun { fd_name = fd ; fd_type = js ; fd_descr = doc } ->
- if doc<>[] then Format.fprintf fmt " /** %a */@\n" pp_descr doc ;
+ makeDescr ~indent:" " fmt doc ;
match js with
| Joption js ->
Format.fprintf fmt " @[<hov 2>%s?: %a;@]@\n" fd jtype js
@@ -110,25 +217,63 @@ let makeDeclaration fmt names d =
) fjs ;
Format.fprintf fmt "}@\n" ;
| D_enum tgs ->
- Format.fprintf fmt "export enum %s {@\n" self ;
+ Format.fprintf fmt "export enum %s {@\n" self.name ;
List.iter
(fun { tg_name = tag ; tg_descr = doc } ->
- if doc<>[] then Format.fprintf fmt " /** %a */@\n" pp_descr doc ;
+ makeDescr ~indent:" " fmt doc ;
Format.fprintf fmt " %s = '%s';@\n" tag tag ;
) tgs ;
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 prefix ;
+ Format.fprintf fmt "export const %s: Server.%sRequest = {@\n"
+ self.name prefix ;
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 ;
+ 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_value js ->
+ Format.fprintf fmt "export const %s: State.Value<%a> = {@\n"
+ self.name jtype js ;
+ Format.fprintf fmt " signal: %a,@\n"
+ (jcall names) (Pkg.Derived.signal self) ;
+ Format.fprintf fmt " getter: %a,@\n"
+ (jcall names) (Pkg.Derived.getter self) ;
+ Format.fprintf fmt "};@\n" ;
+ | D_state js ->
+ Format.fprintf fmt "export const %s: State.State<%a> = {@\n"
+ self.name jtype js ;
+ Format.fprintf fmt " signal: %a,@\n"
+ (jcall names) (Pkg.Derived.signal self) ;
+ Format.fprintf fmt " getter: %a,@\n"
+ (jcall names) (Pkg.Derived.getter self) ;
+ Format.fprintf fmt " setter: %a,@\n"
+ (jcall names) (Pkg.Derived.setter self) ;
+ 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"
+ self.name kd (jcall names) data ;
+ Format.fprintf fmt " signal: %a,@\n"
+ (jcall names) (Pkg.Derived.signal self) ;
+ Format.fprintf fmt " fetch: %a,@\n"
+ (jcall names) (Pkg.Derived.fetch self) ;
+ Format.fprintf fmt " reload: %a,@\n"
+ (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"
+ 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"
+ self.name (jcall names) id
+ (makeRootDecoder ~safe:false ~self:id ~names) js ;
+ | D_order _ -> ()
(* -------------------------------------------------------------------------- *)
(* --- Package Generator --- *)
@@ -138,15 +283,16 @@ let makePackage pkg name fmt =
begin
let open Pkg in
Format.fprintf fmt "/* --- Generated Frama-C Server API --- */@\n@\n" ;
- Format.fprintf fmt "/** %s@\n" pkg.p_title ;
+ Format.fprintf fmt "/**@\n %s@\n" pkg.p_title ;
if pkg.p_descr <> [] then
- Format.fprintf fmt "@\n@\n%a@\n" pp_descr pkg.p_descr ;
+ Format.fprintf fmt "@\n @[<hov 0>%a@]@\n@\n" pp_descr pkg.p_descr ;
Format.fprintf fmt " @@packageDocumentation@\n" ;
Format.fprintf fmt " @@module frama-c/%s@\n" name ;
- Format.fprintf fmt "*/@\n@\n" ;
+ Format.fprintf fmt "*/@\n@." ;
let names = Pkg.resolve ~keywords pkg in
Format.fprintf fmt "import * as Json from 'dome/data/json';@\n" ;
Format.fprintf fmt "import * as Server from 'frama-c/server';@\n" ;
+ Format.pp_print_newline fmt () ;
Pkg.IdMap.iter
(fun id name ->
if id.plugin <> pkg.p_plugin ||
@@ -160,7 +306,9 @@ let makePackage pkg name fmt =
Format.fprintf fmt "import { %s: %s } from 'api/%s';@\n"
id.name name pkg
) names ;
- List.iter (makeDeclaration fmt names) pkg.p_content
+ List.iter (makeDeclaration fmt names) pkg.p_content ;
+ Format.pp_print_newline fmt () ;
+ Format.fprintf fmt "/* ------------------------------------- */@." ;
end
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index e6cc295d6d0c21e861c1baf17ffdedd13449cd3e..75833d9b4613c2d03ce89f8705d4de956d0e781c 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -57,6 +57,28 @@ let failure_from_type_error msg json =
let package = Package.package ~name:"data" ~title:"Informations" ()
+(* -------------------------------------------------------------------------- *)
+(* --- Declared Type --- *)
+(* -------------------------------------------------------------------------- *)
+
+let derived ~package ~id jtype =
+ let module Md = Markdown in
+ begin
+ declare ~package ~name:(Derived.safe id).name
+ ~descr:(Md.plain "Safe decoder for" @ Md.code id.name)
+ (D_safe(id,jtype)) ;
+ declare ~package ~name:(Derived.loose id).name
+ ~descr:(Md.plain "Loose decoder for" @ Md.code id.name)
+ (D_loose(id,jtype)) ;
+ declare ~package ~name:(Derived.order id).name
+ ~descr:(Md.plain "Natural order for" @ Md.code id.name)
+ (D_order(id,jtype)) ;
+ end
+
+let declare ~package ~name ?descr jtype =
+ let id = declare_id ~package ~name ?descr (D_type jtype) in
+ derived ~package ~id jtype ; Jdata id
+
(* -------------------------------------------------------------------------- *)
(* --- Option --- *)
(* -------------------------------------------------------------------------- *)
@@ -195,12 +217,16 @@ struct
let to_json s = `String s
end
+(* -------------------------------------------------------------------------- *)
+(* --- Text Datatypes --- *)
+(* -------------------------------------------------------------------------- *)
+
module Jmarkdown : S with type t = Markdown.text =
struct
type t = Markdown.text
let jtype =
let descr = Markdown.plain "Markdown (inlined) text." in
- datatype ~package ~name:"markdown" ~descr Jstring
+ declare ~package ~name:"markdown" ~descr Jstring
let of_json js = Markdown.plain (Ju.to_string js)
let to_json txt = `String (Pretty_utils.to_string Markdown.pp_text txt)
end
@@ -213,8 +239,8 @@ struct
"Rich text format uses `[tag; …text ]` to apply \
the tag `tag` to the enclosed text. \
Empty tag `\"\"` can also used to simply group text together." in
- let jdef = Junion [ Jnull; Jstring; Jarray Jself ] in
- datatype ~package ~name:"text" ~descr jdef
+ let jdef = Junion [ Jnull; Jstring; Jlist Jself ] in
+ declare ~package ~name:"text" ~descr jdef
end
(* -------------------------------------------------------------------------- *)
@@ -350,8 +376,11 @@ struct
type nonrec r = r
type t = r record
let jtype =
- let record = D_record (List.rev s.fields) in
- Jdata (Package.declare_id ~package ~name ~descr record)
+ let fields = List.rev s.fields in
+ let id = Package.declare_id ~package ~name ~descr (D_record fields) in
+ let field fd = fd.fd_name, fd.fd_type in
+ derived ~package ~id (Jrecord (List.map field fields)) ;
+ Jdata id
let default = s.default
let has fd r = fd.member r
let get fd r = fd.getter r
@@ -380,8 +409,7 @@ module Tag =
struct
type t = Package.tagInfo
- let jtype =
- datatype ~package ~name:"tag"
+ let jtype = declare ~package ~name:"tag"
~descr:(Markdown.plain "Enum Tag Description")
(Jrecord [
"name",Jstring ;
@@ -520,7 +548,9 @@ struct
type t = a
let jtype =
let enums = D_enum (List.rev d.tags) in
- Jdata (Package.declare_id ~package ~name ~descr enums)
+ let id = Package.declare_id ~package ~name ~descr enums in
+ let js = Jenum id in
+ derived ~package ~id js ; js
let of_json = of_json name d.values
let to_json = to_json name d.lookup d.vindex
end in
diff --git a/src/plugins/server/data.mli b/src/plugins/server/data.mli
index 6ee41b06e217f64cf381e0ca8af834f7bf3fb31b..6134493c968e528edd6e99098642c8a5e037cf72 100644
--- a/src/plugins/server/data.mli
+++ b/src/plugins/server/data.mli
@@ -115,6 +115,23 @@ val jalist : 'a data -> 'a list data
val jarray : 'a data -> 'a array data
val joption : 'a data -> 'a option data
+(**
+ Declare the derived names for the provided type.
+ Shall not be used directely.
+*)
+val derived : package:package -> id:ident -> jtype -> unit
+
+(**
+ Declare a new type and returns its alias.
+ Same as [Jdata (declare_id ~package ~name (D_type js))].
+ Automatically declare the derived names.
+*)
+val declare :
+ package:package ->
+ name:string ->
+ ?descr:Markdown.text ->
+ jtype -> jtype
+
(* -------------------------------------------------------------------------- *)
(** {2 Records} *)
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/kernel_ast.ml b/src/plugins/server/kernel_ast.ml
index 6bbd4d7c472faf4cd96a0d428b266efe44238f6a..a278440a524f50a1d051e66b5ccf01616e06a245 100644
--- a/src/plugins/server/kernel_ast.ml
+++ b/src/plugins/server/kernel_ast.ml
@@ -185,7 +185,7 @@ struct
let jglobal = jmarker "global"
let jproperty = jmarker "property"
- let jtype = Pkg.datatype ~package ~name:"marker"
+ let jtype = Data.declare ~package ~name:"marker"
~descr:(Md.plain "Localizable AST markers")
Pkg.(Junion (List.rev !markers))
diff --git a/src/plugins/server/kernel_main.ml b/src/plugins/server/kernel_main.ml
index 1c7166aab805aea19848f336c516bd206906ed74..a09524ecd4b6e8440541c5a83fac0bdd20f7fc28 100644
--- a/src/plugins/server/kernel_main.ml
+++ b/src/plugins/server/kernel_main.ml
@@ -79,7 +79,7 @@ module LogSource =
struct
type t = Filepath.position
- let jtype = Pkg.datatype ~package ~name:"source"
+ let jtype = Data.declare ~package ~name:"source"
~descr:(Md.plain "Source file positions.")
(Jrecord [
"dir", Jstring;
diff --git a/src/plugins/server/kernel_project.ml b/src/plugins/server/kernel_project.ml
index 7d96485713a9ef3a1a0ecce0bcad682c30db541c..80a7b106b5187e2fec1fe6dadb7d9ea5add05cc7 100644
--- a/src/plugins/server/kernel_project.ml
+++ b/src/plugins/server/kernel_project.ml
@@ -37,7 +37,7 @@ module ProjectId = (val jkey ~kind:"project")
module ProjectInfo =
struct
type t = Project.t
- let jtype = Pkg.datatype ~package
+ let jtype = Data.declare ~package
~name:"projectInfo"
~descr:(Md.plain "Project informations")
Pkg.(Jrecord [
@@ -68,7 +68,7 @@ struct
type t = Project.t * string * json
- let jtype = Pkg.datatype ~package ~name:"projectRequest"
+ let jtype = Data.declare ~package ~name:"projectRequest"
~descr:(Md.plain "Request to be executed on the specified project.")
(Jrecord [
"project",ProjectId.jtype;
diff --git a/src/plugins/server/package.ml b/src/plugins/server/package.ml
index b5fb7e83f50194f5635bebe593c08e11e439bb80..29f47cd79b6abe044e1e948567c23eda4a665a56 100644
--- a/src/plugins/server/package.ml
+++ b/src/plugins/server/package.ml
@@ -166,17 +166,17 @@ type jtype =
| Jnumber
| Jstring
| Jalpha (* string primarily compared without case *)
- | Jtag of string
| Jkey of string (* kind of a string used for indexing *)
| Jindex of string (* kind of an integer used for indexing *)
| Joption of jtype
- | Jassoc of string * jtype (* kind of keys *)
+ | Jdict of string * jtype (* kind of keys *)
| Jlist of jtype (* order does not matter *)
| Jarray of jtype (* order matters *)
| Jtuple of jtype list
| Junion of jtype list
| Jrecord of (string * jtype) list
| Jdata of ident
+ | Jenum of ident (* data that is an enum *)
| Jself (* for (simply) recursive types *)
(* -------------------------------------------------------------------------- *)
@@ -214,6 +214,9 @@ type declKindInfo =
| D_value of jtype
| D_state of jtype
| D_array of string (* key kind *)
+ | D_safe of ident * jtype (* safe decoder *)
+ | D_loose of ident * jtype (* loose decoder *)
+ | D_order of ident * jtype (* natural ordering *)
type declInfo = {
d_ident : ident;
@@ -253,11 +256,11 @@ let pp_pkgname fmt { p_plugin ; p_package } =
let rec visit_jtype fn = function
| Jany | Jself | Jnull | Jboolean | Jnumber
- | Jstring | Jalpha | Jkey _ | Jindex _ | Jtag _ -> ()
- | Joption js | Jassoc(_,js) | Jarray js | Jlist js -> visit_jtype fn js
+ | Jstring | Jalpha | Jkey _ | Jindex _ -> ()
+ | 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 -> fn id
+ | Jdata id | Jenum id -> fn id
let visit_field f { fd_type } = visit_jtype f fd_type
@@ -271,6 +274,7 @@ let visit_request f { rq_input ; rq_output } =
let visit_dkind f = function
| D_signal | D_enum _ | D_array _ -> ()
| D_type js | D_state js | D_value js -> visit_jtype f js
+ | D_loose(id,js) | D_safe(id,js) | D_order(id,js) -> f id ; visit_jtype f js
| D_record fds -> List.iter (visit_field f) fds
| D_request rq -> visit_request f rq
@@ -303,12 +307,16 @@ let derived ?prefix ?suffix id =
module Derived =
struct
- let signal id = derived ~prefix:"sig" id
+ 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
(* -------------------------------------------------------------------------- *)
@@ -399,9 +407,6 @@ let update ~package:pkg ~name decl =
else curr
) pkg.revDecl
-let datatype ~package ~name ?descr jtype =
- Jdata (declare_id ~package ~name ?descr (D_type jtype))
-
let iter f =
List.iter f @@
match !collection with
@@ -434,16 +439,15 @@ let rec md_jtype pp = function
| Jnumber -> Md.emph "number"
| Jboolean -> Md.emph "boolean"
| Jstring | Jalpha -> Md.emph "string"
- | Jtag tag -> escaped tag
| Jkey kd -> key kd
| Jindex kd -> index kd
- | Jdata id -> pp.ident id
+ | Jdata id | Jenum id -> pp.ident id
| Joption js -> protect pp js @ Md.code "?"
| Jtuple js -> Md.code "[" @ md_jlist pp "," js @ Md.code "]"
| Junion js -> md_jlist pp "|" js
| Jarray js | Jlist js -> protect pp js @ Md.code "[]"
| Jrecord fjs -> Md.code "{" @ fields pp fjs @ Md.code "}"
- | Jassoc (id,js) ->
+ | Jdict (id,js) ->
Md.code "{[" @ key id @ Md.code "]:" @ md_jtype pp js @ Md.code "}"
and md_jlist pp sep js =
diff --git a/src/plugins/server/package.mli b/src/plugins/server/package.mli
index 0e3605c50f18465be741f4468dc63e8d1807e11e..0e639a0ee9e584fb6738a1fdc0e1ee8f1da13d85 100644
--- a/src/plugins/server/package.mli
+++ b/src/plugins/server/package.mli
@@ -34,17 +34,17 @@ type jtype =
| Jnumber
| Jstring
| Jalpha (** string primarily compared without case *)
- | Jtag of string
| Jkey of string (** kind of a string used for indexing *)
| Jindex of string (** kind of an integer used for indexing *)
| Joption of jtype
- | Jassoc of string * jtype (** kind of keys *)
+ | Jdict of string * jtype (** kind of keys *)
| Jlist of jtype (** order does not matter *)
| Jarray of jtype (** order matters *)
| Jtuple of jtype list
| Junion of jtype list
| Jrecord of (string * jtype) list
| Jdata of ident
+ | Jenum of ident (** data that is an enum *)
| Jself (** for (simply) recursive types *)
type fieldInfo = {
@@ -78,6 +78,9 @@ type declKindInfo =
| D_value of jtype
| D_state of jtype
| D_array of string
+ | D_safe of ident * jtype (* safe decoder *)
+ | D_loose of ident * jtype (* loose decoder *)
+ | D_order of ident * jtype (* natural ordering *)
type declInfo = {
d_ident : ident;
@@ -103,7 +106,6 @@ val pp_pkgname : Format.formatter -> packageInfo -> unit
val pp_ident : Format.formatter -> ident -> unit
val pp_jtype : Format.formatter -> jtype -> unit
-
(* -------------------------------------------------------------------------- *)
(* --- Derived Names --- *)
(* -------------------------------------------------------------------------- *)
@@ -118,6 +120,10 @@ sig
val data : ident -> ident
val fetch : ident -> ident
val reload : ident -> ident
+ val safe : ident -> ident
+ val loose : ident -> ident
+ val order : ident -> ident
+ val decode : safe:bool -> ident -> ident
end
(* -------------------------------------------------------------------------- *)
@@ -181,16 +187,6 @@ val declare_id :
declKindInfo ->
ident
-(**
- Declare a new type and returns its alias.
- Same as [Jdata (declare_id ~package ~name (D_type js))]`
-*)
-val datatype :
- package:package ->
- name:string ->
- ?descr:Markdown.text ->
- jtype -> jtype
-
(**
Replace the declaration for the given name in the package.
*)
diff --git a/src/plugins/server/server_doc.ml b/src/plugins/server/server_doc.ml
index fa71c4a6fae13631348b74f95fe5200afe0002c9..522cc6584cfffdbadf3508ce01515780ef9ab1d5 100644
--- a/src/plugins/server/server_doc.ml
+++ b/src/plugins/server/server_doc.ml
@@ -134,6 +134,7 @@ let kind_of_decl = function
| D_request { rq_kind=`GET } -> "GET"
| D_request { rq_kind=`SET } -> "SET"
| D_request { rq_kind=`EXEC } -> "EXEC"
+ | D_loose _ | D_safe _ | D_order _ -> assert false
let pp_for ?decl names =
let self =
@@ -158,6 +159,7 @@ let md_named ~kind pp = function
let descr_of_decl names decl =
match decl.d_kind with
+ | D_safe _ | D_loose _ | D_order _ -> assert false
| D_signal -> []
| D_state _ -> [] (* TBC *)
| D_value _ -> [] (* TBC *)
@@ -181,16 +183,19 @@ let descr_of_decl names decl =
md_named ~kind:"output" pp rq.rq_output
let declaration page names decl =
- let name = decl.d_ident.name in
- let fullname = name_of_ident decl.d_ident in
- let kind = kind_of_decl decl.d_kind in
- (* let title = Printf.sprintf "`%s` %s" kind fullname in *)
- let title = Printf.sprintf "%s (`%s`)" fullname kind in
- let index = [ title ] in
- let contents = Markdown.par decl.d_descr in
- let generated () = descr_of_decl names decl in
- let _href = publish ~page ~name ~title ~index ~contents ~generated () in
- ()
+ match decl.d_kind with
+ | D_safe _ | D_loose _ | D_order _ -> ()
+ | _ ->
+ let name = decl.d_ident.name in
+ let fullname = name_of_ident decl.d_ident in
+ let kind = kind_of_decl decl.d_kind in
+ (* let title = Printf.sprintf "`%s` %s" kind fullname in *)
+ let title = Printf.sprintf "%s (`%s`)" fullname kind in
+ let index = [ title ] in
+ let contents = Markdown.par decl.d_descr in
+ let generated () = descr_of_decl names decl in
+ let href = publish ~page ~name ~title ~index ~contents ~generated () in
+ ignore href
let package pkg =
begin