Source file oprint.ml

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Projet Cristal, INRIA Rocquencourt                   *)
(*                                                                        *)
(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Format_doc
open Outcometree

exception Ellipsis

let cautious f ppf arg =
  try f ppf arg with
    Ellipsis -> fprintf ppf "..."

let print_lident ppf = function
  | "::" -> pp_print_string ppf "(::)"
  | s when Lexer.is_keyword s -> fprintf ppf "\\#%s" s
  | s -> pp_print_string ppf s

let rec print_ident ppf =
  function
    Oide_ident s -> print_lident ppf s.printed_name
  | Oide_dot (id, s) ->
      print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
  | Oide_apply (id1, id2) ->
      fprintf ppf "%a(%a)" print_ident id1 print_ident id2
  | Oide_hash id ->
      print_ident ppf id; pp_print_char ppf '#'

let out_ident = ref print_ident

(* Check a character matches the [identchar_latin1] class from the lexer *)
let is_ident_char c =
  match c with
  | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246'
  | '\248'..'\255' | '\'' | '0'..'9' -> true
  | _ -> false

let all_ident_chars s =
  let rec loop s len i =
    if i < len then begin
      if is_ident_char s.[i] then loop s len (i+1)
      else false
    end else begin
      true
    end
  in
  let len = String.length s in
  loop s len 0

let parenthesized_ident name =
  (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
  || not (all_ident_chars name)

let value_ident ppf name =
  if parenthesized_ident name then
    fprintf ppf "( %s )" name
  else if Lexer.is_keyword name then
    fprintf ppf "\\#%s" name
  else
    pp_print_string ppf name

(* Values *)

let valid_float_lexeme s =
  let l = String.length s in
  let rec loop i =
    if i >= l then s ^ "." else
    match s.[i] with
    | '0' .. '9' | '-' -> loop (i+1)
    | _ -> s
  in loop 0

let float_repres f =
  match classify_float f with
    FP_nan -> "nan"
  | FP_infinite ->
      if f < 0.0 then "neg_infinity" else "infinity"
  | _ ->
      let float_val =
        let s1 = Printf.sprintf "%.12g" f in
        if f = float_of_string s1 then s1 else
        let s2 = Printf.sprintf "%.15g" f in
        if f = float_of_string s2 then s2 else
        Printf.sprintf "%.18g" f
      in valid_float_lexeme float_val

let parenthesize_if_neg ppf fmt v isneg =
  if isneg then pp_print_char ppf '(';
  fprintf ppf fmt v;
  if isneg then pp_print_char ppf ')'

let escape_string s =
  (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\'
     and '"' *)
   let n = ref 0 in
  for i = 0 to String.length s - 1 do
    n := !n +
      (match String.unsafe_get s i with
       | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
       | '\x00' .. '\x1F'
       | '\x7F' -> 4
       | _ -> 1)
  done;
  if !n = String.length s then s else begin
    let s' = Bytes.create !n in
    n := 0;
    for i = 0 to String.length s - 1 do
      begin match String.unsafe_get s i with
      | ('\"' | '\\') as c ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c
      | '\n' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n'
      | '\t' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't'
      | '\r' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r'
      | '\b' ->
          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b'
      | '\x00' .. '\x1F' | '\x7F' as c ->
          let a = Char.code c in
          Bytes.unsafe_set s' !n '\\';
          incr n;
          Bytes.unsafe_set s' !n (Char.chr (48 + a / 100));
          incr n;
          Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10));
          incr n;
          Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10));
      | c -> Bytes.unsafe_set s' !n c
      end;
      incr n
    done;
    Bytes.to_string s'
  end

let rec print_typlist print_elem sep ppf =
  function
    [] -> ()
  | [ty] -> print_elem ppf ty
  | ty :: tyl ->
      print_elem ppf ty;
      pp_print_string ppf sep;
      pp_print_space ppf ();
      print_typlist print_elem sep ppf tyl

let print_label_type ppf =
  function
  | Some s ->
    pp_print_string ppf s;
    pp_print_string ppf ":";
  | None -> ()

let print_label ppf =
  function
  | Some s ->
    pp_print_string ppf "~";
    pp_print_string ppf s;
    pp_print_string ppf ":";
  | None -> ()

let rec print_labeled_typlist print_elem sep ppf =
  function
    [] -> ()
  | [label, ty] ->
      pp_open_box ppf 0;
      print_label_type ppf label;
      print_elem ppf ty;
      pp_close_box ppf ()
  | (label, ty) :: tyl ->
      pp_open_box ppf 0;
      print_label_type ppf label;
      print_elem ppf ty;
      pp_close_box ppf ();
      pp_print_string ppf sep;
      pp_print_space ppf ();
      print_labeled_typlist print_elem sep ppf tyl

let print_out_string ppf s =
  let not_escaped =
    (* let the user dynamically choose if strings should be escaped: *)
    match Sys.getenv_opt "OCAMLTOP_UTF_8" with
    | None -> true
    | Some x ->
        match bool_of_string_opt x with
        | None -> true
        | Some f -> f in
  if not_escaped then
    fprintf ppf "\"%s\"" (escape_string s)
  else
    fprintf ppf "%S" s

(* We cannot use the [float32] type in the compiler. *)
external float32_format : string -> Obj.t -> string = "caml_format_float32"

let float32_to_string f = Stdlib.valid_float_lexem (float32_format "%.9g" f)

let print_constr ppf name =
  match name with
  | Oide_ident {printed_name = ("true" | "false") as c} ->
    (* despite being keywords, these are constructor names
       and should not be escaped *)
    fprintf ppf "%s" c
  | _ -> print_ident ppf name

let print_out_value ppf tree =
  let rec print_tree_1 ppf =
    function
    | Oval_constr (name, [param]) ->
        fprintf ppf "@[<1>%a@ %a@]" print_constr name print_constr_param param
    | Oval_constr (name, (_ :: _ as params)) ->
        fprintf ppf "@[<1>%a@ (%a)@]" print_constr name
          (print_tree_list print_tree_1 ",") params
    | Oval_variant (name, Some param) ->
        fprintf ppf "@[<2>`%a@ %a@]" print_lident name print_constr_param param
    | Oval_lazy param ->
        fprintf ppf "@[<2>lazy@ %a@]" print_constr_param param
    | tree -> print_simple_tree ppf tree
  and print_constr_param ppf = function
    | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
    | Oval_int8 i -> parenthesize_if_neg ppf "%is" i (i < 0)
    | Oval_int16 i -> parenthesize_if_neg ppf "%iS" i (i < 0)
    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
    | Oval_float f ->
        parenthesize_if_neg ppf "%s" (float_repres f)
                                     (f < 0.0 || 1. /. f = neg_infinity)
    | Oval_float32 f ->
        let s = float32_to_string f in
        parenthesize_if_neg ppf "%ss" s (String.starts_with ~prefix:"-" s)
    | Oval_string (_,_, Ostr_bytes) as tree ->
      pp_print_char ppf '(';
      print_simple_tree ppf tree;
      pp_print_char ppf ')';
    | tree -> print_simple_tree ppf tree
  and print_simple_tree ppf =
    function
      Oval_int i -> fprintf ppf "%i" i
    | Oval_int8 i -> fprintf ppf "%is" i
    | Oval_int16 i -> fprintf ppf "%iS" i
    | Oval_int32 i -> fprintf ppf "%lil" i
    | Oval_int64 i -> fprintf ppf "%LiL" i
    | Oval_nativeint i -> fprintf ppf "%nin" i
    | Oval_float f -> pp_print_string ppf (float_repres f)
    | Oval_float32 f -> fprintf ppf "%ss" (float32_to_string f)
    | Oval_char c -> fprintf ppf "%C" c
    | Oval_string (s, maxlen, kind) ->
       begin try
         let len = String.length s in
         let maxlen = max maxlen 8 in (* always show a little prefix *)
         let s = if len > maxlen then String.sub s 0 maxlen else s in
         begin match kind with
         | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s
         | Ostr_string -> print_out_string ppf s
         end;
         (if len > maxlen then
            fprintf ppf
              "... (* string length %d; truncated *)" len
         )
          with
          Invalid_argument _ (* "String.create" *)-> fprintf ppf "<huge string>"
        end
    | Oval_list tl ->
        fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
    | Oval_array (tl, am) ->
        let sigil = match am with
          | Mutable   -> '|'
          | Immutable -> ':'
        in
        fprintf ppf "@[<2>[%c%a%c]@]"
          sigil (print_tree_list print_tree_1 ";") tl sigil
    | Oval_constr (name, []) -> print_constr ppf name
    | Oval_variant (name, None) -> fprintf ppf "`%a" print_lident name
    | Oval_stuff s -> pp_print_string ppf s
    | Oval_record fel ->
        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
    | Oval_record_unboxed_product fel ->
        fprintf ppf "@[<1>#{%a}@]" (cautious (print_fields true)) fel
    | Oval_ellipsis -> raise Ellipsis
    | Oval_printer f -> f ppf
    | Oval_tuple tree_list ->
        fprintf ppf "@[<1>(%a)@]" (print_labeled_tree_list print_tree_1 ",") tree_list
    | Oval_unboxed_tuple tree_list ->
        fprintf ppf "@[<1>#(%a)@]" (print_labeled_tree_list print_tree_1 ",")
          tree_list
    | Oval_code e ->
        deprecated_printer (fun fmt -> CamlinternalQuote.Code.print fmt e) ppf
    | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
  and print_fields first ppf =
    function
      [] -> ()
    | (name, tree) :: fields ->
        if not first then fprintf ppf ";@ ";
        fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
          tree;
        print_fields false ppf fields
  and print_tree_list print_item sep ppf tree_list =
    let rec print_list first ppf =
      function
        [] -> ()
      | tree :: tree_list ->
          if not first then fprintf ppf "%s@ " sep;
          print_item ppf tree;
          print_list false ppf tree_list
    in
    cautious (print_list true) ppf tree_list
  and print_labeled_tree_list print_item sep ppf labeled_tree_list =
    let rec print_list first ppf =
      function
        [] -> ()
      | (label, tree) :: labeled_tree_list ->
          if not first then fprintf ppf "%s@ " sep;
          print_label ppf label;
          print_item ppf tree;
          print_list false ppf labeled_tree_list
    in
    cautious (print_list true) ppf labeled_tree_list
  in
  cautious print_tree_1 ppf tree

let out_value = ref (compat print_out_value)

(* Types *)

let rec print_list_init pr sep ppf =
  function
    [] -> ()
  | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l

let rec print_list pr sep ppf =
  function
    [] -> ()
  | [a] -> pr ppf a
  | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l

let pr_present =
  print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")

let pr_var = Pprintast.Doc.tyvar
let ty_var ~non_gen ppf s =
  pr_var ppf (if non_gen then "_" ^ s else s)


(* NON-LEGACY MODES
  Here, we are printing mode annotations even if the mode extension is
  disabled. Mode extension being disabled means mode annotations are
  disallowed in parsing of this file, but non-legacy modes might still pop
  up. For example, the current file might cite values from other files that
  mention non-legacy modes *)
let print_out_mode = pp_print_string

let print_out_modes ppf l =
  (match l with
  | [] -> ()
  | _ -> pp_print_string ppf " @ ");
  pp_print_list ~pp_sep:pp_print_space print_out_mode ppf l

(* Labeled tuples with the first element labeled sometimes require parens. *)
let is_initially_labeled_tuple ty =
  match ty with
  | Otyp_tuple ((Some _, _) :: _) -> true
  | _ -> false

let print_out_modality = pp_print_string

let print_out_modalities ppf l =
  match l with
  | [] -> ()
  | _ ->
    pp_print_space ppf ();
    pp_print_string ppf "@@";
    pp_print_space ppf ();
    pp_print_list ~pp_sep:pp_print_space pp_print_string ppf l

let print_arg_label_and_out_type ppf (lbl : arg_label) ty ~print_type =
  match lbl with
  | Nolabel -> print_type ppf ty
  | Labelled l -> fprintf ppf "%a:%a" print_lident l print_type ty
  | Position l -> fprintf ppf "%a:[%%call_pos]" print_lident l
  | Optional l -> fprintf ppf "?%a:%a" print_lident l print_type ty

let rec print_out_type_0 ppf =
  function
  | Otyp_alias {non_gen; aliased; alias } ->
    fprintf ppf "@[%a@ as %a@]"
      print_out_type_0 aliased
      (ty_var ~non_gen) alias
  | Otyp_poly ([], ty) ->
      print_out_type_0 ppf ty  (* no "." if there are no vars *)
  | Otyp_newlayout ([], ty) ->
      print_out_type_0 ppf ty  (* no "." if there are no vars *)
  | Otyp_poly (sl, ty) ->
      fprintf ppf "@[<hov 2>%a.@ %a@]"
        pr_var_jkinds sl
        print_out_type_0 ty
  | Otyp_newlayout (sl, ty) ->
      fprintf ppf "@[<hov 2>layout_ %a.@ %a@]"
        pr_sort_univars sl
        print_out_type_0 ty
  | Otyp_repr ([], ty) ->
      print_out_type_0 ppf ty  (* no "." if there are no vars *)
  | Otyp_repr (sl, ty) ->
      fprintf ppf "@[<hov 2>%a.@ %a@]"
        pr_var_reprs sl
        print_out_type_0 ty
  | ty ->
      print_out_type_1 ppf ty

(* We must parenthesize a labeled tuple with the first element labeled when:
   - It is an argument to a function ([~arg])
   - Or, there is at least one mode to print.
 *)
and print_out_type_mode ~arg mode ppf ty =
  let parens =
    is_initially_labeled_tuple ty && arg
  in
  if parens then
    pp_print_char ppf '(';
  print_out_type_2 ppf ty;
  if parens then
    pp_print_char ppf ')';
  print_out_modes ppf mode

and print_out_type_1 ppf =
  function
  | Otyp_arrow (lab, am, ty1, ty2) ->
      pp_open_box ppf 0;
      print_arg_label_and_out_type ppf lab ty1 ~print_type:(print_out_arg am);
      pp_print_string ppf " ->";
      pp_print_space ppf ();
      print_out_ret ppf ty2;
      pp_close_box ppf ()
  | ty -> print_out_type_2 ppf ty

and print_out_arg am ppf ty =
  print_out_type_mode ~arg:true am ppf ty

and print_out_ret ppf =
  function
  | Otyp_ret (rm, (Otyp_arrow _ as ty)) ->
    begin match rm with
    | Orm_no_parens ->
      print_out_type_1 ppf ty
    | Orm_any rm | Orm_parens rm ->
      pp_print_char ppf '(';
      print_out_type_1 ppf ty;
      pp_print_char ppf ')';
      print_out_modes ppf rm
    end
  | Otyp_ret (Orm_any rm, ty) -> print_out_type_mode ~arg:false rm ppf ty
  | _ -> assert false

and print_out_type_2 ppf =
  function
  | Otyp_tuple tyl ->
      fprintf
        ppf "@[<0>%a@]" (print_labeled_typlist print_simple_out_type " *") tyl
  | ty -> print_out_type_3 ppf ty
and print_out_type_3 ppf =
  function
    Otyp_class (id, tyl) ->
      fprintf ppf "@[%a#%a@]" print_typargs tyl print_ident id
  | Otyp_constr (id, tyl) ->
      pp_open_box ppf 0;
      print_typargs ppf tyl;
      print_ident ppf id;
      pp_close_box ppf ()
  | Otyp_object {fields; open_row} ->
      fprintf ppf "@[<2>< %a >@]" (print_fields open_row) fields
  | Otyp_stuff s -> pp_print_string ppf s
  | Otyp_var (non_gen, s) -> ty_var ~non_gen ppf s
  | Otyp_variant (row_fields, closed, tags) ->
      let print_present ppf =
        function
          None | Some [] -> ()
        | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
      in
      let print_fields ppf =
        function
          Ovar_fields fields ->
            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
              ppf fields
        | Ovar_typ typ ->
           print_simple_out_type ppf typ
      in
      fprintf ppf "@[<hov>[%s@[<hv>@[<hv>%a@]%a@]@ ]@]"
        (if closed then if tags = None then " " else "< "
         else if tags = None then "> " else "? ")
        print_fields row_fields
        print_present tags
  | Otyp_alias _ | Otyp_poly _ | Otyp_repr _ | Otyp_arrow _ | Otyp_tuple _
  | Otyp_newlayout _
    as ty ->
      pp_open_box ppf 1;
      pp_print_char ppf '(';
      print_out_type_0 ppf ty;
      pp_print_char ppf ')';
      pp_close_box ppf ()
  | Otyp_unboxed_tuple tyl ->
      pp_open_box ppf 1;
      fprintf ppf "#(";
      fprintf
        ppf "@[<0>%a@]"
        (print_labeled_typlist print_simple_out_type " *")
        tyl;
      pp_print_char ppf ')';
      pp_close_box ppf ()
  | Otyp_abstract | Otyp_open
  | Otyp_sum _ | Otyp_manifest (_, _) -> ()
  | Otyp_record lbls -> print_record_decl ~unboxed:false ppf lbls
  | Otyp_record_unboxed_product lbls -> print_record_decl ~unboxed:true ppf lbls
  | Otyp_module (p, fl) ->
      fprintf ppf "@[<1>(module %a" print_ident p;
      let first = ref true in
      List.iter
        (fun (s, t) ->
          let sep = if !first then (first := false; "with") else "and" in
          fprintf ppf " %s type %s = %a" sep s print_out_type t
        )
        fl;
      fprintf ppf ")@]"
  | Otyp_attribute (t, attr) ->
      fprintf ppf "@[<1>(%a [@@%s])@]"
        print_out_type_0 t attr.oattr_name
  | Otyp_jkind_annot (t, jk) ->
    fprintf ppf "@[<1>(%a@ :@ %a)@]"
      print_out_type_0 t
      print_out_jkind jk
  | Otyp_of_kind jk ->
    fprintf ppf "(type@ :@ %a)" print_out_jkind jk
  | Otyp_ret _ -> assert false
  | Otyp_quote t -> fprintf ppf "@[<1><[@,%a@,]>@]" print_out_type_0 t
  | Otyp_splice t -> fprintf ppf "@[<1>$@,(%a)@]" print_out_type_0 t
and print_out_type ppf typ =
  print_out_type_0 ppf typ
and print_simple_out_type ppf typ =
  print_out_type_3 ppf typ
and print_record_decl ~unboxed ppf lbls =
  let hash = if unboxed then "#" else "" in
  fprintf ppf "%s{%a@;<1 -2>}"
    hash (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
and print_fields open_row ppf =
  function
    [] ->
      if open_row then fprintf ppf "..";
  | [s, t] ->
      fprintf ppf "%a : %a" print_lident s print_out_type t;
      if open_row then fprintf ppf ";@ ";
      print_fields open_row ppf []
  | (s, t) :: l ->
      fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields open_row) l
and print_row_field ppf (l, opt_amp, tyl) =
  let pr_of ppf =
    if opt_amp then fprintf ppf " of@ &@ "
    else if tyl <> [] then fprintf ppf " of@ "
    else fprintf ppf ""
  in
  fprintf ppf "@[<hv 2>`%a%t%a@]" print_lident l pr_of
    (print_typlist print_out_type " &")
    tyl
and print_typargs ppf =
  function
    [] -> ()
  | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf ()
  | tyl ->
      pp_open_box ppf 1;
      pp_print_char ppf '(';
      print_typlist print_out_type "," ppf tyl;
      pp_print_char ppf ')';
      pp_close_box ppf ();
      pp_print_space ppf ()
and print_out_label ppf (name, mut, arg, gbl) =
  (* See the notes [NON-LEGACY MODES] *)
  let mut, atomic =
    match mut with
    | Om_immutable -> "", Nonatomic
    | Om_mutable (None, atomic) -> "mutable ", atomic
    | Om_mutable (Some s, atomic) -> "mutable(" ^ s ^ ") ", atomic
  in
  let print_atomic ppf atomic = match atomic with
    | Nonatomic -> ()
    | Atomic -> fprintf ppf " [@@atomic]"
  in
  fprintf ppf "@[<2>%s%a :@ %a%a%a@];"
    mut
    print_lident name
    print_out_type arg
    print_out_modalities gbl
    print_atomic atomic

and print_out_jkind_const ppf ojkind =
  let rec pp_element ~nested ppf (ojkind : Outcometree.out_jkind_const) =
    (* HACK: we strip off the [Ojkind_const_with]s and convert them to a [string
       list list] so we can sort them lexicographically, because otherwise the
       order of printed [with]s is nondeterministic. This is sad, but we'd need
       deterministic sorting of types to work around it.

       CR aspsmith: remove this if we ever add deterministic, semantic type comparison
    *)
    let rec strip_withs ojkind =
      match ojkind with
      | Ojkind_const_with (base, ty, modalities) ->
        let fix_indentation ppf =
          let ({ Format.out_newline; out_indent; _ } as out_functions) =
            Format.pp_get_formatter_out_functions ppf ()
          in
          let out_newline () =
            out_newline ();
            out_indent 18  (* this works well in practice: the string produced
                              here gets included in a larger message, indented
                              by 18 *)
          in
          Format.pp_set_formatter_out_functions ppf
             { out_functions with out_newline }
        in
        let base, withs = strip_withs base in
        let with_ =
          Format.asprintf "%t%a" fix_indentation (compat print_out_type) ty
          :: (match modalities with
            | [] -> []
            | modalities -> "@@" :: modalities)
        in
        base, with_ :: withs
      | base -> base, []
    in
    let base, withs = strip_withs ojkind in
    (match base with
    | Ojkind_const_default -> fprintf ppf "_"
    | Ojkind_const_abbreviation (abbrev, sa) ->
      (pp_print_list ~pp_sep:pp_print_space pp_print_string) ppf (abbrev :: sa)
    | Ojkind_const_mod (base, modes) ->
      let pp_base ppf base =
        match base with
        | Some base -> fprintf ppf "%a@ " (pp_element ~nested:true) base
        | None -> ()
      in
      pp_parens_if nested (fun ppf (base, modes) ->
        fprintf ppf "%amod @[<hv>%a@]" pp_base base
          (pp_print_list ~pp_sep:pp_print_space pp_print_string)
          modes
      ) ppf (base, modes)
    | Ojkind_const_product ts ->
      let pp_sep ppf () = fprintf ppf "@ & " in
      pp_nested_list ~nested ~pp_element ~pp_sep ppf ts
    | Ojkind_const_with _ -> failwith "XXX unreachable (stripped off earlier)"
    | Ojkind_const_kind_of _ ->
      failwith "XXX unimplemented jkind syntax");
    let withs = List.sort (List.compare String.compare) withs in
    match withs with
    | [] -> ()
    | withs ->
      pp_print_list
        ~pp_sep:(fun _ () -> ())
        (fun ppf ->
           fprintf ppf "@ with @[<hv 2>%a@]"
             (pp_print_list ~pp_sep:pp_print_space pp_print_string))
        ppf
        withs;
  in
  fprintf ppf "@[<hv 2>%a@]" (pp_element ~nested:false) ojkind

and print_out_jkind ppf ojkind =
  let rec pp_element ~nested ppf ojkind =
    match ojkind with
    | Ojkind_var (v, nts) ->
      (pp_print_list ~pp_sep:pp_print_space pp_print_string) ppf (v :: nts)
    | Ojkind_const jkind -> print_out_jkind_const ppf jkind
    | Ojkind_product ts ->
      let pp_sep ppf () = fprintf ppf "@ & " in
      pp_nested_list ~nested ~pp_element ~pp_sep ppf ts
  in
  pp_element ~nested:false ppf ojkind

and print_out_jkind_annot ppf = function
  | None -> ()
  | Some lay -> fprintf ppf "@ : %a" print_out_jkind lay

and pr_var_jkind ppf (v, l) = match l with
    | None -> pr_var ppf v
    | Some lay -> fprintf ppf "(%a : %a)"
                    pr_var v
                    print_out_jkind lay
and pr_var_jkinds jks =
  print_list pr_var_jkind (fun ppf -> fprintf ppf "@ ") jks

and pr_sort_univar = pp_print_string

and pr_sort_univars univars =
  print_list pr_sort_univar (fun ppf -> fprintf ppf "@ ") univars

and pr_var_repr ppf v =
  fprintf ppf "(repr_@ %a)" pr_var v

and pr_var_reprs vs =
  print_list pr_var_repr (fun ppf -> fprintf ppf "@ ") vs

let out_label = ref print_out_label

let out_modality = ref print_out_modality

let out_modes = ref print_out_modes

let out_jkind_const = ref print_out_jkind_const

let out_jkind = ref print_out_jkind

let out_type = ref print_out_type

let out_type_args = ref print_typargs

(* Class types *)

let print_type_parameter ?(non_gen=false) ppf s =
  if s = "_" then fprintf ppf "_" else ty_var ~non_gen ppf s

let type_parameter ~in_parens ppf
    {ot_non_gen=non_gen; ot_name=ty; ot_variance=var,inj;
     ot_jkind=lay; }
  =
  let open Asttypes in
  let format_string : _ format = "%s%s%a%a" in
  let format_string : _ format = match lay with
    | Some _ when not in_parens -> "(" ^^ format_string ^^ ")"
    | _ -> format_string
  in
  fprintf ppf format_string
    (match var with Covariant -> "+" | Contravariant -> "-" | NoVariance ->  "")
    (match inj with Injective -> "!" | NoInjectivity -> "")
    (print_type_parameter ~non_gen) ty
    print_out_jkind_annot lay

let print_out_class_params ppf =
  function
    [] -> ()
  | tyl ->
      fprintf ppf "@[<1>[%a]@]@ "
        (print_list (type_parameter ~in_parens:true)
           (fun ppf -> fprintf ppf ", "))
        tyl

let rec print_out_class_type ppf =
  function
    Octy_constr (id, tyl) ->
      let pr_tyl ppf =
        function
          [] -> ()
        | tyl ->
            fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
      in
      fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
  | Octy_arrow (lab, ty, cty) ->
      let print_type = print_out_type_2 in
      fprintf ppf "@[%t ->@ %a@]"
        (fun ppf -> print_arg_label_and_out_type ppf lab ty ~print_type)
        print_out_class_type cty
  | Octy_signature (self_ty, csil) ->
      let pr_param ppf =
        function
          Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
        | None -> ()
      in
      fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
        (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
        csil
and print_out_class_sig_item ppf =
  function
    Ocsg_constraint (ty1, ty2) ->
      fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1
        !out_type ty2
  | Ocsg_method (name, priv, virt, ty) ->
      fprintf ppf "@[<2>method %s%s%a :@ %a@]"
        (if priv then "private " else "") (if virt then "virtual " else "")
        print_lident name !out_type ty
  | Ocsg_value (name, mut, vr, ty) ->
      fprintf ppf "@[<2>val %s%s%a :@ %a@]"
        (if mut then "mutable " else "")
        (if vr then "virtual " else "")
        print_lident name !out_type ty

let out_class_type = ref print_out_class_type

(* Signature *)

let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type")
let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item")
let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension")

(* For anonymous functor arguments, the logic to choose between
   the long-form
     functor (_ : S) -> ...
   and the short-form
     S -> ...
   is as follows: if we are already printing long-form functor arguments,
   we use the long form unless all remaining functor arguments can use
   the short form. (Otherwise use the short form.)

   For example,
     functor (X : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
   will get printed as
     functor (X : S1) (_ : S2) (Y : S3) -> S4 -> S5 -> sig end

   but
     functor (_ : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end
   gets printed as
     S1 -> S2 -> functor (Y : S3) -> S4 -> S5 -> sig end
*)

let constructor_of_extension_constructor
    (ext : out_extension_constructor) : out_constructor
=
  {
    ocstr_name = ext.oext_name;
    ocstr_args = ext.oext_args;
    ocstr_return_type = ext.oext_ret_type;
  }

let rec print_out_module_type ppf = function
  | Omty_functor (param, res, mres) ->
      fprintf ppf "@[<2>%a@]" print_out_functor (param, res, mres)
  | _ as mty -> print_simple_out_module_type ppf mty

and print_out_module_type_with_modes ppf (mty, mm) =
  match mm with
  | [] -> print_out_module_type ppf mty
  | _ :: _ ->
      fprintf ppf "%a%a" print_simple_out_module_type mty print_out_modes mm

(** Prints functor parameter in the context of long form [functor ...]. *)
and print_out_functor_parameter ppf = function
  | None -> fprintf ppf "()"
  | Some (name, mty, mm) -> fprintf ppf "(%s : %a)"
     (Option.value name ~default:"_")
     print_out_module_type_with_modes (mty, mm)

and print_out_functor ppf (param, res, mres) =
  match param with
  | Some (None, mty, mm) ->
      fprintf ppf "%a ->@ %a"
        print_simple_out_module_type_with_modes (mty, mm)
        print_out_module_type_with_modes (res, mres)
  | _ ->
      fprintf ppf "@[<2>functor@ %a%a"
        print_out_functor_parameter param
        print_out_functor_return_with_modes (res, mres)

(** The caller has printed [functor (X : S) ... (Y : T)] and we need to print
    the functor return. *)
and print_out_functor_return_with_modes ppf (mty, mm) =
  let print_as_fresh () =
    fprintf ppf "@]@ ->@ %a" print_out_module_type_with_modes (mty, mm)
  in
  match mty with
  | Omty_functor (param, res, mres) ->
      begin match param, mm with
      | (None | Some (Some _, _, _)), [] ->
          fprintf ppf "@ %a%a" print_out_functor_parameter param
            print_out_functor_return_with_modes (res, mres)
      | _ -> print_as_fresh ()
      end
  | _ -> print_as_fresh ()
and print_simple_out_module_type ppf =
  function
    Omty_abstract -> ()
  | Omty_ident id -> fprintf ppf "%a" print_ident id
  | Omty_signature sg ->
     begin match sg with
       | [] -> fprintf ppf "sig end"
       | sg ->
          fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_out_signature sg
     end
  | Omty_alias id -> fprintf ppf "(module %a)" print_ident id
  | Omty_functor _ as non_simple ->
     fprintf ppf "(%a)" print_out_module_type non_simple
  | Omty_hole -> fprintf ppf "_"
  | Omty_strengthen (mty, id, unaliasable) ->
     fprintf ppf "(%a with %a%s)"
       print_simple_out_module_type mty
       print_ident id
       (if unaliasable then " [@unaliasable]" else "")
and print_simple_out_module_type_with_modes ppf (mty, mm) =
  match mm with
  | [] -> print_simple_out_module_type ppf mty
  | _ :: _ ->
      fprintf ppf "%a%a" print_simple_out_module_type mty print_out_modes mm
and print_out_signature ppf =
  function
    [] -> ()
  | [item] -> !out_sig_item ppf item
  | Osig_typext(ext, Oext_first) :: items ->
      (* Gather together the extension constructors *)
      let rec gather_extensions acc items =
        match items with
            Osig_typext(ext, Oext_next) :: items ->
              gather_extensions
                (constructor_of_extension_constructor ext :: acc)
                items
          | _ -> (List.rev acc, items)
      in
      let exts, items =
        gather_extensions
          [constructor_of_extension_constructor ext]
          items
      in
      let te =
        { otyext_name = ext.oext_type_name;
          otyext_params = ext.oext_type_params;
          otyext_constructors = exts;
          otyext_private = ext.oext_private }
      in
        fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items
  | item :: items ->
      fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
and print_out_sig_item ppf =
  function
    Osig_class (vir_flag, name, params, clt, rs) ->
      fprintf ppf "@[<2>%s%s@ %a%a@ :@ %a@]"
        (if rs = Orec_next then "and" else "class")
        (if vir_flag then " virtual" else "") print_out_class_params params
        print_lident name !out_class_type clt
  | Osig_class_type (vir_flag, name, params, clt, rs) ->
      fprintf ppf "@[<2>%s%s@ %a%a@ =@ %a@]"
        (if rs = Orec_next then "and" else "class type")
        (if vir_flag then " virtual" else "") print_out_class_params params
        print_lident name !out_class_type clt
  | Osig_typext (ext, Oext_exception) ->
      fprintf ppf "@[<2>exception %a@]"
        print_out_constr (constructor_of_extension_constructor ext)
  | Osig_typext (ext, _es) ->
      print_out_extension_constructor ppf ext
  | Osig_modtype (name, Omty_abstract) ->
      fprintf ppf "@[<2>module type %s@]" name
  | Osig_modtype (name, mty) ->
      fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
  | Osig_module (name, Omty_alias id, moda, _) ->
      fprintf ppf "@[<2>module %s =@ %a%a@]" name print_ident id
        print_out_modalities moda
  | Osig_module (name, mty, moda, rs) ->
      fprintf ppf "@[<2>%s %s :@ %a%a@]"
        (match rs with Orec_not -> "module"
                     | Orec_first -> "module rec"
                     | Orec_next -> "and")
        name !out_module_type mty
        print_out_modalities moda
  | Osig_type(td, rs) ->
        print_out_type_decl
          (match rs with
           | Orec_not   -> "type nonrec"
           | Orec_first -> "type"
           | Orec_next  -> "and")
          ppf td
  | Osig_value { oval_name; oval_type; oval_modalities;
                 oval_prims; oval_attributes } ->
      let kwd = if oval_prims = [] then "val" else "external" in
      let pr_prims ppf =
        function
          [] -> ()
        | s :: sl ->
            fprintf ppf "@ = \"%s\"" s;
            List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
      in
      fprintf ppf "@[<2>%s %a :@ %a%a%a%a@]" kwd value_ident oval_name
        !out_type oval_type
        print_out_modalities oval_modalities
        pr_prims oval_prims
        (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name))
        oval_attributes
  | Osig_ellipsis ->
      fprintf ppf "..."
  | Osig_jkind jkd -> print_out_jkind_decl ppf jkd

and print_out_type_decl kwd ppf td =
  let print_constraints ppf =
    List.iter
      (fun (ty1, ty2) ->
         fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
           !out_type ty2)
      td.otype_cstrs
  in
  let type_defined ppf =
    match td.otype_params with
      [] -> print_lident ppf td.otype_name
    | [param] -> fprintf ppf "@[%a@ %a@]"
                   (type_parameter ~in_parens:false) param
                   print_lident td.otype_name
    | _ ->
        fprintf ppf "@[(@[%a)@]@ %a@]"
          (print_list (type_parameter ~in_parens:true)
             (fun ppf -> fprintf ppf ",@ "))
          td.otype_params
          print_lident td.otype_name
  in
  let print_manifest ppf =
    function
      Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
    | _ -> ()
  in
  let print_name_params ppf =
    fprintf ppf "%s %t%a%a" kwd type_defined
      print_out_jkind_annot td.otype_jkind
      print_manifest td.otype_type
  in
  let ty =
    match td.otype_type with
      Otyp_manifest (_, ty) -> ty
    | _ -> td.otype_type
  in
  let print_private ppf = function
    Asttypes.Private -> fprintf ppf " private"
  | Asttypes.Public -> ()
  in
  let print_unboxed ppf =
    if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
  in
  let print_or_null_attr ppf =
    match td.otype_or_null_attribute with
    | None -> ()
    | Some attr -> fprintf ppf " [%@@@%s]" attr
  in
  let print_out_tkind ppf = function
  | Otyp_abstract -> ()
  | Otyp_record lbls ->
      fprintf ppf " =%a %a"
        print_private td.otype_private
        (print_record_decl ~unboxed:false) lbls
  | Otyp_record_unboxed_product lbls ->
      fprintf ppf " =%a %a"
        print_private td.otype_private
        (print_record_decl ~unboxed:true) lbls
  | Otyp_sum constrs ->
    let variants fmt constrs =
        if constrs = [] then fprintf fmt "|" else
        fprintf fmt "%a" (print_list print_out_constr
          (fun ppf -> fprintf ppf "@ | ")) constrs in
    fprintf ppf " =%a@;<1 2>%a"
      print_private td.otype_private variants constrs
  | Otyp_open ->
      fprintf ppf " =%a .."
        print_private td.otype_private
  | ty ->
      fprintf ppf " =%a@;<1 2>%a"
        print_private td.otype_private
        !out_type ty
  in
  let print_out_attrs ppf =
    List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name)
  in
  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t%t@]%a"
    print_name_params
    print_out_tkind ty
    print_constraints
    print_unboxed
    print_or_null_attr
    print_out_attrs td.otype_attributes

and print_simple_out_gf_type ppf (ty, gf) =
  print_simple_out_type ppf ty;
  print_out_modalities ppf gf

and print_out_constr_args ppf tyl =
  print_typlist print_simple_out_gf_type " *" ppf tyl

and print_out_constr ppf constr =
  let {
    ocstr_name = name;
    ocstr_args = tyl;
    ocstr_return_type = return_type;
  } = constr in
  let name =
    match name with
    | "::" -> "(::)"   (* #7200 *)
    | s -> s
  in
  match return_type with
  | None ->
      begin match tyl with
      | [] ->
          pp_print_string ppf name
      | _ ->
          fprintf ppf "@[<2>%s of@ %a@]" name
            print_out_constr_args tyl
      end
  | Some (vars_jkinds, ret_type) ->
      fprintf ppf "@[<2>%s :@ " name;
      begin match vars_jkinds with
      | [] -> ()
      | _ -> fprintf ppf "@[<hov>%a.@]@ " pr_var_jkinds vars_jkinds
      end;
      begin match tyl with
      | [] ->
          fprintf ppf "%a@]" print_simple_out_type ret_type
      | _ ->
          fprintf ppf "%a -> %a@]"
            print_out_constr_args tyl print_simple_out_type ret_type
      end

and print_out_extension_constructor ppf ext =
  let print_extended_type ppf =
      match ext.oext_type_params with
        [] -> fprintf ppf "%a" print_lident ext.oext_type_name
      | [ty_param] ->
        fprintf ppf "@[%a@ %a@]"
          (print_type_parameter ~non_gen:false)
          ty_param
          print_lident ext.oext_type_name
      | _ ->
        fprintf ppf "@[(@[%a)@]@ %a@]"
          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
          ext.oext_type_params
          print_lident ext.oext_type_name
  in
  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
    print_extended_type
    (if ext.oext_private = Asttypes.Private then " private" else "")
    print_out_constr
    (constructor_of_extension_constructor ext)

and print_out_type_extension ppf te =
  let print_extended_type ppf =
    match te.otyext_params with
      [] -> fprintf ppf "%a" print_lident te.otyext_name
    | [param] ->
      fprintf ppf "@[%a@ %a@]"
        (print_type_parameter ~non_gen:false) param
        print_lident te.otyext_name
    | _ ->
        fprintf ppf "@[(@[%a)@]@ %a@]"
          (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ "))
          te.otyext_params
          print_lident te.otyext_name
  in
  fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
    print_extended_type
    (if te.otyext_private = Asttypes.Private then " private" else "")
    (print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
     te.otyext_constructors

and print_out_jkind_decl ppf jkd =
  let print_manifest ppf =
    function
      None -> ()
    | Some jkind -> fprintf ppf " =@ %a" print_out_jkind jkind
  in
  fprintf ppf "@[kind_ %s%a@]" jkd.ojkind_name print_manifest jkd.ojkind_jkind

let out_constr = ref print_out_constr
let out_constr_args = ref print_out_constr_args
let _ = out_module_type := print_out_module_type
let _ = out_signature := print_out_signature
let _ = out_sig_item := print_out_sig_item
let _ = out_type_extension := print_out_type_extension

(* Phrases *)

open Format

let print_out_exception ppf exn outv =
  match exn with
    Sys.Break -> fprintf ppf "Interrupted.@."
  | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
  | Stack_overflow ->
      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
  | _ -> match Printexc.use_printers exn with
        | None -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv
        | Some s -> fprintf ppf "@[Exception:@ %s@]@." s

let rec print_items ppf =
  function
    [] -> ()
  | (Osig_typext(ext, Oext_first), None) :: items ->
      (* Gather together extension constructors *)
      let rec gather_extensions acc items =
        match items with
            (Osig_typext(ext, Oext_next), None) :: items ->
              gather_extensions
                (constructor_of_extension_constructor ext :: acc)
                items
          | _ -> (List.rev acc, items)
      in
      let exts, items =
        gather_extensions
          [constructor_of_extension_constructor ext]
          items
      in
      let te =
        { otyext_name = ext.oext_type_name;
          otyext_params = ext.oext_type_params;
          otyext_constructors = exts;
          otyext_private = ext.oext_private }
      in
        fprintf ppf "@[%a@]" (Format_doc.compat !out_type_extension) te;
        if items <> [] then fprintf ppf "@ %a" print_items items
  | (tree, valopt) :: items ->
      begin match valopt with
        Some v ->
          fprintf ppf "@[<2>%a =@ %a@]" (Format_doc.compat !out_sig_item) tree
            !out_value v
      | None -> fprintf ppf "@[%a@]" (Format_doc.compat !out_sig_item) tree
      end;
      if items <> [] then fprintf ppf "@ %a" print_items items

let print_out_phrase ppf =
  function
    Ophr_eval (outv, ty) ->
      fprintf ppf "@[- : %a@ =@ %a@]@." (compat !out_type) ty !out_value outv
  | Ophr_signature [] -> ()
  | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv

let out_phrase = ref print_out_phrase

type 'a printer = 'a Format_doc.printer ref
type 'a toplevel_printer = (Format.formatter -> 'a -> unit) ref