diff --git a/src/plugins/api-generator/api_generator.ml b/src/plugins/api-generator/api_generator.ml
index 69e3656ed10b654a572d4ac5c2faf276cb55f47f..f271f73dbfebb4661ffaa57e3b0a1e7595f55afc 100644
--- a/src/plugins/api-generator/api_generator.ml
+++ b/src/plugins/api-generator/api_generator.ml
@@ -100,7 +100,7 @@ let makeJtype ?self ~names =
| Jkey kd -> Format.fprintf fmt "Json.key<'#%s'>" kd
| Jindex kd -> Format.fprintf fmt "Json.index<'#%s'>" kd
| Jdict js -> Format.fprintf fmt "@[<hov 2>Json.dict<@,%a>@]" pp js
- | Jdata id | Jenum id -> pp_ident fmt id
+ | 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
@@ -179,7 +179,7 @@ let rec makeDecoder ?self ~names fmt js =
| Jtag a -> Format.fprintf fmt "Json.jTag(\"%s\")" a
| Jkey kd -> jkey fmt kd
| Jindex kd -> jindex fmt kd
- | Jdata id -> jcall names fmt (Pkg.Derived.decode id)
+ | Jdata(id,_) -> jcall names fmt (Pkg.Derived.decode id)
| Jenum id -> jenum names fmt id
| Jself -> jcall names fmt (Pkg.Derived.decode (getSelf self))
| Joption js ->
@@ -216,7 +216,7 @@ let makeOrder ~self ~names fmt js =
| 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)
+ | Jdata(id,_) -> jcall names fmt (Pkg.Derived.order id)
| Joption js ->
Format.fprintf fmt "@[<hov 2>Compare.defined(@,%a)@]" pp js
| Jenum id ->
@@ -361,9 +361,8 @@ let makeDeclaration fmt names d =
self.name jtype js self.name;
- | D_array { arr_key ; arr_kind = jkey } ->
+ | D_array { arr_key ; arr_kind = jkey ; arr_rows = jrow } ->
let data = Pkg.Derived.data self in
- let jrow = Pkg.Jdata data in
Format.fprintf fmt
"@[<hv 2>const %s_internal: State.Array<@,%a,@,%a@,>@] = {@\n"
self.name jtype jkey jtype jrow ;
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index 5f66e9c0f2452e10ed0215681fe0d4d9f5d0c07f..1a9d84463181ec3eda6651d6f9108bd8bca9b867 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -70,11 +70,12 @@ let derived ~package ~id jtype =
declare ~package ~name:(Derived.order id).name
~descr:(Md.plain "Natural order for" @ Md.code id.name)
(D_order(id,jtype)) ;
+ Jdata(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
+ derived ~package ~id jtype
(* -------------------------------------------------------------------------- *)
(* --- Option --- *)
@@ -382,8 +383,7 @@ struct
let jtype =
let fields = List.rev s.fields in
let id = Package.declare_id ~package ~name ~descr (D_record fields) in
- derived ~package ~id (Jrecord (List.map Package.field fields)) ;
- Jdata id
+ derived ~package ~id (Jrecord (List.map Package.field fields))
let default = s.default
let has fd r = fd.member r
let get fd r = fd.getter r
@@ -552,7 +552,7 @@ struct
let jtype =
let enums = D_enum (List.rev d.tags) in
let id = Package.declare_id ~package ~name ~descr enums in
- derived ~package ~id (Jenum id) ; Jdata id
+ derived ~package ~id (Jenum id)
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 eeb25bca7e5f338c58678b50a7b43f8e98eb9495..b749b8409286620f1244fd1eb29580233d35c3c4 100644
--- a/src/plugins/server/data.mli
+++ b/src/plugins/server/data.mli
@@ -126,7 +126,7 @@ 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
+val derived : package:package -> id:ident -> jtype -> jtype
(**
Declare a new type and returns its alias.
diff --git a/src/plugins/server/package.ml b/src/plugins/server/package.ml
index 7124b65a0f2a773033ce2721ab7c3d37fe62503d..a9031f4bd28104e5e60a22a7ea737503aa596d15 100644
--- a/src/plugins/server/package.ml
+++ b/src/plugins/server/package.ml
@@ -175,8 +175,8 @@ type jtype =
| Jtuple of jtype list
| Junion of jtype list
| Jrecord of (string * jtype) list
- | Jdata of ident
| Jenum of ident (* enum type declaration *)
+ | Jdata of ident * jtype (* underlying definition *)
| Jself (* for (simply) recursive types *)
(* -------------------------------------------------------------------------- *)
@@ -209,6 +209,7 @@ type requestInfo = {
type arrayInfo = {
arr_key: string;
arr_kind: jtype;
+ arr_rows: jtype;
}
type declKindInfo =
@@ -298,7 +299,7 @@ let rec visit_jtype fn = function
| Joption js | Jdict js | Jarray 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 | Jenum id ->
+ | Jdata(id,_) | Jenum id ->
begin
fn id ;
fn (Derived.decode id) ;
@@ -461,7 +462,7 @@ let rec md_jtype pp = function
| Jtag a -> litteral a
| Jkey kd -> key kd
| Jindex kd -> index kd
- | Jdata id | Jenum 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
diff --git a/src/plugins/server/package.mli b/src/plugins/server/package.mli
index a9ec8918b5b661c9bfe7b6a7c2570d277f28140a..8a120b5af1072b4e894de2aaade4a210dd0af6e6 100644
--- a/src/plugins/server/package.mli
+++ b/src/plugins/server/package.mli
@@ -33,19 +33,19 @@ type jtype =
| Jboolean
| 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 *)
+ | 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
- | Jdict of jtype (** dictionaries *)
- | Jarray of jtype (** order matters *)
+ | Jdict of jtype (* dictionaries *)
+ | 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 *)
+ | Jenum of ident (* enum type declaration *)
+ | Jdata of ident * jtype (* underlying definition *)
+ | Jself (* for (simply) recursive types *)
type fieldInfo = {
fd_name: string;
@@ -73,6 +73,7 @@ type requestInfo = {
type arrayInfo = {
arr_key: string;
arr_kind: jtype;
+ arr_rows: jtype;
}
type declKindInfo =
diff --git a/src/plugins/server/states.ml b/src/plugins/server/states.ml
index 18bbe9a2ee0235563205720e7988aecb66916204..005896b6ed5f566bf0189fb0b60a27e0408f9e7d 100644
--- a/src/plugins/server/states.ml
+++ b/src/plugins/server/states.ml
@@ -292,6 +292,7 @@ let fetch array n =
let rec is_keyType = function
| Package.Junion js -> List.for_all is_keyType js
| Jstring | Jalpha | Jkey _ | Jtag _ -> true
+ | Jdata(_,def) -> is_keyType def
| _ -> false
let register_array ~package ~name ~descr ~key
@@ -313,7 +314,8 @@ let register_array ~package ~name ~descr ~key
));
if not (is_keyType keyType) then
raise (Invalid_argument (
- Printf.sprintf "States.array(%S): invalid key type" name
+ Format.asprintf "States.array(%S): invalid key type (%a)"
+ name Package.pp_jtype keyType
));
end ;
let fields = Package.{
@@ -321,8 +323,9 @@ let register_array ~package ~name ~descr ~key
fd_type = keyType ;
fd_descr = plain "Entry identifier." ;
} :: List.map fst columns in
- let id = Package.declare_id ~package:package ~name:name ~descr
- (D_array { arr_key = keyName ; arr_kind = keyType }) in
+ let id = Package.declare_id ~package ~name ~descr
+ (D_array { arr_key = keyName ; arr_kind = keyType ; arr_rows = Jany })
+ in
let signal = Request.signal
~package ~name:(Package.Derived.signal id).name
~descr:(plain "Signal for array" @ href) in
@@ -330,8 +333,10 @@ let register_array ~package ~name ~descr ~key
~package ~name:(Package.Derived.data id).name
~descr:(plain "Data for array rows" @ href)
(D_record fields) in
- let fs = List.map Package.field fields in
- Data.derived ~package ~id:row (Jrecord fs) ;
+ let jrow = Data.derived ~package ~id:row
+ (Jrecord (List.map Package.field fields)) in
+ Package.update ~package ~name
+ (D_array { arr_key = keyName ; arr_kind = keyType ; arr_rows = jrow }) ;
let getter =
List.map Package.(fun (fd,to_js) -> fd.fd_name , to_js) !model in
let array = {
@@ -345,7 +350,7 @@ let register_array ~package ~name ~descr ~key
end) in
let module Jrows = Jlist (struct
include Jany
- let jtype = Package.Jdata row
+ let jtype = jrow
end) in
let set_reload = Request.result signature
~name:"reload" ~descr:(plain "array fully reloaded")