From 8d394a0c32936f9be3d27ebade591daf490e1990 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Thu, 9 Jul 2020 09:44:58 +0200
Subject: [PATCH] [server] added Jtag for light enums
---
ivette/api/server_tsc.ml | 6 ++++--
ivette/src/dome/src/renderer/data/json.ts | 9 +++++++++
src/plugins/server/package.ml | 16 +++++++++-------
src/plugins/server/package.mli | 4 +++-
4 files changed, 25 insertions(+), 10 deletions(-)
diff --git a/ivette/api/server_tsc.ml b/ivette/api/server_tsc.ml
index 8f5eb6e829b..2fbbeae1873 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)
@@ -223,8 +225,6 @@ let makeOrder ~self ~names fmt js =
| 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 +250,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/json.ts b/ivette/src/dome/src/renderer/data/json.ts
index ba0be2fc66f..e79d5515597 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/src/plugins/server/package.ml b/src/plugins/server/package.ml
index 6f2e56f956b..cb716919cf5 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 c040c985bc8..85af7f86923 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
--
GitLab