[server] Jdata with definition

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 ;

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

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.

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

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 =

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")