(* graph typed abstract syntax tree:

   couple options for hooking into compilation:
   - modify ocaml source
   - reimplement toplevel functions to allow extracting tast
     * needs multiple implementaitons for byte and js
     * only accepts toplevel phrases
   - ppx
     * only gets ast, would need to parse for tast (could use merlin or ocamlcommon?)
   - merlin
     * need to understand protocol and whether current lib interfaces give enough control
*)

open Ppxlib
open Lwt
module F = Fmt
module Log = Logs

module Printast = struct
  include Ocaml_common.Printast
  open Asttypes
  open Format
  open Lexing
  open Location
  open Parsetree

  let fmt_position with_name f l =
    let fname = if with_name then l.pos_fname else "" in
    if l.pos_lnum = -1 then fprintf f "%s[%d]" fname l.pos_cnum
    else
      fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
        (l.pos_cnum - l.pos_bol)

  let fmt_location f loc =
    if not !Ocaml_common.Clflags.locations then ()
    else
      let p_2nd_name =
        loc.loc_start.pos_fname <> loc.loc_end.pos_fname
      in
      fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
        (fmt_position p_2nd_name)
        loc.loc_end;
      if loc.loc_ghost then fprintf f " ghost"

  let rec fmt_longident_aux f x =
    match x with
    | Longident.Lident s -> fprintf f "%s" s
    | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s
    | Longident.Lapply (y, z) ->
        fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z

  let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x

  let fmt_longident_loc f (x : Longident.t loc) =
    fprintf f "%a" fmt_longident_aux x.txt

  let fmt_string_loc f (x : string loc) = fprintf f "\"%s\"@ " x.txt

  let fmt_str_opt_loc f (x : string option loc) =
    fprintf f "\"%s\"@ " (Option.value x.txt ~default:"_")

  let fmt_char_option f = function
    | None -> fprintf f ""
    | Some c -> fprintf f "%c" c

  let fmt_constant f x =
    match x with
    | Pconst_integer (i, m) -> fprintf f "%s%a" i fmt_char_option m
    | Pconst_char c -> fprintf f "'%02x'" (Char.code c)
    | Pconst_string (s, _strloc, None) -> fprintf f "%S" s
    | Pconst_string (s, _strloc, Some delim) ->
        fprintf f "%S(%S)" s delim
    | Pconst_float (s, _) -> fprintf f "%s" s

  let str_longident_loc = F.to_to_string fmt_longident_loc
  let str_constant = F.to_to_string fmt_constant

  let fmt_mutable_flag f x =
    match x with
    | Immutable -> fprintf f "Immutable"
    | Mutable -> fprintf f "Mutable"

  let fmt_virtual_flag f x =
    match x with
    | Virtual -> fprintf f "Virtual"
    | Concrete -> fprintf f "Concrete"

  let fmt_override_flag f x =
    match x with
    | Override -> fprintf f "Override"
    | Fresh -> fprintf f "Fresh"

  let fmt_closed_flag f x =
    match x with
    | Closed -> fprintf f "Closed"
    | Open -> fprintf f "Open"

  let fmt_rec_flag f x =
    match x with
    | Nonrecursive -> fprintf f ""
    | Recursive -> fprintf f "Rec "

  let fmt_direction_flag f x =
    match x with Upto -> fprintf f "Up" | Downto -> fprintf f "Down"

  let fmt_private_flag f x =
    match x with
    | Public -> fprintf f "Public"
    | Private -> fprintf f "Private"

  let line = F.pf

  let list f ppf l =
    F.pf ppf "%a" (F.brackets @@ F.list ~sep:F.semi f) l

  let option f = F.option ~none:(fun ppf () -> F.pf ppf "None") f
  let longident_loc ppf li = line ppf "%a@ " fmt_longident_loc li
  let string ppf s = line ppf "\"%s\"@ " s
  let string_loc ppf s = line ppf "%a@ " fmt_string_loc s
  let str_opt_loc ppf s = line ppf "%a@ " fmt_str_opt_loc s

  let arg_label ppf = function
    | Nolabel -> fprintf ppf "" (* "Nolabel\n" *)
    | Optional s -> fprintf ppf "?:%s@ " s
    | Labelled s -> fprintf ppf "~:%s@ " s

  let rec core_type ppf x =
    attributes ppf x.ptyp_attributes;
    match x.ptyp_desc with
    | Ptyp_any -> line ppf "Ptyp_any@ "
    | Ptyp_var s -> line ppf "Ptyp_var %s@ " s
    | Ptyp_arrow (l, ct1, ct2) ->
        line ppf "Ptyp_arrow@ ";
        arg_label ppf l;
        core_type ppf ct1;
        core_type ppf ct2
    | Ptyp_tuple l ->
        line ppf "Ptyp_tuple@ ";
        list core_type ppf l
    | Ptyp_constr (li, l) ->
        line ppf "Ptyp_constr %a@ " fmt_longident_loc li;
        list core_type ppf l
    | Ptyp_variant (l, closed, low) ->
        line ppf "Ptyp_variant closed=%a@ " fmt_closed_flag closed;
        list label_x_bool_x_core_type_list ppf l;
        option (list string) ppf low
    | Ptyp_object (l, c) ->
        line ppf "Ptyp_object %a@ " fmt_closed_flag c;
        List.iter
          (fun field ->
            match field.pof_desc with
            | Otag (l, t) ->
                line ppf "method %s@ " l.txt;
                attributes ppf field.pof_attributes;
                core_type ppf t
            | Oinherit ct ->
                line ppf "Oinherit@ ";
                core_type ppf ct)
          l
    | Ptyp_class (li, l) ->
        line ppf "Ptyp_class %a@ " fmt_longident_loc li;
        list core_type ppf l
    | Ptyp_alias (ct, s) ->
        line ppf "Ptyp_alias \"%s\"@ " s;
        core_type ppf ct
    | Ptyp_poly (sl, ct) ->
        line ppf "Ptyp_poly%a@ "
          (fun ppf ->
            List.iter (fun x ->
                fprintf ppf " %a" Ocaml_common.Pprintast.tyvar x.txt))
          sl;
        core_type ppf ct
    | Ptyp_package (s, l) ->
        line ppf "Ptyp_package %a@ " fmt_longident_loc s;
        list package_with ppf l
    | Ptyp_extension (s, arg) ->
        line ppf "Ptyp_extension \"%s\"@ " s.txt;
        payload ppf arg

  and package_with ppf (s, t) =
    line ppf "with type %a@ " fmt_longident_loc s;
    core_type ppf t

  and pattern ppf x =
    (* line i ppf "pattern %a@ " fmt_location x.ppat_loc; *)
    attributes ppf x.ppat_attributes;
    match x.ppat_desc with
    | Ppat_any -> line ppf "Ppat_any@ "
    | Ppat_var s -> line ppf "<var> %a@ " fmt_string_loc s
    | Ppat_alias (p, s) ->
        line ppf "Ppat_alias %a@ " fmt_string_loc s;
        pattern ppf p
    | Ppat_constant c -> line ppf "Ppat %a@ " fmt_constant c
    | Ppat_interval (c1, c2) ->
        line ppf "Ppat_interval %a..%a@ " fmt_constant c1 fmt_constant
          c2
    | Ppat_tuple l ->
        line ppf "Ppat_tuple@ ";
        list pattern ppf l
    | Ppat_construct (li, po) ->
        line ppf "Ppat_construct %a@ " fmt_longident_loc li;
        option pattern ppf (Option.map snd po)
    | Ppat_variant (l, po) ->
        line ppf "Ppat_variant \"%s\"@ " l;
        option pattern ppf po
    | Ppat_record (l, c) ->
        line ppf "Ppat_record %a@ " fmt_closed_flag c;
        list longident_x_pattern ppf l
    | Ppat_array l ->
        line ppf "Ppat_array@ ";
        list pattern ppf l
    | Ppat_or (p1, p2) ->
        line ppf "Ppat_or@ ";
        pattern ppf p1;
        pattern ppf p2
    | Ppat_lazy p ->
        line ppf "Ppat_lazy@ ";
        pattern ppf p
    | Ppat_constraint (p, ct) ->
        line ppf "Ppat_constraint@ ";
        pattern ppf p;
        core_type ppf ct
    | Ppat_type li ->
        line ppf "Ppat_type@ ";
        longident_loc ppf li
    | Ppat_unpack s -> line ppf "Ppat_unpack %a@ " fmt_str_opt_loc s
    | Ppat_exception p ->
        line ppf "Ppat_exception@ ";
        pattern ppf p
    | Ppat_open (m, p) ->
        line ppf "Ppat_open \"%a\"@ " fmt_longident_loc m;
        pattern ppf p
    | Ppat_extension (s, arg) ->
        line ppf "Ppat_extension \"%s\"@ " s.txt;
        payload ppf arg

  and expression ppf x : unit =
    (* line ppf "expression %a@ " fmt_location x.pexp_loc; *)
    attributes ppf x.pexp_attributes;

    match x.pexp_desc with
    | Pexp_ident _li ->
        (* line ppf "Pexp_ident %a@ " fmt_longident_loc li; *)
        (* str_longident_loc li *)
        ()
    | Pexp_constant _c ->
        (*line ppf "Pexp %a@ " fmt_constant c;*)
        (* str_constant c *)
        ()
    | Pexp_let (rf, l, e) ->
        line ppf "Pexp_let %a@ " fmt_rec_flag rf;
        list value_binding ppf l;
        expression ppf e
    | Pexp_function _l ->
        line ppf "Pexp_function@ " (* ; list case ppf l *)
    | Pexp_fun (l, eo, p, e) ->
        line ppf "Pexp_fun@ ";
        arg_label ppf l;
        F.option (fun ppf -> F.pf ppf "=%a" expression) ppf eo;
        F.pf ppf "%a@ ->@ %a" pattern p expression e
    | Pexp_apply (e, l) ->
        line ppf "Pexp_apply@ ";
        expression ppf e;
        let name = Pprintast.string_of_expression x in
        list (graph_node name) ppf l
    | Pexp_match (e, l) ->
        line ppf "Pexp_match@ ";
        expression ppf e;
        list case ppf l
    | Pexp_try (e, l) ->
        line ppf "Pexp_try@ ";
        expression ppf e;
        list case ppf l
    | Pexp_tuple l ->
        line ppf "Pexp_tuple@ ";
        list expression ppf l
    | Pexp_construct (li, eo) ->
        line ppf "Pexp_construct %a@ " fmt_longident_loc li;
        option expression ppf eo
    | Pexp_variant (l, eo) ->
        line ppf "Pexp_variant \"%s\"@ " l;
        option expression ppf eo
    | Pexp_record (l, eo) ->
        line ppf "Pexp_record@ ";
        list longident_x_expression ppf l;
        option expression ppf eo
    | Pexp_field (e, li) ->
        line ppf "Pexp_field@ ";
        expression ppf e;
        longident_loc ppf li
    | Pexp_setfield (e1, li, e2) ->
        line ppf "Pexp_setfield@ ";
        expression ppf e1;
        longident_loc ppf li;
        expression ppf e2
    | Pexp_array l ->
        line ppf "Pexp_array@ ";
        list expression ppf l
    | Pexp_ifthenelse (e1, e2, eo) ->
        line ppf "Pexp_if@ ";
        expression ppf e1;
        line ppf "Pexp_then@ ";
        expression ppf e2;
        F.option
          (fun ppf ->
            line ppf "Pexp_else@ ";
            expression ppf)
          ppf eo
    | Pexp_sequence (e1, e2) ->
        line ppf "Pexp_sequence@ ";
        expression ppf e1;
        expression ppf e2
    | Pexp_while (e1, e2) ->
        line ppf "Pexp_while@ ";
        expression ppf e1;
        expression ppf e2
    | Pexp_for (p, e1, e2, df, e3) ->
        line ppf "Pexp_for %a@ " fmt_direction_flag df;
        pattern ppf p;
        expression ppf e1;
        expression ppf e2;
        expression ppf e3
    | Pexp_constraint (e, ct) ->
        line ppf "Pexp_constraint@ ";
        expression ppf e;
        core_type ppf ct
    | Pexp_coerce (e, cto1, cto2) ->
        line ppf "Pexp_coerce@ ";
        expression ppf e;
        option core_type ppf cto1;
        core_type ppf cto2
    | Pexp_send (e, s) ->
        line ppf "Pexp_send \"%s\"@ " s.txt;
        expression ppf e
    | Pexp_new li -> line ppf "Pexp_new %a@ " fmt_longident_loc li
    | Pexp_setinstvar (s, e) ->
        line ppf "Pexp_setinstvar %a@ " fmt_string_loc s;
        expression ppf e
    | Pexp_override l ->
        line ppf "Pexp_override@ ";
        list string_x_expression ppf l
    | Pexp_letmodule (s, me, e) ->
        line ppf "Pexp_letmodule %a@ " fmt_str_opt_loc s;
        module_expr ppf me;
        expression ppf e
    | Pexp_letexception (cd, e) ->
        line ppf "Pexp_letexception@ ";
        extension_constructor ppf cd;
        expression ppf e
    | Pexp_assert e ->
        line ppf "Pexp_assert@ ";
        expression ppf e
    | Pexp_lazy e ->
        line ppf "Pexp_lazy@ ";
        expression ppf e
    | Pexp_poly (e, cto) ->
        line ppf "Pexp_poly@ ";
        expression ppf e;
        option core_type ppf cto
    | Pexp_object s ->
        line ppf "Pexp_object@ ";
        class_structure ppf s
    | Pexp_newtype (s, e) ->
        line ppf "Pexp_newtype \"%s\"@ " s.txt;
        expression ppf e
    | Pexp_pack me ->
        line ppf "Pexp_pack@ ";
        module_expr ppf me
    | Pexp_open (o, e) ->
        line ppf "Pexp_open %a@ " fmt_override_flag o.popen_override;
        module_expr ppf o.popen_expr;
        expression ppf e
    | Pexp_letop { let_; ands; body } ->
        line ppf "Pexp_letop@ ";
        binding_op ppf let_;
        list binding_op ppf ands;
        expression ppf body
    | Pexp_extension (s, arg) ->
        line ppf "Pexp_extension \"%s\"@ " s.txt;
        payload ppf arg
    | Pexp_unreachable -> line ppf "Pexp_unreachable"

  and value_description ppf x =
    line ppf "value_description %a %a@ " fmt_string_loc x.pval_name
      fmt_location x.pval_loc;
    attributes ppf x.pval_attributes;
    core_type ppf x.pval_type;
    list string ppf x.pval_prim

  and type_parameter ppf (x, _variance) = core_type ppf x

  and type_declaration ppf x =
    line ppf "type_declaration %a %a@ " fmt_string_loc x.ptype_name
      fmt_location x.ptype_loc;
    attributes ppf x.ptype_attributes;

    line ppf "ptype_params =@ ";
    list type_parameter ppf x.ptype_params;
    line ppf "ptype_cstrs =@ ";
    list core_type_x_core_type_x_location ppf x.ptype_cstrs;
    line ppf "ptype_kind =@ ";
    type_kind ppf x.ptype_kind;
    line ppf "ptype_private = %a@ " fmt_private_flag x.ptype_private;
    line ppf "ptype_manifest =@ ";
    option core_type ppf x.ptype_manifest

  and attribute ppf k a =
    line ppf "%s \"%s\"@ " k a.attr_name.txt;
    payload ppf a.attr_payload

  and attributes ppf l =
    List.iter
      (fun a ->
        line ppf "attribute \"%s\"@ " a.attr_name.txt;
        payload ppf a.attr_payload)
      l

  and payload ppf = function
    | PStr x -> structure ppf x
    | PSig x -> signature ppf x
    | PTyp x -> core_type ppf x
    | PPat (x, None) -> pattern ppf x
    | PPat (x, Some g) ->
        pattern ppf x;
        line ppf "<when>@ ";
        expression ppf g

  and type_kind ppf x =
    match x with
    | Ptype_abstract -> line ppf "Ptype_abstract@ "
    | Ptype_variant l ->
        line ppf "Ptype_variant@ ";
        list constructor_decl ppf l
    | Ptype_record l ->
        line ppf "Ptype_record@ ";
        list label_decl ppf l
    | Ptype_open -> line ppf "Ptype_open@ "

  and type_extension ppf x =
    line ppf "type_extension@ ";
    attributes ppf x.ptyext_attributes;

    line ppf "ptyext_path = %a@ " fmt_longident_loc x.ptyext_path;
    line ppf "ptyext_params =@ ";
    list type_parameter ppf x.ptyext_params;
    line ppf "ptyext_constructors =@ ";
    list extension_constructor ppf x.ptyext_constructors;
    line ppf "ptyext_private = %a@ " fmt_private_flag x.ptyext_private

  and type_exception ppf x =
    line ppf "type_exception@ ";
    attributes ppf x.ptyexn_attributes;
    line ppf "ptyext_constructor =@ ";

    extension_constructor ppf x.ptyexn_constructor

  and extension_constructor ppf x =
    line ppf "extension_constructor %a@ " fmt_location x.pext_loc;
    attributes ppf x.pext_attributes;

    line ppf "pext_name = \"%s\"@ " x.pext_name.txt;
    line ppf "pext_kind =@ ";
    extension_constructor_kind ppf x.pext_kind

  and extension_constructor_kind ppf x =
    match x with
    | Pext_decl (_, a, r) ->
        line ppf "Pext_decl@ ";
        constructor_arguments ppf a;
        option core_type ppf r
    | Pext_rebind li ->
        line ppf "Pext_rebind@ ";
        line ppf "%a@ " fmt_longident_loc li

  and class_type ppf x =
    line ppf "class_type %a@ " fmt_location x.pcty_loc;
    attributes ppf x.pcty_attributes;

    match x.pcty_desc with
    | Pcty_constr (li, l) ->
        line ppf "Pcty_constr %a@ " fmt_longident_loc li;
        list core_type ppf l
    | Pcty_signature cs ->
        line ppf "Pcty_signature@ ";
        class_signature ppf cs
    | Pcty_arrow (l, co, cl) ->
        line ppf "Pcty_arrow@ ";
        arg_label ppf l;
        core_type ppf co;
        class_type ppf cl
    | Pcty_extension (s, arg) ->
        line ppf "Pcty_extension \"%s\"@ " s.txt;
        payload ppf arg
    | Pcty_open (o, e) ->
        line ppf "Pcty_open %a %a@ " fmt_override_flag
          o.popen_override fmt_longident_loc o.popen_expr;
        class_type ppf e

  and class_signature ppf cs =
    line ppf "class_signature@ ";
    core_type ppf cs.pcsig_self;
    list class_type_field ppf cs.pcsig_fields

  and class_type_field ppf x =
    line ppf "class_type_field %a@ " fmt_location x.pctf_loc;
    attributes ppf x.pctf_attributes;
    match x.pctf_desc with
    | Pctf_inherit ct ->
        line ppf "Pctf_inherit@ ";
        class_type ppf ct
    | Pctf_val (s, mf, vf, ct) ->
        line ppf "Pctf_val \"%s\" %a %a@ " s.txt fmt_mutable_flag mf
          fmt_virtual_flag vf;
        core_type ppf ct
    | Pctf_method (s, pf, vf, ct) ->
        line ppf "Pctf_method \"%s\" %a %a@ " s.txt fmt_private_flag
          pf fmt_virtual_flag vf;
        core_type ppf ct
    | Pctf_constraint (ct1, ct2) ->
        line ppf "Pctf_constraint@ ";
        core_type ppf ct1;
        core_type ppf ct2
    | Pctf_attribute a -> attribute ppf "Pctf_attribute" a
    | Pctf_extension (s, arg) ->
        line ppf "Pctf_extension \"%s\"@ " s.txt;
        payload ppf arg

  and class_description ppf x =
    line ppf "class_description %a@ " fmt_location x.pci_loc;
    attributes ppf x.pci_attributes;

    line ppf "pci_virt = %a@ " fmt_virtual_flag x.pci_virt;
    line ppf "pci_params =@ ";
    list type_parameter ppf x.pci_params;
    line ppf "pci_name = %a@ " fmt_string_loc x.pci_name;
    line ppf "pci_expr =@ ";
    class_type ppf x.pci_expr

  and class_type_declaration ppf x =
    line ppf "class_type_declaration %a@ " fmt_location x.pci_loc;
    attributes ppf x.pci_attributes;
    line ppf "pci_virt = %a@ " fmt_virtual_flag x.pci_virt;
    line ppf "pci_params =@ ";
    list type_parameter ppf x.pci_params;
    line ppf "pci_name = %a@ " fmt_string_loc x.pci_name;
    line ppf "pci_expr =@ ";
    class_type ppf x.pci_expr

  and class_expr ppf x =
    line ppf "class_expr %a@ " fmt_location x.pcl_loc;
    attributes ppf x.pcl_attributes;
    match x.pcl_desc with
    | Pcl_constr (li, l) ->
        line ppf "Pcl_constr %a@ " fmt_longident_loc li;
        list core_type ppf l
    | Pcl_structure cs ->
        line ppf "Pcl_structure@ ";
        class_structure ppf cs
    | Pcl_fun (l, eo, p, e) ->
        line ppf "Pcl_fun@ ";
        arg_label ppf l;
        option expression ppf eo;
        pattern ppf p;
        class_expr ppf e
    | Pcl_apply (ce, l) ->
        line ppf "Pcl_apply@ ";
        class_expr ppf ce;
        list label_x_expression ppf l
    | Pcl_let (rf, l, ce) ->
        line ppf "Pcl_let %a@ " fmt_rec_flag rf;
        list value_binding ppf l;
        class_expr ppf ce
    | Pcl_constraint (ce, ct) ->
        line ppf "Pcl_constraint@ ";
        class_expr ppf ce;
        class_type ppf ct
    | Pcl_extension (s, arg) ->
        line ppf "Pcl_extension \"%s\"@ " s.txt;
        payload ppf arg
    | Pcl_open (o, e) ->
        line ppf "Pcl_open %a %a@ " fmt_override_flag o.popen_override
          fmt_longident_loc o.popen_expr;
        class_expr ppf e

  and class_structure ppf { pcstr_self = p; pcstr_fields = l } =
    line ppf "class_structure@ ";
    pattern ppf p;
    list class_field ppf l

  and class_field ppf x =
    line ppf "class_field %a@ " fmt_location x.pcf_loc;
    attributes ppf x.pcf_attributes;
    match x.pcf_desc with
    | Pcf_inherit (ovf, ce, so) ->
        line ppf "Pcf_inherit %a@ " fmt_override_flag ovf;
        class_expr ppf ce;
        option string_loc ppf so
    | Pcf_val (s, mf, k) ->
        line ppf "Pcf_val %a@ " fmt_mutable_flag mf;
        line ppf "%a@ " fmt_string_loc s;
        class_field_kind ppf k
    | Pcf_method (s, pf, k) ->
        line ppf "Pcf_method %a@ " fmt_private_flag pf;
        line ppf "%a@ " fmt_string_loc s;
        class_field_kind ppf k
    | Pcf_constraint (ct1, ct2) ->
        line ppf "Pcf_constraint@ ";
        core_type ppf ct1;
        core_type ppf ct2
    | Pcf_initializer e ->
        line ppf "Pcf_initializer@ ";
        expression ppf e
    | Pcf_attribute a -> attribute ppf "Pcf_attribute" a
    | Pcf_extension (s, arg) ->
        line ppf "Pcf_extension \"%s\"@ " s.txt;
        payload ppf arg

  and class_field_kind ppf = function
    | Cfk_concrete (o, e) ->
        line ppf "Concrete %a@ " fmt_override_flag o;
        expression ppf e
    | Cfk_virtual t ->
        line ppf "Virtual@ ";
        core_type ppf t

  and class_declaration ppf x =
    line ppf "class_declaration %a@ " fmt_location x.pci_loc;
    attributes ppf x.pci_attributes;
    line ppf "pci_virt = %a@ " fmt_virtual_flag x.pci_virt;
    line ppf "pci_params =@ ";
    list type_parameter ppf x.pci_params;
    line ppf "pci_name = %a@ " fmt_string_loc x.pci_name;
    line ppf "pci_expr =@ ";
    class_expr ppf x.pci_expr

  and module_type ppf x =
    line ppf "module_type %a@ " fmt_location x.pmty_loc;
    attributes ppf x.pmty_attributes;

    match x.pmty_desc with
    | Pmty_ident li -> line ppf "Pmty_ident %a@ " fmt_longident_loc li
    | Pmty_alias li -> line ppf "Pmty_alias %a@ " fmt_longident_loc li
    | Pmty_signature s ->
        line ppf "Pmty_signature@ ";
        signature ppf s
    | Pmty_functor (Unit, mt2) ->
        line ppf "Pmty_functor ()@ ";
        module_type ppf mt2
    | Pmty_functor (Named (s, mt1), mt2) ->
        line ppf "Pmty_functor %a@ " fmt_str_opt_loc s;
        module_type ppf mt1;
        module_type ppf mt2
    | Pmty_with (mt, l) ->
        line ppf "Pmty_with@ ";
        module_type ppf mt;
        list with_constraint ppf l
    | Pmty_typeof m ->
        line ppf "Pmty_typeof@ ";
        module_expr ppf m
    | Pmty_extension (s, arg) ->
        line ppf "Pmod_extension \"%s\"@ " s.txt;
        payload ppf arg

  and signature ppf x = list signature_item ppf x

  and signature_item ppf x =
    line ppf "signature_item %a@ " fmt_location x.psig_loc;

    match x.psig_desc with
    | Psig_value vd ->
        line ppf "Psig_value@ ";
        value_description ppf vd
    | Psig_type (rf, l) ->
        line ppf "Psig_type %a@ " fmt_rec_flag rf;
        list type_declaration ppf l
    | Psig_typesubst l ->
        line ppf "Psig_typesubst@ ";
        list type_declaration ppf l
    | Psig_typext te ->
        line ppf "Psig_typext@ ";
        type_extension ppf te
    | Psig_exception te ->
        line ppf "Psig_exception@ ";
        type_exception ppf te
    | Psig_module pmd ->
        line ppf "Psig_module %a@ " fmt_str_opt_loc pmd.pmd_name;
        attributes ppf pmd.pmd_attributes;
        module_type ppf pmd.pmd_type
    | Psig_modsubst pms ->
        line ppf "Psig_modsubst %a = %a@ " fmt_string_loc pms.pms_name
          fmt_longident_loc pms.pms_manifest;
        attributes ppf pms.pms_attributes
    | Psig_recmodule decls ->
        line ppf "Psig_recmodule@ ";
        list module_declaration ppf decls
    | Psig_modtype x ->
        line ppf "Psig_modtype %a@ " fmt_string_loc x.pmtd_name;
        attributes ppf x.pmtd_attributes;
        modtype_declaration ppf x.pmtd_type
    | Psig_open od ->
        line ppf "Psig_open %a %a@ " fmt_override_flag
          od.popen_override fmt_longident_loc od.popen_expr;
        attributes ppf od.popen_attributes
    | Psig_include incl ->
        line ppf "Psig_include@ ";
        module_type ppf incl.pincl_mod;
        attributes ppf incl.pincl_attributes
    | Psig_class l ->
        line ppf "Psig_class@ ";
        list class_description ppf l
    | Psig_class_type l ->
        line ppf "Psig_class_type@ ";
        list class_type_declaration ppf l
    | Psig_extension ((s, arg), attrs) ->
        line ppf "Psig_extension \"%s\"@ " s.txt;
        attributes ppf attrs;
        payload ppf arg
    | Psig_attribute a -> attribute ppf "Psig_attribute" a
    | _ ->
        Log.err (fun m -> m "Printast signature_item not matched");
        raise Not_found

  and modtype_declaration ppf = function
    | None -> line ppf "#abstract"
    | Some mt -> module_type ppf mt

  and with_constraint ppf x =
    match x with
    | Pwith_type (lid, td) ->
        line ppf "Pwith_type %a@ " fmt_longident_loc lid;
        type_declaration ppf td
    | Pwith_typesubst (lid, td) ->
        line ppf "Pwith_typesubst %a@ " fmt_longident_loc lid;
        type_declaration ppf td
    | Pwith_module (lid1, lid2) ->
        line ppf "Pwith_module %a = %a@ " fmt_longident_loc lid1
          fmt_longident_loc lid2
    | Pwith_modsubst (lid1, lid2) ->
        line ppf "Pwith_modsubst %a = %a@ " fmt_longident_loc lid1
          fmt_longident_loc lid2
    | _ ->
        Log.err (fun m -> m "Printast with_constraint not matched");
        raise Not_found

  and module_expr ppf x =
    line ppf "module_expr %a@ " fmt_location x.pmod_loc;
    attributes ppf x.pmod_attributes;

    match x.pmod_desc with
    | Pmod_ident li -> line ppf "Pmod_ident %a@ " fmt_longident_loc li
    | Pmod_structure s ->
        line ppf "Pmod_structure@ ";
        structure ppf s
    | Pmod_functor (Unit, me) ->
        line ppf "Pmod_functor ()@ ";
        module_expr ppf me
    | Pmod_functor (Named (s, mt), me) ->
        line ppf "Pmod_functor %a@ " fmt_str_opt_loc s;
        module_type ppf mt;
        module_expr ppf me
    | Pmod_apply (me1, me2) ->
        line ppf "Pmod_apply@ ";
        module_expr ppf me1;
        module_expr ppf me2
    | Pmod_constraint (me, mt) ->
        line ppf "Pmod_constraint@ ";
        module_expr ppf me;
        module_type ppf mt
    | Pmod_unpack e ->
        line ppf "Pmod_unpack@ ";
        expression ppf e
    | Pmod_extension (s, arg) ->
        line ppf "Pmod_extension \"%s\"@ " s.txt;
        payload ppf arg

  and structure ppf x =
    line ppf "struct@ ";
    list structure_item ppf x

  and structure_item ppf x =
    match x.pstr_desc with
    | Pstr_eval (e, attrs) ->
        line ppf "Pstr_eval ";
        attributes ppf attrs;
        expression ppf e
    | Pstr_value (rf, l) ->
        line ppf "%a" fmt_rec_flag rf;
        list value_binding ppf l
    | Pstr_primitive vd ->
        line ppf "Pstr_primitive@ ";
        value_description ppf vd
    | Pstr_type (rf, l) ->
        line ppf "Pstr_type %a@ " fmt_rec_flag rf;
        list type_declaration ppf l
    | Pstr_typext te ->
        line ppf "Pstr_typext@ ";
        type_extension ppf te
    | Pstr_exception te ->
        line ppf "Pstr_exception@ ";
        type_exception ppf te
    | Pstr_module x ->
        line ppf "Pstr_module@ ";
        module_binding ppf x
    | Pstr_recmodule bindings ->
        line ppf "Pstr_recmodule@ ";
        list module_binding ppf bindings
    | Pstr_modtype x ->
        line ppf "Pstr_modtype %a@ " fmt_string_loc x.pmtd_name;
        attributes ppf x.pmtd_attributes;
        modtype_declaration ppf x.pmtd_type
    | Pstr_open od ->
        line ppf "Pstr_open %a@ " fmt_override_flag od.popen_override;
        module_expr ppf od.popen_expr;
        attributes ppf od.popen_attributes
    | Pstr_class l ->
        line ppf "Pstr_class@ ";
        list class_declaration ppf l
    | Pstr_class_type l ->
        line ppf "Pstr_class_type@ ";
        list class_type_declaration ppf l
    | Pstr_include incl ->
        line ppf "Pstr_include";
        attributes ppf incl.pincl_attributes;
        module_expr ppf incl.pincl_mod
    | Pstr_extension ((s, arg), attrs) ->
        line ppf "Pstr_extension \"%s\"@ " s.txt;
        attributes ppf attrs;
        payload ppf arg
    | Pstr_attribute a -> attribute ppf "Pstr_attribute" a

  and module_declaration ppf pmd =
    str_opt_loc ppf pmd.pmd_name;
    attributes ppf pmd.pmd_attributes;
    module_type ppf pmd.pmd_type

  and module_binding ppf x =
    str_opt_loc ppf x.pmb_name;
    attributes ppf x.pmb_attributes;
    module_expr ppf x.pmb_expr

  and core_type_x_core_type_x_location ppf (ct1, ct2, l) =
    line ppf "<constraint> %a@ " fmt_location l;
    core_type ppf ct1;
    core_type ppf ct2

  and constructor_decl ppf
      { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes; _ } =
    line ppf "%a@ " fmt_location pcd_loc;
    line ppf "%a@ " fmt_string_loc pcd_name;
    attributes ppf pcd_attributes;
    constructor_arguments ppf pcd_args;
    option core_type ppf pcd_res

  and constructor_arguments ppf = function
    | Pcstr_tuple l -> list core_type ppf l
    | Pcstr_record l -> list label_decl ppf l

  and label_decl ppf
      { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } =
    line ppf "%a@ " fmt_location pld_loc;
    attributes ppf pld_attributes;
    line ppf "%a@ " fmt_mutable_flag pld_mutable;
    line ppf "%a" fmt_string_loc pld_name;
    core_type ppf pld_type

  and longident_x_pattern ppf (li, p) =
    line ppf "%a@ " fmt_longident_loc li;
    pattern ppf p

  and case ppf { pc_lhs; pc_guard; pc_rhs } =
    line ppf "<case>@ ";
    pattern ppf pc_lhs;
    (match pc_guard with
    | None -> ()
    | Some g ->
        line ppf "<when>@ ";
        expression ppf g);
    expression ppf pc_rhs

  and value_binding ppf x =
    line ppf "<def> ";
    attributes ppf x.pvb_attributes;
    pattern ppf x.pvb_pat;
    expression ppf x.pvb_expr

  and binding_op ppf x =
    line ppf "<binding_op> %a %a" fmt_string_loc x.pbop_op
      fmt_location x.pbop_loc;
    pattern ppf x.pbop_pat;
    expression ppf x.pbop_exp

  and string_x_expression ppf (s, e) =
    line ppf "<override> %a " fmt_string_loc s;
    expression ppf e

  and longident_x_expression ppf (li, e) =
    line ppf "%a@ " fmt_longident_loc li;
    expression ppf e

  and label_x_expression ppf (l, e) =
    fprintf ppf "<arg> ";
    arg_label ppf l;
    expression ppf e

  and graph_node (name : string) ppf (l, e) =
    F.pf ppf "\"%s\"" name;
    label_x_expression ppf (l, e)

  and label_x_bool_x_core_type_list ppf x =
    match x.prf_desc with
    | Rtag (l, b, ctl) ->
        line ppf "Rtag \"%s\" %s@ " l.txt (string_of_bool b);
        attributes ppf x.prf_attributes;
        list core_type ppf ctl
    | Rinherit ct ->
        line ppf "Rinherit@ ";
        core_type ppf ct

  let rec toplevel_phrase ppf x =
    match x with
    | Ptop_def s ->
        line ppf "Ptop_def\n";
        structure ppf s
    | Ptop_dir { pdir_name; pdir_arg; _ } -> (
        line ppf "Ptop_dir \"%s\"\n" pdir_name.txt;
        match pdir_arg with
        | None -> ()
        | Some da -> directive_argument ppf da)

  and directive_argument ppf x =
    match x.pdira_desc with
    | Pdir_string s -> line ppf "Pdir_string \"%s\"\n" s
    | Pdir_int (n, None) -> line ppf "Pdir_int %s\n" n
    | Pdir_int (n, Some m) -> line ppf "Pdir_int %s%c\n" n m
    | Pdir_ident li -> line ppf "Pdir_ident %a\n" fmt_longident li
    | Pdir_bool b -> line ppf "Pdir_bool %s\n" (string_of_bool b)

  let interface = signature
  let implementation = structure
  let top_phrase = toplevel_phrase
end

let log_info pp exp = Log.info (fun m -> m "ppx_graph:@ %a" pp exp)

let graph_structure str =
  let string_constants_of =
    object
      inherit [string list] Ast_traverse.fold as super

      (* sig
         val interface : Format.formatter -> signature_item list -> unit
         val implementation : Format.formatter -> structure_item list -> unit
         val top_phrase : Format.formatter -> toplevel_phrase -> unit
         val expression : int -> Format.formatter -> expression -> unit
         val structure : int -> Format.formatter -> Parsetree.structure -> unit
         val payload : int -> Format.formatter -> payload -> unit
          end *)

      method! expression e acc =
        let acc = super#expression e acc in
        F.str "%a" Printast.expression e :: acc

      (* match e.pexp_desc with
         | Pexp_constant (Pconst_string (s, _, _)) -> s :: acc
         | Pexp_let (_, vb, exp) ->
             F.str "\"%a\" -> \"%a\""
               (F.parens
                  (F.list
                     ~sep:(fun ppf () -> F.string ppf "->")
                     (F.pair Pprintast.pattern ppPprintast.expression)))
               (List.map (fun vb -> (vb.pvb_pat, vb.pvb_expr)) vb)
               Pprintast.expression exp
             :: acc
           | _ -> acc *)

      (* method! pattern p acc =
         let acc = super#pattern p acc in
         match p.ppat_desc with
         | Ppat_constant (Pconst_string (s, _, _)) -> s :: acc
         | _ -> acc *)
    end
  in
  Log.debug (fun m ->
      m "graph_structure:@[<hov> %a@]"
        (F.list ~sep:(fun ppf () -> F.pf ppf "\n") F.string)
        (List.rev (string_constants_of#structure str [])))

let init () =
  Driver.register_transformation
    ~impl:(fun str ->
      log_info Ocaml_common.Pprintast.structure str;
      (* log_info Ocaml_common.Printast.implementation str; *)
      Ocaml_common.Clflags.locations := false;
      log_info Printast.implementation str;
      Ocaml_common.Clflags.locations := true;
      str)
    "ppx_graph"