diff --git a/src/libraries/utils/markdown.ml b/src/libraries/utils/markdown.ml
index 85c3f96613984bb9792d4169d4ec7fd1712af5c0..2d00ab2478c0c64ecef50ab213d88865edd1708a 100644
--- a/src/libraries/utils/markdown.ml
+++ b/src/libraries/utils/markdown.ml
@@ -61,7 +61,6 @@ and element =
| Raw of string list
(** Each element of the list is printed as-is on its own line.
A blank line separates the [Raw] node from the next one. *)
- | Delayed of (unit -> elements)
| H1 of text * string option
| H2 of text * string option
| H3 of text * string option
@@ -84,10 +83,10 @@ let glue ?sep ls =
| _ , [] -> []
| _ , [l] -> l
| Some s , ls -> (* tailrec *)
- let rec aux w s = function
+ let rec aux sep w = function
| [] -> List.rev w
| [e] -> List.rev_append w e
- | e::el -> aux s (List.rev_append s (List.rev_append e w)) el
+ | e::el -> aux sep (List.rev_append sep (List.rev_append e w)) el
in aux s [] ls
(* -------------------------------------------------------------------------- *)
@@ -139,7 +138,6 @@ let description items = [DL items]
let par text = [Block [Text text]]
let block b = [Block b]
-let delayed f = [Delayed f]
(* -------------------------------------------------------------------------- *)
(* --- Sectioning --- *)
@@ -419,7 +417,6 @@ and pp_element ?page fmt e =
"@[<hv>@[<hov 5><!-- %a@]@ -->@]" Format.pp_print_text s
| Table table -> pp_table_inlined ?page fmt table
(* pp_table_extended ?page fmt table *)
- | Delayed f -> pp_elements ?page fmt (f ())
| H1(t,lab) -> Format.fprintf fmt "@[<h># %a%a@]" pp_text t pp_lab lab
| H2(t,lab) -> Format.fprintf fmt "@[<h>## %a%a@]" pp_text t pp_lab lab
| H3(t,lab) -> Format.fprintf fmt "@[<h>### %a%a@]" pp_text t pp_lab lab
diff --git a/src/libraries/utils/markdown.mli b/src/libraries/utils/markdown.mli
index 6cc566b6c573d66cb457d36baae19a85dcc1416e..79f35f876fbe3662e366dede54295bfcbd883bf3 100644
--- a/src/libraries/utils/markdown.mli
+++ b/src/libraries/utils/markdown.mli
@@ -76,7 +76,6 @@ and element =
| Raw of string list
(** Each element of the list is printed as-is on its own line.
A blank line separates the [Raw] node from the next one. *)
- | Delayed of (unit -> elements)
| H1 of text * string option
| H2 of text * string option
| H3 of text * string option
@@ -170,9 +169,6 @@ val block : block -> elements
*)
val rawfile: string -> elements
-(** Delayed element. The content is computed on pretty-printing. *)
-val delayed: (unit -> elements) -> elements
-
(** {2 Document Structure} *)
(** Creates a document from a list of elements and optional metadatas.
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index 3731b58b8eb4dca606fbb26672de6755e2758204..961a30ae148b87dd286ddc6cb2f2672f622f4ba3 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -234,41 +234,66 @@ end
module Fmap = Map.Make(String)
-module Record( R : Info ) =
+type 'a record = json Fmap.t
+
+type ('r,'a) field = {
+ member : 'r record -> bool ;
+ getter : 'r record -> 'a ;
+ setter : 'r record -> 'a -> 'r record ;
+}
+
+type 'a signature = {
+ page : Doc.page ;
+ name : string ;
+ descr : Markdown.text ;
+ mutable fields : Syntax.field list ;
+ mutable default : 'a record ;
+ mutable published : bool ;
+}
+
+module Record =
struct
- type t = json Fmap.t
-
- type 'a field = {
- member : t -> bool ;
- getter : t -> 'a ;
- setter : t -> 'a -> t ;
+ module type S =
+ sig
+ type r
+ include S with type t = r record
+ val default : t
+ val has : (r,'a) field -> t -> bool
+ val get : (r,'a) field -> t -> 'a
+ val set : (r,'a) field -> 'a -> t -> t
+ end
+
+ let signature ~page ~name ~descr () = {
+ page ; name ; descr ;
+ published = false ;
+ fields = [] ;
+ default = Fmap.empty ;
}
- (* Declared Fields in this Record *)
- let fdocs = ref []
- let defaults = ref Fmap.empty
-
- let default () = !defaults
- let has fd r = fd.member r
- let get fd r = fd.getter r
- let set fd v r = fd.setter r v
-
- let field (type a) name ~descr ?default (d : a data) : a field =
+ let field (type a r) (s : r signature)
+ ~name ~descr ?default (d : a data) : (r,a) field =
+ if s.published then
+ raise (Invalid_argument "Server.Data.Record.field") ;
let module D = (val d) in
begin match default with
| None -> ()
- | Some v -> defaults := Fmap.add name (D.to_json v) !defaults
+ | Some v -> s.default <- Fmap.add name (D.to_json v) s.default
end ;
- fdocs := Syntax.{ name ; syntax = D.syntax ; descr } :: !fdocs ;
+ let field = Syntax.{ name ; syntax = D.syntax ; descr } in
+ s.fields <- field :: s.fields ;
let member r = Fmap.mem name r in
let getter r = D.of_json (Fmap.find name r) in
let setter r v = Fmap.add name (D.to_json v) r in
{ member ; getter ; setter }
- let option (type a) name ~descr (d : a data) : a option field =
+ let option (type a r) (s : r signature)
+ ~name ~descr (d : a data) : (r,a option) field =
+ if s.published then
+ raise (Invalid_argument "Server.Data.Record.option") ;
let module D = (val d) in
- fdocs := Syntax.{ name ; syntax = option D.syntax ; descr } :: !fdocs ;
+ let field = Syntax.{ name ; syntax = option D.syntax ; descr } in
+ s.fields <- field :: s.fields ;
let member r = Fmap.mem name r in
let getter r =
try Some (D.of_json (Fmap.find name r)) with Not_found -> None in
@@ -277,21 +302,36 @@ struct
| Some v -> Fmap.add name (D.to_json v) r in
{ member ; getter ; setter }
- let fields () = [Syntax.fields ~title:"Field" !fdocs]
-
- let syntax =
- Syntax.publish ~page:R.page ~name:R.name
- ~descr:R.descr
- ~synopsis:(Syntax.record [])
- ~details:(Markdown.delayed fields) ()
-
- let of_json js =
- List.fold_left
- (fun r (fd,js) -> Fmap.add fd js r)
- (default ()) (Ju.to_assoc js)
-
- let to_json r : json =
- `Assoc (Fmap.fold (fun fd js fds -> (fd,js) :: fds) r [])
+ let publish (type r) (s : r signature) =
+ if s.published then
+ raise (Invalid_argument "Server.Data.Record.publish") ;
+ let module M =
+ struct
+ type nonrec r = r
+ type t = r record
+ let descr = s.descr
+ let syntax =
+ let fields = Syntax.fields ~title:"Field" (List.rev s.fields) in
+ Syntax.publish ~page:s.page ~name:s.name ~descr
+ ~synopsis:(Syntax.record [])
+ ~details:[fields] ()
+ let default = s.default
+ let has fd r = fd.member r
+ let get fd r = fd.getter r
+ let set fd v r = fd.setter r v
+ let of_json js =
+ List.fold_left
+ (fun r (fd,js) -> Fmap.add fd js r)
+ default (Ju.to_assoc js)
+ let to_json r : json =
+ `Assoc (Fmap.fold (fun fd js fds -> (fd,js) :: fds) r [])
+ end in
+ begin
+ s.default <- Fmap.empty ;
+ s.fields <- [] ;
+ s.published <- true ;
+ (module M : S with type r = r)
+ end
end
diff --git a/src/plugins/server/data.mli b/src/plugins/server/data.mli
index 3e10ece5cbfb35d8753129d85d094c118919bab0..52ab09382893efb8fa7d8c3907197bd9affc707f 100644
--- a/src/plugins/server/data.mli
+++ b/src/plugins/server/data.mli
@@ -94,33 +94,62 @@ module Jtext : S with type t = json (** Rich text encoding, see [Jbuffer] *)
(** {2 Records} *)
(* -------------------------------------------------------------------------- *)
-module Record(R : Info) :
+type 'a record (** Records of type 'a *)
+type 'a signature (** Opened signature for record of type ['a] *)
+type ('a,'b) field (** Field of type ['b] for a record of type ['a] *)
+
+(** Record factory.
+
+ You shall start by declaring a (ghost) type [r] and call
+ [Record.signature] to create a signature of type [r].
+ Then, populate the record with [Record.field] or [Record.option].
+ Finally, you shall call [Record.publish] to obtain a new data module
+ of type [Record with type r = r], which gives you a [Data] with an opaque
+ type [t = r record] with fields of type [(r,a) field].
+
+ {[
+ (* ---- Exemple of Record Data --- *)
+ type r
+ let s = Record.signature ~page ~kind ~name ~descr () in
+ let fd_a = Record.field s ~name:"a" ~descr:"..." (module A) in
+ let fd_b = Record.field s ~name:"b" ~descr:"..." (module B) in
+
+ module M = (val (Record.publish s) : Record with type r = r)
+
+ let make a b = M.default |> M.set fd_a a |> M.set fd_b b
+ ]}
+*)
+module Record :
sig
- (** A new type [t] is created for each application of the functor. *)
- include S
-
- (** Parametric field. Can only be used with type [t]. *)
- type 'a field
-
- (** Field constructor *)
- val field : string -> descr:Markdown.text -> ?default:'a -> 'a data -> 'a field
-
- (** Optional field constructor *)
- val option : string -> descr:Markdown.text -> 'a data -> 'a option field
-
- (** Field presence. If the field has a default value, it will be always
- present. *)
- val has : 'a field -> t -> bool
-
- (** Field accessor.
- @raise Not_found if the field is optional and not present *)
- val get : 'a field -> t -> 'a
-
- (** Field updator. *)
- val set : 'a field -> 'a -> t -> t
- (** Contains only the default values. *)
- val default : unit -> t
+ (** Data with [type t = r record].
+ Also contains getters and setters for fields. *)
+ module type S =
+ sig
+ type r
+ include S with type t = r record
+ val default : t
+ val has : (r,'a) field -> t -> bool
+ val get : (r,'a) field -> t -> 'a
+ val set : (r,'a) field -> 'a -> t -> t
+ end
+
+ (** Create a new, opened record type *)
+ val signature : page:Doc.page -> name:string -> descr:Markdown.text ->
+ unit -> 'a signature
+
+ (** Adds a field to an opened record *)
+ val field : 'r signature ->
+ name:string -> descr:Markdown.text -> ?default:'a -> 'a data ->
+ ('r,'a) field
+
+ (** Adds a optional field to an opened record *)
+ val option : 'r signature ->
+ name:string -> descr:Markdown.text -> 'a data ->
+ ('r,'a option) field
+
+ (** Publish and close an opened record *)
+ val publish : 'a signature -> (module S with type r = 'a)
end
diff --git a/src/plugins/server/kernel_main.ml b/src/plugins/server/kernel_main.ml
index 9c18bde3e567481bb4d896806af56e5654d57781..49e11148a95a714eb77d28b4a947e56774c34fca 100644
--- a/src/plugins/server/kernel_main.ml
+++ b/src/plugins/server/kernel_main.ml
@@ -63,6 +63,7 @@ let () =
module RawSource =
struct
type t = Filepath.position
+
let syntax = Sy.publish ~page ~name:"source"
~synopsis:(Sy.record [ "file" , Sy.string ; "line" , Sy.int ])
~descr:(Md.plain "Source file positions.")
@@ -114,31 +115,29 @@ module LogKind = Dictionary(RawKind)
module RawEvent =
struct
- module R = Record
- (struct
- let page = page
- let name = "log"
- let descr = Md.plain "Message event record."
- end)
-
- let syntax = R.syntax
+ type rlog
- let kind = R.field "kind" ~descr:(Md.plain "Message kind") (module LogKind)
- let plugin = R.field "plugin" ~descr:(Md.plain "Emitter plugin") (module Jstring)
- let message = R.field "message" ~descr:(Md.plain "Message text") (module Jstring)
+ let jlog : rlog signature = Record.signature ~page
+ ~name:"log" ~descr:(Md.plain "Message event record.") ()
- let category = R.option "category"
- ~descr:(Md.plain "Message category (DEBUG or WARNING)")
- (module Jstring)
+ let kind = Record.field jlog ~name:"kind"
+ ~descr:(Md.plain "Message kind") (module LogKind)
+ let plugin = Record.field jlog ~name:"plugin"
+ ~descr:(Md.plain "Emitter plugin") (module Jstring)
+ let message = Record.field jlog ~name:"message"
+ ~descr:(Md.plain "Message text") (module Jstring)
+ let category = Record.option jlog ~name:"category"
+ ~descr:(Md.plain "Message category (DEBUG or WARNING)") (module Jstring)
+ let source = Record.option jlog ~name:"source"
+ ~descr:(Md.plain "Source file position") (module LogSource)
- let source = R.option "source"
- ~descr:(Md.plain "Source file position")
- (module LogSource)
+ module R = (val (Record.publish jlog) : Record.S with type r = rlog)
type t = Log.event
+ let syntax = R.syntax
let to_json evt =
- R.default () |>
+ R.default |>
R.set plugin evt.Log.evt_plugin |>
R.set kind evt.Log.evt_kind |>
R.set category evt.Log.evt_category |>