mirror of
https://github.com/c-cube/tiny_httpd.git
synced 2025-12-06 11:15:35 -05:00
add html sub-library
This commit is contained in:
Simon Cruanes
parent
5f321774e1
commit
8e2cf23e27
4 changed files with 599 additions and 0 deletions
65
src/html/Tiny_httpd_html.ml
Normal file
65
src/html/Tiny_httpd_html.ml
Normal file
|
|
@ -0,0 +1,65 @@
|
||||||
|
(** HTML combinators.
|
||||||
|
|
||||||
|
This module provides combinators to produce html. It doesn't enforce
|
||||||
|
the well-formedness of the html, unlike Tyxml, but it's simple and should
|
||||||
|
be reasonably efficient.
|
||||||
|
@since 0.12
|
||||||
|
*)
|
||||||
|
|
||||||
|
module IO = Tiny_httpd_io
|
||||||
|
|
||||||
|
include Html_
|
||||||
|
(** @inline *)
|
||||||
|
|
||||||
|
(** Write an HTML element to this output.
|
||||||
|
@param top if true, add DOCTYPE at the beginning. The top element should then
|
||||||
|
be a "html" tag.
|
||||||
|
@since 0.14
|
||||||
|
*)
|
||||||
|
let to_output ?(top = false) (self : elt) (out : IO.Output.t) : unit =
|
||||||
|
let out = Out.create_of_out out in
|
||||||
|
if top then Out.add_string out "<!DOCTYPE html>\n";
|
||||||
|
self out;
|
||||||
|
Out.add_format_nl out;
|
||||||
|
Out.flush out
|
||||||
|
|
||||||
|
(** Convert a HTML element to a string.
|
||||||
|
@param top if true, add DOCTYPE at the beginning. The top element should then
|
||||||
|
be a "html" tag. *)
|
||||||
|
let to_string ?top (self : elt) : string =
|
||||||
|
let buf = Buffer.create 64 in
|
||||||
|
let out = IO.Output.of_buffer buf in
|
||||||
|
to_output ?top self out;
|
||||||
|
Buffer.contents buf
|
||||||
|
|
||||||
|
(** Convert a list of HTML elements to a string.
|
||||||
|
This is designed for fragments of HTML that are to be injected inside
|
||||||
|
a bigger context, as it's invalid to have multiple elements at the toplevel
|
||||||
|
of a HTML document. *)
|
||||||
|
let to_string_l (l : elt list) =
|
||||||
|
let buf = Buffer.create 64 in
|
||||||
|
let out = Out.create_of_buffer buf in
|
||||||
|
List.iter
|
||||||
|
(fun f ->
|
||||||
|
f out;
|
||||||
|
Out.add_format_nl out)
|
||||||
|
l;
|
||||||
|
Buffer.contents buf
|
||||||
|
|
||||||
|
let to_string_top = to_string ~top:true
|
||||||
|
|
||||||
|
(** Write a toplevel element to an output channel.
|
||||||
|
@since 0.14 *)
|
||||||
|
let to_out_channel_top = to_output ~top:true
|
||||||
|
|
||||||
|
(** Produce a streaming writer from this HTML element.
|
||||||
|
@param top if true, add a DOCTYPE. See {!to_out_channel}.
|
||||||
|
@since 0.14 *)
|
||||||
|
let to_writer ?top (self : elt) : IO.Writer.t =
|
||||||
|
let write oc = to_output ?top self oc in
|
||||||
|
IO.Writer.make ~write ()
|
||||||
|
|
||||||
|
(** Convert a HTML element to a stream. This might just convert
|
||||||
|
it to a string first, do not assume it to be more efficient. *)
|
||||||
|
let to_stream (self : elt) : Tiny_httpd_stream.t =
|
||||||
|
Tiny_httpd_stream.of_string @@ to_string self
|
||||||
15
src/html/dune
Normal file
15
src/html/dune
Normal file
|
|
@ -0,0 +1,15 @@
|
||||||
|
|
||||||
|
|
||||||
|
(library
|
||||||
|
(name tiny_httpd_html)
|
||||||
|
(public_name tiny_httpd.html)
|
||||||
|
(libraries seq tiny_httpd.html))
|
||||||
|
|
||||||
|
(rule
|
||||||
|
(targets html_.ml)
|
||||||
|
(deps
|
||||||
|
(:bin ./gen/gentags.exe))
|
||||||
|
(action
|
||||||
|
(with-stdout-to
|
||||||
|
%{targets}
|
||||||
|
(run %{bin}))))
|
||||||
2
src/html/gen/dune
Normal file
2
src/html/gen/dune
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
(executables
|
||||||
|
(names gentags))
|
||||||
517
src/html/gen/gentags.ml
Normal file
517
src/html/gen/gentags.ml
Normal file
|
|
@ -0,0 +1,517 @@
|
||||||
|
(* adapted from https://github.com/sindresorhus/html-tags (MIT licensed) *)
|
||||||
|
|
||||||
|
let pf = Printf.printf
|
||||||
|
let spf = Printf.sprintf
|
||||||
|
|
||||||
|
let void =
|
||||||
|
[
|
||||||
|
"area";
|
||||||
|
"base";
|
||||||
|
"br";
|
||||||
|
"col";
|
||||||
|
"embed";
|
||||||
|
"hr";
|
||||||
|
"img";
|
||||||
|
"input";
|
||||||
|
"link";
|
||||||
|
"menuitem";
|
||||||
|
"meta";
|
||||||
|
"param";
|
||||||
|
"source";
|
||||||
|
"track";
|
||||||
|
"wbr";
|
||||||
|
]
|
||||||
|
|
||||||
|
let normal =
|
||||||
|
[
|
||||||
|
"a";
|
||||||
|
"abbr";
|
||||||
|
"address";
|
||||||
|
"area";
|
||||||
|
"article";
|
||||||
|
"aside";
|
||||||
|
"audio";
|
||||||
|
"b";
|
||||||
|
"base";
|
||||||
|
"bdi";
|
||||||
|
"bdo";
|
||||||
|
"blockquote";
|
||||||
|
"body";
|
||||||
|
"br";
|
||||||
|
"button";
|
||||||
|
"canvas";
|
||||||
|
"caption";
|
||||||
|
"cite";
|
||||||
|
"code";
|
||||||
|
"col";
|
||||||
|
"colgroup";
|
||||||
|
"data";
|
||||||
|
"datalist";
|
||||||
|
"dd";
|
||||||
|
"del";
|
||||||
|
"details";
|
||||||
|
"dfn";
|
||||||
|
"dialog";
|
||||||
|
"div";
|
||||||
|
"dl";
|
||||||
|
"dt";
|
||||||
|
"em";
|
||||||
|
"embed";
|
||||||
|
"fieldset";
|
||||||
|
"figcaption";
|
||||||
|
"figure";
|
||||||
|
"footer";
|
||||||
|
"form";
|
||||||
|
"h1";
|
||||||
|
"h2";
|
||||||
|
"h3";
|
||||||
|
"h4";
|
||||||
|
"h5";
|
||||||
|
"h6";
|
||||||
|
"head";
|
||||||
|
"header";
|
||||||
|
"hgroup";
|
||||||
|
"hr";
|
||||||
|
"html";
|
||||||
|
"i";
|
||||||
|
"iframe";
|
||||||
|
"img";
|
||||||
|
"input";
|
||||||
|
"ins";
|
||||||
|
"kbd";
|
||||||
|
"label";
|
||||||
|
"legend";
|
||||||
|
"li";
|
||||||
|
"link";
|
||||||
|
"main";
|
||||||
|
"map";
|
||||||
|
"mark";
|
||||||
|
"math";
|
||||||
|
"menu";
|
||||||
|
"menuitem";
|
||||||
|
"meta";
|
||||||
|
"meter";
|
||||||
|
"nav";
|
||||||
|
"noscript";
|
||||||
|
"object";
|
||||||
|
"ol";
|
||||||
|
"optgroup";
|
||||||
|
"option";
|
||||||
|
"output";
|
||||||
|
"p";
|
||||||
|
"param";
|
||||||
|
"picture";
|
||||||
|
"pre";
|
||||||
|
"progress";
|
||||||
|
"q";
|
||||||
|
"rb";
|
||||||
|
"rp";
|
||||||
|
"rt";
|
||||||
|
"rtc";
|
||||||
|
"ruby";
|
||||||
|
"s";
|
||||||
|
"samp";
|
||||||
|
"script";
|
||||||
|
"section";
|
||||||
|
"select";
|
||||||
|
"slot";
|
||||||
|
"small";
|
||||||
|
"source";
|
||||||
|
"span";
|
||||||
|
"strong";
|
||||||
|
"style";
|
||||||
|
"sub";
|
||||||
|
"summary";
|
||||||
|
"sup";
|
||||||
|
"svg";
|
||||||
|
"table";
|
||||||
|
"tbody";
|
||||||
|
"td";
|
||||||
|
"template";
|
||||||
|
"textarea";
|
||||||
|
"tfoot";
|
||||||
|
"th";
|
||||||
|
"thead";
|
||||||
|
"time";
|
||||||
|
"title";
|
||||||
|
"tr";
|
||||||
|
"track";
|
||||||
|
"u";
|
||||||
|
"ul";
|
||||||
|
"var";
|
||||||
|
"video";
|
||||||
|
"wbr";
|
||||||
|
]
|
||||||
|
|> List.filter (fun s -> not (List.mem s void))
|
||||||
|
|
||||||
|
(* obtained via:
|
||||||
|
{[
|
||||||
|
l = Array(...document.querySelectorAll('div tbody td code a')).map(
|
||||||
|
x => x.firstChild.textContent);
|
||||||
|
JSON.stringify(l)
|
||||||
|
]}
|
||||||
|
on https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes
|
||||||
|
*)
|
||||||
|
let attrs =
|
||||||
|
[
|
||||||
|
"accept";
|
||||||
|
"accept-charset";
|
||||||
|
"accesskey";
|
||||||
|
"action";
|
||||||
|
"align";
|
||||||
|
"allow";
|
||||||
|
"alt";
|
||||||
|
"async";
|
||||||
|
"autocapitalize";
|
||||||
|
"autocomplete";
|
||||||
|
"autofocus";
|
||||||
|
"autoplay";
|
||||||
|
"buffered";
|
||||||
|
"capture";
|
||||||
|
"challenge";
|
||||||
|
"charset";
|
||||||
|
"checked";
|
||||||
|
"cite";
|
||||||
|
"class";
|
||||||
|
"code";
|
||||||
|
"codebase";
|
||||||
|
"cols";
|
||||||
|
"colspan";
|
||||||
|
"content";
|
||||||
|
"contenteditable";
|
||||||
|
"contextmenu";
|
||||||
|
"controls";
|
||||||
|
"coords";
|
||||||
|
"crossorigin";
|
||||||
|
"csp";
|
||||||
|
"data";
|
||||||
|
"data-*";
|
||||||
|
"datetime";
|
||||||
|
"decoding";
|
||||||
|
"default";
|
||||||
|
"defer";
|
||||||
|
"dir";
|
||||||
|
"dirname";
|
||||||
|
"disabled";
|
||||||
|
"download";
|
||||||
|
"draggable";
|
||||||
|
"enctype";
|
||||||
|
"enterkeyhint";
|
||||||
|
"for";
|
||||||
|
"form";
|
||||||
|
"formaction";
|
||||||
|
"formenctype";
|
||||||
|
"formmethod";
|
||||||
|
"formnovalidate";
|
||||||
|
"formtarget";
|
||||||
|
"headers";
|
||||||
|
"hidden";
|
||||||
|
"high";
|
||||||
|
"href";
|
||||||
|
"hreflang";
|
||||||
|
"http-equiv";
|
||||||
|
"icon";
|
||||||
|
"id";
|
||||||
|
"importance";
|
||||||
|
"integrity";
|
||||||
|
"ismap";
|
||||||
|
"itemprop";
|
||||||
|
"keytype";
|
||||||
|
"kind";
|
||||||
|
"label";
|
||||||
|
"lang";
|
||||||
|
"language";
|
||||||
|
"list";
|
||||||
|
"loop";
|
||||||
|
"low";
|
||||||
|
"manifest";
|
||||||
|
"max";
|
||||||
|
"maxlength";
|
||||||
|
"minlength";
|
||||||
|
"media";
|
||||||
|
"method";
|
||||||
|
"min";
|
||||||
|
"multiple";
|
||||||
|
"muted";
|
||||||
|
"name";
|
||||||
|
"novalidate";
|
||||||
|
"open";
|
||||||
|
"optimum";
|
||||||
|
"pattern";
|
||||||
|
"ping";
|
||||||
|
"placeholder";
|
||||||
|
"poster";
|
||||||
|
"preload";
|
||||||
|
"radiogroup";
|
||||||
|
"readonly";
|
||||||
|
"referrerpolicy";
|
||||||
|
"rel";
|
||||||
|
"required";
|
||||||
|
"reversed";
|
||||||
|
"rows";
|
||||||
|
"rowspan";
|
||||||
|
"sandbox";
|
||||||
|
"scope";
|
||||||
|
"scoped";
|
||||||
|
"selected";
|
||||||
|
"shape";
|
||||||
|
"size";
|
||||||
|
"sizes";
|
||||||
|
"slot";
|
||||||
|
"span";
|
||||||
|
"spellcheck";
|
||||||
|
"src";
|
||||||
|
"srcdoc";
|
||||||
|
"srclang";
|
||||||
|
"srcset";
|
||||||
|
"start";
|
||||||
|
"step";
|
||||||
|
"style";
|
||||||
|
"summary";
|
||||||
|
"tabindex";
|
||||||
|
"target";
|
||||||
|
"title";
|
||||||
|
"translate";
|
||||||
|
"Text";
|
||||||
|
"type";
|
||||||
|
"usemap";
|
||||||
|
"value";
|
||||||
|
"width";
|
||||||
|
"wrap";
|
||||||
|
]
|
||||||
|
|
||||||
|
let prelude =
|
||||||
|
{|
|
||||||
|
(** Output for HTML combinators.
|
||||||
|
|
||||||
|
This output type is used to produce a string reasonably efficiently from
|
||||||
|
a tree of combinators.
|
||||||
|
|
||||||
|
{b NOTE}: this is experimental and an unstable API.
|
||||||
|
|
||||||
|
@since 0.12
|
||||||
|
@open *)
|
||||||
|
module Out : sig
|
||||||
|
type t
|
||||||
|
val create_of_buffer : Buffer.t -> t
|
||||||
|
val create_of_out: Tiny_httpd_io.Output.t -> t
|
||||||
|
val flush : t -> unit
|
||||||
|
val add_char : t -> char -> unit
|
||||||
|
val add_string : t -> string -> unit
|
||||||
|
val add_format_nl : t -> unit
|
||||||
|
val with_no_format_nl : t -> (unit -> 'a) -> 'a
|
||||||
|
end = struct
|
||||||
|
module IO = Tiny_httpd_io
|
||||||
|
type t = {
|
||||||
|
out: IO.Output.t;
|
||||||
|
mutable fmt_nl: bool; (* if true, we print [\n] around tags to format the html *)
|
||||||
|
}
|
||||||
|
let create_of_out out = {out; fmt_nl=true}
|
||||||
|
let create_of_buffer buf : t = create_of_out (IO.Output.of_buffer buf)
|
||||||
|
let[@inline] flush self : unit = IO.Output.flush self.out
|
||||||
|
let[@inline] add_char self c = IO.Output.output_char self.out c
|
||||||
|
let[@inline] add_string self s = IO.Output.output_string self.out s
|
||||||
|
let[@inline] add_format_nl self = if self.fmt_nl then add_char self '\n'
|
||||||
|
let with_no_format_nl self f =
|
||||||
|
if self.fmt_nl then (
|
||||||
|
self.fmt_nl <- false;
|
||||||
|
try let x=f() in self.fmt_nl <- true; x with e -> self.fmt_nl <- true; raise e
|
||||||
|
) else f()
|
||||||
|
end
|
||||||
|
|
||||||
|
type attribute = string * string
|
||||||
|
(** An attribute, i.e. a key/value pair *)
|
||||||
|
|
||||||
|
type elt = Out.t -> unit
|
||||||
|
(** A html element. It is represented by its output function, so we
|
||||||
|
can directly print it. *)
|
||||||
|
|
||||||
|
type void = ?if_:bool -> attribute list -> elt
|
||||||
|
(** Element without children. *)
|
||||||
|
|
||||||
|
type nary = ?if_:bool -> attribute list -> elt list -> elt
|
||||||
|
(** Element with children, represented as a list.
|
||||||
|
@param if_ if false, do not print anything (default true) *)
|
||||||
|
|
||||||
|
(** A chunk of sub-elements, possibly empty.
|
||||||
|
@inline *)
|
||||||
|
type sub_elt = [ `E of elt | `L of elt list | `S of elt Seq.t | `Nil]
|
||||||
|
|
||||||
|
type nary' = ?if_:bool -> attribute list -> sub_elt list -> elt
|
||||||
|
(** Element with children, represented as a list of {!sub_elt} to be flattened
|
||||||
|
@param if_ if false, do not print anything (default true) *)
|
||||||
|
|
||||||
|
(**/**)
|
||||||
|
module Helpers_ = struct
|
||||||
|
|
||||||
|
(** Escape string so it can be safely embedded in HTML text. *)
|
||||||
|
let _str_escape (out:Out.t) (s:string) : unit =
|
||||||
|
String.iter (function
|
||||||
|
| '<' -> Out.add_string out "<"
|
||||||
|
| '>' -> Out.add_string out ">"
|
||||||
|
| '&' -> Out.add_string out "&"
|
||||||
|
| '"' -> Out.add_string out """
|
||||||
|
| '\'' -> Out.add_string out "'"
|
||||||
|
| c -> Out.add_char out c)
|
||||||
|
s
|
||||||
|
|
||||||
|
(** Print the value part of an attribute *)
|
||||||
|
let _attr_escape (out:Out.t) (s:string) =
|
||||||
|
Out.add_char out '"';
|
||||||
|
_str_escape out s;
|
||||||
|
Out.add_char out '"'
|
||||||
|
|
||||||
|
(** Output a list of attributes. *)
|
||||||
|
let _write_attrs (out:Out.t) (l:attribute list) : unit =
|
||||||
|
List.iter
|
||||||
|
(fun (k,v) ->
|
||||||
|
Out.add_char out ' ';
|
||||||
|
Out.add_string out k;
|
||||||
|
Out.add_char out '=';
|
||||||
|
_attr_escape out v)
|
||||||
|
l
|
||||||
|
|
||||||
|
(** Write sub-elements of a {!nary'} element, returns [true] iff
|
||||||
|
at least one sub-element was written. *)
|
||||||
|
let _write_subs (out:Out.t) (l:sub_elt list) : bool =
|
||||||
|
let has_sub = ref false in
|
||||||
|
let prepend_white () = has_sub := true; Out.add_format_nl out; in
|
||||||
|
let emit1 = function
|
||||||
|
| `E x -> prepend_white(); x out
|
||||||
|
| `L l -> List.iter (fun e -> prepend_white(); e out) l
|
||||||
|
| `S l -> Seq.iter (fun e -> prepend_white(); e out) l
|
||||||
|
| `Nil -> ()
|
||||||
|
in
|
||||||
|
List.iter emit1 l;
|
||||||
|
!has_sub
|
||||||
|
|
||||||
|
(** Write a tag, with its attributes.
|
||||||
|
@param void if true, end with "/>", otherwise end with ">" *)
|
||||||
|
let _write_tag_attrs ~void (out:Out.t) (tag:string) (attrs:attribute list) : unit =
|
||||||
|
Out.add_string out "<";
|
||||||
|
Out.add_string out tag;
|
||||||
|
_write_attrs out attrs;
|
||||||
|
if void then Out.add_string out "/>" else Out.add_string out ">"
|
||||||
|
|
||||||
|
end
|
||||||
|
open Helpers_
|
||||||
|
(**/**)
|
||||||
|
|
||||||
|
(** Sub-element with a single element inside. *)
|
||||||
|
let[@inline] sub_e (elt:elt) : sub_elt = `E elt
|
||||||
|
|
||||||
|
(** Sub-element with a list of items inside. *)
|
||||||
|
let[@inline] sub_l (l:elt list) : sub_elt = `L l
|
||||||
|
|
||||||
|
(** Sub-element with a sequence ({!Seq.t}) of items inside. *)
|
||||||
|
let[@inline] sub_seq (l:elt Seq.t) : sub_elt = `S l
|
||||||
|
|
||||||
|
(** Helper to build a {!Seq.t} from an array. *)
|
||||||
|
let seq_of_array (a:_ array) : _ Seq.t =
|
||||||
|
let rec loop i () =
|
||||||
|
if i=Array.length a then Seq.Nil
|
||||||
|
else Seq.Cons (a.(i), loop (i+1))
|
||||||
|
in loop 0
|
||||||
|
|
||||||
|
(** Sub-element with nothing inside. Useful in conditionals, when one
|
||||||
|
decides not to emit a sub-element at all. *)
|
||||||
|
let sub_empty : sub_elt = `Nil
|
||||||
|
|
||||||
|
(** Emit a string value, which will be escaped. *)
|
||||||
|
let txt (txt:string) : elt = fun out -> _str_escape out txt
|
||||||
|
|
||||||
|
(** Formatted version of {!txt} *)
|
||||||
|
let txtf fmt = Format.kasprintf (fun s -> fun out -> _str_escape out s) fmt
|
||||||
|
|
||||||
|
(** Emit raw HTML. Caution, this can lead to injection vulnerabilities,
|
||||||
|
never use with text that comes from untrusted users. *)
|
||||||
|
let raw_html (s:string) : elt = fun out -> Out.add_string out s
|
||||||
|
|}
|
||||||
|
|
||||||
|
let oname = function
|
||||||
|
| "object" -> "object_"
|
||||||
|
| "class" -> "class_"
|
||||||
|
| "method" -> "method_"
|
||||||
|
| "data-*" -> "data_star"
|
||||||
|
| "for" -> "for_"
|
||||||
|
| "open" -> "open_"
|
||||||
|
| "Text" -> "text"
|
||||||
|
| "type" -> "type_"
|
||||||
|
| name ->
|
||||||
|
String.map
|
||||||
|
(function
|
||||||
|
| '-' -> '_'
|
||||||
|
| c -> c)
|
||||||
|
name
|
||||||
|
|
||||||
|
let emit_void name =
|
||||||
|
let oname = oname name in
|
||||||
|
pf
|
||||||
|
"(** tag %S, see \
|
||||||
|
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
|
||||||
|
name name;
|
||||||
|
pf "let %s : void = fun ?(if_=true) attrs out ->\n" oname;
|
||||||
|
pf " if if_ then (\n";
|
||||||
|
pf " _write_tag_attrs ~void:true out %S attrs;\n" name;
|
||||||
|
pf " )";
|
||||||
|
pf "\n\n";
|
||||||
|
()
|
||||||
|
|
||||||
|
let emit_normal name =
|
||||||
|
let oname = oname name in
|
||||||
|
|
||||||
|
pf
|
||||||
|
"(** tag %S, see \
|
||||||
|
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
|
||||||
|
name name;
|
||||||
|
pf "let %s : nary = fun ?(if_=true) attrs sub out ->\n" oname;
|
||||||
|
pf " if if_ then (\n";
|
||||||
|
(* for <pre>, newlines actually matter *)
|
||||||
|
if name = "pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
|
||||||
|
pf " _write_tag_attrs ~void:false out %S attrs;\n" name;
|
||||||
|
pf " List.iter (fun sub -> Out.add_format_nl out; sub out) sub;\n";
|
||||||
|
pf " if sub <> [] then Out.add_format_nl out;\n";
|
||||||
|
pf " Out.add_string out \"</%s>\")" name;
|
||||||
|
pf "\n\n";
|
||||||
|
|
||||||
|
(* block version *)
|
||||||
|
let oname = oname ^ "'" in
|
||||||
|
pf
|
||||||
|
"(** tag %S, see \
|
||||||
|
{{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
|
||||||
|
name name;
|
||||||
|
pf "let %s : nary' = fun ?(if_=true) attrs l out ->\n" oname;
|
||||||
|
pf " if if_ then (\n";
|
||||||
|
if name = "pre" then pf " Out.with_no_format_nl out @@ fun () ->\n";
|
||||||
|
pf " _write_tag_attrs ~void:false out %S attrs;\n" name;
|
||||||
|
pf " let has_sub = _write_subs out l in\n";
|
||||||
|
pf " if has_sub then Out.add_format_nl out;\n";
|
||||||
|
pf " Out.add_string out \"</%s>\")" name;
|
||||||
|
pf "\n\n";
|
||||||
|
|
||||||
|
()
|
||||||
|
|
||||||
|
let doc_attrs =
|
||||||
|
{|Attributes.
|
||||||
|
|
||||||
|
This module contains combinator for the standard attributes.
|
||||||
|
One can also just use a pair of strings. |}
|
||||||
|
|
||||||
|
let emit_attr name =
|
||||||
|
let oname = oname name in
|
||||||
|
pf " (** Attribute %S. *)\n" name;
|
||||||
|
pf " let %s : t = fun v -> %S, v\n" oname name;
|
||||||
|
pf "\n"
|
||||||
|
|
||||||
|
let () =
|
||||||
|
pf "%s\n" prelude;
|
||||||
|
List.iter emit_void void;
|
||||||
|
List.iter emit_normal normal;
|
||||||
|
pf "(** %s *)\n" doc_attrs;
|
||||||
|
pf "module A = struct\n";
|
||||||
|
pf " type t = string -> attribute\n";
|
||||||
|
pf " (** Attribute builder *)\n";
|
||||||
|
pf "\n";
|
||||||
|
List.iter emit_attr attrs;
|
||||||
|
pf "end\n";
|
||||||
|
()
|
||||||
Loading…
Add table
Reference in a new issue