From f1551d5b497414993bf754ed66fc80c1d09ed165 Mon Sep 17 00:00:00 2001 From: Jonathan Coates Date: Mon, 21 Oct 2024 19:59:49 +0100 Subject: [PATCH] Add a custom "Output_sink" module for emitting strings OCaml doesn't have a good abstraction over writing text to generic output (file, stdout, to memory). As a result, we often end up using Format.formatter as an arbitrary output source. This is fine in some use-cases. However, Format is designed around pretty-printing values, rather than being high-performance. We see this particularly when emitting HTML, with the format machinery contributing a significant amount of time. This change adds a new Output_sink module, which effectively exposes a single "write" method. We switch the HTML module over to this. This provides a significant performance boost. For a CC:T doc-gen this reduces allocations and time taken by ~15%. --- src/bin/cli/dune | 1 - src/bin/cli/illuaminate_cli.ml | 7 +- src/doc_emit/dune | 1 - src/doc_emit/html_basic.ml | 7 +- src/doc_emit/html_highlight.ml | 12 ++- src/doc_emit/html_highlight.mli | 4 +- src/doc_emit/html_loader.ml | 2 +- src/doc_emit/html_loader.mli | 2 +- src/doc_emit/html_main.re | 2 +- src/doc_emit/html_main.rei | 6 +- src/doc_emit/html_md.ml | 5 +- src/doc_emit/html_md.mli | 9 +- src/doc_emit/html_type.re | 2 +- src/doc_emit/html_type.rei | 12 +-- src/doc_emit/html_value.re | 2 +- src/doc_emit/illuaminateDocEmit.mli | 14 +-- src/html/dune | 7 -- src/html/html.ml | 106 ----------------------- src/html/html.mli | 69 --------------- src/illuaminate/html.ml | 130 ++++++++++++++++++++++++++++ src/illuaminate/html.mli | 63 ++++++++++++++ src/illuaminate/output_sink.ml | 28 ++++++ src/illuaminate/output_sink.mli | 35 ++++++++ src/web/dune | 1 - src/web/main.ml | 3 +- src/web/template.re | 10 +-- test/doc_emit.ml | 2 +- test/dune | 1 - 28 files changed, 311 insertions(+), 232 deletions(-) delete mode 100644 src/html/dune delete mode 100644 src/html/html.ml delete mode 100644 src/html/html.mli create mode 100644 src/illuaminate/html.ml create mode 100644 src/illuaminate/html.mli create mode 100644 src/illuaminate/output_sink.ml create mode 100644 src/illuaminate/output_sink.mli diff --git a/src/bin/cli/dune b/src/bin/cli/dune index b93ee229..a8a330c9 100644 --- a/src/bin/cli/dune +++ b/src/bin/cli/dune @@ -19,7 +19,6 @@ illuaminate.lint illuaminate.config illuaminateConfigFormat - illuaminate.html illuaminate.minify illuaminate.pattern illuaminate.doc_emit diff --git a/src/bin/cli/illuaminate_cli.ml b/src/bin/cli/illuaminate_cli.ml index ee1d2430..619ce145 100644 --- a/src/bin/cli/illuaminate_cli.ml +++ b/src/bin/cli/illuaminate_cli.ml @@ -104,10 +104,7 @@ let doc_gen path = let to_abs path = Fpath.to_string (to_abs' path) in (* Write a HTML doc to a file. *) - let emit_doc node out = - let fmt = Format.formatter_of_out_channel out in - Html.Default.emit_doc fmt node; Format.pp_print_flush fmt () - in + let emit_doc node out = Output_sink.with_output_stream out @@ fun out -> Html.emit_doc out node in (* Resolve the path to the logo, copying it into the output directory if needed. *) let resolve_logo ~data ~destination logo = @@ -199,7 +196,7 @@ let doc_gen path = |> CCIO.with_out ~flags:[ Open_creat; Open_trunc; Open_binary ] (Fpath.to_string path) ); let path = Fpath.(destination / "index.html") in - Option.fold ~none:Html.Default.nil ~some:(parse_index ~options:(options Fun.id)) index + Option.fold ~none:Html.nil ~some:(parse_index ~options:(options Fun.id)) index |> E.Html.emit_index ~options:(options Fun.id) ~pages |> emit_doc |> CCIO.with_out ~flags:[ Open_creat; Open_trunc; Open_binary ] (Fpath.to_string path); diff --git a/src/doc_emit/dune b/src/doc_emit/dune index afa54500..3130159c 100644 --- a/src/doc_emit/dune +++ b/src/doc_emit/dune @@ -9,7 +9,6 @@ illuaminate illuaminate.core illuaminate.data - illuaminate.html illuaminate.parser illuaminate.semantics markup diff --git a/src/doc_emit/html_basic.ml b/src/doc_emit/html_basic.ml index 8139ed23..c583f262 100644 --- a/src/doc_emit/html_basic.ml +++ b/src/doc_emit/html_basic.ml @@ -9,10 +9,11 @@ let reference_link ~options:{ resolve; _ } : Reference.resolved -> string option | External { url = None; _ } -> None | Unknown _ -> None -let show_list ?(tag = "h3") ?(expandable = false) ?(expand = true) title = function - | [] -> Html.Default.nil +let show_list ?(tag = "h3") ?(expandable = false) ?(expand = true) title = + let open Illuaminate.Html in + function + | [] -> nil | xs -> - let open Html.Default in [ create_node ~tag ~children:[ str title ] ~attributes: diff --git a/src/doc_emit/html_highlight.ml b/src/doc_emit/html_highlight.ml index d7a23d08..a91248a8 100644 --- a/src/doc_emit/html_highlight.ml +++ b/src/doc_emit/html_highlight.ml @@ -21,7 +21,7 @@ let transform_ref ~options ((r : M.Reference.t), t) = | _ -> None let emit ~options ~data ~input visit tree = - let open Html.Default in + let open Illuaminate.Html in (* TODO: Emit a true HTML node. Not sure how to do that elegantly though - we'd probably need to use a visitor within Emit instead. *) let res = Buffer.create (String.length input) in @@ -49,7 +49,11 @@ let emit ~options ~data ~input visit tree = in ("title", desc) :: attrs in - Format.asprintf "" Html.Emitters.attrs attrs + let module Sink = Illuaminate.Output_sink in + Sink.with_to_str @@ fun out -> + Sink.write out "" | None -> stack := false :: xs; "" @@ -117,7 +121,7 @@ let do_lua ~options:({ Html_options.data; _ } as options) input = | Error _, (lazy (Ok tree)) -> let data = resolve tree in (emit ~options ~data ~input Emit.program tree, Some `Stmt) - | Error _, (lazy (Error _)) -> (Html.Default.str input, None) + | Error _, (lazy (Error _)) -> (Illuaminate.Html.str input, None) let lua ~options input = do_lua ~options input |> fst @@ -129,6 +133,6 @@ let lua_block ?(attrs = []) ~options input = | Some `Expr -> Some "expr" | Some `Stmt -> Some "stmt" in - Html.Default.create_node ~tag:"pre" + Illuaminate.Html.create_node ~tag:"pre" ~attributes:(("class", Some "highlight") :: ("data-lua-kind", kind) :: attrs) ~children:[ highlighted ] () diff --git a/src/doc_emit/html_highlight.mli b/src/doc_emit/html_highlight.mli index 4841065c..d677d4e3 100644 --- a/src/doc_emit/html_highlight.mli +++ b/src/doc_emit/html_highlight.mli @@ -1,5 +1,5 @@ (** Highlight a Lua string, rendering it as HTML *) -val lua : options:Html_options.t -> string -> Html.Default.node +val lua : options:Html_options.t -> string -> Illuaminate.Html.node_ val lua_block : - ?attrs:(string * string option) list -> options:Html_options.t -> string -> Html.Default.node + ?attrs:(string * string option) list -> options:Html_options.t -> string -> Illuaminate.Html.node_ diff --git a/src/doc_emit/html_loader.ml b/src/doc_emit/html_loader.ml index 74939acd..bd9fcc4c 100644 --- a/src/doc_emit/html_loader.ml +++ b/src/doc_emit/html_loader.ml @@ -1,5 +1,5 @@ let load_file ~options path = - let open Html.Default in + let open Illuaminate.Html in match CCIO.File.read (Fpath.to_string path) with | Error msg -> Format.asprintf "Cannot open documentation index '%a' (%s)\n%!" Fpath.pp path msg diff --git a/src/doc_emit/html_loader.mli b/src/doc_emit/html_loader.mli index 031d017e..1fa3d583 100644 --- a/src/doc_emit/html_loader.mli +++ b/src/doc_emit/html_loader.mli @@ -1,2 +1,2 @@ (** Load a file, converting it to a HTML node depending on the file's type. *) -val load_file : options:Html_options.t -> Fpath.t -> (Html.Default.node, string) result +val load_file : options:Html_options.t -> Fpath.t -> (Illuaminate.Html.node_, string) result diff --git a/src/doc_emit/html_main.re b/src/doc_emit/html_main.re index f100a424..ac85c200 100644 --- a/src/doc_emit/html_main.re +++ b/src/doc_emit/html_main.re @@ -1,4 +1,4 @@ -open Html.Default; +open Illuaminate.Html; open Html_basic; open Html_md; open Html_value; diff --git a/src/doc_emit/html_main.rei b/src/doc_emit/html_main.rei index 67790dd0..794a0f50 100644 --- a/src/doc_emit/html_main.rei +++ b/src/doc_emit/html_main.rei @@ -7,10 +7,10 @@ type page_list := /** Emit an index file from a list of page. */ let emit_index: - (~options: Html_options.t, ~pages: page_list, Html.Default.node) => - Html.Default.node; + (~options: Html_options.t, ~pages: page_list, Illuaminate.Html.node_) => + Illuaminate.Html.node_; /** Emit a single page. */ let emit_page: (~options: Html_options.t, ~pages: page_list, documented(page)) => - Html.Default.node; + Illuaminate.Html.node_; diff --git a/src/doc_emit/html_md.ml b/src/doc_emit/html_md.ml index cd0603cf..7107127c 100644 --- a/src/doc_emit/html_md.ml +++ b/src/doc_emit/html_md.ml @@ -1,4 +1,4 @@ -open Html.Default +open Illuaminate.Html open Cmarkit module S = IlluaminateSemantics.Doc.Syntax module A = IlluaminateSemantics.Doc.AbstractSyntax @@ -132,7 +132,8 @@ let emit_code_block ~options c block = match language with | "lua" -> let attrs = merge_classes ~classes ~attrs in - Cmarkit_ext.cprintf c "%a" Html.Default.emit (Html_highlight.lua_block ~attrs ~options code) + let sink = Illuaminate.Output_sink.of_buffer (Cmarkit_renderer.Context.buffer c) in + Illuaminate.Html.emit sink (Html_highlight.lua_block ~attrs ~options code) | _ -> C.string c {| options:Html_options.t -> Doc.Syntax.Markdown.t -> Html.Default.node +val md : ?path:Fpath.t -> options:Html_options.t -> Doc.Syntax.Markdown.t -> Illuaminate.Html.node_ (** Render a description to a HTML node. *) -val show_desc : options:Html_options.t -> Doc.Syntax.description option -> Html.Default.node +val show_desc : options:Html_options.t -> Doc.Syntax.description option -> Illuaminate.Html.node_ (** Render a description to a HTML node. If this description is a single paragraph, it will be rendered inline rather than wrapped in a [

] element. *) -val show_desc_inline : options:Html_options.t -> Doc.Syntax.description option -> Html.Default.node +val show_desc_inline : + options:Html_options.t -> Doc.Syntax.description option -> Illuaminate.Html.node_ (** Show the summary ({!Helpers.get_summary}) of a document. *) -val show_summary : options:Html_options.t -> Doc.Syntax.description option -> Html.Default.node +val show_summary : options:Html_options.t -> Doc.Syntax.description option -> Illuaminate.Html.node_ diff --git a/src/doc_emit/html_type.re b/src/doc_emit/html_type.re index 7d9768d2..37187010 100644 --- a/src/doc_emit/html_type.re +++ b/src/doc_emit/html_type.re @@ -1,4 +1,4 @@ -open Html.Default; +open Illuaminate.Html; open! IlluaminateSemantics.Doc.Syntax.Type; let show_opt = (~kind, optional) => diff --git a/src/doc_emit/html_type.rei b/src/doc_emit/html_type.rei index e1952321..b39789e0 100644 --- a/src/doc_emit/html_type.rei +++ b/src/doc_emit/html_type.rei @@ -1,19 +1,21 @@ -open Html.Default; open IlluaminateSemantics; /** Show an optional specifier if required. */ -let show_opt: (~kind: string, bool) => node; +let show_opt: (~kind: string, bool) => Illuaminate.Html.node_; /** Check if a type is optional (i.e. is a union contianing `nil`), and extract the non-optional type component if so. */ let opt_ty: Doc.Syntax.Type.t => (bool, Doc.Syntax.Type.t); /** Convert a type to HTML, using some resolve function to look up internal links. */ -let show_type: (~options: Html_options.t, Doc.Syntax.Type.t) => node; +let show_type: + (~options: Html_options.t, Doc.Syntax.Type.t) => Illuaminate.Html.node_; /** Convert a potential type to HTML. */ let show_type_opt: - (~options: Html_options.t, option(Doc.Syntax.Type.t)) => node; + (~options: Html_options.t, option(Doc.Syntax.Type.t)) => + Illuaminate.Html.node_; /** Wrap a HTML node with a link to a reference, using some resolve function to look up internal links. */ let show_reference: - (~options: Html_options.t, Reference.resolved, node) => node; + (~options: Html_options.t, Reference.resolved, Illuaminate.Html.node_) => + Illuaminate.Html.node_; diff --git a/src/doc_emit/html_value.re b/src/doc_emit/html_value.re index 54a8ff9a..a4c2e243 100644 --- a/src/doc_emit/html_value.re +++ b/src/doc_emit/html_value.re @@ -1,4 +1,4 @@ -open Html.Default; +open Illuaminate.Html; open Html_basic; open Html_md; open Html_type; diff --git a/src/doc_emit/illuaminateDocEmit.mli b/src/doc_emit/illuaminateDocEmit.mli index 3b88a990..ad5edb18 100644 --- a/src/doc_emit/illuaminateDocEmit.mli +++ b/src/doc_emit/illuaminateDocEmit.mli @@ -19,10 +19,13 @@ module Html : sig module Highlight : sig (** Highlight a Lua string, rendering it as HTML *) - val lua : options:Html_options.t -> string -> Html.Default.node + val lua : options:Html_options.t -> string -> Illuaminate.Html.node_ val lua_block : - ?attrs:(string * string option) list -> options:Html_options.t -> string -> Html.Default.node + ?attrs:(string * string option) list -> + options:Html_options.t -> + string -> + Illuaminate.Html.node_ end module Assets = Html_assets @@ -33,18 +36,19 @@ module Html : sig Map.Make(IlluaminateSemantics.Namespace).t (** Emit an index file from a list of pages. *) - val emit_index : options:Options.t -> pages:page_list -> Html.Default.node -> Html.Default.node + val emit_index : + options:Options.t -> pages:page_list -> Illuaminate.Html.node_ -> Illuaminate.Html.node_ (** Emit a single page. *) val emit_page : options:Options.t -> pages:page_list -> Doc.Syntax.page Doc.Syntax.documented -> - Html.Default.node + Illuaminate.Html.node_ (** Load a file and convert it to HTML. This correctly handles loading markdown, HTML and text files. *) - val load_file : options:Options.t -> Fpath.t -> (Html.Default.node, string) result + val load_file : options:Options.t -> Fpath.t -> (Illuaminate.Html.node_, string) result (** The contents of the default JS file. *) val embedded_js : string diff --git a/src/html/dune b/src/html/dune deleted file mode 100644 index 2d976ab5..00000000 --- a/src/html/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name html) - (public_name illuaminate.html) - (synopsis "A basic HTML library suitable for using with illuaminate.jsx") - (libraries containers) - (instrumentation - (backend bisect_ppx))) diff --git a/src/html/html.ml b/src/html/html.ml deleted file mode 100644 index e4344d27..00000000 --- a/src/html/html.ml +++ /dev/null @@ -1,106 +0,0 @@ -module Emitters = struct - open Format - - let skip _ () = () - let attr out (k, v) = CCString.replace ~sub:"\"" ~by:""" v |> fprintf out " %s=\"%s\"" k - let attrs = pp_print_list ~pp_sep:skip attr -end - -module Make (X : sig - type event_handler -end) = -struct - type event_handler = X.event_handler - - type node = - | Element of - { tag : string; - attributes : (string * string) list; - events : (string * event_handler) list; - children : node list - } - | Text of string - | Raw of string - | Nil - | Many of node list - - let create_node ~tag ?(attributes = []) ?(events = []) ?(children = []) () = - let attributes = - attributes - |> List.filter_map @@ function - | _, None -> None - | a, Some b -> Some (a, b) - in - Element { tag; attributes; events; children } - - let str x = Text x - let raw x = Raw x - let nil = Nil - let many xs = Many xs - - let html_escape s = - let n = String.length s in - let rec loop_escape b i = - if i >= n then Buffer.contents b - else ( - (match s.[i] with - | '"' -> Buffer.add_string b """ - | '&' -> Buffer.add_string b "&" - | '<' -> Buffer.add_string b "<" - | '>' -> Buffer.add_string b ">" - | c -> Buffer.add_char b c); - loop_escape b (i + 1)) - in - let rec loop_pure i = - if i >= n then s - else - match s.[i] with - | '"' | '&' | '<' | '>' -> - let b = Buffer.create n in - Buffer.add_substring b s 0 i; loop_escape b i - | _ -> loop_pure (i + 1) - in - loop_pure 0 - - let do_emit ~indent = - let open Format in - let open Emitters in - let cut out = if indent then pp_print_cut out () else () in - let break out = if indent then pp_print_break out 0 2 else () in - let open_box fmt = if indent then pp_open_hvbox fmt 0 else () in - let close_box fmt = if indent then pp_close_box fmt () else () in - let non_empty prev out go = - if prev then cut out; - go (); - true - in - let rec go out prev = function - | Many xs -> list prev out xs - | Nil | Text "" | Raw "" -> prev - | Raw x -> non_empty prev out @@ fun () -> pp_print_string out x - | Text x -> non_empty prev out @@ fun () -> pp_print_string out (html_escape x) - | Element - { tag = ("br" | "img" | "link" | "meta") as tag; attributes; children = []; events = [] } - -> non_empty prev out @@ fun () -> fprintf out "<%s%a />" tag attrs attributes - | Element { tag; attributes; children; events = [] } -> - non_empty prev out @@ fun () -> - open_box out; - fprintf out "<%s%a>%t%t%a%t%t" tag attrs attributes break open_box list' children - close_box cut tag; - close_box out - | Element { events = _ :: _; _ } -> failwith "Cannot emit event handlers to a formatter." - and list prev out = List.fold_left (go out) prev - and list' out xs = list false out xs |> ignore in - fun out node -> go out false node |> ignore - - let emit = do_emit ~indent:false - let emit_pretty = do_emit ~indent:true - - let emit_doc out node = - Format.fprintf out ""; - emit out node -end - -module Default = Make (struct - type event_handler = | -end) diff --git a/src/html/html.mli b/src/html/html.mli deleted file mode 100644 index 109bc5f8..00000000 --- a/src/html/html.mli +++ /dev/null @@ -1,69 +0,0 @@ -(** Functions for building and emitting HTML nodes. This is designed to be used in tandem with - Reason's JSX syntax and the {!Jsx} pre-processor. *) - -(** Utility functions for emitting HTML *) -module Emitters : sig - (** Emit a list of attributes. This is assumed to appear immediately after the tag, and so should - be printed using [printf "%s%a" tag attributes] *) - val attrs : Format.formatter -> (string * string) list -> unit -end - -(** A HTML syntax tree and functions for working with them. - - This functor is parameterised by the type of event handler this tree uses. The {!Default} module - uses an empty variant type, however other modules (such as our website) use a js_of_ocaml event - handler. *) -module Make (X : sig - type event_handler -end) : sig - type event_handler = X.event_handler - - (** The type of HTML nodes. *) - type node = private - | Element of - { tag : string; - attributes : (string * string) list; - events : (string * event_handler) list; - children : node list - } - | Text of string - | Raw of string - | Nil - | Many of node list - - (** Create an element with a specific tag, attributes, event handlers and children. Indented to be - used from Reason via the JSX processor. *) - val create_node : - tag:string -> - ?attributes:(string * string option) list -> - ?events:(string * event_handler) list -> - ?children:node list -> - unit -> - node - - (** An empty node. *) - val nil : node - - (** A node representing a string. This will be escaped when emitted. *) - val str : string -> node - - (** A node representing raw HTML contents. *) - val raw : string -> node - - (** Merge multiple nodes into one. Easier than flattening lists. *) - val many : node list -> node - - (** Emit a node. *) - val emit : Format.formatter -> node -> unit - - (** Emit a node, with additional whitespace. *) - val emit_pretty : Format.formatter -> node -> unit - - (** Emit a document, including the DOCTYPE header. *) - val emit_doc : Format.formatter -> node -> unit -end - -(** The default HTML tree. *) -module Default : module type of Make (struct - type event_handler = | -end) diff --git a/src/illuaminate/html.ml b/src/illuaminate/html.ml new file mode 100644 index 00000000..c327c81f --- /dev/null +++ b/src/illuaminate/html.ml @@ -0,0 +1,130 @@ +type 'ev node = + | Element of + { tag : string; + attributes : (string * string) list; + events : (string * 'ev) list; + children : 'ev node list + } + | Text of string + | Raw of string + | Nil + | Many of 'ev node list + +let create_node ~tag ?(attributes = []) ?(events = []) ?(children = []) () = + let attributes = + attributes + |> List.filter_map @@ function + | _, None -> None + | a, Some b -> Some (a, b) + in + Element { tag; attributes; events; children } + +let str x = Text x +let raw x = Raw x +let nil = Nil +let many xs = Many xs + +let html_escape s = + let n = String.length s in + let rec loop_escape b i = + if i >= n then Buffer.contents b + else ( + (match s.[i] with + | '"' -> Buffer.add_string b """ + | '&' -> Buffer.add_string b "&" + | '<' -> Buffer.add_string b "<" + | '>' -> Buffer.add_string b ">" + | c -> Buffer.add_char b c); + loop_escape b (i + 1)) + in + let rec loop_pure i = + if i >= n then s + else + match s.[i] with + | '"' | '&' | '<' | '>' -> + let b = Buffer.create n in + Buffer.add_substring b s 0 i; loop_escape b i + | _ -> loop_pure (i + 1) + in + loop_pure 0 + +type no_events = | +type node_ = no_events node + +let rec emit_attr_value out str start len = + if start > len then () + else + match String.index_from_opt str start '"' with + | Some i -> + Output_sink.write_substring out str start (i - start); + Output_sink.write out """; + emit_attr_value out str (i + 1) len + | None -> Output_sink.write_substring out str start (len - start) + +let emit_attr out (k, v) = + Output_sink.write out " "; + Output_sink.write out k; + Output_sink.write out "=\""; + emit_attr_value out v 0 (String.length v); + Output_sink.write out "\"" + +let emit_attrs out xs = List.iter (emit_attr out) xs + +let do_emit ~indent = + let open Format in + let cut out = pp_print_cut out () in + let break out = if indent then pp_print_break out 0 2 else () in + let open_box fmt = if indent then pp_open_hvbox fmt 0 else () in + let close_box fmt = if indent then pp_close_box fmt () else () in + let non_empty prev out go = + if prev then cut out; + go (); + true + in + let attrs out attrs = emit_attrs (Output_sink.of_formatter out) attrs in + let rec go out prev : node_ -> _ = function + | Many xs -> list prev out xs + | Nil | Text "" | Raw "" -> prev + | Raw x -> non_empty prev out @@ fun () -> pp_print_string out x + | Text x -> non_empty prev out @@ fun () -> pp_print_string out (html_escape x) + | Element + { tag = ("br" | "img" | "link" | "meta") as tag; attributes; children = []; events = [] } -> + non_empty prev out @@ fun () -> fprintf out "<%s%a />" tag attrs attributes + | Element { tag; attributes; children; events = [] } -> + non_empty prev out @@ fun () -> + open_box out; + fprintf out "<%s%a>%t%t%a%t%t" tag attrs attributes break open_box list' children + close_box cut tag; + close_box out + | Element { events = _ :: _; _ } -> . + and list prev out = List.fold_left (go out) prev + and list' out xs = list false out xs |> ignore in + fun out node -> go out false node |> ignore + +let emit_pretty = do_emit ~indent:true + +let rec emit out : node_ -> unit = function + | Nil | Text "" | Raw "" -> () + | Many xs -> List.iter (emit out) xs + | Raw txt -> Output_sink.write out txt + | Text txt -> Output_sink.write out (html_escape txt) + | Element + { tag = ("br" | "img" | "link" | "meta") as tag; attributes; children = []; events = [] } -> + Output_sink.write out "<"; + Output_sink.write out tag; + emit_attrs out attributes; + Output_sink.write out " />" + | Element { tag; attributes; children; events = [] } -> + Output_sink.write out "<"; + Output_sink.write out tag; + emit_attrs out attributes; + Output_sink.write out ">"; + List.iter (emit out) children; + Output_sink.write out "" + | Element { events = _ :: _; _ } -> . + +let emit_doc out node = + Output_sink.write out ""; + emit out node diff --git a/src/illuaminate/html.mli b/src/illuaminate/html.mli new file mode 100644 index 00000000..8ff57961 --- /dev/null +++ b/src/illuaminate/html.mli @@ -0,0 +1,63 @@ +(** Functions for building and emitting HTML nodes. This is designed to be used in tandem with + Reason's JSX syntax and the {!Jsx} pre-processor. *) + +(** {1 Nodes} *) + +(** The type of HTML nodes. *) +type 'ev node = private + | Element of + { tag : string; + attributes : (string * string) list; + events : (string * 'ev) list; + children : 'ev node list + } + | Text of string + | Raw of string + | Nil + | Many of 'ev node list + +(** Create an element with a specific tag, attributes, event handlers and children. Indented to be + used from Reason via the JSX processor. *) +val create_node : + tag:string -> + ?attributes:(string * string option) list -> + ?events:(string * 'ev) list -> + ?children:'ev node list -> + unit -> + 'ev node + +(** An empty node. *) +val nil : 'ev node + +(** A node representing a string. This will be escaped when emitted. *) +val str : string -> 'ev node + +(** A node representing raw HTML contents. *) +val raw : string -> 'ev node + +(** Merge multiple nodes into one. Easier than flattening lists. *) +val many : 'ev node list -> 'ev node + +(** {1 Basic nodes} *) + +type no_events = | + +(** A basic {! node} that has no event handlers. *) +type node_ = no_events node + +(** {1 Emitting basic nodes} *) + +(** Emit a node. *) +val emit : Output_sink.t -> node_ -> unit + +(** Emit a document, including the DOCTYPE header. *) +val emit_doc : Output_sink.t -> node_ -> unit + +(** Emit a node, with additional whitespace. *) +val emit_pretty : Format.formatter -> node_ -> unit + +(** {1 Utility functions for emitting HTML} *) + +(** Emit a list of attributes. This is assumed to appear immediately after the tag, and so should be + printed using [printf "%s%a" tag attributes] *) +val emit_attrs : Output_sink.t -> (string * string) list -> unit diff --git a/src/illuaminate/output_sink.ml b/src/illuaminate/output_sink.ml new file mode 100644 index 00000000..c0011cbc --- /dev/null +++ b/src/illuaminate/output_sink.ml @@ -0,0 +1,28 @@ +type t = { write : string -> int -> int -> unit } [@@unboxed] +type 'a pp = t -> 'a -> unit + +let with_output_stream oc fn = + let buffer = Buffer.create 8192 in + let write str start len = + Buffer.add_substring buffer str start len; + if Buffer.length buffer >= 8192 then (Buffer.output_buffer oc buffer; Buffer.clear buffer) + in + Fun.protect ~finally:(fun () -> Buffer.output_buffer oc buffer) @@ fun () -> fn { write } + +let of_buffer buffer = { write = Buffer.add_substring buffer } + +let of_formatter fmt = + let write str start len = + let str = if start = 0 && len = String.length str then str else String.sub str 0 len in + Format.pp_print_string fmt str + in + { write } + +let with_to_str fn = + let b = Buffer.create 16 in + fn (of_buffer b); + Buffer.contents b + +let write_substring w = w.write +let write w str = w.write str 0 (String.length str) +let printf p fmt = Printf.ksprintf (write p) fmt diff --git a/src/illuaminate/output_sink.mli b/src/illuaminate/output_sink.mli new file mode 100644 index 00000000..e25c612d --- /dev/null +++ b/src/illuaminate/output_sink.mli @@ -0,0 +1,35 @@ +(** A generic type that can be used for outputting strings. + + Like {!Format.formatter}, this provides a generic interface for outputting strings. However, + this sacrifices the flexibility of {!Format} to provide a simpler and more efficient interface. *) + +type t +type 'a pp = t -> 'a -> unit + +(** {1 Constructing a sink} *) + +(** Construct a printer from an output stream, then apply some action with it. + + Writes will be automatically buffered to the supplied output channel, and flushed when + sufficient bytes are written, or when the inner function completes. *) +val with_output_stream : out_channel -> (t -> unit) -> unit + +(** Construct a printer from a buffer. *) +val of_buffer : Buffer.t -> t + +(** Construct a printer from a formatter. *) +val of_formatter : Format.formatter -> t + +(** [with_to_str fn] returns the result of printing with [fn] as a string. *) +val with_to_str : (t -> unit) -> string + +(** {1 Outputting strings} *) + +(** Write a string to this printer. *) +val write : t -> string -> unit + +(** Write a substring to this printer. *) +val write_substring : t -> string -> int -> int -> unit + +(** Write a formatted string to this printer. *) +val printf : t -> ('a, unit, string, unit) format4 -> 'a diff --git a/src/web/dune b/src/web/dune index de418686..9f0aadef 100644 --- a/src/web/dune +++ b/src/web/dune @@ -11,7 +11,6 @@ illuaminate.semantics illuaminate.lint illuaminate.config - illuaminate.html illuaminate.data illuaminate.minify) (modes js) diff --git a/src/web/main.ml b/src/web/main.ml index d31658af..17f8f98a 100644 --- a/src/web/main.ml +++ b/src/web/main.ml @@ -16,7 +16,8 @@ let store = |> Schema.default (** Append virtual HTML node to a concrete element. *) -let rec render_to (out : Dom.node Js.t) : Template.node -> unit = function +let rec render_to (out : Dom.node Js.t) : Template.event_handler Illuaminate.Html.node -> unit = + function | Nil -> () | Raw _ -> failwith "Cannot render raw HTML" | Text txt -> diff --git a/src/web/template.re b/src/web/template.re index 8359165c..bba9c4c1 100644 --- a/src/web/template.re +++ b/src/web/template.re @@ -1,10 +1,8 @@ open IlluaminateCore; -module JsHtml = - Html.Make({ - open Js_of_ocaml; - type event_handler = Js.t(Dom_html.event) => Js.t(bool); - }); -include JsHtml; +open Illuaminate.Html; + +type event_handler = + Js_of_ocaml.Js.t(Js_of_ocaml.Dom_html.event) => Js_of_ocaml.Js.t(bool); let level: Error.level => string = level => diff --git a/test/doc_emit.ml b/test/doc_emit.ml index 3c1f0291..eb6fb54e 100644 --- a/test/doc_emit.ml +++ b/test/doc_emit.ml @@ -86,7 +86,7 @@ module Html_module = struct ~data ~source_link () in H.emit_page ~options ~pages:NMap.empty m - |> Format.asprintf "%a" Html.Default.emit_pretty + |> Format.asprintf "%a" Illuaminate.Html.emit_pretty |> (fun x -> CCString.replace ~sub:date ~by:"xxxx-xx-xx" x) |> Format.pp_print_string out end diff --git a/test/dune b/test/dune index 3aa75a93..19877ea5 100644 --- a/test/dune +++ b/test/dune @@ -38,7 +38,6 @@ alcotest fmt qcheck-core - html unix) (deps (source_tree data))