[server] arrays

src/plugins/server/package.ml

@@ -197,6 +197,9 @@ type requestInfo = {
 
 type declKindInfo =
   | D_signal
+  | D_value
+  | D_state
+  | D_array
   | D_type of jtype
   | D_enum of tagInfo list
   | D_record of fieldInfo list
@@ -247,8 +250,7 @@ let visit_request f { rq_input ; rq_output } =
   ( visit_param f rq_input ; visit_param f rq_output )
 
 let visit_dkind f = function
-  | D_signal -> ()
-  | D_enum _ -> ()
+  | D_signal | D_state | D_value | D_array | D_enum _ -> ()
   | D_type js -> visit_jtype f js
   | D_record fds -> List.iter (visit_field f) fds
   | D_request rq -> visit_request f rq

src/plugins/server/package.mli

@@ -70,6 +70,9 @@ type requestInfo = {
 
 type declKindInfo =
   | D_signal
+  | D_value
+  | D_state
+  | D_array
   | D_type of jtype
   | D_enum of tagInfo list
   | D_record of fieldInfo list

src/plugins/server/server_doc.ml

@@ -133,6 +133,8 @@ let page_of_package pkg =
 
 let kind_of_decl = function
   | D_signal -> "SIGNAL"
+  | D_value | D_state -> "STATE"
+  | D_array -> "ARRAY"
   | D_type _ | D_record _ | D_enum _ -> "DATA"
   | D_request { rq_kind=`GET } -> "GET"
   | D_request { rq_kind=`SET } -> "SET"
@@ -159,6 +161,9 @@ let md_named ~kind pp = function
 let descr_of_decl names decl =
   match decl.d_kind with
   | D_signal -> []
+  | D_state -> [] (* TBC *)
+  | D_value -> [] (* TBC *)
+  | D_array -> [] (* TBC *)
   | D_type data ->
     let pp = pp_for ~decl names in
     Md.quote (pp.self @ Md.code "::=" @ Package.md_jtype pp data)

src/plugins/server/states.ml

@@ -43,20 +43,22 @@ let install_emit signal add_hook =
 (* --- Values                                                             --- *)
 (* -------------------------------------------------------------------------- *)
 
-let register_value (type a) ~page ~name ~descr ?(details=[])
+let register_value (type a) ~package ~name ~descr
     ~(output : a Request.output) ~get
     ?(add_hook : unit callback option) ()
   =
   let open Markdown in
-  let title =  Printf.sprintf "`VALUE` %s" name in
-  let index = [ Printf.sprintf "%s (`VALUE`)" name ] in
-  let contents = [ Block [Text descr] ; Block details] in
-  let h = Server_doc.publish ~page ~name ~title ~index ~contents () in
-  let signal = Request.signal ~page ~name:(name ^ ".sig")
-      ~descr:(plain "Signal for value " @ href h) () in
-  Request.register ~page ~kind:`GET ~name:(name ^ ".get")
-    ~descr:(plain "Getter for value " @ href h)
-    ~input:(module Junit) ~output get ;
+  let href = link ~name () in
+  let descr = Markdown.par descr in
+  let () = Package.declare
+      ~package ~name ~descr D_value in
+  let signal = Request.signal
+      ~package ~name:(name ^ "Sig")
+      ~descr:(plain "Signal for state" @ href) in
+  let () = Request.register
+      ~package ~name:(name ^ "Get")
+      ~descr:(plain "Getter for state" @ href)
+      ~kind:`GET ~input:(module Junit) ~output get in
   install_emit signal add_hook ;
   signal
 
@@ -64,22 +66,26 @@ let register_value (type a) ~page ~name ~descr ?(details=[])
 (* --- States                                                             --- *)
 (* -------------------------------------------------------------------------- *)
 
-let register_state (type a) ~page ~name ~descr ?(details=[])
+let register_state (type a) ~package ~name ~descr
     ~(data : a data) ~get ~set
     ?(add_hook : unit callback option) () =
   let open Markdown in
-  let title =  Printf.sprintf "`STATE` %s" name in
-  let index = [ Printf.sprintf "%s (`STATE`)" name ] in
-  let contents = [ Block [Text descr] ; Block details] in
-  let h = Server_doc.publish ~page ~name ~title ~index ~contents () in
-  let signal = Request.signal ~page ~name:(name ^ ".sig")
-      ~descr:(plain "Signal for state " @ href h) () in
-  Request.register ~page ~kind:`GET ~name:(name ^ ".get")
-    ~descr:(plain "Getter for state " @ href h)
-    ~input:(module Junit) ~output:(module (val data)) get ;
-  Request.register ~page ~kind:`SET ~name:(name ^ ".set")
-    ~descr:(plain "Setter for state " @ href h)
-    ~input:(module (val data)) ~output:(module Junit) set ;
+  let module D = (val data) in
+  let href = link ~name () in
+  let descr = Markdown.par descr in
+  let () = Package.declare
+      ~package ~name ~descr D_state in
+  let signal = Request.signal
+      ~package ~name:(name ^ "Sig")
+      ~descr:(plain "Signal for state" @ href) in
+  let () = Request.register
+      ~package ~name:(name ^ "Get")
+      ~descr:(plain "Getter for state" @ href)
+      ~kind:`GET ~input:(module Junit) ~output:(module D) get in
+  let () = Request.register
+      ~package ~name:(name ^ "Set")
+      ~descr:(plain "Setter for state" @ href)
+      ~kind:`SET ~input:(module D) ~output:(module Junit) set in
   install_emit signal add_hook ;
   signal
 
@@ -87,22 +93,22 @@ let register_state (type a) ~page ~name ~descr ?(details=[])
 (* --- Model Signature                                                    --- *)
 (* -------------------------------------------------------------------------- *)
 
-type 'a column = Syntax.field * ('a -> json)
+type 'a column = Package.fieldInfo * ('a -> json)
 
 type 'a model = 'a column list ref
 
 let model () = ref []
 
-let column (type a b) ~(model : a model) ~name ~descr
-    ~(data: b Request.output) ~(get : a -> b) () =
+let column (type a b) ~name ~descr
+    ~(data: b Request.output) ~(get : a -> b) (model : a model) =
   let module D = (val data) in
   if name = "key" || name = "index" then
     raise (Invalid_argument "Server.States.column: invalid name") ;
-  if List.exists (fun (fd,_) -> fd.Syntax.fd_name = name) !model then
+  if List.exists (fun (fd,_) -> fd.Package.fd_name = name) !model then
     raise (Invalid_argument "Server.States.column: duplicate name") ;
-  let fd = Syntax.{
+  let fd = Package.{
       fd_name = name ;
-      fd_syntax = D.syntax ;
+      fd_type = D.jtype ;
       fd_descr = descr ;
     } in
   model := (fd , fun a -> D.to_json (get a)) :: !model
@@ -255,65 +261,61 @@ let fetch array n =
 (* --- Signature Registry                                                 --- *)
 (* -------------------------------------------------------------------------- *)
 
-let register_array ~page ~name ~descr ?(details=[]) ~key
+let register_array ~package ~name ~descr ~key
     ~(iter : 'a callback)
     ?(add_update_hook : 'a callback option)
     ?(add_remove_hook : 'a callback option)
     ?(add_reload_hook : unit callback option)
     model =
   let open Markdown in
-  let title =  Printf.sprintf "`ARRAY` %s" name in
-  let index = [ Printf.sprintf "%s (`ARRAY`)" name ] in
-  let columns = !model in
-  let contents = [
-    Block [Text descr] ;
-    Syntax.fields ~title:"Columns"
-      begin
-        Syntax.{
-          fd_name = "key" ;
-          fd_syntax = Syntax.ident ;
-          fd_descr = plain "entry identifier" ;
-        } :: List.rev (List.map fst columns)
-      end ;
-    Block details
-  ] in
-  let mref = Server_doc.publish ~page:page ~name:name ~title ~index ~contents () in
-  let signal = Request.signal ~page ~name:(name ^ ".sig")
-      ~descr:(plain "Signal for array " @ href mref) () in
-  let getter = List.map Syntax.(fun (fd,to_js) -> fd.fd_name , to_js) columns in
+  let href = link ~name () in
+  let descr = Markdown.par descr in
+  let columns = List.rev !model in
+  let fields = Package.{
+      fd_name = "key" ;
+      fd_type = Jkey name ;
+      fd_descr = plain "Entry identifier." ;
+    } :: List.map fst columns in
+  let () = Package.declare ~package:package ~name:name ~descr D_array in
+  let signal = Request.signal
+      ~package ~name:(name ^ "Sig")
+      ~descr:(plain "Signal for array" @ href) in
+  let row = Package.declare_id
+      ~package ~name:(name ^ "Row")
+      ~descr:(par (plain "Data rows for array" @ href))
+      (D_record fields) in
+  let getter =
+    List.map Package.(fun (fd,to_js) -> fd.fd_name , to_js) columns in
   let array = {
     key ; iter ; getter ; signal ;
     current = None ; projects = Hashtbl.create 0
   } in
-  let signature =
-    Request.signature ~kind:`GET ~page ~name:(name ^ ".fetch")
-      ~descr:(plain "Fetch updates for array " @ href mref)
-      ~input:(module Jint)
-      ~details:[
-        Text(plain
-               "Collect all entry updates since the last fetch.\n\
-                The number of fetched entries is limited to the\n\
-                provided integer. When `reload:true` is returned,\n\
-                _all_ previously received entries must be removed.")]
-      () in
-  let module Jentries =
-    (struct
-      include Jany
-      let syntax = Syntax.data "entry" mref
-    end) in
+  let signature = Request.signature () in
+  let module Jkeys = Jlist(struct
+    include Jstring
+    let jtype = Package.Jkey name
+  end) in
+  let module Jrows = Jlist (struct
+    include Jany
+    let jtype = Package.Jdata row
+  end) in
   let set_reload = Request.result signature
       ~name:"reload" ~descr:(plain "array fully reloaded")
       (module Jbool) in
   let set_removed = Request.result signature
       ~name:"removed" ~descr:(plain "removed entries")
-      (module Jident.Jlist) in
+      (module Jkeys) in
   let set_updated = Request.result signature
       ~name:"updated" ~descr:(plain "updated entries")
-      (module Jlist(Jentries)) in
+      (module Jrows) in
   let set_pending = Request.result signature
       ~name:"pending" ~descr:(plain "remaining entries to be fetched")
       (module Jint) in
-  Request.register_sig signature
+  Request.register_sig
+    ~package ~name:(name ^ "Fetch")
+    ~descr:(plain "Data fetcher for array" @ href)
+    ~kind:`GET
+    signature
     begin fun rq n ->
       let buffer = fetch array n in
       set_reload rq buffer.reload ;
@@ -321,8 +323,9 @@ let register_array ~page ~name ~descr ?(details=[]) ~key
       set_updated rq buffer.updated ;
       set_pending rq buffer.pending ;
     end ;
-  Request.register ~kind:`GET ~page ~name:(name ^ ".reload")
-    ~descr:(plain "Force full reload for array " @ href mref)
+  Request.register
+    ~package ~name:(name ^ "Reload") ~kind:`GET
+    ~descr:(plain "Force full reload for array" @ href)
     ~input:(module Junit) ~output:(module Junit)
     (fun () -> reload array) ;
   synchronize array ;

src/plugins/server/states.mli

@@ -22,6 +22,8 @@
 
 (** Synchronized values between Server and Client *)
 
+open Package
+
 type 'a callback = ('a -> unit) -> unit
 
 (** Register a (projectified) value and generates the associated signal and
@@ -37,10 +39,9 @@ type 'a callback = ('a -> unit) -> unit
     synchronize with this value.
 *)
 val register_value :
-  page:Server_doc.page ->
+  package:package ->
   name:string ->
   descr:Markdown.text ->
-  ?details:Markdown.block ->
   output:'a Request.output ->
   get:(unit -> 'a) ->
   ?add_hook:(unit callback) ->
@@ -60,10 +61,9 @@ val register_value :
     synchronize with this state.
 *)
 val register_state :
-  page:Server_doc.page ->
+  package:package ->
   name:string ->
   descr:Markdown.text ->
-  ?details:Markdown.block ->
   data:'a Data.data ->
   get:(unit -> 'a) ->
   set:('a -> unit) ->
@@ -78,12 +78,11 @@ val model : unit -> 'a model
 (** Populate an array model with a new field.
     Columns with name `"id"` and `"_index"` are reserved for internal use. *)
 val column :
-  model:'a model ->
   name:string ->
   descr:Markdown.text ->
   data:('b Request.output) ->
   get:('a -> 'b) ->
-  unit -> unit
+  'a model -> unit
 
 (** Synchronized array state. *)
 type 'a array
@@ -121,10 +120,9 @@ val signal : 'a array -> Request.signal
     [States.useSyncArray()] hook.
 *)
 val register_array :
-  page:Server_doc.page ->
+  package:package ->
   name:string ->
   descr:Markdown.text ->
-  ?details:Markdown.block ->
   key:('a -> string) ->
   iter:('a callback) ->
   ?add_update_hook:('a callback) ->