package / ocaml-base-compiler.4.10.0 / manual / tests / cross_reference_checker.ml
1 (** Check reference to manual section in ml files
2
3 [cross-reference-cheker -auxfile tex.aux src.ml ]
4 checks that all expression and let bindings in [src.ml] annotated
5 with [[@manual.ref "tex_label"]] are integer tuple literals, e.g
6 {[
7 let[@manual.ref "sec:major"] ref = 1, 1
8 (* or *)
9 let ref = (3 [@manual.ref "ch:pentatonic"])
10 ]}
11 and that their values are consistent with the computed references for the
12 payload labels (e.g "sec:major", "ch:pentatonic") present in the TeX
13 auxiliary file [tex.aux]
14
15 *)
16
17
18 (** {1 Error printing } *)
19 type error =
20 | Reference_mismatch of
21 {loc:Location.t; label:string; ocaml:int list; tex:int list}
22 | Unknown_label of Location.t * string
23 | Tuple_expected of Location.t
24 | No_aux_file
25 | Wrong_attribute_payload of Location.t
26
27 let pp_ref ppf = Format.pp_print_list ~pp_sep:( fun ppf () ->
28 Format.pp_print_string ppf ".") Format.pp_print_int ppf
29
30 let print_error error =
31 Location.print_report Format.std_formatter @@ match error with
32 | Tuple_expected loc ->
33 Location.errorf ~loc
34 "Integer tuple expected after manual reference annotation@."
35 | Unknown_label (loc,label) ->
36 Location.errorf ~loc
37 "@[<hov>Unknown manual label:@ %s@]@." label
38 | Reference_mismatch r ->
39 Location.errorf ~loc:r.loc
40 "@[<v 2>References for label %S do not match:@,\
41 OCaml side %a,@,\
42 manual %a@]@."
43 r.label
44 pp_ref r.ocaml
45 pp_ref r.tex
46 | No_aux_file ->
47 Location.errorf "No aux file provided@."
48 | Wrong_attribute_payload loc ->
49 Location.errorf ~loc "Wrong payload for \"@manual.ref\"@."
50
51
52 (** {1 Main types} *)
53
54 (** Maps of ocaml reference to manual labels *)
55 module Refs = Map.Make(String)
56
57 (** Reference extracted from TeX aux files *)
58 type tex_reference =
59 { label: string;
60 pos: int list;
61 level: string
62 }
63
64 type status = Ok | Bad | Unknown
65
66 (** Reference extracted from OCaml source files *)
67 type ml_reference = { loc: Location.t; pos: int list; status:status }
68
69 (** {1 Consistency check } *)
70
71 let check_consistency (ref:tex_reference) {loc; pos; _ } =
72 if ref.pos = pos then
73 { loc; pos; status = Ok }
74 else begin
75 print_error @@ Reference_mismatch {loc;label=ref.label;tex=ref.pos;ocaml=pos};
76 {loc; pos; status = Bad }
77 end
78
79 let rec check_final_status label error = function
80 | { status = Ok; _ } -> error
81 | { status = Bad; _ } -> true
82 | { status = Unknown; loc; _} ->
83 print_error (Unknown_label (loc,label));
84 true
85
86 (** {1 Data extraction from TeX side} *)
87
88 module TeX = struct
89
90 (** Read reference information from a line of the aux file *)
91 let scan s =
92 try
93 Scanf.sscanf s
94 "\\newlabel{%s@}{{%s@}{%_d}{%_s@}{%s@.%_s@}{%_s@}}"
95 (fun label position_string level ->
96 let pos =
97 List.map int_of_string (String.split_on_char '.' position_string) in
98 Some {label;level;pos} )
99 with
100 | Scanf.Scan_failure _ -> None
101 | Failure _ -> None
102
103 let check_line refs line =
104 match scan line with
105 | None -> refs
106 | Some ref ->
107 match Refs.find_opt ref.label refs with
108 | None -> refs
109 | Some l ->
110 Refs.add ref.label
111 (List.map (check_consistency ref) l)
112 refs
113
114 let check_all aux refs =
115 let chan = open_in aux in
116 let rec lines refs =
117 let s = try Some (input_line chan) with End_of_file -> None in
118 match s with
119 | None -> refs
120 | Some line ->
121 lines @@ check_line refs line in
122 let refs = lines refs in
123 close_in chan;
124 let error = Refs.fold (fun label ocaml_refs error ->
125 List.fold_left (check_final_status label) error ocaml_refs)
126 refs false in
127 if error then exit 2 else exit 0
128 end
129
130 (** {1 Extract references from Ocaml source files} *)
131 module OCaml_refs = struct
132
133 let parse sourcefile =
134 Pparse.parse_implementation ~tool_name:"manual_cross_reference_check"
135 sourcefile
136
137 (** search for an attribute [[@manual.ref "tex_label_name"]] *)
138 let manual_reference_attribute attr =
139 let open Parsetree in
140 if attr.attr_name.Location.txt <> "manual.ref"
141 then None
142 else begin match attr.attr_payload with
143 | PStr [{pstr_desc= Pstr_eval
144 ({ pexp_desc = Pexp_constant Pconst_string (s,_) },_) } ] ->
145 Some s
146 | _ -> print_error (Wrong_attribute_payload attr.attr_loc);
147 Some "" (* triggers an error *)
148 end
149
150 let rec label_from_attributes = function
151 | [] -> None
152 | a :: q -> match manual_reference_attribute a with
153 | Some _ as x -> x
154 | None -> label_from_attributes q
155
156 let int e =
157 let open Parsetree in
158 match e.pexp_desc with
159 | Pexp_constant Pconst_integer (s, _ ) -> int_of_string s
160 | _ -> raise Exit
161
162 let int_list l =
163 try Some (List.map int l) with
164 | Exit -> None
165
166 (** We keep a list of OCaml-side references to the same label *)
167 let add_ref label ref refs =
168 let l = match Refs.find_opt label refs with
169 | None -> [ref]
170 | Some l -> ref :: l in
171 Refs.add label l refs
172
173 let inner_expr loc e =
174 let tuple_expected () = print_error (Tuple_expected loc) in
175 match e.Parsetree.pexp_desc with
176 | Parsetree.Pexp_tuple l ->
177 begin match int_list l with
178 | None -> tuple_expected (); []
179 | Some pos -> pos
180 end
181 | Parsetree.Pexp_constant Pconst_integer (n,_) ->
182 [int_of_string n]
183 | _ -> tuple_expected (); []
184
185 (** extract from [let[@manual.ref "label"] x= 1, 2] *)
186 let value_binding m iterator vb =
187 let open Parsetree in
188 begin match label_from_attributes vb.pvb_attributes with
189 | None -> ()
190 | Some label ->
191 let pos = inner_expr vb.pvb_loc vb.pvb_expr in
192 m := add_ref label {loc = vb.pvb_loc; pos; status = Unknown } !m
193 end;
194 iterator.Ast_iterator.expr iterator vb.pvb_expr
195
196
197 (** extract from [ (1,2)[@manual.ref "label"]] *)
198 let expr m iterator e =
199 let open Parsetree in
200 begin match label_from_attributes e.pexp_attributes with
201 | None -> ()
202 | Some label ->
203 let pos = inner_expr e.pexp_loc e in
204 m := add_ref label {loc = e.pexp_loc; pos; status = Unknown } !m
205 end;
206 Ast_iterator.default_iterator.expr iterator e
207
208 let from_ast m ast =
209 let iterator =
210 let value_binding = value_binding m in
211 let expr = expr m in
212 Ast_iterator.{ default_iterator with value_binding; expr } in
213 iterator.structure iterator ast
214
215 let from_file m f =
216 from_ast m @@ parse f
217 end
218
219
220 (** {1 Argument handling and main function } *)
221
222 let usage =
223 "cross-reference-check -auxfile [file.aux] file_1 ... file_n checks that \
224 the cross reference annotated with [@manual_cross_reference] are consistent \
225 with the provided auxiliary TeX file"
226
227 (** the auxiliary file containing reference to be checked *)
228 let aux_file = ref None
229
230 let args =
231 [
232 "-auxfile",Arg.String (fun s -> aux_file := Some s),
233 "set the reference file"
234 ]
235
236 let () =
237 let m = ref Refs.empty in
238 Arg.parse args (OCaml_refs.from_file m) usage;
239 match !aux_file with
240 | None -> print_error No_aux_file; exit 2
241 | Some aux ->
242 let error = TeX.check_all aux !m in
243 if error then exit 2 else exit 0
244