flambda-backend: Move code between Printast and Pprintast (#2194)

* Revert "Pprintast now depends on Printast"

This reverts commit bdac10c.

That commit was part of #1417, but ended up getting squashed
in a rebase. Why revert? Because it's hard to upstream this
change, due to the new dependency of the tyvar printer on the
lexer. This can be disentangled, but doing so would be disruptive
for little gain. So I'm just undoing this unforced little cleanup,
which isn't so important anyway.

* Fix the build

Author: goldfirere

.depend

@@ -262,13 +262,13 @@
     (location.mli as compiler-libs/location.mli)
     (longident.mli as compiler-libs/longident.mli)
     (docstrings.mli as compiler-libs/docstrings.mli)
-    (printast.mli as compiler-libs/printast.mli)
     (syntaxerr.mli as compiler-libs/syntaxerr.mli)
     (ast_helper.mli as compiler-libs/ast_helper.mli)
     (camlinternalMenhirLib.mli as compiler-libs/camlinternalMenhirLib.mli)
     (parser.mli as compiler-libs/parser.mli)
     (lexer.mli as compiler-libs/lexer.mli)
     (parse.mli as compiler-libs/parse.mli)
+    (printast.mli as compiler-libs/printast.mli)
     (pprintast.mli as compiler-libs/pprintast.mli)
     (ast_mapper.mli as compiler-libs/ast_mapper.mli)
     (ast_iterator.mli as compiler-libs/ast_iterator.mli)

boot/ocamlc

@@ -104,3 +104,53 @@ let constr_ident= wrap Parser.parse_constr_longident
 let extended_module_path = wrap Parser.parse_mod_ext_longident
 let simple_module_path = wrap Parser.parse_mod_longident
 let type_ident = wrap Parser.parse_mty_longident
+
+(* Error reporting for Syntaxerr *)
+(* The code has been moved here so that one can reuse Pprintast.tyvar *)
+
+let prepare_error err =
+  let open Syntaxerr in
+  match err with
+  | Unclosed(opening_loc, opening, closing_loc, closing) ->
+      Location.errorf
+        ~loc:closing_loc
+        ~sub:[
+          Location.msg ~loc:opening_loc
+            "This '%s' might be unmatched" opening
+        ]
+        "Syntax error: '%s' expected" closing
+
+  | Expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s expected." nonterm
+  | Not_expecting (loc, nonterm) ->
+      Location.errorf ~loc "Syntax error: %s not expected." nonterm
+  | Applicative_path loc ->
+      Location.errorf ~loc
+        "Syntax error: applicative paths of the form F(X).t \
+         are not supported when the option -no-app-func is set."
+  | Variable_in_scope (loc, var) ->
+      Location.errorf ~loc
+        "In this scoped type, variable %a \
+         is reserved for the local type %s."
+        Pprintast.tyvar var var
+  | Other loc ->
+      Location.errorf ~loc "Syntax error"
+  | Ill_formed_ast (loc, s) ->
+      Location.errorf ~loc
+        "broken invariant in parsetree: %s" s
+  | Invalid_package_type (loc, s) ->
+      Location.errorf ~loc "invalid package type: %s" s
+  | Removed_string_set loc ->
+    Location.errorf ~loc
+      "Syntax error: strings are immutable, there is no assignment \
+       syntax for them.\n\
+       @{<hint>Hint@}: Mutable sequences of bytes are available in \
+       the Bytes module.\n\
+       @{<hint>Hint@}: Did you mean to use 'Bytes.set'?"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Syntaxerr.Error err -> Some (prepare_error err)
+      | _ -> None
+    )

dune

@@ -288,7 +288,14 @@ let iter_loc f ctxt {txt; loc = _} = f ctxt txt
 
 let constant_string f s = pp f "%S" s
 
-let tyvar = Printast.tyvar
+let tyvar ppf s =
+  if String.length s >= 2 && s.[1] = '\'' then
+    (* without the space, this would be parsed as
+       a character literal *)
+    Format.fprintf ppf "' %s" s
+  else
+    Format.fprintf ppf "'%s" s
+
 let jkind_annotation = Jane_syntax.Layouts.Pprint.jkind_annotation
 
 let tyvar_jkind_loc ~print_quote f (str,jkind) =
@@ -301,6 +308,7 @@ let tyvar_jkind_loc ~print_quote f (str,jkind) =
   | None -> pptv f str.txt
   | Some lay -> Format.fprintf f "(%a : %a)" pptv str.txt jkind_annotation lay
 
+
 let tyvar_loc f str = tyvar f str.txt
 let string_quot f x = pp f "`%s" x
 

parsing/parse.ml

@@ -130,16 +130,10 @@ let arg_label i ppf = function
   | Optional s -> line i ppf "Optional \"%s\"\n" s
   | Labelled s -> line i ppf "Labelled \"%s\"\n" s
 
-let tyvar ppf s =
-  if String.length s >= 2 && s.[1] = '\'' then
-    (* without the space, this would be parsed as
-       a character literal *)
-    Format.fprintf ppf "' %s" s
-  else
-    Format.fprintf ppf "'%s" s
-
 let typevars ppf vs =
-  List.iter (fun x -> fprintf ppf " %a" tyvar x.txt) vs
+  List.iter (fun x -> fprintf ppf " '%s" x.txt) vs
+    (* Don't use Pprintast.tyvar, as that causes a dependency cycle with
+       Jane_syntax, which depends on this module for debugging. *)
 
 let rec core_type i ppf x =
   line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
@@ -991,4 +985,3 @@ let implementation ppf x = list 0 structure_item ppf x
 let top_phrase ppf x = toplevel_phrase 0 ppf x
 
 let constant = fmt_constant
-

parsing/pprintast.ml

@@ -35,6 +35,3 @@ val payload: int -> formatter -> payload -> unit
 val core_type: int -> formatter -> core_type -> unit
 val extension_constructor: int -> formatter -> extension_constructor -> unit
 
-val tyvar: Format.formatter -> string -> unit
-  (** Print a type variable name, taking care of the special treatment
-      required for the single quote character in second position. *)

parsing/printast.ml

@@ -43,49 +43,3 @@ let location_of_error = function
 
 let ill_formed_ast loc s =
   raise (Error (Ill_formed_ast (loc, s)))
-
-let prepare_error err =
-  match err with
-  | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      Location.errorf
-        ~loc:closing_loc
-        ~sub:[
-          Location.msg ~loc:opening_loc
-            "This '%s' might be unmatched" opening
-        ]
-        "Syntax error: '%s' expected" closing
-
-  | Expecting (loc, nonterm) ->
-      Location.errorf ~loc "Syntax error: %s expected." nonterm
-  | Not_expecting (loc, nonterm) ->
-      Location.errorf ~loc "Syntax error: %s not expected." nonterm
-  | Applicative_path loc ->
-      Location.errorf ~loc
-        "Syntax error: applicative paths of the form F(X).t \
-         are not supported when the option -no-app-func is set."
-  | Variable_in_scope (loc, var) ->
-      Location.errorf ~loc
-        "In this scoped type, variable %a \
-         is reserved for the local type %s."
-        Printast.tyvar var var
-  | Other loc ->
-      Location.errorf ~loc "Syntax error"
-  | Ill_formed_ast (loc, s) ->
-      Location.errorf ~loc
-        "broken invariant in parsetree: %s" s
-  | Invalid_package_type (loc, s) ->
-      Location.errorf ~loc "invalid package type: %s" s
-  | Removed_string_set loc ->
-    Location.errorf ~loc
-      "Syntax error: strings are immutable, there is no assignment \
-       syntax for them.\n\
-       @{<hint>Hint@}: Mutable sequences of bytes are available in \
-       the Bytes module.\n\
-       @{<hint>Hint@}: Did you mean to use 'Bytes.set'?"
-
-let () =
-  Location.register_error_of_exn
-    (function
-      | Error err -> Some (prepare_error err)
-      | _ -> None
-    )

parsing/printast.mli

@@ -85,7 +85,7 @@ ocamldep.opt$(EXE): $(call byte2native, $(OCAMLDEP))
 OCAMLPROF=config.cmo build_path_prefix_map.cmo misc.cmo identifiable.cmo \
   numbers.cmo arg_helper.cmo clflags.cmo debug.cmo terminfo.cmo \
   warnings.cmo location.cmo longident.cmo docstrings.cmo \
-  printast.cmo syntaxerr.cmo ast_helper.cmo \
+  syntaxerr.cmo ast_helper.cmo \
   language_extension_kernel.cmo language_extension.cmo \
   jane_asttypes.cmo jane_syntax_parsing.cmo jane_syntax.cmo \
    ast_iterator.cmo builtin_attributes.cmo \

parsing/syntaxerr.ml

@@ -311,7 +311,7 @@ let rec print_list pr sep ppf =
 let pr_present =
   print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
 
-let pr_var = Printast.tyvar
+let pr_var = Pprintast.tyvar
 let ty_var ~non_gen ppf s =
   pr_var ppf (if non_gen then "_" ^ s else s)
 

tools/Makefile

@@ -145,7 +145,7 @@ let arg_label i ppf = function
 let typevar_jkind ~print_quote ppf (v, l) =
   let pptv =
     if print_quote
-    then Printast.tyvar
+    then Pprintast.tyvar
     else fun ppf s -> fprintf ppf "%s" s
   in
   match l with

typing/oprint.ml

@@ -2943,7 +2943,7 @@ let report_error ppf = function
             fprintf ppf "an unnamed existential variable"
         | Some str ->
             fprintf ppf "the existential variable %a"
-              Printast.tyvar str in
+              Pprintast.tyvar str in
       fprintf ppf "@[This type cannot be unboxed because@ \
                    it might contain both float and non-float values,@ \
                    depending on the instantiation of %a.@ \

typing/printtyped.ml

@@ -1381,7 +1381,7 @@ let report_error env ppf = function
         but is here applied to %i argument(s)@]"
       longident lid expected provided
   | Bound_type_variable name ->
-    fprintf ppf "Already bound type parameter %a" Printast.tyvar name
+    fprintf ppf "Already bound type parameter %a" Pprintast.tyvar name
   | Recursive_type ->
     fprintf ppf "This type is recursive"
   | Unbound_row_variable lid ->
@@ -1437,7 +1437,7 @@ let report_error env ppf = function
   | Cannot_quantify (name, reason) ->
       fprintf ppf
         "@[<hov>The universal type variable %a cannot be generalized:@ "
-        Printast.tyvar name;
+        Pprintast.tyvar name;
       begin match reason with
       | Unified v ->
         fprintf ppf "it is bound to@ %a" Printtyp.type_expr v
@@ -1451,7 +1451,7 @@ let report_error env ppf = function
       fprintf ppf
         "@[<hov>The universal type variable %a was %s to have@ \
          layout %a, but was inferred to have %t.@]"
-        Printast.tyvar name
+        Pprintast.tyvar name
         (if jkind_info.defaulted then "defaulted" else "declared")
         Jkind.format jkind_info.original_jkind
         (fun ppf -> match Jkind.get inferred_jkind with