Commit 4b43d83a authored by Loïc Correnson's avatar Loïc Correnson
Browse files

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

[server] added Jtag for light enums

See merge request frama-c/frama-c!2746
parents dd3c845f 2d771f5e
......@@ -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) */
......
......@@ -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[];
......
......@@ -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,
});
......
......@@ -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) */
......
......@@ -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),
});
......
......@@ -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
(* -------------------------------------------------------------------------- *)
......
......@@ -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;
......
......@@ -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)`.
......
......@@ -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,
};
......
......@@ -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 ;
......
......@@ -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 ;
]
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment