manual: new consistency test for cross-references

7 files changed, 284 insertions, 3 deletions

diff --git a/manual/Makefile b/manual/Makefile
index 3737493386..d866494dcd 100644
--- a/manual/Makefile
+++ b/manual/Makefile
@@ -1,5 +1,6 @@
 all: tools
 	cd manual; ${MAKE} all
+	${MAKE} tests
 #	cd fpcl; ${MAKE} all
 
 clean:
@@ -24,3 +25,8 @@ pregen-etex: tools
 # pregen builds both .etex files and the documentation of the standard library
 pregen: tools
 	cd manual; $(MAKE) files
+
+# test the consistency of the manual and the compiler source
+.PHONY:tests
+tests:
+	${MAKE} -C tests all
diff --git a/manual/README.md b/manual/README.md
index 3ffe4052ac..30e580881b 100644
--- a/manual/README.md
+++ b/manual/README.md
@@ -219,3 +219,9 @@ when this extension is used `@` characters must be escaped as `\@`.
 This extension is used mainly in the language reference part of the manual.
 and a more complete description of the notation used is available in the
 first subsection of `refman/refman.etex`.
+
+Consistency tests
+-----------------
+
+The `tests` folder contains consistency tests that checks that the manual
+and the rest of the compiler sources stay synced.
diff --git a/manual/manual/library/Makefile b/manual/manual/library/Makefile
index a64a7d943d..6e8fea293b 100644
--- a/manual/manual/library/Makefile
+++ b/manual/manual/library/Makefile
@@ -53,7 +53,6 @@ VPATH=.:$(CSLDIR)/stdlib:$(CSLDIR)/parsing:$(CSLDIR)/otherlibs/unix:$(CSLDIR)/ot
 
 etex-files: $(BLURB)
 all: libs
-	sh ./check-stdlib-modules $(CSLDIR)
 
 libs: $(FILES)
 
@@ -96,7 +95,7 @@ clean:
 
 .etex.tex: $(TEXQUOTE)
 	@$(TEXQUOTE) < $*.etex > $*.texquote_error.tex\
-	&& cp $*.texquote_error.tex $*.tex\
+	&& mv $*.texquote_error.tex $*.tex\
 	|| printf "Failure when generating %s\n" $*.tex
 
 
diff --git a/manual/tests/Makefile b/manual/tests/Makefile
new file mode 100644
index 0000000000..ff9fb720b6
--- /dev/null
+++ b/manual/tests/Makefile
@@ -0,0 +1,19 @@
+TOPDIR=$(abspath ../..)
+include $(TOPDIR)/Makefile.tools
+MANUAL=$(TOPDIR)/manual/manual
+
+.PHONY: all
+all: check-cross-references check-stdlib
+
+cross-reference-checker: cross_reference_checker.ml
+	$(OCAMLC) $(TOPDIR)/compilerlibs/ocamlcommon.cma -I $(TOPDIR)/parsing \
+         -I $(TOPDIR)/driver \
+        cross_reference_checker.ml -o cross-reference-checker
+
+check-cross-references: cross-reference-checker
+	$(OCAMLRUN) ./cross-reference-checker \
+	-auxfile $(MANUAL)/texstuff/manual.aux \
+        $(TOPDIR)/utils/warnings.ml
+
+check-stdlib:
+	./check-stdlib-modules $(TOPDIR)
diff --git a/manual/tests/README.md b/manual/tests/README.md
new file mode 100644
index 0000000000..31d2ab40fd
--- /dev/null
+++ b/manual/tests/README.md
@@ -0,0 +1,8 @@
+These tests have for objective to test the consistency between the manual and
+the rest of the compiler sources:
+
+- `cross_reference_checker.ml` checks that reference to the manual from the
+  compiler sources are still accurate.
+
+- `check-stdlib-modules` checks that all stdlib modules are linked from the
+  main entry of the stdlib in the manual: `manual/manual/library/stdlib.etex`
diff --git a/manual/manual/library/check-stdlib-modules b/manual/tests/check-stdlib-modules
index 4782ee4a15..fb056b4b30 100755
--- a/manual/manual/library/check-stdlib-modules
+++ b/manual/tests/check-stdlib-modules
@@ -12,7 +12,7 @@ for i in `cat $TMPDIR/stdlib-$$-modules`; do
   case $i in
     Camlinternal* | *Labels | Obj | Pervasives) continue;;
   esac
-  grep -q -e '"'$i'" & p\.~\\pageref{'$i'} &' stdlib.etex || {
+  grep -q -e '"'$i'" & p\.~\\pageref{'$i'} &' $1/manual/manual/library/stdlib.etex || {
     echo "Module $i is missing from stdlib.etex." >&2
     exitcode=2
   }
diff --git a/manual/tests/cross_reference_checker.ml b/manual/tests/cross_reference_checker.ml
new file mode 100644
index 0000000000..98eb598ddb
--- /dev/null
+++ b/manual/tests/cross_reference_checker.ml
@@ -0,0 +1,243 @@
+(** Check reference to manual section in ml files
+
+    [cross-reference-cheker -auxfile tex.aux src.ml ]
+    checks that all expression and let bindings in [src.ml] annotated
+    with [[@manual.ref "tex_label"]] are integer tuple literals, e.g
+    {[
+      let[@manual.ref "sec:major"] ref = 1, 1
+      (* or *)
+      let ref = (3 [@manual.ref "ch:pentatonic"])
+    ]}
+    and that their values are consistent with the computed references for the
+    payload labels (e.g "sec:major", "ch:pentatonic") present in the TeX
+    auxiliary file [tex.aux]
+
+*)
+
+
+(** {1 Error printing } *)
+type error =
+  | Reference_mismatch of
+      {loc:Location.t; label:string; ocaml:int list; tex:int list}
+  | Unknown_label of Location.t * string
+  | Tuple_expected of Location.t
+  | No_aux_file
+  | Wrong_attribute_payload of Location.t
+
+let pp_ref ppf = Format.pp_print_list ~pp_sep:( fun ppf () ->
+    Format.pp_print_string ppf ".") Format.pp_print_int ppf
+
+let print_error error =
+  Location.report_error Format.std_formatter @@ match error with
+  | Tuple_expected loc ->
+      Location.errorf ~loc
+        "Integer tuple expected after manual reference annotation@."
+  | Unknown_label (loc,label) ->
+    Location.errorf ~loc
+      "@[<hov>Unknown manual label:@ %s@]@." label
+  | Reference_mismatch r ->
+    Location.errorf ~loc:r.loc
+      "@[<v 2>References for label %S do not match:@,\
+       OCaml side %a,@,\
+       manual     %a@]@."
+      r.label
+      pp_ref r.ocaml
+      pp_ref r.tex
+  | No_aux_file ->
+      Location.errorf "No aux file provided@."
+  | Wrong_attribute_payload loc ->
+      Location.errorf ~loc "Wrong payload for \"@manual.ref\"@."
+
+
+(** {1 Main types} *)
+
+(** Maps of ocaml reference to manual labels *)
+module Refs = Map.Make(String)
+
+(** Reference extracted from TeX aux files *)
+type tex_reference =
+  { label: string;
+    pos: int list;
+    level: string
+  }
+
+type status = Ok | Bad | Unknown
+
+(** Reference extracted from OCaml source files *)
+type ml_reference = { loc: Location.t; pos: int list; status:status }
+
+(** {1 Consistency check } *)
+
+let check_consistency (ref:tex_reference) {loc; pos; _ } =
+  if ref.pos = pos then
+    { loc; pos; status = Ok }
+  else begin
+    print_error @@ Reference_mismatch {loc;label=ref.label;tex=ref.pos;ocaml=pos};
+    {loc; pos;  status = Bad }
+  end
+
+let rec check_final_status label error = function
+  | { status = Ok; _ } -> error
+  | { status = Bad; _ } -> true
+  | { status = Unknown; loc; _} ->
+      print_error (Unknown_label (loc,label));
+      true
+
+(** {1 Data extraction from TeX side} *)
+
+module TeX = struct
+
+  (** Read reference information from a line of the aux file *)
+  let scan s =
+    try
+      Scanf.sscanf s
+        "\\newlabel{%s@}{{%s@}{%_d}{%_s@}{%s@.%_s@}{%_s@}}"
+        (fun label position_string level ->
+           let pos =
+             List.map int_of_string (String.split_on_char '.' position_string) in
+           Some {label;level;pos} )
+    with
+    | Scanf.Scan_failure _ -> None
+    | Failure _ -> None
+
+  let check_line refs line =
+    match scan line with
+    | None -> refs
+    | Some ref ->
+        match Refs.find_opt ref.label refs with
+        | None -> refs
+        | Some l ->
+            Refs.add ref.label
+              (List.map (check_consistency ref)  l)
+              refs
+
+  let check_all aux refs =
+    let chan = open_in aux in
+    let rec lines refs =
+      let s = try Some (input_line chan)  with End_of_file -> None in
+      match s with
+      | None -> refs
+      | Some line ->
+          lines @@ check_line refs line in
+    let refs = lines refs in
+    close_in chan;
+    let error = Refs.fold (fun label ocaml_refs error ->
+        List.fold_left (check_final_status label) error ocaml_refs)
+        refs false in
+    if error then exit 2 else exit 0
+end
+
+(** {1 Extract references from Ocaml source files} *)
+module OCaml_refs = struct
+
+  let parse ppf sourcefile  =
+    Pparse.parse_implementation ppf ~tool_name:"manual_cross_reference_check"
+      sourcefile
+
+  (** search for an attribute [[@manual.ref "tex_label_name"]] *)
+  let manual_reference_attribute (s, payload) =
+    if s.Location.txt = "manual.ref" then
+      match payload with
+      | Parsetree.(
+          PStr [{pstr_desc= Pstr_eval
+                     ({ pexp_desc = Pexp_constant Pconst_string (s,_) },_) } ] ) ->
+          Some s
+      | _ -> print_error (Wrong_attribute_payload s.Location.loc);
+          Some "" (* triggers an error *)
+    else
+      None
+
+  let rec label_from_attributes = function
+    | [] -> None
+    | a :: q -> match manual_reference_attribute a with
+      | Some _ as x -> x
+      | None -> label_from_attributes q
+
+  let int e =
+    let open Parsetree in
+    match e.pexp_desc with
+    | Pexp_constant Pconst_integer (s, _ ) -> int_of_string s
+    | _ -> raise Exit
+
+  let int_list l =
+    try Some (List.map int l) with
+    | Exit -> None
+
+  (** We keep a list of OCaml-side references to the same label *)
+  let add_ref label ref refs =
+    let l = match Refs.find_opt label refs with
+      | None -> [ref]
+      | Some l -> ref :: l in
+    Refs.add label l refs
+
+  let inner_expr loc e =
+    let tuple_expected () = print_error (Tuple_expected loc) in
+    match e.Parsetree.pexp_desc with
+          | Parsetree.Pexp_tuple l ->
+              begin match int_list l with
+              | None -> tuple_expected (); []
+              | Some pos -> pos
+              end
+          | Parsetree.Pexp_constant Pconst_integer (n,_) ->
+              [int_of_string n]
+          | _ -> tuple_expected (); []
+
+  (** extract from [let[@manual.ref "label"] x= 1, 2] *)
+  let value_binding m iterator vb =
+    let open Parsetree in
+    begin match label_from_attributes vb.pvb_attributes with
+    | None -> ()
+    | Some label ->
+        let pos = inner_expr vb.pvb_loc vb.pvb_expr in
+        m := add_ref label {loc = vb.pvb_loc; pos; status = Unknown } !m
+    end;
+    iterator.Ast_iterator.expr iterator vb.pvb_expr
+
+
+  (** extract from [ (1,2)[@manual.ref "label"]] *)
+  let expr m iterator e =
+    let open Parsetree in
+    begin match label_from_attributes e.pexp_attributes with
+    | None -> ()
+    | Some label ->
+        let pos = inner_expr e.pexp_loc e in
+        m := add_ref label {loc = e.pexp_loc; pos; status = Unknown } !m
+    end;
+    Ast_iterator.default_iterator.expr iterator e
+
+  let from_ast m ast =
+    let iterator =
+      let value_binding = value_binding m in
+      let expr = expr m in
+      Ast_iterator.{ default_iterator with value_binding; expr } in
+    iterator.structure iterator ast
+
+  let from_file m f =
+    from_ast m @@ parse Format.std_formatter f
+end
+
+
+(** {1 Argument handling and main function } *)
+
+let usage =
+  "cross-reference-check -auxfile [file.aux] file_1 ... file_n checks that \
+   the cross reference annotated with [@manual_cross_reference] are consistent \
+   with the provided auxiliary TeX file"
+
+(** the auxiliary file containing reference to be checked *)
+let aux_file = ref None
+
+let args =
+  [
+    "-auxfile",Arg.String (fun s -> aux_file := Some s),
+    "set the reference file"
+  ]
+
+let () =
+  let m = ref Refs.empty in
+  Arg.parse args (OCaml_refs.from_file m) usage;
+  match !aux_file with
+  | None -> print_error No_aux_file; exit 2
+  |  Some aux ->
+      let error = TeX.check_all aux !m  in
+      if error then exit 2 else exit 0