jon.recoil.org
this repo has no description
1module Html : sig
2 type t
3
4 val string_of_list : t list -> string
5
6 type attr
7
8 val a_class : string list -> attr
9 val code : a:attr list -> t list -> t
10 val span : a:attr list -> t list -> t
11 val div : a:attr list -> t list -> t
12 val txt : string -> t
13
14 module Unsafe : sig
15 val data : string -> t
16 end
17end = struct
18 type t = Raw of string | Txt of string | Concat of t list
19
20 let add_escape_string buf s =
21 (* https://discuss.ocaml.org/t/html-encoding-of-string/4289/4 *)
22 let add = Buffer.add_string buf in
23 let len = String.length s in
24 let max_idx = len - 1 in
25 let flush start i =
26 if start < len then Buffer.add_substring buf s start (i - start)
27 in
28 let rec loop start i =
29 if i > max_idx then flush start i
30 else
31 match String.get s i with
32 | '&' -> escape "&" start i
33 | '<' -> escape "<" start i
34 | '>' -> escape ">" start i
35 | '\'' -> escape "'" start i
36 | '"' -> escape """ start i
37 | '@' -> escape "@" start i
38 | _ -> loop start (i + 1)
39 and escape amperstr start i =
40 flush start i;
41 add amperstr;
42 let next = i + 1 in
43 loop next next
44 in
45 loop 0 0
46
47 let to_string t =
48 let buf = Buffer.create 16 in
49 let rec go = function
50 | Raw s -> Buffer.add_string buf s
51 | Txt s -> add_escape_string buf s
52 | Concat xs -> List.iter go xs
53 in
54 go t;
55 Buffer.contents buf
56
57 let string_of_list lst = to_string (Concat lst)
58
59 type attr = t
60
61 let a_class lst =
62 Concat [ Raw "class=\""; Txt (String.concat " " lst); Raw "\"" ]
63
64 let attrs = function [] -> Concat [] | xs -> Concat (Raw " " :: xs)
65
66 let block name ~a body =
67 let name = Raw name in
68 Concat
69 [ Raw "<"; name; attrs a; Raw ">"; Concat body; Raw "</"; name; Raw ">" ]
70
71 let code = block "code"
72 let span = block "span"
73 let div = block "div"
74 let txt s = Txt s
75
76 module Unsafe = struct
77 let data s = Raw s
78 end
79end
80
81let of_strings ~kind ~prefix_name ~name ~rhs ~typedecl_params ~doc =
82 let open Html in
83 let kind = code ~a:[ a_class [ "entry-kind" ] ] [ txt kind ]
84 and typedecl_params =
85 match typedecl_params with
86 | None -> []
87 | Some p ->
88 [
89 span
90 ~a:
91 [
92 a_class
93 [
94 (* the parameter of the typedecl are highlighted as if part of main entry name. *)
95 "entry-name";
96 ];
97 ]
98 [ txt (p ^ " ") ];
99 ]
100 and prefix_name =
101 match prefix_name with
102 | None -> []
103 | Some "" -> []
104 | Some prefix_name ->
105 [ span ~a:[ a_class [ "prefix-name" ] ] [ txt prefix_name ] ]
106 and name =
107 match name with
108 | Some name -> [ span ~a:[ a_class [ "entry-name" ] ] [ txt name ] ]
109 | None -> []
110 and rhs =
111 match rhs with
112 | None -> []
113 | Some rhs -> [ code ~a:[ a_class [ "entry-rhs" ] ] [ txt rhs ] ]
114 in
115 Html.string_of_list
116 [
117 kind;
118 code
119 ~a:[ a_class [ "entry-title" ] ]
120 (typedecl_params @ prefix_name @ name @ rhs);
121 div ~a:[ a_class [ "entry-comment" ] ] [ Unsafe.data doc ];
122 ]
123
124let kind_doc = "doc"
125let kind_typedecl = "type"
126let kind_module = "mod"
127let kind_exception = "exn"
128let kind_class_type = "class"
129let kind_class = "class"
130let kind_method = "meth"
131let kind_extension_constructor = "cons"
132let kind_module_type = "sig"
133let kind_constructor = "cons"
134let kind_field = "field"
135let kind_value = "val"
136let kind_extension = "ext"