diff --git a/src/plugins/server/package.ml b/src/plugins/server/package.ml
index 459737e998e1dc2e09c6391c6056105d1ea99e2a..db8e80d96647bf0c51b1a345871ef2a1a9640768 100644
--- a/src/plugins/server/package.ml
+++ b/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
diff --git a/src/plugins/server/package.mli b/src/plugins/server/package.mli
index 9fc18b1444370619f06d48d89e3f274f79cb1eff..b9b5a1bef1b271d381acc452f86f345ff122c649 100644
--- a/src/plugins/server/package.mli
+++ b/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
diff --git a/src/plugins/server/server_doc.ml b/src/plugins/server/server_doc.ml
index 05ea79e1d700ab684a1758d56da295dc5b0f2195..e0dd63f4d70f3fb9ab15ccb932e772313ba03ec1 100644
--- a/src/plugins/server/server_doc.ml
+++ b/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)
diff --git a/src/plugins/server/states.ml b/src/plugins/server/states.ml
index 8b5c990250da67b5dad22b44d381c497e69605b2..3e6a9157ef3f23986e926311e01ce59f47808c1d 100644
--- a/src/plugins/server/states.ml
+++ b/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 ;
diff --git a/src/plugins/server/states.mli b/src/plugins/server/states.mli
index 96ff7efa021890b2acc684e5947eae021c880505..d7c6a067eb7e22c001e1b6809b73eb39ec5fcfdf 100644
--- a/src/plugins/server/states.mli
+++ b/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) ->