From 7fdb420eb05dd5972a916e91ea86402d1b03f877 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 17 Mar 2022 22:34:29 -0400
Subject: [PATCH] fix(html): ensure that <pre> is printed without spurious
 newlines

---
 src/gen/gentags.ml | 49 +++++++++++++++++++++++++++++++++++++---------
 1 file changed, 40 insertions(+), 9 deletions(-)

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 <pre>, 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 \"</%s>\\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 \"</%s>\";" 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 \"</%s>\\n\")" name;
+  pf "    Out.add_string out \"</%s>\";" 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";