2860

Committed 26 Feb 2025 10:42AM UTC coverage: 73.427% (+0.06%) from 73.368%

Build # 2860

Build Type

Pull #1321

github

Committed by

web-flow

Commit Message

Merge 5bdc6f16b into b8c8d99e8

Pull Request Pull Request #1321: Remove unneeded code and unify "utils" modules

Run Details

56 of 77 new or added lines in 12 files covered. (72.73%)

1 existing line in 1 file now uncovered.

10257 of 13969 relevant lines covered (73.43%)

9954.81 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

88.37

/src/document/codefmt.ml

open! Compat
open Types

type out = Source.t

module State = struct
  type t = {
    context : (out * Source.tag) Stack.t;
    mutable current : out;
    mutable ignore_all : int;
  }

  let create () = { context = Stack.create (); current = []; ignore_all = 0 }

  let push state elt =
    if state.ignore_all = 0 then state.current <- elt :: state.current

  let push_ignore state = state.ignore_all <- state.ignore_all + 1

  let pop_ignore state =
    state.ignore_all <-
      (if state.ignore_all > 0 then state.ignore_all - 1 else 0)

  let enter state tag =
    if state.ignore_all = 0 then (
      let previous_elt = state.current in
      Stack.push (previous_elt, tag) state.context;
      state.current <- [];
      ())

  let leave state =
    if state.ignore_all = 0 then (
      let current_elt = List.rev state.current in
      let previous_elt, tag = Stack.pop state.context in
      state.current <- Tag (tag, current_elt) :: previous_elt;
      ())

  let rec flush state =
    if Stack.is_empty state.context then List.rev state.current
    else (
      leave state;
      flush state)
end

let rec compute_length_source (t : Types.Source.t) : int =
  let f (acc : int) = function
    | Types.Source.Elt t -> acc + compute_length_inline t
    | Types.Source.Tag (_, t) -> acc + compute_length_source t
  in
  List.fold_left f 0 t

and compute_length_inline (t : Types.Inline.t) : int =
  let f (acc : int) { Types.Inline.desc; _ } =
    match desc with
    | Text s -> acc + String.length s
    | Entity _e -> acc + 1
    | Linebreak -> 0 (* TODO *)
    | Styled (_, t) | Link { content = t; _ } -> acc + compute_length_inline t
    | Source s -> acc + compute_length_source s
    | Math _ -> assert false
    | Raw_markup _ -> assert false
    (* TODO *)
  in
  List.fold_left f 0 t

(** Modern implementation using semantic tags, Only for 4.08+ *)

(*
module Tag = struct

  type Format.stag +=
    | Elt of Inline.t
    | Tag of Source.tag
    | Ignore

  let setup_tags formatter state0 =
    let stag_functions =
      let mark_open_stag = function
        | Elt elt -> State.push state0 (Elt elt); ""
        | Tag tag -> State.enter state0 tag; ""
        | Format.String_tag "" -> State.enter state0 None; ""
        | Format.String_tag tag -> State.enter state0 (Some tag); ""
        | Ignore -> State.push_ignore state0; ""
        | _ -> ""
      and mark_close_stag = function
        | Elt _ -> ""
        | Tag _
        | Format.String_tag _ -> State.leave state0; ""
        | Ignore -> State.pop_ignore state0; ""
        | _ -> ""
      in {Format.
        print_open_stag = (fun _ -> ());
        print_close_stag = (fun _ -> ());
        mark_open_stag; mark_close_stag;
      }
    in
    Format.pp_set_tags formatter true;
    Format.pp_set_formatter_stag_functions formatter stag_functions;
    ()

  let elt ppf elt =
    Format.pp_open_stag ppf (Elt elt);
    Format.pp_print_as ppf (compute_length_inline elt) "";
    Format.pp_close_stag ppf ()

  let ignore ppf txt =
    Format.pp_open_stag ppf Ignore;
    Format.fprintf ppf "%t" txt;
    Format.pp_close_stag ppf ()
end
*)

(** Ugly terrible implementation of Format Semantic tags for OCaml < 4.08.
    Please get rid of it as soon as possible. *)
module Tag = struct
  let setup_tags formatter state0 =
    let tag_functions =
      let get_tag s =
        let prefix_tag = "tag:" and prefix_ignore = "ignore-tag" in
        let l = String.length prefix_tag in
        if String.length s > l && String.sub s 0 l = prefix_tag then
          let elt : Inline.t = Marshal.from_string s l in
          `Elt elt
        else if s = prefix_ignore then `Ignore
        else `String s
      in
      let mark_open_tag s =
        match get_tag s with
        | `Ignore ->
            State.push_ignore state0;
            ""
        | `Elt elt ->
            State.push state0 (Elt elt);
            ""
        | `String "" ->
            State.enter state0 None;
            ""
        | `String tag ->
            State.enter state0 (Some tag);
            ""
      and mark_close_tag s =
        match get_tag s with
        | `Ignore ->
            State.pop_ignore state0;
            ""
        | `Elt _ -> ""
        | `String _ ->
            State.leave state0;
            ""
      in
      {
        Format.print_open_tag = (fun _ -> ());
        print_close_tag = (fun _ -> ());
        mark_open_tag;
        mark_close_tag;
      }
    in
    Format.pp_set_tags formatter true;
    Format.pp_set_formatter_tag_functions formatter tag_functions;
    ()

  let elt ppf (elt : Inline.t) =
    Format.fprintf ppf "@{<tag:%s>%t@}" (Marshal.to_string elt []) (fun fmt ->
        Format.pp_print_as fmt (compute_length_inline elt) "")

  let ignore ppf txt = Format.fprintf ppf "@{<ignore-tag>%t@}" txt
end
[@@alert "-deprecated--deprecated"]

type t = Format.formatter -> unit

let make () =
  let open Inline in
  let state0 = State.create () in
  let push elt = State.push state0 (Elt elt) in
  let push_text s = if state0.ignore_all = 0 then push [ inline @@ Text s ] in

  let formatter =
    let out_string s i j = push_text (String.sub s i j) in
    let out_flush () = () in
    Format.make_formatter out_string out_flush
  in

  (* out_functions is only available in OCaml>=4.06 *)
  (* let out_functions = {Format.
   *   out_string = (fun i j s -> push_text @@ String.sub i j s );
   *   out_flush = (fun () -> ());
   *   out_newline = (fun () -> push [inline @@ Linebreak]);
   *   out_spaces = (fun n -> push_text (String.make n ' '));
   *   out_indent = (fun n -> push_text (String.make n ' '))
   * }
   * in
   * let formatter = Format.formatter_of_out_functions out_functions in *)
  Tag.setup_tags formatter state0;
  Format.pp_set_margin formatter 80;
  ( (fun () ->
      Format.pp_print_flush formatter ();
      State.flush state0),
    formatter )

let spf fmt =
  let flush, ppf = make () in
  Format.kfprintf (fun _ -> flush ()) ppf fmt

let pf = Format.fprintf

let elt t ppf = Tag.elt ppf t

let entity e ppf = elt [ inline @@ Inline.Entity e ] ppf

let ignore t ppf = Tag.ignore ppf t

let ( ++ ) f g ppf =
  f ppf;
  g ppf

let span ?(attr = "") f ppf = pf ppf "@{<%s>%t@}" attr f

let txt s ppf = Format.pp_print_string ppf s

let noop (_ : Format.formatter) = ()

let break i j ppf = Format.pp_print_break ppf i j

let cut = break 0 0

let sp = break 1 0

let rec list ?sep ~f = function
  | [] -> noop
  | [ x ] -> f x
  | x :: xs -> (
      let hd = f x in
      let tl = list ?sep ~f xs in
      match sep with None -> hd ++ tl | Some sep -> hd ++ sep ++ tl)

let box_hv t ppf = pf ppf "@[<hv 2>%t@]" t

let box_hv_no_indent t ppf = pf ppf "@[<hv 0>%t@]" t

let render f = spf "@[<hv 2>%t@]" (span f)

let code ?attr f = [ inline ?attr @@ Inline.Source (render f) ]

let documentedSrc f = [ DocumentedSrc.Code (render f) ]

let codeblock ?attr f =
  [ block ?attr @@ Block.Source (Comment.default_lang_tag, render f) ]

let keyword keyword ppf = pf ppf "@{<keyword>%s@}" keyword

module Infix = struct
  let ( ++ ) = ( ++ )
end

1	open! Compat
2	open Types
3
4	type out = Source.t
5
6	module 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 }	106,666✔
14
15	let push state elt =
16	if state.ignore_all = 0 then state.current <- elt :: state.current	5,374,157✔
17
18	let push_ignore state = state.ignore_all <- state.ignore_all + 1	5,307✔
19
20	let pop_ignore state =
21	state.ignore_all <-	5,307✔
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 (	923,894✔
26	let previous_elt = state.current in
27	Stack.push (previous_elt, tag) state.context;
28	state.current <- [];	923,894✔
29	())
30
31	let leave state =
32	if state.ignore_all = 0 then (	923,894✔
33	let current_elt = List.rev state.current in
34	let previous_elt, tag = Stack.pop state.context in	923,894✔
35	state.current <- Tag (tag, current_elt) :: previous_elt;	923,894✔
36	())
37
38	let rec flush state =
39	if Stack.is_empty state.context then List.rev state.current	106,666✔
40	else (	×
41	leave state;
42	flush state)	×
43	end
44
45	let rec compute_length_source (t : Types.Source.t) : int =
NEW 46	let f (acc : int) = function	×
NEW 47	\| Types.Source.Elt t -> acc + compute_length_inline t	×
NEW 48	\| Types.Source.Tag (_, t) -> acc + compute_length_source t	×
49	in
50	List.fold_left f 0 t
51
52	and compute_length_inline (t : Types.Inline.t) : int =
53	let f (acc : int) { Types.Inline.desc; _ } =	753,205✔
54	match desc with	753,205✔
55	\| Text s -> acc + String.length s	234,303✔
56	\| Entity _e -> acc + 1	357,546✔
NEW 57	\| Linebreak -> 0 (* TODO *)	×
NEW 58	\| Styled (_, t) \| Link { content = t; _ } -> acc + compute_length_inline t	×
NEW 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	(*
69	module 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 ()
110	end
111	*)
112
113	(** Ugly terrible implementation of Format Semantic tags for OCaml < 4.08.
114	Please get rid of it as soon as possible. *)
115	module Tag = struct
116	let setup_tags formatter state0 =
117	let tag_functions =	106,666✔
118	let get_tag s =
119	let prefix_tag = "tag:" and prefix_ignore = "ignore-tag" in	3,054,824✔
120	let l = String.length prefix_tag in
121	if String.length s > l && String.sub s 0 l = prefix_tag then	2,102,720✔
122	let elt : Inline.t = Marshal.from_string s l in	1,183,698✔
123	`Elt elt
124	else if s = prefix_ignore then `Ignore	10,614✔
125	else `String s	1,860,512✔
126	in
127	let mark_open_tag s =
128	match get_tag s with	1,527,412✔
129	\| `Ignore ->	5,307✔
130	State.push_ignore state0;
131	""	5,307✔
132	\| `Elt elt ->	591,849✔
133	State.push state0 (Elt elt);
134	""	591,849✔
135	\| `String "" ->	476,052✔
136	State.enter state0 None;
137	""	476,052✔
138	\| `String tag ->	454,204✔
139	State.enter state0 (Some tag);
140	""	454,204✔
141	and mark_close_tag s =
142	match get_tag s with	1,527,412✔
143	\| `Ignore ->	5,307✔
144	State.pop_ignore state0;
145	""	5,307✔
146	\| `Elt _ -> ""	591,849✔
147	\| `String _ ->	930,256✔
148	State.leave state0;
149	""	930,256✔
150	in
151	{
152	Format.print_open_tag = (fun _ -> ());	1,527,412✔
153	print_close_tag = (fun _ -> ());	1,527,412✔
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;	106,666✔
160	()	106,666✔
161
162	let elt ppf (elt : Inline.t) =
163	Format.fprintf ppf "@{<tag:%s>%t@}" (Marshal.to_string elt []) (fun fmt ->	591,849✔
164	Format.pp_print_as fmt (compute_length_inline elt) "")	591,849✔
165
166	let ignore ppf txt = Format.fprintf ppf "@{<ignore-tag>%t@}" txt	5,307✔
167	end
168	[@@alert "-deprecated--deprecated"]
169
170	type t = Format.formatter -> unit
171
172	let make () =
173	let open Inline in	106,666✔
174	let state0 = State.create () in
175	let push elt = State.push state0 (Elt elt) in	106,666✔
176	let push_text s = if state0.ignore_all = 0 then push [ inline @@ Text s ] in	4,784,273✔
177
178	let formatter =
179	let out_string s i j = push_text (String.sub s i j) in	4,824,319✔
180	let out_flush () = () in	106,666✔
181	Format.make_formatter out_string out_flush	106,666✔
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;	106,666✔
196	( (fun () ->	106,666✔
197	Format.pp_print_flush formatter ();	106,666✔
198	State.flush state0),	106,666✔
199	formatter )
200
201	let spf fmt =
202	let flush, ppf = make () in	106,666✔
203	Format.kfprintf (fun _ -> flush ()) ppf fmt	106,666✔
204
205	let pf = Format.fprintf
206
207	let elt t ppf = Tag.elt ppf t	591,849✔
208
209	let entity e ppf = elt [ inline @@ Inline.Entity e ] ppf	357,546✔
210
211	let ignore t ppf = Tag.ignore ppf t	5,307✔
212
213	let ( ++ ) f g ppf =
214	f ppf;	1,696,497✔
215	g ppf	1,696,497✔
216
217	let span ?(attr = "") f ppf = pf ppf "@{<%s>%t@}" attr f	476,052✔
218
219	let txt s ppf = Format.pp_print_string ppf s	761,945✔
220
221	let noop (_ : Format.formatter) = ()	15,778✔
222
223	let break i j ppf = Format.pp_print_break ppf i j	407,743✔
224
225	let cut = break 0 0	1,245✔
226
227	let sp = break 1 0	1,245✔
228
229	let rec list ?sep ~f = function
230	\| [] -> noop	3,066✔
231	\| [ x ] -> f x	55,517✔
232	\| x :: xs -> (	68,166✔
233	let hd = f x in
234	let tl = list ?sep ~f xs in	68,166✔
235	match sep with None -> hd ++ tl \| Some sep -> hd ++ sep ++ tl)	6✔
236
237	let box_hv t ppf = pf ppf "@[<hv 2>%t@]" t	501,120✔
238
239	let box_hv_no_indent t ppf = pf ppf "@[<hv 0>%t@]" t	8,867✔
240
241	let render f = spf "@[<hv 2>%t@]" (span f)	106,666✔
242
243	let code ?attr f = [ inline ?attr @@ Inline.Source (render f) ]	1,849✔
244
245	let documentedSrc f = [ DocumentedSrc.Code (render f) ]	23,487✔
246
247	let codeblock ?attr f =
248	[ block ?attr @@ Block.Source (Comment.default_lang_tag, render f) ]	×
249
250	let keyword keyword ppf = pf ppf "@{<keyword>%s@}" keyword	25,848✔
251
252	module Infix = struct
253	let ( ++ ) = ( ++ )
254	end

ocaml / odoc / 2860

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous