Merge branch 'feature/server/jtags' into 'master'

[server] added Jtag for light enums

See merge request frama-c/frama-c!2746

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)  */

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[];

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,
   });
 

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)  */

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),
   });
 

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
 
 (* -------------------------------------------------------------------------- *)

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;

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)`.

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,
 };
 

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 ;

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 ;
       ]

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