diff --git a/ivette/api/kernel/ast/index.ts b/ivette/api/kernel/ast/index.ts
index 27e84f57231fa9f2e70cbbfc52dd0f381dffbf4a..a5bfaf9032e5e6800aa93703af31ab2e5d9bb0af 100644
--- a/ivette/api/kernel/ast/index.ts
+++ b/ivette/api/kernel/ast/index.ts
@@ -114,10 +114,10 @@ export const byMarkerInfoData: Compare.Order<markerInfoData> =
Compare.byFields
<{ key: Json.key<'#markerInfo'>, kind: markerKind, name: string,
descr: string }>({
- key: Compare.primitive,
+ key: Compare.string,
kind: byMarkerKind,
name: Compare.alpha,
- descr: Compare.primitive,
+ descr: Compare.string,
});
/** Signal for array [`markerInfo`](#markerinfo) */
@@ -242,9 +242,9 @@ export const jFunctionsDataSafe: Json.Safe<functionsData> =
export const byFunctionsData: Compare.Order<functionsData> =
Compare.byFields
<{ key: Json.key<'#functions'>, name: string, signature: string }>({
- key: Compare.primitive,
+ key: Compare.string,
name: Compare.alpha,
- signature: Compare.primitive,
+ signature: Compare.string,
});
/** Signal for array [`functions`](#functions) */
diff --git a/ivette/api/kernel/data/index.ts b/ivette/api/kernel/data/index.ts
index ffd93535e849479a40c0683f83c6bdf65ed6c5fe..f3bd97722e658b170d5a5e6dbae991eae25396c2 100644
--- a/ivette/api/kernel/data/index.ts
+++ b/ivette/api/kernel/data/index.ts
@@ -27,7 +27,7 @@ export const jMarkdownSafe: Json.Safe<markdown> =
Json.jFail(Json.jString,'String expected');
/** Natural order for `markdown` */
-export const byMarkdown: Compare.Order<markdown> = Compare.primitive;
+export const byMarkdown: Compare.Order<markdown> = Compare.string;
/** 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[];
diff --git a/ivette/api/kernel/project/index.ts b/ivette/api/kernel/project/index.ts
index 6674b144671357e35b45ac7648ca0b0798841b7d..c1dba98e07b19f1bdd52e2c9d1db91ccdbc981c0 100644
--- a/ivette/api/kernel/project/index.ts
+++ b/ivette/api/kernel/project/index.ts
@@ -36,9 +36,9 @@ export const jProjectInfoSafe: Json.Safe<projectInfo> =
export const byProjectInfo: Compare.Order<projectInfo> =
Compare.byFields
<{ id: Json.key<'#project'>, name: string, current: boolean }>({
- id: Compare.primitive,
+ id: Compare.string,
name: Compare.alpha,
- current: Compare.primitive,
+ current: Compare.boolean,
});
/** Request to be executed on the specified project. */
@@ -62,8 +62,8 @@ export const jProjectRequestSafe: Json.Safe<projectRequest> =
export const byProjectRequest: Compare.Order<projectRequest> =
Compare.byFields
<{ project: Json.key<'#project'>, request: string, data: Json.json }>({
- project: Compare.primitive,
- request: Compare.primitive,
+ project: Compare.string,
+ request: Compare.string,
data: Compare.structural,
});
diff --git a/ivette/api/kernel/properties/index.ts b/ivette/api/kernel/properties/index.ts
index 92d7cc4a130b483eb06e5e3267031478de08dfce..9f7eeb5e6e49df77718140190f847501a88e5eec 100644
--- a/ivette/api/kernel/properties/index.ts
+++ b/ivette/api/kernel/properties/index.ts
@@ -275,17 +275,17 @@ export const byStatusData: Compare.Order<statusData> =
names: string[], status: propStatus, function?: Json.key<'#fct'>,
kinstr?: Json.key<'#stmt'>, source: source, alarm?: string,
alarm_descr?: string, predicate?: string }>({
- key: Compare.primitive,
- descr: Compare.primitive,
+ key: Compare.string,
+ descr: Compare.string,
kind: byPropKind,
- names: Compare.array(Compare.primitive),
+ names: Compare.array(Compare.string),
status: byPropStatus,
- function: Compare.defined(Compare.primitive),
- kinstr: Compare.defined(Compare.primitive),
+ function: Compare.defined(Compare.string),
+ kinstr: Compare.defined(Compare.string),
source: bySource,
- alarm: Compare.defined(Compare.primitive),
- alarm_descr: Compare.defined(Compare.primitive),
- predicate: Compare.defined(Compare.primitive),
+ alarm: Compare.defined(Compare.string),
+ alarm_descr: Compare.defined(Compare.string),
+ predicate: Compare.defined(Compare.string),
});
/** Signal for array [`status`](#status) */
diff --git a/ivette/api/kernel/services/index.ts b/ivette/api/kernel/services/index.ts
index cdc371d34b5398ba484204c25ad4712e3899d378..2b98b1c59cbc4e138a9ceada0949b5ca6e7c9de7 100644
--- a/ivette/api/kernel/services/index.ts
+++ b/ivette/api/kernel/services/index.ts
@@ -74,10 +74,10 @@ export const jSourceSafe: Json.Safe<source> =
export const bySource: Compare.Order<source> =
Compare.byFields
<{ dir: string, base: string, file: string, line: number }>({
- dir: Compare.primitive,
- base: Compare.primitive,
- file: Compare.primitive,
- line: Compare.primitive,
+ dir: Compare.string,
+ base: Compare.string,
+ file: Compare.string,
+ line: Compare.number,
});
/** Log messages categories. */
@@ -149,8 +149,8 @@ export const byLog: Compare.Order<log> =
source?: source }>({
kind: byLogkind,
plugin: Compare.alpha,
- message: Compare.primitive,
- category: Compare.defined(Compare.primitive),
+ message: Compare.string,
+ category: Compare.defined(Compare.string),
source: Compare.defined(bySource),
});
diff --git a/ivette/api/server_tsc.ml b/ivette/api/server_tsc.ml
index 8f5eb6e829b7992c706487f59d1b23b226f80421..b303c841281597b3db9ab019a3b6e695c7ac595f 100644
--- a/ivette/api/server_tsc.ml
+++ b/ivette/api/server_tsc.ml
@@ -74,6 +74,7 @@ let makeJtype ?self ~names =
| Jnumber -> Format.pp_print_string fmt "number"
| Jboolean -> Format.pp_print_string fmt "boolean"
| Jstring | Jalpha -> Format.pp_print_string fmt "string"
+ | Jtag a -> Format.fprintf fmt "\"%s\"" a
| 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
@@ -166,6 +167,7 @@ let rec makeDecoder ~safe ?self ~names fmt js =
| Jboolean -> jsafe ~safe "Boolean" jprim fmt "jBoolean"
| Jnumber -> jsafe ~safe "Number" jprim fmt "jNumber"
| Jstring | Jalpha -> jsafe ~safe "String" jprim fmt "jString"
+ | Jtag a -> Format.fprintf fmt "jTag(\"%s\")" a
| Jkey kd -> jsafe ~safe ("#" ^ kd) jkey fmt kd
| Jindex kd -> jsafe ~safe ("#" ^ kd) jindex fmt kd
| Jdata id -> jcall names fmt (Pkg.Derived.decode ~safe id)
@@ -217,14 +219,13 @@ let makeOrder ~self ~names fmt js =
let rec pp fmt = function
| Jnull -> Format.pp_print_string fmt "Compare.equal"
| Jalpha -> Format.pp_print_string fmt "Compare.alpha"
- | Jnumber | Jstring | Jboolean | Jkey _ | Jindex _
- -> Format.pp_print_string fmt "Compare.primitive"
+ | Jnumber | Jindex _ -> Format.pp_print_string fmt "Compare.number"
+ | Jstring | Jkey _ -> Format.pp_print_string fmt "Compare.string"
+ | Jboolean -> Format.pp_print_string fmt "Compare.boolean"
| Jself -> jcall names fmt (Pkg.Derived.order self)
| Jdata id -> jcall names fmt (Pkg.Derived.order id)
| Joption js ->
Format.fprintf fmt "@[<hov 2>Compare.defined(@,%a)@]" pp js
- | Jany | Junion _ -> (* Can not find a better solution *)
- Format.fprintf fmt "Compare.structural"
| Jenum id ->
Format.fprintf fmt "@[<hov 2>Compare.byEnum(@,%a)@]" (jcall names) id
| Jlist js | Jarray js ->
@@ -250,6 +251,8 @@ let makeOrder ~self ~names fmt js =
Format.fprintf fmt
"@[<hov 2>Compare.dictionary<@,Json.dict<'#%s'@,%a>>(@,%a)@]"
kd jtype js pp js
+ | Jany | Junion _ | Jtag _ ->
+ Format.fprintf fmt "Compare.structural"
in pp fmt js
(* -------------------------------------------------------------------------- *)
diff --git a/ivette/src/dome/src/renderer/data/compare.ts b/ivette/src/dome/src/renderer/data/compare.ts
index 31185f33ee006c019b53b8438c9f1b3f390ef10e..b9bcc989b71af9d42a5f7ab74406649a466ad81d 100644
--- a/ivette/src/dome/src/renderer/data/compare.ts
+++ b/ivette/src/dome/src/renderer/data/compare.ts
@@ -41,28 +41,37 @@ export function isBigNum(x: any): x is bignum {
return typeof (x) === 'bigint' || (typeof (x) === 'number' && !Number.isNaN(x));
}
-/**
- Primitive comparison.
- Can only compare arguments that have
- comparable primitive type.
-
- This includes symbols, boolean, non-NaN numbers, bigints and strings.
- Numbers and big-ints can also be compared with each others.
-*/
-export function primitive(x: symbol, y: symbol): number;
-export function primitive(x: boolean, y: boolean): number;
-export function primitive(x: bignum, y: bignum): number;
-export function primitive(x: string, y: string): number;
-export function primitive(x: any, y: any) {
+/** @internal */
+function primitive(x: any, y: any) {
if (x < y) return -1;
if (x > y) return 1;
return 0;
}
/**
- Primitive comparison for numbers (NaN included).
+ Primitive comparison for symbols.
+*/
+export const symbol: Order<symbol> = primitive;
+
+/**
+ Primitive comparison for booleans.
+*/
+export const boolean: Order<boolean> = primitive;
+
+/**
+ Primitive comparison for strings. See also [[alpha]].
+*/
+export const string: Order<string> = primitive;
+
+/**
+ Primitive comparison for (big) integers (non NaN numbers included).
+ */
+export const bignum: Order<bignum> = primitive;
+
+/**
+ Primitive comparison for number (NaN included).
*/
-export function float(x: number, y: number) {
+export function number(x: number, y: number) {
const nx = Number.isNaN(x);
const ny = Number.isNaN(y);
if (nx && ny) return 0;
diff --git a/ivette/src/dome/src/renderer/data/json.ts b/ivette/src/dome/src/renderer/data/json.ts
index ba0be2fc66fcef5b3a37e5e436633d1f4ebfba3f..e79d55155979fcf83fa1bfe84019b97991b17bbd 100644
--- a/ivette/src/dome/src/renderer/data/json.ts
+++ b/ivette/src/dome/src/renderer/data/json.ts
@@ -118,6 +118,15 @@ export const jString: Loose<string> = (js: json) => (
typeof js === 'string' ? js : undefined
);
+/** JSON constant.
+ Capture the tag or returns `undefined`.
+ Can be used with [[jUnion]], although [[jEnum]]
+ might be more efficient.
+*/
+export function jTag<A>(tg: A): Loose<A> {
+ return (js: json) => Object.is(js, tg) ? tg : undefined;
+}
+
/**
Lookup tags in a dictionary.
Can be used directly for enum types, eg. `jEnum(myEnumType)`.
diff --git a/ivette/src/renderer/Properties.tsx b/ivette/src/renderer/Properties.tsx
index e2a434f7a7e0743ff27b63b55aa4ac0d0f9d5fa5..22acbafdf641891b0c6c7adb7a0ccfd6ca5a2880 100644
--- a/ivette/src/renderer/Properties.tsx
+++ b/ivette/src/renderer/Properties.tsx
@@ -202,7 +202,7 @@ function ColumnTag<Row>(props: ColumnProps<Row, States.Tag>) {
// -------------------------------------------------------------------------
const bySource =
- Compare.byFields<SourceLoc>({ file: Compare.alpha, line: Compare.primitive });
+ Compare.byFields<SourceLoc>({ file: Compare.alpha, line: Compare.number });
const byStatus =
Compare.byRank(
@@ -227,7 +227,7 @@ const byProperty: Compare.ByFields<Property> = {
alarm: Compare.defined(Compare.alpha),
names: Compare.array(Compare.alpha),
predicate: Compare.defined(Compare.alpha),
- key: Compare.primitive,
+ key: Compare.string,
kinstr: Compare.structural,
};
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index a298e490e43ceced5223d92f7713cb087ff1d4f2..0dc576f61ca97541dd4e906cac794a5827f24732 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -332,9 +332,21 @@ struct
if s.published then
raise (Invalid_argument "Server.Data.Record: already published")
+ let check_field_name s name =
+ begin
+ if List.exists (fun f -> f.Package.fd_name = name) s.fields then
+ (let msg = Printf.sprintf "Server.Data.Record: duplicate field %S" name
+ in raise (Invalid_argument msg));
+ if not (Str.string_match (Str.regexp "[a-zA-Z0-9 _-]+$") name 0) then
+ (let msg = Printf.sprintf
+ "Server.Data.Record: invalid characters for field %S" name in
+ raise (Invalid_argument msg));
+ end
+
let field (type a r) (s : r signature)
~name ~descr ?default (d : a data) : (r,a) field =
not_published s ;
+ check_field_name s name ;
let module D = (val d) in
begin match default with
| None -> ()
@@ -354,6 +366,7 @@ struct
let option (type a r) (s : r signature)
~name ~descr (d : a data) : (r,a option) field =
not_published s ;
+ check_field_name s name ;
let module D = (val d) in
let field = Package.{
fd_name = name ;
diff --git a/src/plugins/server/package.ml b/src/plugins/server/package.ml
index 6f2e56f956b5cafbb98573b3d8712d95206ed9d6..cb716919cf55fec5794d311fc940b8acd195717c 100644
--- a/src/plugins/server/package.ml
+++ b/src/plugins/server/package.ml
@@ -166,6 +166,7 @@ type jtype =
| Jnumber
| Jstring
| Jalpha (* string primarily compared without case *)
+ | Jtag of string (* single constant string *)
| Jkey of string (* kind of a string used for indexing *)
| Jindex of string (* kind of an integer used for indexing *)
| Joption of jtype
@@ -289,14 +290,14 @@ let rec isRecursive = function
| Jself -> true
| Jdata _ | Jenum _
| Jany | Jnull | Jboolean | Jnumber
- | Jstring | Jalpha | Jkey _ | Jindex _ -> false
+ | Jstring | Jalpha | Jkey _ | Jindex _ | Jtag _ -> false
| Joption js | Jdict(_,js) | Jarray js | Jlist js -> isRecursive js
| Jtuple js | Junion js -> List.exists isRecursive js
| Jrecord fjs -> List.exists (fun (_,js) -> isRecursive js) fjs
let rec visit_jtype fn = function
| Jany | Jself | Jnull | Jboolean | Jnumber
- | Jstring | Jalpha | Jkey _ | Jindex _ -> ()
+ | Jstring | Jalpha | Jkey _ | Jindex _ | Jtag _ -> ()
| 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
@@ -447,7 +448,7 @@ let iter f =
let key kd = Md.plain (Printf.sprintf "`#%s`" kd)
let index kd = Md.plain (Printf.sprintf "`#0%s`" kd)
-let escaped tag = Md.plain (Printf.sprintf "`\"%s\"`" @@ String.escaped tag)
+let litteral tag = Md.plain (Printf.sprintf "`\"%s\"`" tag)
type pp = {
self: Md.text ;
@@ -461,6 +462,7 @@ let rec md_jtype pp = function
| Jnumber -> Md.emph "number"
| Jboolean -> Md.emph "boolean"
| Jstring | Jalpha -> Md.emph "string"
+ | Jtag a -> litteral a
| Jkey kd -> key kd
| Jindex kd -> index kd
| Jdata id | Jenum id -> pp.ident id
@@ -478,7 +480,7 @@ and md_jlist pp sep js =
and fields pp fjs =
Md.glue ~sep:(Md.plain ",") @@
List.map (fun (fd,js) ->
- escaped fd @
+ litteral fd @
match js with
| Joption js -> Md.code ":?" @ md_jtype pp js
| _ -> Md.code ":" @ md_jtype pp js
@@ -501,7 +503,7 @@ let md_tags ?(title="Tags") (tags : tagInfo list) =
] in
let row tg = [
tg.tg_label ;
- escaped tg.tg_name ;
+ litteral tg.tg_name ;
tg.tg_descr ;
] in
Md.{ caption = None ; header ; content = List.map row tags }
@@ -515,12 +517,12 @@ let md_fields ?(title="Field") pp (fields : fieldInfo list) =
let row f =
match f.fd_type with
| Joption js -> [
- escaped (f.fd_name ^ "?") ;
+ litteral f.fd_name @ Md.plain "(opt.)" ;
md_jtype pp js ;
f.fd_descr ;
]
| _ -> [
- escaped f.fd_name ;
+ litteral f.fd_name ;
md_jtype pp f.fd_type ;
f.fd_descr ;
]
diff --git a/src/plugins/server/package.mli b/src/plugins/server/package.mli
index c040c985bc85129a3c15bb222e1afdffaf2262a4..85af7f86923ac5df9fda9ad6fc5b066800ace281 100644
--- a/src/plugins/server/package.mli
+++ b/src/plugins/server/package.mli
@@ -34,6 +34,7 @@ type jtype =
| Jnumber
| Jstring
| Jalpha (** string primarily compared without case *)
+ | Jtag of string (** single constant string *)
| Jkey of string (** kind of a string used for indexing *)
| Jindex of string (** kind of an integer used for indexing *)
| Joption of jtype
@@ -222,7 +223,8 @@ type pp = {
ident: ident -> Markdown.text ;
}
-val escaped : string -> Markdown.text
+(** Quoted string *)
+val litteral : string -> Markdown.text
val md_jtype : pp -> jtype -> Markdown.text
val md_tags : ?title:string -> tagInfo list -> Markdown.table