jon.recoil.org
this repo has no description
1open! Compat
2open Types
3
4type out = Source.t
5
6module State = struct
7 type t = {
8 context : (out * Source.tag) Stack.t;
9 mutable current : out;
10 mutable ignore_all : int;
11 }
12
13 let create () = { context = Stack.create (); current = []; ignore_all = 0 }
14
15 let push state elt =
16 if state.ignore_all = 0 then state.current <- elt :: state.current
17
18 let push_ignore state = state.ignore_all <- state.ignore_all + 1
19
20 let pop_ignore state =
21 state.ignore_all <-
22 (if state.ignore_all > 0 then state.ignore_all - 1 else 0)
23
24 let enter state tag =
25 if state.ignore_all = 0 then (
26 let previous_elt = state.current in
27 Stack.push (previous_elt, tag) state.context;
28 state.current <- [];
29 ())
30
31 let leave state =
32 if state.ignore_all = 0 then (
33 let current_elt = List.rev state.current in
34 let previous_elt, tag = Stack.pop state.context in
35 state.current <- Tag (tag, current_elt) :: previous_elt;
36 ())
37
38 let rec flush state =
39 if Stack.is_empty state.context then List.rev state.current
40 else (
41 leave state;
42 flush state)
43end
44
45let rec compute_length_source (t : Types.Source.t) : int =
46 let f (acc : int) = function
47 | Types.Source.Elt t -> acc + compute_length_inline t
48 | Types.Source.Tag (_, t) -> acc + compute_length_source t
49 in
50 List.fold_left f 0 t
51
52and compute_length_inline (t : Types.Inline.t) : int =
53 let f (acc : int) { Types.Inline.desc; _ } =
54 match desc with
55 | Text s -> acc + String.length s
56 | Entity _e -> acc + 1
57 | Linebreak -> 0 (* TODO *)
58 | Styled (_, t) | Link { content = t; _ } -> acc + compute_length_inline t
59 | Source s -> acc + compute_length_source s
60 | Math _ -> assert false
61 | Raw_markup _ -> assert false
62 (* TODO *)
63 in
64 List.fold_left f 0 t
65
66(** Modern implementation using semantic tags, Only for 4.08+ *)
67
68(*
69module Tag = struct
70
71 type Format.stag +=
72 | Elt of Inline.t
73 | Tag of Source.tag
74 | Ignore
75
76 let setup_tags formatter state0 =
77 let stag_functions =
78 let mark_open_stag = function
79 | Elt elt -> State.push state0 (Elt elt); ""
80 | Tag tag -> State.enter state0 tag; ""
81 | Format.String_tag "" -> State.enter state0 None; ""
82 | Format.String_tag tag -> State.enter state0 (Some tag); ""
83 | Ignore -> State.push_ignore state0; ""
84 | _ -> ""
85 and mark_close_stag = function
86 | Elt _ -> ""
87 | Tag _
88 | Format.String_tag _ -> State.leave state0; ""
89 | Ignore -> State.pop_ignore state0; ""
90 | _ -> ""
91 in {Format.
92 print_open_stag = (fun _ -> ());
93 print_close_stag = (fun _ -> ());
94 mark_open_stag; mark_close_stag;
95 }
96 in
97 Format.pp_set_tags formatter true;
98 Format.pp_set_formatter_stag_functions formatter stag_functions;
99 ()
100
101 let elt ppf elt =
102 Format.pp_open_stag ppf (Elt elt);
103 Format.pp_print_as ppf (compute_length_inline elt) "";
104 Format.pp_close_stag ppf ()
105
106 let ignore ppf txt =
107 Format.pp_open_stag ppf Ignore;
108 Format.fprintf ppf "%t" txt;
109 Format.pp_close_stag ppf ()
110end
111*)
112
113(** Ugly terrible implementation of Format Semantic tags for OCaml < 4.08.
114 Please get rid of it as soon as possible. *)
115module Tag = struct
116 let setup_tags formatter state0 =
117 let tag_functions =
118 let get_tag s =
119 let prefix_tag = "tag:" and prefix_ignore = "ignore-tag" in
120 let l = String.length prefix_tag in
121 if String.length s > l && String.sub s 0 l = prefix_tag then
122 let elt : Inline.t = Marshal.from_string s l in
123 `Elt elt
124 else if s = prefix_ignore then `Ignore
125 else `String s
126 in
127 let mark_open_tag s =
128 match get_tag s with
129 | `Ignore ->
130 State.push_ignore state0;
131 ""
132 | `Elt elt ->
133 State.push state0 (Elt elt);
134 ""
135 | `String "" ->
136 State.enter state0 None;
137 ""
138 | `String tag ->
139 State.enter state0 (Some tag);
140 ""
141 and mark_close_tag s =
142 match get_tag s with
143 | `Ignore ->
144 State.pop_ignore state0;
145 ""
146 | `Elt _ -> ""
147 | `String _ ->
148 State.leave state0;
149 ""
150 in
151 {
152 Format.print_open_tag = (fun _ -> ());
153 print_close_tag = (fun _ -> ());
154 mark_open_tag;
155 mark_close_tag;
156 }
157 in
158 Format.pp_set_tags formatter true;
159 Format.pp_set_formatter_tag_functions formatter tag_functions;
160 ()
161
162 let elt ppf (elt : Inline.t) =
163 Format.fprintf ppf "@{<tag:%s>%t@}" (Marshal.to_string elt []) (fun fmt ->
164 Format.pp_print_as fmt (compute_length_inline elt) "")
165
166 let ignore ppf txt = Format.fprintf ppf "@{<ignore-tag>%t@}" txt
167end
168[@@alert "-deprecated--deprecated"]
169
170type t = Format.formatter -> unit
171
172let make () =
173 let open Inline in
174 let state0 = State.create () in
175 let push elt = State.push state0 (Elt elt) in
176 let push_text s = if state0.ignore_all = 0 then push [ inline @@ Text s ] in
177
178 let formatter =
179 let out_string s i j = push_text (String.sub s i j) in
180 let out_flush () = () in
181 Format.make_formatter out_string out_flush
182 in
183
184 (* out_functions is only available in OCaml>=4.06 *)
185 (* let out_functions = {Format.
186 * out_string = (fun i j s -> push_text @@ String.sub i j s );
187 * out_flush = (fun () -> ());
188 * out_newline = (fun () -> push [inline @@ Linebreak]);
189 * out_spaces = (fun n -> push_text (String.make n ' '));
190 * out_indent = (fun n -> push_text (String.make n ' '))
191 * }
192 * in
193 * let formatter = Format.formatter_of_out_functions out_functions in *)
194 Tag.setup_tags formatter state0;
195 Format.pp_set_margin formatter 80;
196 ( (fun () ->
197 Format.pp_print_flush formatter ();
198 State.flush state0),
199 formatter )
200
201let spf fmt =
202 let flush, ppf = make () in
203 Format.kfprintf (fun _ -> flush ()) ppf fmt
204
205let pf = Format.fprintf
206
207let elt t ppf = Tag.elt ppf t
208
209let entity e ppf = elt [ inline @@ Inline.Entity e ] ppf
210
211let ignore t ppf = Tag.ignore ppf t
212
213let ( ++ ) f g ppf =
214 f ppf;
215 g ppf
216
217let span ?(attr = "") f ppf = pf ppf "@{<%s>%t@}" attr f
218
219let txt s ppf = Format.pp_print_string ppf s
220
221let noop (_ : Format.formatter) = ()
222
223let break i j ppf = Format.pp_print_break ppf i j
224
225let cut = break 0 0
226
227let sp = break 1 0
228
229let rec list ?sep ~f = function
230 | [] -> noop
231 | [ x ] -> f x
232 | x :: xs -> (
233 let hd = f x in
234 let tl = list ?sep ~f xs in
235 match sep with None -> hd ++ tl | Some sep -> hd ++ sep ++ tl)
236
237let box_hv t ppf = pf ppf "@[<hv 2>%t@]" t
238
239let box_hv_no_indent t ppf = pf ppf "@[<hv 0>%t@]" t
240
241let render f = spf "@[<hv 2>%t@]" (span f)
242
243let code ?attr f = [ inline ?attr @@ Inline.Source (render f) ]
244
245let documentedSrc f = [ DocumentedSrc.Code (render f) ]
246
247let codeblock ?attr f =
248 [ block ?attr @@ Block.Source (Comment.default_lang_tag, [], [], render f, []) ]
249
250let keyword keyword ppf = pf ppf "@{<keyword>%s@}" keyword
251
252let mode mode ppf = pf ppf "@{<mode>%s@}" mode
253
254module Infix = struct
255 let ( ++ ) = ( ++ )
256end