(****************************************************************************)
(*                                                                          *)
(*                                   OCaml                                  *)
(*                                                                          *)
(*                            INRIA Rocquencourt                            *)
(*                                                                          *)
(*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed under   *)
(*  the terms of the GNU Library General Public License, with the special   *)
(*  exception on linking described in LICENSE at the top of the Camlp4      *)
(*  source tree.                                                            *)
(*                                                                          *)
(****************************************************************************)

(* Authors:
 * - Nicolas Pouillard: initial version
 *)

open Format;

module Id = struct
  value name = "Camlp4.Printers.OCaml";
  value version = Sys.ocaml_version;
end;

module Make (Syntax : Sig.Camlp4Syntax) = struct
  include Syntax;

  type sep = format unit formatter unit;
  type fun_binding = [= `patt of Ast.patt | `newtype of string ];

  value pp = fprintf;
  value cut f = fprintf f "@ ";

  value list' elt sep sep' f =
    let rec loop =
      fun
      [ [] -> ()
      | [x::xs] -> do { pp f sep ; elt f x; pp f sep'; loop xs } ] in
    fun
    [ [] -> ()
    | [x] -> do { elt f x; pp f sep' }
    | [x::xs] -> do { elt f x; pp f sep'; loop xs } ];

  value list elt sep f =
    let rec loop =
      fun
      [ [] -> ()
      | [x::xs] -> do { pp f sep ; elt f x; loop xs } ] in
    fun
    [ [] -> ()
    | [x] -> elt f x
    | [x::xs] -> do { elt f x; loop xs } ];

  value rec list_of_meta_list =
    fun
    [ Ast.LNil -> []
    | Ast.LCons x xs -> [x :: list_of_meta_list xs]
    | Ast.LAnt _ -> assert False ];

  value meta_list elt sep f mxs =
    let xs = list_of_meta_list mxs in
    list elt sep f xs;

  module CommentFilter = Struct.CommentFilter.Make Token;
  value comment_filter = CommentFilter.mk ();
  CommentFilter.define (Gram.get_filter ()) comment_filter;

  module StringSet = Set.Make String;

  value infix_lidents = ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"];

  value is_infix =
    let first_chars = ['='; '<'; '>'; '|'; '&'; '$'; '@'; '^'; '+'; '-'; '*'; '/'; '%'; '\\']
    and infixes =
      List.fold_right StringSet.add infix_lidents StringSet.empty
    in fun s -> (StringSet.mem s infixes
                 || (s <> "" && List.mem s.[0] first_chars));

  value is_keyword =
    let keywords = (* without infix_lidents *)
      List.fold_right StringSet.add
        ["and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
         "done"; "downto"; "else"; "end"; "exception"; "external"; "false";
         "for"; "fun"; "function"; "functor"; "if"; "in"; "include";
         "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module";
         "mutable"; "new"; "object";  "of";  "open"; "parser";  "private";  "rec"; "sig";
         "struct";  "then";  "to";  "true";  "try";  "type";  "val"; "virtual";
         "when"; "while"; "with"] StringSet.empty
      in fun s -> StringSet.mem s keywords;

  module Lexer = Struct.Lexer.Make Token;
  let module M = ErrorHandler.Register Lexer.Error in ();
  open Sig;
  value lexer s =
    Lexer.from_string ~quotations:Camlp4_config.quotations.val Loc.ghost s;
  value lex_string str =
    try match lexer str with parser
        [: `(tok, _); `(EOI, _) :] -> tok
    with
    [ Stream.Failure | Stream.Error _ ->
        failwith (sprintf
          "Cannot print %S this string contains more than one token" str)
    | Lexer.Error.E exn ->
        failwith (sprintf
          "Cannot print %S this identifier does not respect OCaml lexing rules (%s)"
          str (Lexer.Error.to_string exn)) ];

  (* This is to be sure character literals are always escaped. *)
  value ocaml_char x = Char.escaped (Struct.Token.Eval.char x);

  value rec get_expr_args a al =
    match a with
    [ <:expr< $a1$ $a2$ >> -> get_expr_args a1 [a2 :: al]
    | _ -> (a, al) ];

  value rec get_patt_args a al =
    match a with
    [ <:patt< $a1$ $a2$ >> -> get_patt_args a1 [a2 :: al]
    | _ -> (a, al) ];

  value rec get_ctyp_args a al =
    match a with
    [ <:ctyp< $a1$ $a2$ >> -> get_ctyp_args a1 [a2 :: al]
    | _ -> (a, al) ];

  value is_irrefut_patt = Ast.is_irrefut_patt;

  value rec expr_fun_args =
    fun
    [ <:expr< fun $p$ -> $e$ >> as ge ->
        if is_irrefut_patt p then
          let (pl, e) = expr_fun_args e in
          ([`patt p :: pl], e)
        else ([], ge)
    | <:expr< fun (type $i$) -> $e$ >> ->
        let (pl, e) = expr_fun_args e in
        ([`newtype i :: pl], e)
    | ge -> ([], ge) ];

  value rec class_expr_fun_args =
    fun
    [ <:class_expr< fun $p$ -> $ce$ >> as ge ->
        if is_irrefut_patt p then
          let (pl, ce) = class_expr_fun_args ce in
          ([p :: pl], ce)
        else ([], ge)
    | ge -> ([], ge) ];

  value rec do_print_comments_before loc f =
    parser
    [ [: ` (comm, comm_loc) when Loc.strictly_before comm_loc loc; s :] ->
          let () = f comm comm_loc in
          do_print_comments_before loc f s
    | [: :] -> () ];

  class printer ?curry_constr:(init_curry_constr = False) ?(comments = True) () =
  object (o)

    (** pipe means we are under a match case (try, function) *)
    value pipe = False;
    value semi = False;

    method under_pipe = {< pipe = True >};
    method under_semi = {< semi = True >};
    method reset_semi = {< semi = False >};
    method reset =      {< pipe = False; semi = False >};

    value semisep : sep = ";;";
    value no_semisep : sep = ""; (* used to mark where ";;" should not occur *)
    value mode = if comments then `comments else `no_comments;
    value curry_constr = init_curry_constr;
    value var_conversion = False;

    method andsep : sep = "@]@ @[<2>and@ ";
    method value_val = "val";
    method value_let = "let";

    method semisep = semisep;
    method set_semisep s = {< semisep = s >};
    method set_comments b = {< mode = if b then `comments else `no_comments >};
    method set_loc_and_comments = {< mode = `loc_and_comments >};
    method set_curry_constr b = {< curry_constr = b >};

    method print_comments_before loc f =
      match mode with
      [ `comments ->
          do_print_comments_before loc (fun c _ -> pp f "%s@ " c)
            (CommentFilter.take_stream comment_filter)
      | `loc_and_comments ->
          let () = pp f "(*loc: %a*)@ " Loc.dump loc in
          do_print_comments_before loc
            (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump)
            (CommentFilter.take_stream comment_filter)
      | _ -> () ];

    method var f =
      fun
      [ ""   -> pp f "$lid:\"\"$"
      | "[]" -> pp f "[]"
      | "()" -> pp f "()"
      | " True"  -> pp f "True"
      | " False" -> pp f "False"
      | v ->
          match (var_conversion, v) with
          [ (True, "val") -> pp f "contents"
          | (True, "True") -> pp f "true"
          | (True, "False") -> pp f "false"
          | _ ->
            match lex_string v with
            [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s ->
                pp f "%s__" s
            | (LIDENT s | ESCAPED_IDENT s) when List.mem s infix_lidents ->
                pp f "( %s )" s
            | SYMBOL s ->
                pp f "( %s )" s
            | LIDENT s | UIDENT s | ESCAPED_IDENT s ->
                pp_print_string f s
            | tok -> failwith (sprintf
                      "Bad token used as an identifier: %s"
                      (Token.to_string tok)) ] ] ];

    method type_params f =
      fun
      [ [] -> ()
      | [x] -> pp f "%a@ " o#ctyp x
      | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l ];

    method class_params f =
      fun
      [ <:ctyp< $t1$, $t2$ >> ->
          pp f "@[<1>%a,@ %a@]" o#class_params t1 o#class_params t2
      | x -> o#ctyp f x ];

    method override_flag f =
      fun
      [ Ast.OvOverride -> pp f "!"
      | Ast.OvNil -> ()
      | Ast.OvAnt s -> o#anti f s ];

    method mutable_flag f = fun
      [ Ast.MuMutable -> pp f "mutable@ "
      | Ast.MuNil -> ()
      | Ast.MuAnt s -> o#anti f s ];

    method rec_flag f = fun
      [ Ast.ReRecursive -> pp f "rec@ "
      | Ast.ReNonrecursive
      | Ast.ReNil -> ()
      | Ast.ReAnt s -> o#anti f s ];

    method nonrec_flag f = fun
      [ Ast.ReNonrecursive -> pp f "nonrec@ "
      | Ast.ReRecursive
      | Ast.ReNil -> ()
      | Ast.ReAnt s -> o#anti f s ];

    method virtual_flag f = fun
      [ Ast.ViVirtual -> pp f "virtual@ "
      | Ast.ViNil -> ()
      | Ast.ViAnt s -> o#anti f s ];

    method private_flag f = fun
      [ Ast.PrPrivate -> pp f "private@ "
      | Ast.PrNil -> ()
      | Ast.PrAnt s -> o#anti f s ];

    method anti f s = pp f "$%s$" s;

    method seq f =
      fun
      [ <:expr< $e1$; $e2$ >> ->
          pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2
      | <:expr< do { $e$ } >> ->
          o#seq f e
      | e -> o#expr f e ];

          (* FIXME when the Format module will fixed.
                  pp_print_if_newline f ();
                  pp_print_string f "| "; *)
    method match_case f =
      fun
      [ <:match_case@_loc<>> ->
          pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc
      | a -> o#match_case_aux f a ];

    method match_case_aux f =
      fun
      [ <:match_case<>> -> ()
      | <:match_case< $anti:s$ >> -> o#anti f s
      | <:match_case< $a1$ | $a2$ >> ->
          pp f "%a%a" o#match_case_aux a1 o#match_case_aux a2
      | <:match_case< $p$ -> $e$ >> ->
          pp f "@ | @[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e
      | <:match_case< $p$ when $w$ -> $e$ >> ->
          pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]"
            o#patt p o#under_pipe#expr w o#under_pipe#expr e ];

    method fun_binding f =
      fun
      [ `patt p -> o#simple_patt f p
      | `newtype i -> pp f "(type %s)" i ];

    method binding f bi =
      let () = o#node f bi Ast.loc_of_binding in
      match bi with
      [ <:binding<>> -> ()
      | <:binding< $b1$ and $b2$ >> ->
          do { o#binding f b1; pp f o#andsep; o#binding f b2 }
      | <:binding< $p$ = $e$ >> ->
          let (pl, e') =
            match p with
            [ <:patt< ($_$ : $_$) >> -> ([], e)
            | _ -> expr_fun_args e ] in
          match (p, e') with
          [ (<:patt< $lid:_$ >>, <:expr< ($e'$ : $t$) >>) ->
              pp f "%a :@ %a =@ %a"
                (list o#fun_binding "@ ") [`patt p::pl] o#ctyp t o#expr e'
          | (<:patt< $lid:_$ >>, _) ->
              pp f "%a @[<0>%a=@]@ %a" o#simple_patt
                p (list' o#fun_binding "" "@ ") pl o#expr e'
          | _ ->
              pp f "%a =@ %a" o#simple_patt p o#expr e ]
      | <:binding< $anti:s$ >> -> o#anti f s ];

    method record_binding f bi =
      let () = o#node f bi Ast.loc_of_rec_binding in
      match bi with
      [ <:rec_binding<>> -> ()
      | <:rec_binding< $i$ = $e$ >> ->
          pp f "@ @[<2>%a =@ %a@];" o#var_ident i o#expr e
      | <:rec_binding< $b1$ ; $b2$ >> ->
          do { o#under_semi#record_binding f b1;
               o#under_semi#record_binding f b2 }
      | <:rec_binding< $anti:s$ >> -> o#anti f s ];

    method mk_patt_list =
      fun
      [ <:patt< [$p1$ :: $p2$] >> ->
          let (pl, c) = o#mk_patt_list p2 in
          ([p1 :: pl], c)
      | <:patt< [] >> -> ([], None)
      | p -> ([], Some p) ];

    method mk_expr_list =
      fun
      [ <:expr< [$e1$ :: $e2$] >> ->
          let (el, c) = o#mk_expr_list e2 in
          ([e1 :: el], c)
      | <:expr< [] >> -> ([], None)
      | e -> ([], Some e) ];

    method expr_list f =
      fun
      [ []  -> pp f "[]"
      | [e] -> pp f "[ %a ]" o#under_semi#expr e
      | el  -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el ];

    method expr_list_cons simple f e =
      let (el, c) = o#mk_expr_list e in
      match c with
      [ None -> o#expr_list f el
      | Some x ->
          (if simple then pp f "@[<2>(%a)@]" else pp f "@[<2>%a@]")
            (list o#under_semi#dot_expr " ::@ ") (el @ [x]) ];

    method patt_expr_fun_args f (p, e) =
      let (pl, e) = expr_fun_args e
      in pp f "%a@ ->@ %a" (list o#fun_binding "@ ") [p::pl] o#expr e;

    method patt_class_expr_fun_args f (p, ce) =
      let (pl, ce) = class_expr_fun_args ce
      in pp f "%a =@]@ %a" (list o#simple_patt "@ ") [p::pl] o#class_expr ce;

    method constrain f (t1, t2) =
      pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2;

    method sum_type f t =
      match Ast.list_of_ctyp t [] with
      [ [] -> ()
      | ts ->
          pp f "@[<hv0>| %a@]" (list o#constructor_declaration "@ | ") ts ];

    method private constructor_declaration f t =
      match t with
      [ <:ctyp< $t1$ : $t2$ -> $t3$ >> -> pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 o#constructor_type t2 o#ctyp t3
      | t -> o#ctyp f t ];

    method string f = pp f "%s";
    method quoted_string f = pp f "%S";

    method numeric f num suff =
      if num.[0] = '-' then pp f "(%s%s)" num suff else pp f "%s%s" num suff;

    method module_expr_get_functor_args accu =
      fun
      [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> ->
          o#module_expr_get_functor_args [(s, mt)::accu] me
      | <:module_expr< ($me$ : $mt$) >> -> (List.rev accu, me, Some mt)
      | me -> (List.rev accu, me, None) ];

    method functor_args f = list o#functor_arg "@ " f;

    method functor_arg f (s, mt) =
      match mt with
      [ Ast.MtNil _ ->
        o#functor_arg_var f s
      | _ ->
        pp f "@[<2>(%a :@ %a)@]" o#functor_arg_var s o#module_type mt ];

    method functor_arg_var f v =
      match v with
      [ "*" -> pp f "()"
      | v   -> o#var f v ];

    method module_rec_binding f =
      fun
      [ <:module_binding<>> -> ()
      | <:module_binding< $s$ : $mt$ = $me$ >> ->
           pp f "@[<2>%a :@ %a =@ %a@]"
             o#var s o#module_type mt o#module_expr me
      | <:module_binding< $s$ : $mt$ >> ->
           pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt
      | <:module_binding< $mb1$ and $mb2$ >> ->
          do { o#module_rec_binding f mb1;
               pp f o#andsep;
               o#module_rec_binding f mb2 }
      | <:module_binding< $anti:s$ >> -> o#anti f s ];

    method class_declaration f =
      fun
      [ <:class_expr< ( $ce$ : $ct$ ) >> ->
          pp f "%a :@ %a" o#class_expr ce o#class_type ct
      | ce -> o#class_expr f ce ];

    method raise_match_failure f _loc =
      let n = Loc.file_name _loc in
      let l = Loc.start_line _loc in
      let c = Loc.start_off _loc - Loc.start_bol _loc in
      o#expr f <:expr< raise (Match_failure $`str:n$ $`int:l$ $`int:c$) >>;

    method node : ! 'a . formatter -> 'a -> ('a -> Loc.t) -> unit =
      fun f node loc_of_node ->
        o#print_comments_before (loc_of_node node) f;

    method ident f i =
    let () = o#node f i Ast.loc_of_ident in
    match i with
    [ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#ident i1 o#ident i2
    | <:ident< $i1$ $i2$ >> -> pp f "%a@,(%a)" o#ident i1 o#ident i2
    | <:ident< $anti:s$ >> -> o#anti f s
    | <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s ];

    method private var_ident = {< var_conversion = True >}#ident;

    method expr f e =
    let () = o#node f e Ast.loc_of_expr in
    match e with
    [ ((<:expr< let $rec:_$ $_$ in $_$ >> |
        <:expr< let module $_$ = $_$ in $_$ >>) as e) when semi ->
        pp f "(%a)" o#reset#expr e
    | ((<:expr< match $_$ with [ $_$ ] >> |
        <:expr< try $_$ with [ $_$ ] >> |
        <:expr< fun [ $_$ ] >>) as e) when pipe || semi ->
        pp f "(%a)" o#reset#expr e

    | <:expr< - $x$ >> ->
        (* If you want to remove the space take care of - !r *)
        pp f "@[<2>-@ %a@]" o#dot_expr x
    | <:expr< -. $x$ >> ->
        pp f "@[<2>-.@ %a@]" o#dot_expr x (* same note as above *)
    | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons False f e
    | <:expr@_loc< $lid:n$ $x$ $y$ >> when is_infix n ->
        pp f "@[<2>%a@ %s@ %a@]" o#apply_expr x n o#apply_expr y
    | <:expr< $x$ $y$ >> ->
        let (a, al) = get_expr_args x [y] in
        if (not curry_constr) && Ast.is_expr_constructor a then
          match al with
          [ [ <:expr< ($tup:_$) >> ] ->
              pp f "@[<2>%a@ (%a)@]" o#apply_expr x o#expr y
          | [_] -> pp f "@[<2>%a@ %a@]" o#apply_expr x o#apply_expr y
          | al ->
              pp f "@[<2>%a@ (%a)@]" o#apply_expr a
                 (* The #apply_expr below may put too much parens.
                    However using #expr would be wrong: PR#5056. *)
                 (list o#under_pipe#apply_expr ",@ ") al ]
        else pp f "@[<2>%a@]" (list o#apply_expr "@ ") [a::al]
    | <:expr< $e1$.val := $e2$ >> ->
        pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2
    | <:expr< $e1$ := $e2$ >> ->
        pp f "@[<2>%a@ <-@ %a@]" o#dot_expr e1 o#expr e2
    | <:expr@loc< fun [] >> ->
        pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure loc
    | <:expr< fun $p$ -> $e$ >> when is_irrefut_patt p ->
        pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e)
    | <:expr< fun (type $i$) -> $e$ >> ->
        pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e)
    | <:expr< fun [ $a$ ] >> ->
        pp f "@[<hv0>function%a@]" o#match_case a
    | <:expr< if $e1$ then $e2$ else $e3$ >> ->
        pp f "@[<hv0>@[<2>if@ %a@]@ @[<2>then@ %a@]@ @[<2>else@ %a@]@]"
           o#expr e1 o#under_semi#expr e2 o#under_semi#expr e3
    | <:expr< lazy $e$ >> -> pp f "@[<2>lazy@ %a@]" o#simple_expr e
    | <:expr< let $rec:r$ $bi$ in $e$ >> ->
        match e with
        [ <:expr< let $rec:_$ $_$ in $_$ >> ->
            pp f "@[<0>@[<2>let %a%a in@]@ %a@]"
              o#rec_flag r o#binding bi o#reset_semi#expr e
        | _ ->
            pp f "@[<hv0>@[<2>let %a%a@]@ @[<hv2>in@ %a@]@]"
              o#rec_flag r o#binding bi o#reset_semi#expr e ]
    | Ast.ExOpI _loc i ov e ->
    (* | <:expr< let open $i$ in $e$ >> -> *)
        pp f "@[<2>let open%a %a@]@ @[<2>in@ %a@]"
          o#override_flag ov o#ident i o#reset_semi#expr e
    | <:expr< match $e$ with [ $a$ ] >> ->
        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]"
          o#expr e o#match_case a
    | <:expr< try $e$ with [ $a$ ] >> ->
        pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
          o#expr e o#match_case a
    | <:expr< assert False >> -> pp f "@[<2>assert@ false@]"
    | <:expr< assert $e$ >> -> pp f "@[<2>assert@ %a@]" o#dot_expr e
    | <:expr< let module $s$ = $me$ in $e$ >> ->
          pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" o#var s o#module_expr me o#reset_semi#expr e
    | <:expr< object $cst$ end >> ->
        pp f "@[<hv0>@[<hv2>object@ %a@]@ end@]" o#class_str_item cst
    | <:expr< object ($p$ : $t$) $cst$ end >> ->
        pp f "@[<hv0>@[<hv2>object @[<1>(%a :@ %a)@]@ %a@]@ end@]"
          o#patt p o#ctyp t o#class_str_item cst
    | <:expr< object ($p$) $cst$ end >> ->
        pp f "@[<hv0>@[<hv2>object @[<2>(%a)@]@ %a@]@ end@]"
          o#patt p o#class_str_item cst
    | e -> o#apply_expr f e ];

    method apply_expr f e =
    let () = o#node f e Ast.loc_of_expr in
    match e with
    [ <:expr< new $i$ >> -> pp f "@[<2>new@ %a@]" o#ident i
    | e -> o#dot_expr f e ];

    method dot_expr f e =
    let () = o#node f e Ast.loc_of_expr in
    match e with
    [ <:expr< $e$.val >> -> pp f "@[<2>!@,%a@]" o#simple_expr e
    | <:expr< $e1$ . $e2$ >> -> pp f "@[<2>%a.@,%a@]" o#dot_expr e1 o#dot_expr e2
    | <:expr< $e1$ .( $e2$ ) >> ->
        pp f "@[<2>%a.@,(%a)@]" o#dot_expr e1 o#expr e2
    | <:expr< $e1$ .[ $e2$ ] >> ->
        pp f "%a.@[<1>[@,%a@]@,]" o#dot_expr e1 o#expr e2
    | <:expr< $e$ # $s$ >> -> pp f "@[<2>%a#@,%s@]" o#dot_expr e s
    | e -> o#simple_expr f e ];

    method simple_expr f e =
    let () = o#node f e Ast.loc_of_expr in
    match e with
    [ <:expr<>> -> ()
    | <:expr< do { $e$ } >> ->
        pp f "@[<hv1>(%a)@]" o#seq e
    | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons True f e
    | <:expr< ( $tup:e$ ) >> ->
        pp f "@[<1>(%a)@]" o#expr e
    | <:expr< [| $e$ |] >> ->
        pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e
    | <:expr< ($e$ :> $t$) >> ->
        pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t
    | <:expr< ($e$ : $t1$ :> $t2$) >> ->
        pp f "@[<2>(%a :@ %a :>@ %a)@]" o#expr e o#ctyp t1 o#ctyp t2
    | <:expr< ($e$ : $t$) >> ->
        pp f "@[<2>(%a :@ %a)@]" o#expr e o#ctyp t
    | <:expr< $anti:s$ >> -> o#anti f s
    | <:expr< for $p$ = $e1$ $to:df$ $e2$ do { $e3$ } >> ->
        pp f "@[<hv0>@[<hv2>@[<2>for %a =@ %a@ %a@ %a@ do@]@ %a@]@ done@]"
          o#patt p o#expr e1 o#direction_flag df o#expr e2 o#seq e3
    | <:expr< $int:s$ >> -> o#numeric f s ""
    | <:expr< $nativeint:s$ >> -> o#numeric f s "n"
    | <:expr< $int64:s$ >> -> o#numeric f s "L"
    | <:expr< $int32:s$ >> -> o#numeric f s "l"
    | <:expr< $flo:s$ >> -> o#numeric f s ""
    | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s)
    | <:expr< $id:i$ >> -> o#var_ident f i
    | <:expr< { $b$ } >> ->
        pp f "@[<hv0>@[<hv2>{%a@]@ }@]" o#record_binding b
    | <:expr< { ($e$) with $b$ } >> ->
        pp f "@[<hv0>@[<hv2>{@ (%a)@ with%a@]@ }@]"
          o#expr e o#record_binding b
    | <:expr< $str:s$ >> -> pp f "\"%s\"" s
    | <:expr< while $e1$ do { $e2$ } >> ->
        pp f "@[<2>while@ %a@ do@ %a@ done@]" o#expr e1 o#seq e2
    | <:expr< ~ $s$ >> -> pp f "~%s" s
    | <:expr< ~ $s$ : $e$ >> -> pp f "@[<2>~%s:@ %a@]" s o#dot_expr e
    | <:expr< ? $s$ >> -> pp f "?%s" s
    | <:expr< ? $s$ : $e$ >> -> pp f "@[<2>?%s:@ %a@]" s o#dot_expr e
    | <:expr< ` $lid:s$ >> -> pp f "`%a" o#var s
    | <:expr< {< $b$ >} >> ->
        pp f "@[<hv0>@[<hv2>{<%a@]@ >}@]" o#record_binding b
    | <:expr< $e1$, $e2$ >> ->
        pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2
    | <:expr< $e1$; $e2$ >> ->
        pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2
    | <:expr< (module $me$ : $mt$) >> ->
        pp f "@[<hv0>@[<hv2>(module %a : %a@])@]"
           o#module_expr me o#module_type mt
    | <:expr< (module $me$) >> ->
        pp f "@[<hv0>@[<hv2>(module %a@])@]" o#module_expr me
    | Ast.ExAtt _loc s str e ->
        pp f "((%a)[@@%s %a])" o#expr e s o#str_item str
    | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> |
      <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> |
      <:expr< $_$ # $_$ >> |
      <:expr< fun [ $_$ ] >> | <:expr< fun (type $_$) -> $_$ >> | <:expr< match $_$ with [ $_$ ] >> |
      <:expr< try $_$ with [ $_$ ] >> |
      <:expr< if $_$ then $_$ else $_$ >> |
      <:expr< let $rec:_$ $_$ in $_$ >> |
      <:expr< let module $_$ = $_$ in $_$ >> |
      (* <:expr< let open $_$ in $_$ >> *)Ast.ExOpI _ _ _ _ |
      <:expr< assert $_$ >> | <:expr< assert False >> |
      <:expr< lazy $_$ >> | <:expr< new $_$ >> |
      <:expr< object ($_$) $_$ end >> ->
        pp f "(%a)" o#reset#expr e ];

    method direction_flag f b =
      match b with
      [ Ast.DiTo -> pp_print_string f "to"
      | Ast.DiDownto -> pp_print_string f "downto"
      | Ast.DiAnt s -> o#anti f s ];

    method patt f p =
    let () = o#node f p Ast.loc_of_patt in match p with
    [ <:patt< ( $p1$ as $p2$ ) >> -> pp f "@[<1>(%a@ as@ %a)@]" o#patt p1 o#patt p2
    | <:patt< $i$ = $p$ >> -> pp f "@[<2>%a =@ %a@]" o#var_ident i o#patt p
    | <:patt< $p1$; $p2$ >> -> pp f "%a;@ %a" o#patt p1 o#patt p2
    | p -> o#patt1 f p ];

    method patt1 f = fun
    [ <:patt< $p1$ | $p2$ >> -> pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2
    | p -> o#patt2 f p ];

    method patt2 f = fun
    [ (* <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p
    | *) p -> o#patt3 f p ];

    method patt3 f = fun
    [ <:patt< $p1$ .. $p2$ >> -> pp f "@[<2>%a@ ..@ %a@]" o#patt3 p1 o#patt4 p2
    | <:patt< $p1$, $p2$ >> -> pp f "%a,@ %a" o#patt3 p1 o#patt3 p2
    | p -> o#patt4 f p ];

    method patt4 f = fun
    [ <:patt< [$_$ :: $_$] >> as p ->
        let (pl, c) = o#mk_patt_list p in
        match c with
        [ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl
        | Some x -> pp f "@[<2>%a@]" (list o#patt5 " ::@ ") (pl @ [x]) ]
    | p -> o#patt5 f p ];

    method patt5 f = fun
    [ <:patt< [$_$ :: $_$] >> as p -> o#simple_patt f p
    | <:patt< lazy $p$ >> ->
        pp f "@[<2>lazy %a@]" o#simple_patt p
    | Ast.PaExc _ p ->
        pp f "@[<2>exception %a@]" o#simple_patt p
    | <:patt< $x$ $y$ >> ->
        let (a, al) = get_patt_args x [y] in
        if not (Ast.is_patt_constructor a) then
          Format.eprintf "WARNING: strange pattern application of a non constructor@."
        else if curry_constr then
          pp f "@[<2>%a@]" (list o#simple_patt "@ ") [a::al]
        else
          match al with
          [ [ <:patt< ($tup:_$) >> ] ->
              pp f "@[<2>%a@ (%a)@]" o#simple_patt x o#patt y
          | [_] -> pp f "@[<2>%a@ %a@]" o#patt5 x o#simple_patt y
          | al -> pp f "@[<2>%a@ (%a)@]" o#patt5 a
                       (list o#simple_patt ",@ ") al ]
    | p -> o#simple_patt f p ];

    method simple_patt f p =
    let () = o#node f p Ast.loc_of_patt in
    match p with
    [ <:patt<>> -> ()
    | <:patt< $id:i$ >> -> o#var_ident f i
    | <:patt< $anti:s$ >> -> o#anti f s
    | <:patt< _ >> -> pp f "_"
    | <:patt< ( module $m$ ) >> -> pp f "(module %s)" m
    | <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p
    | <:patt< { $p$ } >> -> pp f "@[<hv2>{@ %a@]@ }" o#patt p
    | <:patt< $str:s$ >> -> pp f "\"%s\"" s
    | <:patt< ( $p$ : $t$ ) >> -> pp f "@[<1>(%a :@ %a)@]" o#patt p o#ctyp t
    | <:patt< $nativeint:s$ >> -> o#numeric f s "n"
    | <:patt< $int64:s$ >> -> o#numeric f s "L"
    | <:patt< $int32:s$ >> -> o#numeric f s "l"
    | <:patt< $int:s$ >> -> o#numeric f s ""
    | <:patt< $flo:s$ >> -> o#numeric f s ""
    | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s)
    | <:patt< ~ $s$ >> -> pp f "~%s" s
    | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s
    | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i
    | <:patt< [| $p$ |] >> -> pp f "@[<2>[|@ %a@]@ |]" o#patt p
    | <:patt< ~ $s$ : ($p$) >> -> pp f "@[<2>~%s:@ (%a)@]" s o#patt p
    | <:patt< ? $s$ >> -> pp f "?%s" s
    | <:patt< ?($p$) >> ->
          pp f "@[<2>?(%a)@]" o#patt_tycon p
    | <:patt< ? $s$ : ($p$) >> ->
          pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt_tycon p
    | <:patt< ?($p$ = $e$) >> ->
          pp f "@[<2>?(%a =@ %a)@]" o#patt_tycon p o#expr e
    | <:patt< ? $s$ : ($p$ = $e$) >> ->
          pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt_tycon p o#expr e
    | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> |
      <:patt< $_$ .. $_$ >> | <:patt< $_$, $_$ >> |
      <:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> | <:patt< lazy $_$ >> |
      Ast.PaExc _ _ as p ->
          pp f "@[<1>(%a)@]" o#patt p
    | Ast.PaAtt _loc s str e ->
        pp f "((%a)[@@%s %a])" o#patt e s o#str_item str
    ];

    method patt_tycon f =
      fun
      [ <:patt< ( $p$ : $t$ ) >> -> pp f "%a :@ %a" o#patt p o#ctyp t
      | p -> o#patt f p ];

    method simple_ctyp f t =
    let () = o#node f t Ast.loc_of_ctyp in
    match t with
    [ <:ctyp< $id:i$ >> -> o#ident f i
    | <:ctyp< $anti:s$ >> -> o#anti f s
    | <:ctyp< _ >> -> pp f "_"
    | Ast.TyOpn _ -> pp f ".."
    | Ast.TyAnP _ -> pp f "+_"
    | Ast.TyAnM _ -> pp f "-_"
    | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t
    | <:ctyp< ? $s$ : $t$ >> -> pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t
    | <:ctyp< < > >> -> pp f "< >"
    | <:ctyp< < .. > >> -> pp f "< .. >"
    | <:ctyp< < $t$ .. > >> -> pp f "@[<0>@[<2><@ %a;@ ..@]@ >@]" o#ctyp t
    | <:ctyp< < $t$ > >> -> pp f "@[<0>@[<2><@ %a@]@ >@]" o#ctyp t
    | <:ctyp< '$s$ >> -> pp f "'%a" o#var s
    | <:ctyp< { $t$ } >> -> pp f "@[<2>{@ %a@]@ }" o#ctyp t
    | <:ctyp< [ $t$ ] >> -> pp f "@[<0>%a@]" o#sum_type t
    | <:ctyp< ( $tup:t$ ) >> -> pp f "@[<1>(%a)@]" o#ctyp t
    | <:ctyp< (module $mt$) >> -> pp f "@[<2>(module@ %a@])" o#module_type mt
    | <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[@ %a@]@ ]" o#sum_type t
    | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[<@ %a@]@,]" o#sum_type t
    | <:ctyp< [ < $t1$ > $t2$ ] >> ->
        let (a, al) = get_ctyp_args t2 [] in
        pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#sum_type t1
          (list o#simple_ctyp "@ ") [a::al]
    | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[>@ %a@]@,]" o#sum_type t
    | <:ctyp< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i
    | <:ctyp< `$s$ >> -> pp f "`%a" o#var s
    | <:ctyp< $t1$ * $t2$ >> -> pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2
    | Ast.TyAtt _loc s str e ->
        pp f "((%a)[@@%s %a])" o#ctyp e s o#str_item str
    | <:ctyp<>> -> assert False
    | t -> pp f "@[<1>(%a)@]" o#ctyp t ];

    method ctyp f t =
    let () = o#node f t Ast.loc_of_ctyp in
    match t with
    [ <:ctyp< $t1$ as $t2$ >> -> pp f "@[<2>%a@ as@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2
    | <:ctyp< $t1$ -> $t2$ >> -> pp f "@[<2>%a@ ->@ %a@]" o#ctyp1 t1 o#ctyp t2
    | <:ctyp< +'$s$ >> -> pp f "+'%a" o#var s
    | <:ctyp< -'$s$ >> -> pp f "-'%a" o#var s
    | <:ctyp< $t1$ | $t2$ >> -> pp f "%a@ | %a" o#ctyp t1 o#ctyp t2
    | <:ctyp< $t1$ : mutable $t2$ >> ->
        pp f "@[mutable@ %a :@ %a@]" o#ctyp t1 o#ctyp t2
    | <:ctyp< $t1$ : $t2$ >> -> pp f "@[<2>%a :@ %a@]" o#ctyp t1 o#ctyp t2
    | <:ctyp< $t1$; $t2$ >> -> pp f "%a;@ %a" o#ctyp t1 o#ctyp t2
    | <:ctyp< $t$ of $<:ctyp<>>$ >> -> o#ctyp f t
    | <:ctyp< $t1$ of $t2$ >> ->
        pp f "@[<h>%a@ @[<3>of@ %a@]@]" o#ctyp t1 o#constructor_type t2
    | <:ctyp< $t1$ of & $t2$ >> ->
        pp f "@[<h>%a@ @[<3>of &@ %a@]@]" o#ctyp t1 o#constructor_type t2
    | <:ctyp< $t1$ and $t2$ >> -> pp f "%a@ and %a" o#ctyp t1 o#ctyp t2
    | <:ctyp< mutable $t$ >> -> pp f "@[<2>mutable@ %a@]" o#ctyp t
    | <:ctyp< $t1$ & $t2$ >> -> pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2
    | <:ctyp< $t1$ == $t2$ >> ->
        pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#ctyp t2
    | Ast.TyDcl _ tn tp te cl -> do {
        pp f "@[<2>%a%a@]" o#type_params tp o#var tn;
        match te with
        [ <:ctyp<>> -> ()
        | _ -> pp f " =@ %a" o#ctyp te ];
        if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else ();
      }
    | Ast.TyExt _ tn tp te ->
        pp f "@[<2>%a%a@] =@ %a" o#type_params tp o#ident tn o#ctyp te
    | Ast.TyCom (loc, _, _) ->
        Loc.raise loc (Failure "this construction is not allowed here")
    | t -> o#ctyp1 f t ];

    method ctyp1 f = fun
    [ <:ctyp< $t1$ $t2$ >> ->
        match get_ctyp_args t1 [t2] with
        [ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t2 o#simple_ctyp t1
        | (a, al) -> pp f "@[<2>(%a)@ %a@]" (list o#ctyp ",@ ") al o#simple_ctyp a ]
    | <:ctyp< ! $t1$ . $t2$ >> ->
        let (a, al) = get_ctyp_args t1 [] in
        pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2
    | Ast.TyTypePol (_,t1,t2) ->
        let (a, al) = get_ctyp_args t1 [] in
        pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2
    | <:ctyp< private $t$ >> -> pp f "@[private@ %a@]" o#simple_ctyp t
    | t -> o#simple_ctyp f t ];

    method constructor_type f t =
    match t with
    [ <:ctyp@loc< $t1$ and $t2$ >> ->
        let () = o#node f t (fun _ -> loc) in
        pp f "%a@ * %a" o#constructor_type t1 o#constructor_type t2
    | <:ctyp< $_$ -> $_$ >> -> pp f "(%a)" o#ctyp t
    | t -> o#ctyp f t ];


    method sig_item f sg =
      let () = o#node f sg Ast.loc_of_sig_item in
      match sg with
      [ <:sig_item<>> -> ()
      | <:sig_item< $sg$; $<:sig_item<>>$ >> |
        <:sig_item< $<:sig_item<>>$; $sg$ >> ->
          o#sig_item f sg
      | <:sig_item< $sg1$; $sg2$ >> ->
          do { o#sig_item f sg1; cut f; o#sig_item f sg2 }
      | <:sig_item< exception $t$ >> ->
          pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep
      | <:sig_item< external $s$ : $t$ = $sl$ >> ->
          pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]"
            o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep
      | Ast.SgMod(_, name, Ast.MtAlias(_, id)) ->
          pp f "@[<2>module %a@ =@ %a@]"
            o#var name o#ident id
      | <:sig_item< module $s1$ ($s2$ : $mt1$) : $mt2$ >> ->
          let rec loop accu =
            fun
            [ <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> ->
                loop [(s, mt1)::accu] mt2
            | mt -> (List.rev accu, mt) ] in
          let (al, mt) = loop [(s2, mt1)] mt2 in
          pp f "@[<2>module %a@ @[<0>%a@] :@ %a%(%)@]"
            o#var s1 o#functor_args al o#module_type mt semisep
      | <:sig_item< module $s$ : $mt$ >> ->
          pp f "@[<2>module %a :@ %a%(%)@]"
            o#var s o#module_type mt semisep
      | <:sig_item< module type $s$ = $ <:module_type<>> $ >> ->
          pp f "@[<2>module type %a%(%)@]" o#var s semisep
      | <:sig_item< module type $s$ = $mt$ >> ->
          pp f "@[<2>module type %a =@ %a%(%)@]"
            o#var s o#module_type mt semisep
      | Ast.SgOpn _loc ov sl ->
          pp f "@[<2>open%a@ %a%(%)@]"
            o#override_flag ov
            o#ident sl semisep
      | Ast.SgTyp(_, rf, t) ->
          pp f "@[<hv0>@[<hv2>type%a %a@]%(%)@]" o#nonrec_flag rf o#ctyp t semisep
      | <:sig_item< value $s$ : $t$ >> ->
          pp f "@[<2>%s %a :@ %a%(%)@]"
            o#value_val o#var s o#ctyp t semisep
      | <:sig_item< include $mt$ >> ->
          pp f "@[<2>include@ %a%(%)@]" o#module_type mt semisep
      | <:sig_item< class type $ct$ >> ->
          pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep
      | <:sig_item< class $ce$ >> ->
          pp f "@[<2>class %a%(%)@]" o#class_type ce semisep
      | <:sig_item< module rec $mb$ >> ->
          pp f "@[<2>module rec %a%(%)@]"
            o#module_rec_binding mb semisep
      | Ast.SgDir _ _ _ -> ()
      | <:sig_item< $anti:s$ >> ->
          pp f "%a%(%)" o#anti s semisep ];

    method str_item f st =
      let () = o#node f st Ast.loc_of_str_item in
      match st with
      [ <:str_item<>> -> ()
      | <:str_item< $st$; $<:str_item<>>$ >> |
        <:str_item< $<:str_item<>>$; $st$ >> ->
          o#str_item f st
      | <:str_item< $st1$; $st2$ >> ->
            do { o#str_item f st1; cut f; o#str_item f st2 }
      | <:str_item< exception $t$ >> ->
            pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep
      | <:str_item< exception $t$ = $sl$ >> ->
            pp f "@[<2>exception@ %a =@ %a%(%)@]" o#ctyp t o#ident sl semisep
      | <:str_item< external $s$ : $t$ = $sl$ >> ->
            pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]"
              o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep
      | <:str_item< module $s1$ ($s2$ : $mt1$) = $me$ >> ->
          match o#module_expr_get_functor_args [(s2, mt1)] me with
          [ (al, me, Some mt2) ->
              pp f "@[<2>module %a@ @[<0>%a@] :@ %a =@ %a%(%)@]"
                o#var s1 o#functor_args al o#module_type mt2
                o#module_expr me semisep
          | (al, me, _) ->
              pp f "@[<2>module %a@ @[<0>%a@] =@ %a%(%)@]"
                o#var s1 o#functor_args al o#module_expr me semisep ]
      | <:str_item< module $s$ : $mt$ = $me$ >> ->
            pp f "@[<2>module %a :@ %a =@ %a%(%)@]"
              o#var s o#module_type mt o#module_expr me semisep
      | <:str_item< module $s$ = $me$ >> ->
            pp f "@[<2>module %a =@ %a%(%)@]" o#var s o#module_expr me semisep
      | <:str_item< module type $s$ = $mt$ >> ->
            pp f "@[<2>module type %a =@ %a%(%)@]"
              o#var s o#module_type mt semisep
      | Ast.StOpn _loc ov sl ->
      (* | <:str_item< open $sl$ >> -> *)
            pp f "@[<2>open%a@ %a%(%)@]"
            o#override_flag ov
            o#ident sl semisep
      | Ast.StTyp(_, rf, t) ->
            pp f "@[<hv0>@[<hv2>type%a %a@]%(%)@]" o#nonrec_flag rf o#ctyp t semisep
      | <:str_item< value $rec:r$ $bi$ >> ->
            pp f "@[<2>%s %a%a%(%)@]" o#value_let o#rec_flag r o#binding bi semisep
      | <:str_item< $exp:e$ >> ->
            pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep
      | <:str_item< include $me$ >> ->
            pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr me semisep
      | <:str_item< class type $ct$ >> ->
            pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep
      | <:str_item< class $ce$ >> ->
            pp f "@[<hv2>class %a%(%)@]" o#class_declaration ce semisep
      | <:str_item< module rec $mb$ >> ->
            pp f "@[<2>module rec %a%(%)@]" o#module_rec_binding mb semisep
      | Ast.StDir _ _ _ -> ()
      | <:str_item< $anti:s$ >> -> pp f "%a%(%)" o#anti s semisep
      | Ast.StExc _ _ (Ast.OAnt _) -> assert False ];

    method module_type f mt =
    let () = o#node f mt Ast.loc_of_module_type in
    match mt with
    [ <:module_type<>> -> assert False
    | <:module_type< module type of $me$ >> ->
        pp f "@[<2>module type of@ %a@]" o#module_expr me
    | <:module_type< $id:i$ >> -> o#ident f i
    | <:module_type< $anti:s$ >> -> o#anti f s
    | Ast.MtFun(_, "*", Ast.MtNil _, mt) ->
          pp f "@[<2>functor@ ()@ ->@ %a@]" o#module_type mt
    | <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> ->
          pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]"
            o#var s o#module_type mt1 o#module_type mt2
    | <:module_type< '$s$ >> -> pp f "'%a" o#var s
    | <:module_type< sig $sg$ end >> ->
          pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" o#sig_item sg
    | Ast.MtAtt _loc s str e ->
        pp f "((%a)[@@%s %a])" o#module_type e s o#str_item str
    | <:module_type< $mt$ with $wc$ >> ->
          pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc
    | Ast.MtAlias(_, id) ->
          pp f "@[<2>(module@ %a@])" o#ident id ];

    method with_constraint f wc =
    let () = o#node f wc Ast.loc_of_with_constr in
    match wc with
    [ <:with_constr<>> -> ()
    | <:with_constr< type $t1$ = $t2$ >> ->
          pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2
    | <:with_constr< module $i1$ = $i2$ >> ->
          pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident i2
    | <:with_constr< type $t1$ := $t2$ >> ->
          pp f "@[<2>type@ %a :=@ %a@]" o#ctyp t1 o#ctyp t2
    | <:with_constr< module $i1$ := $i2$ >> ->
          pp f "@[<2>module@ %a :=@ %a@]" o#ident i1 o#ident i2
    | <:with_constr< $wc1$ and $wc2$ >> ->
          do { o#with_constraint f wc1; pp f o#andsep; o#with_constraint f wc2 }
    | <:with_constr< $anti:s$ >> -> o#anti f s ];

    method module_expr f me =
    let () = o#node f me Ast.loc_of_module_expr in
    match me with
    [ <:module_expr<>> -> assert False
    | <:module_expr< ( struct $st$ end : sig $sg$ end ) >> ->
          pp f "@[<2>@[<hv2>struct@ %a@]@ end :@ @[<hv2>sig@ %a@]@ end@]"
            o#str_item st o#sig_item sg
    | _ -> o#simple_module_expr f me ];

    method simple_module_expr f me =
    let () = o#node f me Ast.loc_of_module_expr in
    match me with
    [ <:module_expr<>> -> assert False
    | <:module_expr< $id:i$ >> -> o#ident f i
    | <:module_expr< $anti:s$ >> -> o#anti f s
    | <:module_expr< $me1$ $me2$ >> ->
          pp f "@[<2>%a@,(%a)@]" o#module_expr me1 o#module_expr me2
    | Ast.MeFun(_, "*", Ast.MtNil _, me) ->
          pp f "@[<2>functor@ ()@ ->@ %a@]" o#module_expr me
    | <:module_expr< functor ( $s$ : $mt$ ) -> $me$ >> ->
          pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" o#var s o#module_type mt o#module_expr me
    | <:module_expr< struct $st$ end >> ->
          pp f "@[<hv0>@[<hv2>struct@ %a@]@ end@]" o#str_item st
    | <:module_expr< ( $me$ : $mt$ ) >> ->
          pp f "@[<1>(%a :@ %a)@]" o#module_expr me o#module_type mt
    | <:module_expr< (value $e$ : $mt$ ) >> ->
          pp f "@[<1>(%s %a :@ %a)@]" o#value_val o#expr e o#module_type mt
    | <:module_expr< (value $e$ ) >> ->
          pp f "@[<1>(%s %a)@]" o#value_val o#expr e
    | Ast.MeAtt _loc s str e ->
        pp f "((%a)[@@%s %a])" o#module_expr e s o#str_item str
    ];

    method class_expr f ce =
    let () = o#node f ce Ast.loc_of_class_expr in
    match ce with
    [ <:class_expr< $ce$ $e$ >> ->
          pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e
    | <:class_expr< $id:i$ >> ->
          pp f "@[<2>%a@]" o#ident i
    | <:class_expr< $id:i$ [ $t$ ] >> ->
          pp f "@[<2>@[<1>[%a]@]@ %a@]" o#class_params t o#ident i
    | <:class_expr< virtual $lid:i$ >> ->
          pp f "@[<2>virtual@ %a@]" o#var i
    | <:class_expr< virtual $lid:i$ [ $t$ ] >> ->
          pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" o#class_params t o#var i
    | <:class_expr< fun $p$ -> $ce$ >> ->
          pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_patt p o#class_expr ce
    | <:class_expr< let $rec:r$ $bi$ in $ce$ >> ->
          pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]"
            o#rec_flag r o#binding bi o#class_expr ce
    | <:class_expr< object $cst$ end >> ->
          pp f "@[<hv0>@[<hv2>object %a@]@ end@]" o#class_str_item cst
    | <:class_expr< object ($p$) $cst$ end >> ->
          pp f "@[<hv0>@[<hv2>object @[<1>(%a)@]@ %a@]@ end@]"
            o#patt p o#class_str_item cst
    | <:class_expr< ( $ce$ : $ct$ ) >> ->
          pp f "@[<1>(%a :@ %a)@]" o#class_expr ce o#class_type ct
    | <:class_expr< $anti:s$ >> -> o#anti f s
    | <:class_expr< $ce1$ and $ce2$ >> ->
          do { o#class_expr f ce1; pp f o#andsep; o#class_expr f ce2 }
    | <:class_expr< $ce1$ = fun $p$ -> $ce2$ >> when is_irrefut_patt p ->
          pp f "@[<2>%a@ %a" o#class_expr ce1
            o#patt_class_expr_fun_args (p, ce2)
    | <:class_expr< $ce1$ = $ce2$ >> ->
          pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2
    | Ast.CeAtt _loc s str e ->
        pp f "((%a)[@@%s %a])" o#class_expr e s o#str_item str
    | _ -> assert False ];

    method class_type f ct =
    let () = o#node f ct Ast.loc_of_class_type in
    match ct with
    [ <:class_type< $id:i$ >> ->
          pp f "@[<2>%a@]" o#ident i
    | <:class_type< $id:i$ [ $t$ ] >> ->
          pp f "@[<2>[@,%a@]@,]@ %a" o#class_params t o#ident i
    | <:class_type< virtual $lid:i$ >> ->
          pp f "@[<2>virtual@ %a@]" o#var i
    | <:class_type< virtual $lid:i$ [ $t$ ] >> ->
          pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params t o#var i
    | <:class_type< [ $t$ ] -> $ct$ >> ->
          pp f "@[<2>%a@ ->@ %a@]" o#simple_ctyp t o#class_type ct
    | <:class_type< object $csg$ end >> ->
          pp f "@[<hv0>@[<hv2>object@ %a@]@ end@]" o#class_sig_item csg
    | <:class_type< object ($t$) $csg$ end >> ->
          pp f "@[<hv0>@[<hv2>object @[<1>(%a)@]@ %a@]@ end@]"
            o#ctyp t o#class_sig_item csg
    | <:class_type< $anti:s$ >> -> o#anti f s
    | <:class_type< $ct1$ and $ct2$ >> ->
          do { o#class_type f ct1; pp f o#andsep; o#class_type f ct2 }
    | <:class_type< $ct1$ : $ct2$ >> ->
          pp f "%a :@ %a" o#class_type ct1 o#class_type ct2
    | <:class_type< $ct1$ = $ct2$ >> ->
          pp f "%a =@ %a" o#class_type ct1 o#class_type ct2
    | Ast.CtAtt _loc s str e ->
        pp f "((%a)[@@%s %a])" o#class_type e s o#str_item str
    | _ -> assert False ];

    method class_sig_item f csg =
      let () = o#node f csg Ast.loc_of_class_sig_item in
      match csg with
      [ <:class_sig_item<>> -> ()
      | <:class_sig_item< $csg$; $<:class_sig_item<>>$ >> |
        <:class_sig_item< $<:class_sig_item<>>$; $csg$ >> ->
          o#class_sig_item f csg
      | <:class_sig_item< $csg1$; $csg2$ >> ->
            do { o#class_sig_item f csg1; cut f; o#class_sig_item f csg2 }
      | <:class_sig_item< constraint $t1$ = $t2$ >> ->
            pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep
      | <:class_sig_item< inherit $ct$ >> ->
            pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct no_semisep
      | <:class_sig_item< method $private:pr$ $s$ : $t$ >> ->
            pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s
              o#ctyp t no_semisep
      | <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> ->
            pp f "@[<2>method virtual %a%a :@ %a%(%)@]"
              o#private_flag pr o#var s o#ctyp t no_semisep
      | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> ->
            pp f "@[<2>%s %a%a%a :@ %a%(%)@]"
              o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t
              no_semisep
      | <:class_sig_item< $anti:s$ >> ->
            pp f "%a%(%)" o#anti s no_semisep ];

    method class_str_item f cst =
      let () = o#node f cst Ast.loc_of_class_str_item in
      match cst with
      [ <:class_str_item<>> -> ()
      | <:class_str_item< $cst$; $<:class_str_item<>>$ >> |
        <:class_str_item< $<:class_str_item<>>$; $cst$ >> ->
          o#class_str_item f cst
      | <:class_str_item< $cst1$; $cst2$ >> ->
            do { o#class_str_item f cst1; cut f; o#class_str_item f cst2 }
      | <:class_str_item< constraint $t1$ = $t2$ >> ->
            pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep
      | <:class_str_item< inherit $override:ov$ $ce$ >> ->
            pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce no_semisep
      | <:class_str_item< inherit $override:ov$ $ce$ as $lid:s$ >> ->
            pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s no_semisep
      | <:class_str_item< initializer $e$ >> ->
            pp f "@[<2>initializer@ %a%(%)@]" o#expr e no_semisep
      | <:class_str_item< method $override:ov$ $private:pr$ $s$ = $e$ >> ->
            pp f "@[<2>method%a %a%a =@ %a%(%)@]"
              o#override_flag ov o#private_flag pr o#var s o#expr e no_semisep
      | <:class_str_item< method $override:ov$ $private:pr$ $s$ : $t$ = $e$ >> ->
            pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]"
              o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e no_semisep
      | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> ->
            pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]"
              o#private_flag pr o#var s o#ctyp t no_semisep
      | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> ->
            pp f "@[<2>%s virtual %a%a :@ %a%(%)@]"
              o#value_val o#mutable_flag mu o#var s o#ctyp t no_semisep
      | <:class_str_item< value $override:ov$ $mutable:mu$ $s$ = $e$ >> ->
            pp f "@[<2>%s%a %a%a =@ %a%(%)@]"
              o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e no_semisep
      | <:class_str_item< $anti:s$ >> ->
            pp f "%a%(%)" o#anti s no_semisep ];

    method implem f st =
      match st with
      [ <:str_item< $exp:e$ >> -> pp f "@[<0>%a%(%)@]@." o#expr e semisep
      | st -> pp f "@[<v0>%a@]@." o#str_item st ];

    method interf f sg = pp f "@[<v0>%a@]@." o#sig_item sg;
  end;

  value with_outfile output_file fct arg =
    let call close f = do {
      try fct f arg with [ exn -> do { close (); raise exn } ];
      close ()
    } in
    match output_file with
    [ None -> call (fun () -> ()) std_formatter
    | Some s ->
        let oc = open_out s in
        let f = formatter_of_out_channel oc in
        call (fun () -> close_out oc) f ];

  value print output_file fct =
    let o = new printer () in
    with_outfile output_file (fct o);

  value print_interf ?input_file:(_) ?output_file sg =
    print output_file (fun o -> o#interf) sg;

  value print_implem ?input_file:(_) ?output_file st =
    print output_file (fun o -> o#implem) st;

end;

module MakeMore (Syntax : Sig.Camlp4Syntax)
: (Sig.Printer Syntax.Ast).S
= struct

  include Make Syntax;

  value semisep : ref sep = ref ("@\n" : sep);
  value margin = ref 78;
  value comments = ref True;
  value locations = ref False;
  value curry_constr = ref False;

  value print output_file fct =
    let o = new printer ~comments:comments.val
                        ~curry_constr:curry_constr.val () in
    let o = o#set_semisep semisep.val in
    let o = if locations.val then o#set_loc_and_comments else o in
    with_outfile output_file
      (fun f ->
        let () = Format.pp_set_margin f margin.val in
        Format.fprintf f "@[<v0>%a@]@." (fct o));

  value print_interf ?input_file:(_) ?output_file sg =
    print output_file (fun o -> o#interf) sg;

  value print_implem ?input_file:(_) ?output_file st =
    print output_file (fun o -> o#implem) st;

  value check_sep s =
    if String.contains s '%' then failwith "-sep Format error, % found in string"
    else (Obj.magic (Struct.Token.Eval.string s : string) : sep);

  Options.add "-l" (Arg.Int (fun i -> margin.val := i))
    "<length> line length for pretty printing.";

  Options.add "-ss" (Arg.Unit (fun () -> semisep.val := ";;"))
    " Print double semicolons.";

  Options.add "-no_ss" (Arg.Unit (fun () -> semisep.val := ""))
    " Do not print double semicolons (default).";

  Options.add "-sep" (Arg.String (fun s -> semisep.val := check_sep s))
    " Use this string between phrases.";

  Options.add "-curry-constr" (Arg.Set curry_constr) "Use currified constructors.";

  Options.add "-no_comments" (Arg.Clear comments) "Do not add comments.";

  Options.add "-add_locations" (Arg.Set locations) "Add locations as comment.";

end;
