emitter.ml — Coverage report

(* adopted from ppxlib.0.30.0 source tree *)

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                      Thomas Gazagnaire, OCamlPro                       *)
(*                   Fabrice Le Fessant, INRIA Saclay                     *)
(*               Hongbo Zhang, University of Pennsylvania                 *)
(*                                                                        *)
(*   Copyright 2007 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.          *)
(*                                                                        *)
(**************************************************************************)

(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *)
(* Printing code expressions *)
(* Authors:  Ed Pizzi, Fabrice Le Fessant *)
(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
(* TODO more fine-grained precedence pretty-printing *)

open Ppxlib_ast
[@@@warning "-9"]

(* open Ast_414 *)
open Asttypes
open Format
open Location
open Longident
open Parsetree

module Option = struct
  let value t ~default = match t with None -> default | Some x -> x
end

let varify_type_constructors var_names t =
  let check_variable vl loc v =
    if List.mem v vl then
      Location.raise_errorf ~loc "variable in scope syntax error: %s" v
  in
  let var_names = List.map (fun v -> v.txt) var_names in
  let rec loop t =
    let desc =
      match t.ptyp_desc with
      | Ptyp_any -> Ptyp_any
      | Ptyp_var x ->
          check_variable var_names t.ptyp_loc x;
          Ptyp_var x
      | Ptyp_arrow (label, core_type, core_type') ->
          Ptyp_arrow (label, loop core_type, loop core_type')
      | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
      | Ptyp_constr ({ txt = Longident.Lident s }, []) when List.mem s var_names
        ->
          Ptyp_var s
      | Ptyp_constr (longident, lst) ->
          Ptyp_constr (longident, List.map loop lst)
      | Ptyp_object (lst, o) -> Ptyp_object (List.map loop_object_field lst, o)
      | Ptyp_class (longident, lst) -> Ptyp_class (longident, List.map loop lst)
      | Ptyp_alias (core_type, string) ->
          check_variable var_names t.ptyp_loc string;
          Ptyp_alias (loop core_type, string)
      | Ptyp_variant (row_field_list, flag, lbl_lst_option) ->
          Ptyp_variant
            (List.map loop_row_field row_field_list, flag, lbl_lst_option)
      | Ptyp_poly (string_lst, core_type) ->
          List.iter
            (fun v -> check_variable var_names t.ptyp_loc v.txt)
            string_lst;
          Ptyp_poly (string_lst, loop core_type)
      | Ptyp_package (longident, lst) ->
          Ptyp_package (longident, List.map (fun (n, typ) -> (n, loop typ)) lst)
      | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg)
    in
    { t with ptyp_desc = desc }
  and loop_row_field field =
    let prf_desc =
      match field.prf_desc with
      | Rtag (label, flag, lst) -> Rtag (label, flag, List.map loop lst)
      | Rinherit t -> Rinherit (loop t)
    in
    { field with prf_desc }
  and loop_object_field field =
    let pof_desc =
      match field.pof_desc with
      | Otag (label, t) -> Otag (label, loop t)
      | Oinherit t -> Oinherit (loop t)
    in
    { field with pof_desc }
  in
  loop t

let prefix_symbols = [ '!'; '?'; '~' ]

let infix_symbols =
  [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; '$'; '%'; '#' ]

(* type fixity = Infix| Prefix  *)
let special_infix_strings =
  [ "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]

let letop s =
  String.length s > 3
  && s.[0] = 'l'
  && s.[1] = 'e'
  && s.[2] = 't'
  && List.mem s.[3] infix_symbols

let andop s =
  String.length s > 3
  && s.[0] = 'a'
  && s.[1] = 'n'
  && s.[2] = 'd'
  && List.mem s.[3] infix_symbols

(* determines if the string is an infix string.
   checks backwards, first allowing a renaming postfix ("_102") which
   may have resulted from Pexp -> Texp -> Pexp translation, then checking
   if all the characters in the beginning of the string are valid infix
   characters. *)
let fixity_of_string = function
  | "" -> `Normal
  | s when List.mem s special_infix_strings -> `Infix s
  | s when List.mem s.[0] infix_symbols -> `Infix s
  | s when List.mem s.[0] prefix_symbols -> `Prefix s
  | s when s.[0] = '.' -> `Mixfix s
  | s when letop s -> `Letop s
  | s when andop s -> `Andop s
  | _ -> `Normal

let view_fixity_of_exp = function
  | { pexp_desc = Pexp_ident { txt = Lident l; _ }; pexp_attributes = [] } ->
      fixity_of_string l
  | _ -> `Normal

let is_infix = function `Infix _ -> true | _ -> false
let is_mixfix = function `Mixfix _ -> true | _ -> false
let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false
let first_is c str = str <> "" && str.[0] = c
let last_is c str = str <> "" && str.[String.length str - 1] = c
let first_is_in cs str = str <> "" && List.mem str.[0] cs

(* which identifiers are in fact operators needing parentheses *)
let needs_parens txt =
  let fix = fixity_of_string txt in
  is_infix fix || is_mixfix fix || is_kwdop fix
  || first_is_in prefix_symbols txt

(* some infixes need spaces around parens to avoid clashes with comment
   syntax *)
let needs_spaces txt = first_is '*' txt || last_is '*' txt
let string_loc ppf x = fprintf ppf "%s" x.txt

(* add parentheses to binders when they are in fact infix or prefix operators *)
let protect_ident ppf txt =
  let format : (_, _, _) format =
    if not (needs_parens txt) then "%s"
    else if needs_spaces txt then "(@;%s@;)"
    else "(%s)"
  in
  fprintf ppf format txt

let protect_longident ppf print_longident longprefix txt =
  let format : (_, _, _) format =
    if not (needs_parens txt) then "%a.%s"
    else if needs_spaces txt then "%a.(@;%s@;)"
    else "%a.(%s)"
  in
  fprintf ppf format print_longident longprefix txt

type space_formatter = (unit, Format.formatter, unit) format

let override = function Override -> "!" | Fresh -> ""

(* variance encoding: need to sync up with the [parser.mly] *)
let type_variance = function
  | NoVariance -> ""
  | Covariant -> "+"
  | Contravariant -> "-"

let type_injectivity = function NoInjectivity -> "" | Injective -> "!"

type construct =
  [ `cons of expression list
  | `list of expression list
  | `nil
  | `normal
  | `simple of Longident.t
  | `tuple ]

let view_expr x =
  match x.pexp_desc with
  | Pexp_construct ({ txt = Lident "()"; _ }, _) -> `tuple
  | Pexp_construct ({ txt = Lident "[]"; _ }, _) -> `nil
  | Pexp_construct ({ txt = Lident "::"; _ }, Some _) ->
      let rec loop exp acc =
        match exp with
        | {
         pexp_desc = Pexp_construct ({ txt = Lident "[]"; _ }, _);
         pexp_attributes = [];
        } ->
            (List.rev acc, true)
        | {
         pexp_desc =
           Pexp_construct
             ( { txt = Lident "::"; _ },
               Some { pexp_desc = Pexp_tuple [ e1; e2 ]; pexp_attributes = [] }
             );
         pexp_attributes = [];
        } ->
            loop e2 (e1 :: acc)
        | e -> (List.rev (e :: acc), false)
      in
      let ls, b = loop x [] in
      if b then `list ls else `cons ls
  | Pexp_construct (x, None) -> `simple x.txt
  | _ -> `normal

let is_simple_construct : construct -> bool = function
  | `nil | `tuple | `list _ | `simple _ -> true
  | `cons _ | `normal -> false

let pp = fprintf

type ctxt = { pipe : bool; semi : bool; ifthenelse : bool }

let reset_ctxt = { pipe = false; semi = false; ifthenelse = false }
let under_pipe ctxt = { ctxt with pipe = true }
let under_semi ctxt = { ctxt with semi = true }
let under_ifthenelse ctxt = { ctxt with ifthenelse = true }
(*
let reset_semi ctxt = { ctxt with semi=false }
let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
let reset_pipe ctxt = { ctxt with pipe=false }
*)

let list :
      'a.
      ?sep:space_formatter ->
      ?first:space_formatter ->
      ?last:space_formatter ->
      (Format.formatter -> 'a -> unit) ->
      Format.formatter ->
      'a list ->
      unit =
 fun ?sep ?first ?last fu f xs ->
  let first = match first with Some x -> x | None -> ("" : _ format6)
  and last = match last with Some x -> x | None -> ("" : _ format6)
  and sep = match sep with Some x -> x | None -> ("@ " : _ format6) in
  let aux f = function
    | [] -> ()
    | [ x ] -> fu f x
    | xs ->
        let rec loop f = function
          | [ x ] -> fu f x
          | x :: xs ->
              fu f x;
              pp f sep;
              loop f xs
          | _ -> assert false
        in
        pp f first;
        loop f xs;
        pp f last
  in
  aux f xs

let option :
      'a.
      ?first:space_formatter ->
      ?last:space_formatter ->
      (Format.formatter -> 'a -> unit) ->
      Format.formatter ->
      'a option ->
      unit =
 fun ?first ?last fu f a ->
  let first = match first with Some x -> x | None -> ("" : _ format6)
  and last = match last with Some x -> x | None -> ("" : _ format6) in
  match a with
  | None -> ()
  | Some x ->
      pp f first;
      fu f x;
      pp f last

let paren :
      'a.
      ?first:space_formatter ->
      ?last:space_formatter ->
      bool ->
      (Format.formatter -> 'a -> unit) ->
      Format.formatter ->
      'a ->
      unit =
 fun ?(first = ("" : _ format6)) ?(last = ("" : _ format6)) b fu f x ->
  if b then (
    pp f "(";
    pp f first;
    fu f x;
    pp f last;
    pp f ")")
  else fu f x

let rec longident f = function
  | Lident s -> protect_ident f s
  | Ldot (y, s) -> protect_longident f longident y s
  | Lapply (y, s) -> pp f "%a(%a)" longident y longident s

let longident_loc f x = pp f "%a" longident x.txt

let constant f = function
  | Pconst_char i -> pp f "%C" i
  | Pconst_string (i, _, None) -> pp f "%S" i
  | Pconst_string (i, _, Some delim) -> pp f "{%s|%s|%s}" delim i delim
  | Pconst_integer (i, None) -> paren (first_is '-' i) (fun f -> pp f "%s") f i
  | Pconst_integer (i, Some m) ->
      paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i, m)
  | Pconst_float (i, None) -> paren (first_is '-' i) (fun f -> pp f "%s") f i
  | Pconst_float (i, Some m) ->
      paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i, m)

(* trailing space*)
let mutable_flag f = function Immutable -> () | Mutable -> pp f "mutable@;"
let virtual_flag f = function Concrete -> () | Virtual -> pp f "virtual@;"

(* trailing space added *)
let rec_flag f rf =
  match rf with Nonrecursive -> () | Recursive -> pp f "rec "

let nonrec_flag f rf =
  match rf with Nonrecursive -> pp f "nonrec " | Recursive -> ()

let direction_flag f = function
  | Upto -> pp f "to@ "
  | Downto -> pp f "downto@ "

let private_flag f = function Public -> () | Private -> pp f "private@ "
let iter_loc f ctxt { txt; loc = _ } = f ctxt txt
let constant_string f s = pp f "%S" 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 tyvar_loc f str = tyvar f str.txt
let string_quot f x = pp f "`%s" x

(* c ['a,'b] *)
let rec class_params_def ctxt f = function
  | [] -> ()
  | l -> pp f "[%a] " (* space *) (list (type_param ctxt) ~sep:",") l

and type_with_label ctxt f (label, c) =
  match label with
  | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *)
  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c

and core_type ctxt f x =
  if x.ptyp_attributes <> [] then
    pp f "((%a)%a)" (core_type ctxt)
      { x with ptyp_attributes = [] }
      (attributes ctxt) x.ptyp_attributes
  else
    match x.ptyp_desc with
    | Ptyp_arrow (l, ct1, ct2) ->
        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
          (type_with_label ctxt) (l, ct1) (core_type ctxt) ct2
    | Ptyp_alias (ct, s) ->
        pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s
    | Ptyp_poly ([], ct) -> core_type ctxt f ct
    | Ptyp_poly (sl, ct) ->
        pp f "@[<2>%a%a@]"
          (fun f l ->
            pp f "%a"
              (fun f l ->
                match l with
                | [] -> ()
                | _ -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") l)
              l)
          sl (core_type ctxt) ct
    | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x

and core_type1 ctxt f x =
  if x.ptyp_attributes <> [] then core_type ctxt f x
  else
    match x.ptyp_desc with
    | Ptyp_any -> pp f "_"
    | Ptyp_var s -> tyvar f s
    | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
    | Ptyp_constr (li, l) ->
        pp f (* "%a%a@;" *) "%a%a"
          (fun f l ->
            match l with
            | [] -> ()
            | [ x ] -> pp f "%a@;" (core_type1 ctxt) x
            | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l)
          l longident_loc li
    | Ptyp_variant (l, closed, low) ->
        let first_is_inherit =
          match l with
          | { Parsetree.prf_desc = Rinherit _ } :: _ -> true
          | _ -> false
        in
        let type_variant_helper f x =
          match x.prf_desc with
          | Rtag (l, _, ctl) ->
              pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l
                (fun f l ->
                  match l with
                  | [] -> ()
                  | _ -> pp f "@;of@;%a" (list (core_type ctxt) ~sep:"&") ctl)
                ctl (attributes ctxt) x.prf_attributes
          | Rinherit ct -> core_type ctxt f ct
        in
        pp f "@[<2>[%a%a]@]"
          (fun f l ->
            match (l, closed) with
            | [], Closed -> ()
            | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *)
            | _ ->
                pp f "%s@;%a"
                  (match (closed, low) with
                  | Closed, None -> if first_is_inherit then " |" else ""
                  | Closed, Some _ -> "<" (* FIXME desugar the syntax sugar*)
                  | Open, _ -> ">")
                  (list type_variant_helper ~sep:"@;<1 -2>| ")
                  l)
          l
          (fun f low ->
            match low with
            | Some [] | None -> ()
            | Some xs -> pp f ">@ %a" (list string_quot) xs)
          low
    | Ptyp_object (l, o) ->
        let core_field_type f x =
          match x.pof_desc with
          | Otag (l, ct) ->
              (* Cf #7200 *)
              pp f "@[<hov2>%s: %a@ %a@ @]" l.txt (core_type ctxt) ct
                (attributes ctxt) x.pof_attributes
          | Oinherit ct -> pp f "@[<hov2>%a@ @]" (core_type ctxt) ct
        in
        let field_var f = function
          | Asttypes.Closed -> ()
          | Asttypes.Open -> (
              match l with [] -> pp f ".." | _ -> pp f " ;..")
        in
        pp f "@[<hov2><@ %a%a@ > @]"
          (list core_field_type ~sep:";")
          l field_var o
        (* Cf #7200 *)
    | Ptyp_class (li, l) ->
        (*FIXME*)
        pp f "@[<hov2>%a#%a@]"
          (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
          l longident_loc li
    | Ptyp_package (lid, cstrs) -> (
        let aux f (s, ct) =
          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct
        in
        match cstrs with
        | [] -> pp f "@[<hov2>(module@ %a)@]" longident_loc lid
        | _ ->
            pp f "@[<hov2>(module@ %a@ with@ %a)@]" longident_loc lid
              (list aux ~sep:"@ and@ ") cstrs)
    | Ptyp_extension e -> extension ctxt f e
    | _ -> paren true (core_type ctxt) f x

(********************pattern********************)
(* be cautious when use [pattern], [pattern1] is preferred *)
and pattern ctxt f x =
  if x.ppat_attributes <> [] then
    pp f "((%a)%a)" (pattern ctxt)
      { x with ppat_attributes = [] }
      (attributes ctxt) x.ppat_attributes
  else
    match x.ppat_desc with
    | Ppat_alias (p, s) ->
        pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt
    | _ -> pattern_or ctxt f x

and pattern_or ctxt f x =
  let rec left_associative x acc =
    match x with
    | { ppat_desc = Ppat_or (p1, p2); ppat_attributes = [] } ->
        left_associative p1 (p2 :: acc)
    | x -> x :: acc
  in
  match left_associative x [] with
  | [] -> assert false
  | [ x ] -> pattern1 ctxt f x
  | orpats -> pp f "@[<hov0>%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats

and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit =
  let rec pattern_list_helper f = function
    | {
        ppat_desc =
          Ppat_construct
            ( { txt = Lident "::"; _ },
              Some ([], { ppat_desc = Ppat_tuple [ pat1; pat2 ]; _ }) );
        ppat_attributes = [];
      } ->
        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
    | p -> pattern1 ctxt f p
  in
  if x.ppat_attributes <> [] then pattern ctxt f x
  else
    match x.ppat_desc with
    | Ppat_variant (l, Some p) ->
        pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p
    | Ppat_construct ({ txt = Lident ("()" | "[]"); _ }, _) ->
        simple_pattern ctxt f x
    | Ppat_construct (({ txt; _ } as li), po) -> (
        if (* FIXME The third field always false *)
           txt = Lident "::" then pp f "%a" pattern_list_helper x
        else
          match po with
          | Some ([], x) ->
              pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x
          | Some (vl, x) ->
              pp f "%a@ (type %a)@;%a" longident_loc li
                (list ~sep:"@ " string_loc)
                vl (simple_pattern ctxt) x
          | None -> pp f "%a" longident_loc li)
    | _ -> simple_pattern ctxt f x

and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit =
  if x.ppat_attributes <> [] then pattern ctxt f x
  else
    match x.ppat_desc with
    | Ppat_construct ({ txt = Lident (("()" | "[]") as x); _ }, None) ->
        pp f "%s" x
    | Ppat_any -> pp f "_"
    | Ppat_var { txt; _ } -> protect_ident f txt
    | Ppat_array l -> pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l
    | Ppat_unpack { txt = None } -> pp f "(module@ _)@ "
    | Ppat_unpack { txt = Some s } -> pp f "(module@ %s)@ " s
    | Ppat_type li -> pp f "#%a" longident_loc li
    | Ppat_record (l, closed) -> (
        let longident_x_pattern f (li, p) =
          match (li, p) with
          | ( { txt = Lident s; _ },
              { ppat_desc = Ppat_var { txt; _ }; ppat_attributes = []; _ } )
            when s = txt ->
              pp f "@[<2>%a@]" longident_loc li
          | _ -> pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
        in
        match closed with
        | Closed ->
            pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l
        | _ -> pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l)
    | Ppat_tuple l ->
        pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*)
    | Ppat_constant c -> pp f "%a" constant c
    | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
    | Ppat_variant (l, None) -> pp f "`%s" l
    | Ppat_constraint (p, ct) ->
        pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
    | Ppat_lazy p -> pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p
    | Ppat_exception p -> pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
    | Ppat_extension e -> extension ctxt f e
    | Ppat_open (lid, p) ->
        let with_paren =
          match p.ppat_desc with
          | Ppat_array _ | Ppat_record _
          | Ppat_construct ({ txt = Lident ("()" | "[]"); _ }, None) ->
              false
          | _ -> true
        in
        pp f "@[<2>%a.%a @]" longident_loc lid
          (paren with_paren @@ pattern1 ctxt)
          p
    | _ -> paren true (pattern ctxt) f x

and label_exp ctxt f (l, opt, p) =
  match l with
  | Nolabel ->
      (* single case pattern parens needed here *)
      pp f "%a@ " (simple_pattern ctxt) p
  | Optional rest -> (
      match p with
      | { ppat_desc = Ppat_var { txt; _ }; ppat_attributes = [] }
        when txt = rest -> (
          match opt with
          | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o
          | None -> pp f "?%s@ " rest)
      | _ -> (
          match opt with
          | Some o ->
              pp f "?%s:(%a=@;%a)@;" rest (pattern1 ctxt) p (expression ctxt) o
          | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p))
  | Labelled l -> (
      match p with
      | { ppat_desc = Ppat_var { txt; _ }; ppat_attributes = [] } when txt = l
        ->
          pp f "~%s@;" l
      | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p)

and sugar_expr ctxt f e =
  if e.pexp_attributes <> [] then false
  else
    match e.pexp_desc with
    | Pexp_apply
        ( { pexp_desc = Pexp_ident { txt = id; _ }; pexp_attributes = []; _ },
          args )
      when List.for_all (fun (lab, _) -> lab = Nolabel) args -> (
        let print_indexop a path_prefix assign left sep right print_index
            indices rem_args =
          let print_path ppf = function
            | None -> ()
            | Some m -> pp ppf ".%a" longident m
          in
          match (assign, rem_args) with
          | false, [] ->
              pp f "@[%a%a%s%a%s@]" (simple_expr ctxt) a print_path path_prefix
                left (list ~sep print_index) indices right;
              true
          | true, [ v ] ->
              pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" (simple_expr ctxt) a print_path
                path_prefix left (list ~sep print_index) indices right
                (simple_expr ctxt) v;
              true
          | _ -> false
        in
        match (id, List.map snd args) with
        | Lident "!", [ e ] ->
            pp f "@[<hov>!%a@]" (simple_expr ctxt) e;
            true
        | Ldot (path, (("get" | "set") as func)), a :: other_args -> (
            let assign = func = "set" in
            let print = print_indexop a None assign in
            match (path, other_args) with
            | Lident "Array", i :: rest ->
                print ".(" "" ")" (expression ctxt) [ i ] rest
            | Lident "String", i :: rest ->
                print ".[" "" "]" (expression ctxt) [ i ] rest
            | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
                print ".{" "," "}" (simple_expr ctxt) [ i1 ] rest
            | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
                print ".{" "," "}" (simple_expr ctxt) [ i1; i2 ] rest
            | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
                print ".{" "," "}" (simple_expr ctxt) [ i1; i2; i3 ] rest
            | ( Ldot (Lident "Bigarray", "Genarray"),
                { pexp_desc = Pexp_array indexes; pexp_attributes = [] } :: rest
              ) ->
                print ".{" "," "}" (simple_expr ctxt) indexes rest
            | _ -> false)
        | (Lident s | Ldot (_, s)), a :: i :: rest when first_is '.' s ->
            (* extract operator:
               assignment operators end with [right_bracket ^ "<-"],
               access operators end with [right_bracket] directly
            *)
            let multi_indices = String.contains s ';' in
            let i =
              match i.pexp_desc with
              | Pexp_array l when multi_indices -> l
              | _ -> [ i ]
            in
            let assign = last_is '-' s in
            let kind =
              (* extract the right end bracket *)
              let n = String.length s in
              if assign then s.[n - 3] else s.[n - 1]
            in
            let left, right =
              match kind with
              | ')' -> ('(', ")")
              | ']' -> ('[', "]")
              | '}' -> ('{', "}")
              | _ -> assert false
            in
            let path_prefix =
              match id with Ldot (m, _) -> Some m | _ -> None
            in
            let left = String.sub s 0 (1 + String.index s left) in
            print_indexop a path_prefix assign left ";" right
              (if multi_indices then expression ctxt else simple_expr ctxt)
              i rest
        | _ -> false)
    | _ -> false

and expression ctxt f x =
  if x.pexp_attributes <> [] then
    pp f "((%a)@,%a)" (expression ctxt)
      { x with pexp_attributes = [] }
      (attributes ctxt) x.pexp_attributes
  else
    match x.pexp_desc with
    | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
    | Pexp_newtype _
      when ctxt.pipe || ctxt.semi ->
        paren true (expression reset_ctxt) f x
    | (Pexp_ifthenelse _ | Pexp_sequence _) when ctxt.ifthenelse ->
        paren true (expression reset_ctxt) f x
    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _
    | Pexp_letop _
      when ctxt.semi ->
        paren true (expression reset_ctxt) f x
    | Pexp_fun (l, e0, p, e) ->
        pp f "@[<2>fun@;%a->@;%a@]" (label_exp ctxt) (l, e0, p)
          (expression ctxt) e
    | Pexp_newtype (lid, e) ->
        pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt (expression ctxt) e
    | Pexp_function l -> pp f "@[<hv>function%a@]" (case_list ctxt) l
    | Pexp_match (e, l) ->
        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt)
          e (case_list ctxt) l
    | Pexp_try (e, l) ->
        pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
          (* "try@;@[<2>%a@]@\nwith@\n%a"*)
          (expression reset_ctxt)
          e (case_list ctxt) l
    | Pexp_let (rf, l, e) ->
        (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
           (*no indentation here, a new line*) *)
        (*   rec_flag rf *)
        pp f "@[<2>%a in@;<1 -2>%a@]" (bindings reset_ctxt) (rf, l)
          (expression ctxt) e
    | Pexp_apply (e, l) -> (
        if not (sugar_expr ctxt f x) then
          match view_fixity_of_exp e with
          | `Infix s -> (
              match l with
              | [ ((Nolabel, _) as arg1); ((Nolabel, _) as arg2) ] ->
                  (* FIXME associativity label_x_expression_param *)
                  pp f "@[<2>%a@;%s@;%a@]"
                    (label_x_expression_param reset_ctxt)
                    arg1 s
                    (label_x_expression_param ctxt)
                    arg2
              | _ ->
                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
                    (list (label_x_expression_param ctxt))
                    l)
          | `Prefix s -> (
              let s =
                if
                  List.mem s [ "~+"; "~-"; "~+."; "~-." ]
                  &&
                  match l with
                  (* See #7200: avoid turning (~- 1) into (- 1) which is
                     parsed as an int literal *)
                  | [ (_, { pexp_desc = Pexp_constant _ }) ] -> false
                  | _ -> true
                then String.sub s 1 (String.length s - 1)
                else s
              in
              match l with
              | [ (Nolabel, x) ] -> pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x
              | _ ->
                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
                    (list (label_x_expression_param ctxt))
                    l)
          | _ ->
              pp f "@[<hov2>%a@]"
                (fun f (e, l) ->
                  pp f "%a@ %a" (expression2 ctxt) e
                    (list (label_x_expression_param reset_ctxt))
                    l
                  (* reset here only because [function,match,try,sequence]
                     are lower priority *))
                (e, l))
    | Pexp_construct (li, Some eo) when not (is_simple_construct (view_expr x))
      -> (
        (* Not efficient FIXME*)
        match view_expr x with
        | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;"
        | `normal -> pp f "@[<2>%a@;%a@]" longident_loc li (simple_expr ctxt) eo
        | _ -> assert false)
    | Pexp_setfield (e1, li, e2) ->
        pp f "@[<2>%a.%a@ <-@ %a@]" (simple_expr ctxt) e1 longident_loc li
          (simple_expr ctxt) e2
    | Pexp_ifthenelse (e1, e2, eo) ->
        (* @;@[<2>else@ %a@]@] *)
        let fmt : (_, _, _) format =
          "@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]"
        in
        let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in
        pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2
          (fun f eo ->
            match eo with
            | Some x ->
                pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x
            | None -> ()
            (* pp f "()" *))
          eo
    | Pexp_sequence _ ->
        let rec sequence_helper acc = function
          | { pexp_desc = Pexp_sequence (e1, e2); pexp_attributes = [] } ->
              sequence_helper (e1 :: acc) e2
          | v -> List.rev (v :: acc)
        in
        let lst = sequence_helper [] x in
        pp f "@[<hv>%a@]" (list (expression (under_semi ctxt)) ~sep:";@;") lst
    | Pexp_new li -> pp f "@[<hov2>new@ %a@]" longident_loc li
    | Pexp_setinstvar (s, e) ->
        pp f "@[<hov2>%s@ <-@ %a@]" s.txt (expression ctxt) e
    | Pexp_override l ->
        (* FIXME *)
        let string_x_expression f (s, e) =
          pp f "@[<hov2>%s@ =@ %a@]" s.txt (expression ctxt) e
        in
        pp f "@[<hov2>{<%a>}@]" (list string_x_expression ~sep:";") l
    | Pexp_letmodule (s, me, e) ->
        pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]"
          (Option.value s.txt ~default:"_")
          (module_expr reset_ctxt) me (expression ctxt) e
    | Pexp_letexception (cd, e) ->
        pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
          (extension_constructor ctxt)
          cd (expression ctxt) e
    | Pexp_assert e -> pp f "@[<hov2>assert@ %a@]" (simple_expr ctxt) e
    | Pexp_lazy e -> pp f "@[<hov2>lazy@ %a@]" (simple_expr ctxt) e
    (* Pexp_poly: impossible but we should print it anyway, rather than
       assert false *)
    | Pexp_poly (e, None) -> pp f "@[<hov2>!poly!@ %a@]" (simple_expr ctxt) e
    | Pexp_poly (e, Some ct) ->
        pp f "@[<hov2>(!poly!@ %a@ : %a)@]" (simple_expr ctxt) e
          (core_type ctxt) ct
    | Pexp_open (o, e) ->
        pp f "@[<2>let open%s %a in@;%a@]"
          (override o.popen_override)
          (module_expr ctxt) o.popen_expr (expression ctxt) e
    | Pexp_variant (l, Some eo) -> pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
    | Pexp_letop { let_; ands; body } ->
        pp f "@[<2>@[<v>%a@,%a@] in@;<1 -2>%a@]" (binding_op ctxt) let_
          (list ~sep:"@," (binding_op ctxt))
          ands (expression ctxt) body
    | Pexp_extension e -> extension ctxt f e
    | Pexp_unreachable -> pp f "."
    | _ -> expression1 ctxt f x

and expression1 ctxt f x =
  if x.pexp_attributes <> [] then expression ctxt f x
  else
    match x.pexp_desc with
    | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs
    | _ -> expression2 ctxt f x
(* used in [Pexp_apply] *)

and expression2 ctxt f x =
  if x.pexp_attributes <> [] then expression ctxt f x
  else
    match x.pexp_desc with
    | Pexp_field (e, li) ->
        pp f "@[<hov2>%a.%a@]" (simple_expr ctxt) e longident_loc li
    | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s.txt
    | _ -> simple_expr ctxt f x

and simple_expr ctxt f x =
  if x.pexp_attributes <> [] then expression ctxt f x
  else
    match x.pexp_desc with
    | Pexp_construct _ when is_simple_construct (view_expr x) -> (
        match view_expr x with
        | `nil -> pp f "[]"
        | `tuple -> pp f "()"
        | `list xs ->
            pp f "@[<hv0>[%a]@]"
              (list (expression (under_semi ctxt)) ~sep:";@;")
              xs
        | `simple x -> longident f x
        | _ -> assert false)
    | Pexp_ident li -> longident_loc f li
    (* (match view_fixity_of_exp x with *)
    (* |`Normal -> longident_loc f li *)
    (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *)
    | Pexp_constant c -> constant f c
    | Pexp_pack me -> pp f "(module@;%a)" (module_expr ctxt) me
    | Pexp_tuple l ->
        pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
    | Pexp_constraint (e, ct) ->
        pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
    | Pexp_coerce (e, cto1, ct) ->
        pp f "(%a%a :> %a)" (expression ctxt) e
          (option (core_type ctxt) ~first:" : " ~last:" ")
          cto1
          (* no sep hint*) (core_type ctxt)
          ct
    | Pexp_variant (l, None) -> pp f "`%s" l
    | Pexp_record (l, eo) ->
        let longident_x_expression f (li, e) =
          match e with
          | { pexp_desc = Pexp_ident { txt; _ }; pexp_attributes = []; _ }
            when li.txt = txt ->
              pp f "@[<hov2>%a@]" longident_loc li
          | _ ->
              pp f "@[<hov2>%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
        in
        pp f "@[<hv0>@[<hv2>{@;%a%a@]@;}@]" (* "@[<hov2>{%a%a}@]" *)
          (option ~last:" with@;" (simple_expr ctxt))
          eo
          (list longident_x_expression ~sep:";@;")
          l
    | Pexp_array l ->
        pp f "@[<0>@[<2>[|%a|]@]@]"
          (list (simple_expr (under_semi ctxt)) ~sep:";")
          l
    | Pexp_while (e1, e2) ->
        let fmt : (_, _, _) format = "@[<2>while@;%a@;do@;%a@;done@]" in
        pp f fmt (expression ctxt) e1 (expression ctxt) e2
    | Pexp_for (s, e1, e2, df, e3) ->
        let fmt : (_, _, _) format =
          "@[<hv0>@[<hv2>@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]"
        in
        let expression = expression ctxt in
        pp f fmt (pattern ctxt) s expression e1 direction_flag df expression e2
          expression e3
    | _ -> paren true (expression ctxt) f x

and attributes ctxt f l = List.iter (attribute ctxt f) l
and item_attributes ctxt f l = List.iter (item_attribute ctxt f) l

and classify_attribute = function
  | { attr_name = { txt = "ocaml.doc"; _ };
      attr_payload =
        (PStr [{ pstr_desc =
           Pstr_eval ({
             pexp_desc =
               Pexp_constant (Pconst_string (docstr, _, _))}, _)}]);
    } -> `docstr docstr
  | a -> `misc a

and attribute ctxt f = classify_attribute &> function
  | `docstr str -> pp f "@[<2>(** %s *)@]" str
  | `misc a ->pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload

and item_attribute ctxt f = classify_attribute &> function
  | `docstr str -> pp f "@[<2>(** %s *)@\n@]" str
  | `misc a ->
     pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload

and floating_attribute ctxt f = classify_attribute &> function
  | `docstr str -> pp f "@[<2>(** %s *)@]" str
  | `misc a ->
     pp f "@\n@[<2>[@@@@@@%s@ %a]@]@\n" a.attr_name.txt (payload ctxt) a.attr_payload

and value_description ctxt f x =
  (* note: value_description has an attribute field,
           but they're already printed by the callers this method *)
  pp f "@[<hov2>%a%a@]" (core_type ctxt) x.pval_type
    (fun f x ->
      if x.pval_prim <> [] then
        pp f "@ =@ %a" (list constant_string) x.pval_prim)
    x

and extension ctxt f (s, e) = pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e

and item_extension ctxt f (s, e) =
  pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e

and exception_declaration ctxt f x =
  pp f "@[<hov2>exception@ %a@]%a"
    (extension_constructor ctxt)
    x.ptyexn_constructor (item_attributes ctxt) x.ptyexn_attributes

and class_type_field ctxt f x =
  match x.pctf_desc with
  | Pctf_inherit ct ->
      pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct (item_attributes ctxt)
        x.pctf_attributes
  | Pctf_val (s, mf, vf, ct) ->
      pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" mutable_flag mf virtual_flag vf s.txt
        (core_type ctxt) ct (item_attributes ctxt) x.pctf_attributes
  | Pctf_method (s, pf, vf, ct) ->
      pp f "@[<2>method %a %a%s :@;%a@]%a" private_flag pf virtual_flag vf s.txt
        (core_type ctxt) ct (item_attributes ctxt) x.pctf_attributes
  | Pctf_constraint (ct1, ct2) ->
      pp f "@[<2>constraint@ %a@ =@ %a@]%a" (core_type ctxt) ct1
        (core_type ctxt) ct2 (item_attributes ctxt) x.pctf_attributes
  | Pctf_attribute a -> floating_attribute ctxt f a
  | Pctf_extension e ->
      item_extension ctxt f e;
      item_attributes ctxt f x.pctf_attributes

and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l; _ } =
  pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
    (fun f -> function
      | { ptyp_desc = Ptyp_any; ptyp_attributes = []; _ } -> ()
      | ct -> pp f " (%a)" (core_type ctxt) ct)
    ct
    (list (class_type_field ctxt) ~sep:"@;")
    l

(* call [class_signature] called by [class_signature] *)
and class_type ctxt f x =
  match x.pcty_desc with
  | Pcty_signature cs ->
      class_signature ctxt f cs;
      attributes ctxt f x.pcty_attributes
  | Pcty_constr (li, l) ->
      pp f "%a%a%a"
        (fun f l ->
          match l with
          | [] -> ()
          | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:",") l)
        l longident_loc li (attributes ctxt) x.pcty_attributes
  | Pcty_arrow (l, co, cl) ->
      pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
        (type_with_label ctxt) (l, co) (class_type ctxt) cl
  | Pcty_extension e ->
      extension ctxt f e;
      attributes ctxt f x.pcty_attributes
  | Pcty_open (o, e) ->
      pp f "@[<2>let open%s %a in@;%a@]"
        (override o.popen_override)
        longident_loc o.popen_expr (class_type ctxt) e

(* [class type a = object end] *)
and class_type_declaration_list ctxt f l =
  let class_type_declaration kwd f x =
    let { pci_params = ls; pci_name = { txt; _ }; _ } = x in
    pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd virtual_flag x.pci_virt
      (class_params_def ctxt) ls txt (class_type ctxt) x.pci_expr
      (item_attributes ctxt) x.pci_attributes
  in
  match l with
  | [] -> ()
  | [ x ] -> class_type_declaration "class type" f x
  | x :: xs ->
      pp f "@[<v>%a@,%a@]"
        (class_type_declaration "class type")
        x
        (list ~sep:"@," (class_type_declaration "and"))
        xs

and class_field ctxt f x =
  match x.pcf_desc with
  | Pcf_inherit (ovf, ce, so) ->
      pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) (class_expr ctxt) ce
        (fun f so ->
          match so with None -> () | Some s -> pp f "@ as %s" s.txt)
        so (item_attributes ctxt) x.pcf_attributes
  | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
      pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) mutable_flag mf s.txt
        (expression ctxt) e (item_attributes ctxt) x.pcf_attributes
  | Pcf_method (s, pf, Cfk_virtual ct) ->
      pp f "@[<2>method virtual %a %s :@;%a@]%a" private_flag pf s.txt
        (core_type ctxt) ct (item_attributes ctxt) x.pcf_attributes
  | Pcf_val (s, mf, Cfk_virtual ct) ->
      pp f "@[<2>val virtual %a%s :@ %a@]%a" mutable_flag mf s.txt
        (core_type ctxt) ct (item_attributes ctxt) x.pcf_attributes
  | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
      let bind e =
        binding ctxt f
          {
            pvb_pat =
              {
                ppat_desc = Ppat_var s;
                ppat_loc = Location.none;
                ppat_loc_stack = [];
                ppat_attributes = [];
              };
            pvb_expr = e;
            pvb_attributes = [];
            pvb_loc = Location.none;
          }
      in
      pp f "@[<2>method%s %a%a@]%a" (override ovf) private_flag pf
        (fun f -> function
          | { pexp_desc = Pexp_poly (e, Some ct); pexp_attributes = []; _ } ->
              pp f "%s :@;%a=@;%a" s.txt (core_type ctxt) ct (expression ctxt) e
          | { pexp_desc = Pexp_poly (e, None); pexp_attributes = []; _ } ->
              bind e
          | _ -> bind e)
        e (item_attributes ctxt) x.pcf_attributes
  | Pcf_constraint (ct1, ct2) ->
      pp f "@[<2>constraint %a =@;%a@]%a" (core_type ctxt) ct1 (core_type ctxt)
        ct2 (item_attributes ctxt) x.pcf_attributes
  | Pcf_initializer e ->
      pp f "@[<2>initializer@ %a@]%a" (expression ctxt) e (item_attributes ctxt)
        x.pcf_attributes
  | Pcf_attribute a -> floating_attribute ctxt f a
  | Pcf_extension e ->
      item_extension ctxt f e;
      item_attributes ctxt f x.pcf_attributes

and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } =
  pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]"
    (fun f p ->
      match p.ppat_desc with
      | Ppat_any -> ()
      | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p
      | _ -> pp f " (%a)" (pattern ctxt) p)
    p
    (list (class_field ctxt))
    l

and class_expr ctxt f x =
  if x.pcl_attributes <> [] then
    pp f "((%a)%a)" (class_expr ctxt)
      { x with pcl_attributes = [] }
      (attributes ctxt) x.pcl_attributes
  else
    match x.pcl_desc with
    | Pcl_structure cs -> class_structure ctxt f cs
    | Pcl_fun (l, eo, p, e) ->
        pp f "fun@ %a@ ->@ %a" (label_exp ctxt) (l, eo, p) (class_expr ctxt) e
    | Pcl_let (rf, l, ce) ->
        pp f "%a@ in@ %a" (bindings ctxt) (rf, l) (class_expr ctxt) ce
    | Pcl_apply (ce, l) ->
        pp f "((%a)@ %a)"
          (* Cf: #7200 *) (class_expr ctxt)
          ce
          (list (label_x_expression_param ctxt))
          l
    | Pcl_constr (li, l) ->
        pp f "%a%a"
          (fun f l ->
            if l <> [] then pp f "[%a]@ " (list (core_type ctxt) ~sep:",") l)
          l longident_loc li
    | Pcl_constraint (ce, ct) ->
        pp f "(%a@ :@ %a)" (class_expr ctxt) ce (class_type ctxt) ct
    | Pcl_extension e -> extension ctxt f e
    | Pcl_open (o, e) ->
        pp f "@[<2>let open%s %a in@;%a@]"
          (override o.popen_override)
          longident_loc o.popen_expr (class_expr ctxt) e

and module_type ctxt f x =
  if x.pmty_attributes <> [] then
    pp f "((%a)%a)" (module_type ctxt)
      { x with pmty_attributes = [] }
      (attributes ctxt) x.pmty_attributes
  else
    match x.pmty_desc with
    | Pmty_functor (Unit, mt2) ->
        pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
    | Pmty_functor (Named (s, mt1), mt2) -> (
        match s.txt with
        | None ->
            pp f "@[<hov2>%a@ ->@ %a@]" (module_type1 ctxt) mt1
              (module_type ctxt) mt2
        | Some name ->
            pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" name
              (module_type ctxt) mt1 (module_type ctxt) mt2)
    | Pmty_with (mt, []) -> module_type ctxt f mt
    | Pmty_with (mt, l) ->
        pp f "@[<hov2>%a@ with@ %a@]" (module_type1 ctxt) mt
          (list (with_constraint ctxt) ~sep:"@ and@ ")
          l
    | _ -> module_type1 ctxt f x

and with_constraint ctxt f = function
  | Pwith_type (li, ({ ptype_params = ls; _ } as td)) ->
      let ls = List.map fst ls in
      pp f "type@ %a %a =@ %a"
        (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
        ls longident_loc li (type_declaration ctxt) td
  | Pwith_module (li, li2) ->
      pp f "module %a =@ %a" longident_loc li longident_loc li2
  | Pwith_modtype (li, mty) ->
      pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty
  | Pwith_typesubst (li, ({ ptype_params = ls; _ } as td)) ->
      let ls = List.map fst ls in
      pp f "type@ %a %a :=@ %a"
        (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
        ls longident_loc li (type_declaration ctxt) td
  | Pwith_modsubst (li, li2) ->
      pp f "module %a :=@ %a" longident_loc li longident_loc li2
  | Pwith_modtypesubst (li, mty) ->
      pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty

and module_type1 ctxt f x =
  if x.pmty_attributes <> [] then module_type ctxt f x
  else
    match x.pmty_desc with
    | Pmty_ident li -> pp f "%a" longident_loc li
    | Pmty_alias li -> pp f "(module %a)" longident_loc li
    | Pmty_signature s ->
        pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
          (list (signature_item ctxt))
          s
        (* FIXME wrong indentation*)
    | Pmty_typeof me ->
        pp f "@[<hov2>module@ type@ of@ %a@]" (module_expr ctxt) me
    | Pmty_extension e -> extension ctxt f e
    | _ -> paren true (module_type ctxt) f x

and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x

and signature_item ctxt f x : unit =
  match x.psig_desc with
  | Psig_type (rf, l) -> type_def_list ctxt f (rf, true, l)
  | Psig_typesubst l ->
      (* Psig_typesubst is never recursive, but we specify [Recursive] here to
         avoid printing a [nonrec] flag, which would be rejected by the parser.
      *)
      type_def_list ctxt f (Recursive, false, l)
  | Psig_value vd ->
      let intro = if vd.pval_prim = [] then "val" else "external" in
      pp f "@[<2>%s@ %a@ :@ %a@]%a" intro protect_ident vd.pval_name.txt
        (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes
  | Psig_typext te -> type_extension ctxt f te
  | Psig_exception ed -> exception_declaration ctxt f ed
  | Psig_class l -> (
      let class_description kwd f
          ({ pci_params = ls; pci_name = { txt; _ }; _ } as x) =
        pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd virtual_flag x.pci_virt
          (class_params_def ctxt) ls txt (class_type ctxt) x.pci_expr
          (item_attributes ctxt) x.pci_attributes
      in
      match l with
      | [] -> ()
      | [ x ] -> class_description "class" f x
      | x :: xs ->
          pp f "@[<v>%a@,%a@]"
            (class_description "class")
            x
            (list ~sep:"@," (class_description "and"))
            xs)
  | Psig_module
      ({
         pmd_type = { pmty_desc = Pmty_alias alias; pmty_attributes = []; _ };
         _;
       } as pmd) ->
      pp f "@[<hov>module@ %s@ =@ %a@]%a"
        (Option.value pmd.pmd_name.txt ~default:"_")
        longident_loc alias (item_attributes ctxt) pmd.pmd_attributes
  | Psig_module pmd ->
      pp f "@[<hov>module@ %s@ :@ %a@]%a"
        (Option.value pmd.pmd_name.txt ~default:"_")
        (module_type ctxt) pmd.pmd_type (item_attributes ctxt)
        pmd.pmd_attributes
  | Psig_modsubst pms ->
      pp f "@[<hov>module@ %s@ :=@ %a@]%a" pms.pms_name.txt longident_loc
        pms.pms_manifest (item_attributes ctxt) pms.pms_attributes
  | Psig_open od ->
      pp f "@[<hov2>open%s@ %a@]%a"
        (override od.popen_override)
        longident_loc od.popen_expr (item_attributes ctxt) od.popen_attributes
  | Psig_include incl ->
      pp f "@[<hov2>include@ %a@]%a" (module_type ctxt) incl.pincl_mod
        (item_attributes ctxt) incl.pincl_attributes
  | Psig_modtype { pmtd_name = s; pmtd_type = md; pmtd_attributes = attrs } ->
      pp f "@[<hov2>module@ type@ %s%a@]%a" s.txt
        (fun f md ->
          match md with
          | None -> ()
          | Some mt ->
              pp_print_space f ();
              pp f "@ =@ %a" (module_type ctxt) mt)
        md (item_attributes ctxt) attrs
  | Psig_modtypesubst { pmtd_name = s; pmtd_type = md; pmtd_attributes = attrs }
    ->
      let md =
        match md with None -> assert false (* ast invariant *) | Some mt -> mt
      in
      pp f "@[<hov2>module@ type@ %s@ :=@ %a@]%a" s.txt (module_type ctxt) md
        (item_attributes ctxt) attrs
  | Psig_class_type l -> class_type_declaration_list ctxt f l
  | Psig_recmodule decls ->
      let rec string_x_module_type_list f ?(first = true) l =
        match l with
        | [] -> ()
        | pmd :: tl ->
            if not first then
              pp f "@ @[<hov2>and@ %s:@ %a@]%a"
                (Option.value pmd.pmd_name.txt ~default:"_")
                (module_type1 ctxt) pmd.pmd_type (item_attributes ctxt)
                pmd.pmd_attributes
            else
              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a"
                (Option.value pmd.pmd_name.txt ~default:"_")
                (module_type1 ctxt) pmd.pmd_type (item_attributes ctxt)
                pmd.pmd_attributes;
            string_x_module_type_list f ~first:false tl
      in
      string_x_module_type_list f decls
  | Psig_attribute a -> floating_attribute ctxt f a
  | Psig_extension (e, a) ->
      item_extension ctxt f e;
      item_attributes ctxt f a

and module_expr ctxt f x =
  if x.pmod_attributes <> [] then
    pp f "((%a)%a)" (module_expr ctxt)
      { x with pmod_attributes = [] }
      (attributes ctxt) x.pmod_attributes
  else
    match x.pmod_desc with
    | Pmod_structure s ->
        pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
          (list (structure_item ctxt) ~sep:"@\n")
          s
    | Pmod_constraint (me, mt) ->
        pp f "@[<hov2>(%a@ :@ %a)@]" (module_expr ctxt) me (module_type ctxt) mt
    | Pmod_ident li -> pp f "%a" longident_loc li
    | Pmod_functor (Unit, me) -> pp f "functor ()@;->@;%a" (module_expr ctxt) me
    | Pmod_functor (Named (s, mt), me) ->
        pp f "functor@ (%s@ :@ %a)@;->@;%a"
          (Option.value s.txt ~default:"_")
          (module_type ctxt) mt (module_expr ctxt) me
    | Pmod_apply (me1, me2) ->
        pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
        (* Cf: #7200 *)
    | Pmod_unpack e -> pp f "(val@ %a)" (expression ctxt) e
    | Pmod_extension e -> extension ctxt f e

and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x

and payload ctxt f = function
  | PStr [ { pstr_desc = Pstr_eval (e, attrs) } ] ->
      pp f "@[<2>%a@]%a" (expression ctxt) e (item_attributes ctxt) attrs
  | PStr x -> structure ctxt f x
  | PTyp x ->
      pp f ":@ ";
      core_type ctxt f x
  | PSig x ->
      pp f ":@ ";
      signature ctxt f x
  | PPat (x, None) ->
      pp f "?@ ";
      pattern ctxt f x
  | PPat (x, Some e) ->
      pp f "?@ ";
      pattern ctxt f x;
      pp f " when ";
      expression ctxt f e

(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
and binding ctxt f { pvb_pat = p; pvb_expr = x; _ } =
  (* .pvb_attributes have already been printed by the caller, #bindings *)
  let rec pp_print_pexp_function f x =
    if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
    else
      match x.pexp_desc with
      | Pexp_fun (label, eo, p, e) ->
          if label = Nolabel then
            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
          else
            pp f "%a@ %a" (label_exp ctxt) (label, eo, p) pp_print_pexp_function
              e
      | Pexp_newtype (str, e) ->
          pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e
      | _ -> pp f "=@;%a" (expression ctxt) x
  in
  let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
  let is_desugared_gadt p e =
    let gadt_pattern =
      match p with
      | {
       ppat_desc =
         Ppat_constraint
           ( ({ ppat_desc = Ppat_var _ } as pat),
             { ptyp_desc = Ptyp_poly (args_tyvars, rt) } );
       ppat_attributes = [];
      } ->
          Some (pat, args_tyvars, rt)
      | _ -> None
    in
    let rec gadt_exp tyvars e =
      match e with
      | { pexp_desc = Pexp_newtype (tyvar, e); pexp_attributes = [] } ->
          gadt_exp (tyvar :: tyvars) e
      | { pexp_desc = Pexp_constraint (e, ct); pexp_attributes = [] } ->
          Some (List.rev tyvars, e, ct)
      | _ -> None
    in
    let gadt_exp = gadt_exp [] e in
    match (gadt_pattern, gadt_exp) with
    | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct)
      when tyvars_str pt_tyvars = tyvars_str e_tyvars ->
        let ety = varify_type_constructors e_tyvars e_ct in
        if ety = pt_ct then Some (p, pt_tyvars, e_ct, e) else None
    | _ -> None
  in
  if x.pexp_attributes <> [] then
    match p with
    | {
     ppat_desc =
       Ppat_constraint
         ( ({ ppat_desc = Ppat_var _; _ } as pat),
           ({ ptyp_desc = Ptyp_poly _; _ } as typ) );
     ppat_attributes = [];
     _;
    } ->
        pp f "%a@;: %a@;=@;%a" (simple_pattern ctxt) pat (core_type ctxt) typ
          (expression ctxt) x
    | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
  else
    match is_desugared_gadt p x with
    | Some (p, [], ct, e) ->
        pp f "%a@;: %a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ct
          (expression ctxt) e
    | Some (p, tyvars, ct, e) ->
        pp f "%a@;: type@;%a.@;%a@;=@;%a" (simple_pattern ctxt) p
          (list pp_print_string ~sep:"@;")
          (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
    | None -> (
        match p with
        | { ppat_desc = Ppat_constraint (p, ty); ppat_attributes = [] } -> (
            (* special case for the first*)
            match ty with
            | { ptyp_desc = Ptyp_poly _; ptyp_attributes = [] } ->
                pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt)
                  ty (expression ctxt) x
            | _ ->
                pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
                  (core_type ctxt) ty (expression ctxt) x)
        | { ppat_desc = Ppat_var _; ppat_attributes = [] } ->
            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
        | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x)

(* [in] is not printed *)
and bindings ctxt f (rf, l) =
  let binding kwd rf f x =
    pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf (binding ctxt) x
      (item_attributes ctxt) x.pvb_attributes
  in
  match l with
  | [] -> ()
  | [ x ] -> binding "let" rf f x
  | x :: xs ->
      pp f "@[<v>%a@,%a@]" (binding "let" rf) x
        (list ~sep:"@," (binding "and" Nonrecursive))
        xs

and binding_op ctxt f x =
  match (x.pbop_pat, x.pbop_exp) with
  | ( { ppat_desc = Ppat_var { txt = pvar; _ }; ppat_attributes = []; _ },
      {
        pexp_desc = Pexp_ident { txt = Lident evar; _ };
        pexp_attributes = [];
        _;
      } )
    when pvar = evar ->
      pp f "@[<2>%s %s@]" x.pbop_op.txt evar
  | pat, exp ->
      pp f "@[<2>%s %a@;=@;%a@]" x.pbop_op.txt (pattern ctxt) pat
        (expression ctxt) exp

and structure_item ctxt f x =
  match x.pstr_desc with
  | Pstr_eval (e, attrs) ->
      pp f "@[<hov2>;;%a@]%a" (expression ctxt) e (item_attributes ctxt) attrs
  | Pstr_type (_, []) -> assert false
  | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l)
  | Pstr_value (rf, l) ->
      (* pp f "@[<hov2>let %a%a@]"  rec_flag rf bindings l *)
      pp f "@[<2>%a@]" (bindings ctxt) (rf, l)
  | Pstr_typext te -> type_extension ctxt f te
  | Pstr_exception ed -> exception_declaration ctxt f ed
  | Pstr_module x ->
      let rec module_helper = function
        | { pmod_desc = Pmod_functor (arg_opt, me'); pmod_attributes = [] } ->
            (match arg_opt with
            | Unit -> pp f "()"
            | Named (s, mt) ->
                pp f "(%s:%a)"
                  (Option.value s.txt ~default:"_")
                  (module_type ctxt) mt);
            module_helper me'
        | me -> me
      in
      pp f "@[<hov2>module %s%a@]%a"
        (Option.value x.pmb_name.txt ~default:"_")
        (fun f me ->
          let me = module_helper me in
          match me with
          | {
           pmod_desc =
             Pmod_constraint
               (me', ({ pmty_desc = Pmty_ident _ | Pmty_signature _; _ } as mt));
           pmod_attributes = [];
          } ->
              pp f " :@;%a@;=@;%a@;" (module_type ctxt) mt (module_expr ctxt)
                me'
          | _ -> pp f " =@ %a" (module_expr ctxt) me)
        x.pmb_expr (item_attributes ctxt) x.pmb_attributes
  | Pstr_open od ->
      pp f "@[<2>open%s@;%a@]%a"
        (override od.popen_override)
        (module_expr ctxt) od.popen_expr (item_attributes ctxt)
        od.popen_attributes
  | Pstr_modtype { pmtd_name = s; pmtd_type = md; pmtd_attributes = attrs } ->
      pp f "@[<hov2>module@ type@ %s%a@]%a" s.txt
        (fun f md ->
          match md with
          | None -> ()
          | Some mt ->
              pp_print_space f ();
              pp f "@ =@ %a" (module_type ctxt) mt)
        md (item_attributes ctxt) attrs
  | Pstr_class l -> (
      let extract_class_args cl =
        let rec loop acc = function
          | { pcl_desc = Pcl_fun (l, eo, p, cl'); pcl_attributes = [] } ->
              loop ((l, eo, p) :: acc) cl'
          | cl -> (List.rev acc, cl)
        in
        let args, cl = loop [] cl in
        let constr, cl =
          match cl with
          | { pcl_desc = Pcl_constraint (cl', ct); pcl_attributes = [] } ->
              (Some ct, cl')
          | _ -> (None, cl)
        in
        (args, constr, cl)
      in
      let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in
      let class_declaration kwd f
          ({ pci_params = ls; pci_name = { txt; _ }; _ } as x) =
        let args, constr, cl = extract_class_args x.pci_expr in
        pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd virtual_flag x.pci_virt
          (class_params_def ctxt) ls txt
          (list (label_exp ctxt))
          args (option class_constraint) constr (class_expr ctxt) cl
          (item_attributes ctxt) x.pci_attributes
      in
      match l with
      | [] -> ()
      | [ x ] -> class_declaration "class" f x
      | x :: xs ->
          pp f "@[<v>%a@,%a@]"
            (class_declaration "class")
            x
            (list ~sep:"@," (class_declaration "and"))
            xs)
  | Pstr_class_type l -> class_type_declaration_list ctxt f l
  | Pstr_primitive vd ->
      pp f "@[<hov2>external@ %a@ :@ %a@]%a" protect_ident vd.pval_name.txt
        (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes
  | Pstr_include incl ->
      pp f "@[<hov2>include@ %a@]%a" (module_expr ctxt) incl.pincl_mod
        (item_attributes ctxt) incl.pincl_attributes
  | Pstr_recmodule decls -> (
      (* 3.07 *)
      let aux f = function
        | { pmb_expr = { pmod_desc = Pmod_constraint (expr, typ) } } as pmb ->
            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a"
              (Option.value pmb.pmb_name.txt ~default:"_")
              (module_type ctxt) typ (module_expr ctxt) expr
              (item_attributes ctxt) pmb.pmb_attributes
        | pmb ->
            pp f "@[<hov2>@ and@ %s@ =@ %a@]%a"
              (Option.value pmb.pmb_name.txt ~default:"_")
              (module_expr ctxt) pmb.pmb_expr (item_attributes ctxt)
              pmb.pmb_attributes
      in
      match decls with
      | ({ pmb_expr = { pmod_desc = Pmod_constraint (expr, typ) } } as pmb)
        :: l2 ->
          pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
            (Option.value pmb.pmb_name.txt ~default:"_")
            (module_type ctxt) typ (module_expr ctxt) expr
            (item_attributes ctxt) pmb.pmb_attributes
            (fun f l2 -> List.iter (aux f) l2)
            l2
      | pmb :: l2 ->
          pp f "@[<hv>@[<hov2>module@ rec@ %s@ =@ %a@]%a@ %a@]"
            (Option.value pmb.pmb_name.txt ~default:"_")
            (module_expr ctxt) pmb.pmb_expr (item_attributes ctxt)
            pmb.pmb_attributes
            (fun f l2 -> List.iter (aux f) l2)
            l2
      | _ -> assert false)
  | Pstr_attribute a -> floating_attribute ctxt f a
  | Pstr_extension (e, a) ->
      item_extension ctxt f e;
      item_attributes ctxt f a

and type_param ctxt f (ct, (a, b)) =
  pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct

and type_params ctxt f = function
  | [] -> ()
  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l

and type_def_list ctxt f (rf, exported, l) =
  let type_decl kwd rf f x =
    let eq =
      if x.ptype_kind = Ptype_abstract && x.ptype_manifest = None then ""
      else if exported then " ="
      else " :="
    in
    pp f "@[<2>%s %a%a%s%s%a@]%a" kwd nonrec_flag rf (type_params ctxt)
      x.ptype_params x.ptype_name.txt eq (type_declaration ctxt) x
      (item_attributes ctxt) x.ptype_attributes
  in
  match l with
  | [] -> assert false
  | [ x ] -> type_decl "type" rf f x
  | x :: xs ->
      pp f "@[<v>%a@,%a@]" (type_decl "type" rf) x
        (list ~sep:"@," (type_decl "and" Recursive))
        xs

and record_declaration ctxt f lbls =
  let type_record_field f pld =
    pp f "@[<2>%a%s:@;%a@;%a@]" mutable_flag pld.pld_mutable pld.pld_name.txt
      (core_type ctxt) pld.pld_type (attributes ctxt) pld.pld_attributes
  in
  pp f "{@\n%a}" (list type_record_field ~sep:";@\n") lbls

and type_declaration ctxt f x =
  (* type_declaration has an attribute field,
     but it's been printed by the caller of this method *)
  let priv f =
    match x.ptype_private with Public -> () | Private -> pp f "@;private"
  in
  let manifest f =
    match x.ptype_manifest with
    | None -> ()
    | Some y ->
        if x.ptype_kind = Ptype_abstract then
          pp f "%t@;%a" priv (core_type ctxt) y
        else pp f "@;%a" (core_type ctxt) y
  in
  let constructor_declaration f pcd =
    pp f "|@;";
    constructor_declaration ctxt f
      ( pcd.pcd_name.txt,
        pcd.pcd_vars,
        pcd.pcd_args,
        pcd.pcd_res,
        pcd.pcd_attributes )
  in
  let repr f =
    let intro f = if x.ptype_manifest = None then () else pp f "@;=" in
    match x.ptype_kind with
    | Ptype_variant xs ->
        let variants fmt xs =
          if xs = [] then pp fmt " |"
          else pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs
        in
        pp f "%t%t%a" intro priv variants xs
    | Ptype_abstract -> ()
    | Ptype_record l -> pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
    | Ptype_open -> pp f "%t%t@;.." intro priv
  in
  let constraints f =
    List.iter
      (fun (ct1, ct2, _) ->
        pp f "@[<hov2>@ constraint@ %a@ =@ %a@]" (core_type ctxt) ct1
          (core_type ctxt) ct2)
      x.ptype_cstrs
  in
  pp f "%t%t%t" manifest repr constraints

and type_extension ctxt f x =
  let extension_constructor f x =
    pp f "@\n|@;%a" (extension_constructor ctxt) x
  in
  pp f "@[<2>type %a%a += %a@ %a@]%a"
    (fun f -> function
      | [] -> ()
      | l ->
          pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
    x.ptyext_params longident_loc x.ptyext_path private_flag
    x.ptyext_private (* Cf: #7200 *)
    (list ~sep:"" extension_constructor)
    x.ptyext_constructors (item_attributes ctxt) x.ptyext_attributes

and constructor_declaration ctxt f (name, vars, args, res, attrs) =
  let name = match name with "::" -> "(::)" | s -> s in
  let pp_vars f vs =
    match vs with
    | [] -> ()
    | vs -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") vs
  in
  match res with
  | None ->
      pp f "%s%a@;%a" name
        (fun f -> function
          | Pcstr_tuple [] -> ()
          | Pcstr_tuple l ->
              pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l
          | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l)
        args (attributes ctxt) attrs
  | Some r ->
      pp f "%s:@;%a%a@;%a" name pp_vars vars
        (fun f -> function
          | Pcstr_tuple [] -> core_type1 ctxt f r
          | Pcstr_tuple l ->
              pp f "%a@;->@;%a"
                (list (core_type1 ctxt) ~sep:"@;*@;")
                l (core_type1 ctxt) r
          | Pcstr_record l ->
              pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r)
        args (attributes ctxt) attrs

and extension_constructor ctxt f x =
  (* Cf: #7200 *)
  match x.pext_kind with
  | Pext_decl (v, l, r) ->
      constructor_declaration ctxt f
        (x.pext_name.txt, v, l, r, x.pext_attributes)
  | Pext_rebind li ->
      pp f "%s@;=@;%a%a" x.pext_name.txt longident_loc li (attributes ctxt)
        x.pext_attributes

and case_list ctxt f l : unit =
  let aux f { pc_lhs; pc_guard; pc_rhs } =
    pp f "@;| @[<2>%a%a@;->@;%a@]" (pattern ctxt) pc_lhs
      (option (expression ctxt) ~first:"@;when@;")
      pc_guard
      (expression (under_pipe ctxt))
      pc_rhs
  in
  list aux f l ~sep:""

and label_x_expression_param ctxt f (l, e) =
  let simple_name =
    match e with
    | { pexp_desc = Pexp_ident { txt = Lident l; _ }; pexp_attributes = [] } ->
        Some l
    | _ -> None
  in
  match l with
  | Nolabel -> expression2 ctxt f e (* level 2*)
  | Optional str ->
      if Some str = simple_name then pp f "?%s" str
      else pp f "?%s:%a" str (simple_expr ctxt) e
  | Labelled lbl ->
      if Some lbl = simple_name then pp f "~%s" lbl
      else pp f "~%s:%a" lbl (simple_expr ctxt) e

and directive_argument f x =
  match x.pdira_desc with
  | Pdir_string s -> pp f "@ %S" s
  | Pdir_int (n, None) -> pp f "@ %s" n
  | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
  | Pdir_ident li -> pp f "@ %a" longident li
  | Pdir_bool b -> pp f "@ %s" (string_of_bool b)

let toplevel_phrase f x =
  match x with
  | Ptop_def s -> pp f "@[<hov0>%a@]" (list (structure_item reset_ctxt)) s
  (* pp_open_hvbox f 0; *)
  (* pp_print_list structure_item f s ; *)
  (* pp_close_box f (); *)
  | Ptop_dir { pdir_name; pdir_arg = None; _ } ->
      pp f "@[<hov2>#%s@]" pdir_name.txt
  | Ptop_dir { pdir_name; pdir_arg = Some pdir_arg; _ } ->
      pp f "@[<hov2>#%s@ %a@]" pdir_name.txt directive_argument pdir_arg

let expression f x = pp f "@[%a@]" (expression reset_ctxt) x

let string_of_expression x =
  ignore (flush_str_formatter ());
  let f = str_formatter in
  expression f x;
  flush_str_formatter ()

let string_of_structure x =
  ignore (flush_str_formatter ());
  let f = str_formatter in
  structure reset_ctxt f x;
  flush_str_formatter ()

let top_phrase f x =
  pp_print_newline f ();
  toplevel_phrase f x;
  pp f ";;";
  pp_print_newline f ()

let core_type = core_type reset_ctxt
let pattern = pattern reset_ctxt
let signature = signature reset_ctxt
let structure = structure reset_ctxt
let class_expr = class_expr reset_ctxt
let class_field = class_field reset_ctxt
let class_type = class_type reset_ctxt
let class_signature = class_signature reset_ctxt
let class_type_field = class_type_field reset_ctxt
let module_expr = module_expr reset_ctxt
let module_type = module_type reset_ctxt
let signature_item = signature_item reset_ctxt
let structure_item = structure_item reset_ctxt
let type_declaration = type_declaration reset_ctxt
src/lib_gen/emitter.ml

37.55%
