diff --git a/src/gen/gentags.ml b/src/gen/gentags.ml index 9b6d3129..92217233 100644 --- a/src/gen/gentags.ml +++ b/src/gen/gentags.ml @@ -291,11 +291,25 @@ module Out : sig val clear : 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 val to_string : t -> string end = struct - include Buffer - let create () = Buffer.create 256 - let to_string = contents + type t = { + buf: Buffer.t; + mutable fmt_nl: bool; (* if true, we print \b around to format the html *) + } + let create () = {buf=Buffer.create 256; fmt_nl=true} + let clear self = Buffer.clear self.buf; self.fmt_nl <- true + let[@inline] add_char self c = Buffer.add_char self.buf c + let[@inline] add_string self s = Buffer.add_string self.buf s + let to_string self = Buffer.contents self.buf + let 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 @@ -316,6 +330,8 @@ type nary' = ?if_:bool -> attribute list -> (Out.t -> unit) -> elt (** Element with children, represented as a continuation. @param if_ if false, do not print anything (default true) *) +let (@<) (out:Out.t) (elt:elt) : unit = elt out + (** Escape string so it can be safely embedded in HTML text. *) let str_escape (out:Out.t) (s:string) : unit = String.iter (function @@ -346,6 +362,9 @@ let write_attrs (out:Out.t ) (l:attribute list) : unit = (** 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 @@ -382,11 +401,15 @@ let emit_normal name = name name; pf "let %s : nary = fun ?(if_=true) attrs sub out ->\n" oname; pf " if if_ then (\n"; + (* for
, newlines actually matter *)
+  if name="pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
   pf "    Out.add_string out \"<%s\";\n" name;
   pf "    write_attrs out attrs;\n";
-  pf "    Out.add_string out \">\\n\";\n";
-  pf "    List.iter (fun sub -> sub out; Out.add_char out '\\n') sub;\n";
-  pf "    Out.add_string out \"\\n\")" name;
+  pf "    Out.add_string out \">\";\n";
+  pf "    Out.add_format_nl out;\n";
+  pf "    List.iter (fun sub -> sub out; Out.add_format_nl out) sub;\n";
+  pf "    Out.add_string out \"\";" name;
+  pf "    Out.add_format_nl out)\n";
   pf "\n\n";
 
   (* block version *)
@@ -395,16 +418,24 @@ let emit_normal name =
     name name;
   pf "let %s : nary' = fun ?(if_=true) attrs f out ->\n" oname;
   pf "  if if_ then (\n";
+  if name="pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
   pf "    Out.add_string out \"<%s\";\n" name;
   pf "    write_attrs out attrs;\n";
-  pf "    Out.add_string out \">\\n\";\n";
+  pf "    Out.add_string out \">\";\n";
+  pf "    Out.add_format_nl out;\n";
   pf "    f out;\n";
-  pf "    Out.add_string out \"\\n\")" name;
+  pf "    Out.add_string out \"\";" name;
+  pf "    Out.add_format_nl out)\n";
   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;
@@ -415,7 +446,7 @@ let () =
   pf "%s\n" prelude;
   List.iter emit_void void;
   List.iter emit_normal normal;
-  pf "(** Attributes *)\n";
+  pf "(** %s *)\n" doc_attrs;
   pf "module A = struct\n";
   pf "  type t = string -> attribute\n";
   pf "  (** Attribute builder *)\n";