who knows what was going on here

dune

@@ -14,6 +14,25 @@
  (libraries
    logs))
 
+(library
+ (name graphast)
+ (modes byte)
+ (kind ppx_rewriter)
+ (modules graphast)
+ (libraries
+   logs
+   ppxlib
+   fmt
+   lwt
+   ))
+
+(executable
+ (name ppx_graph)
+ (modes byte)
+ (modules ppx_graph)
+ (libraries
+ graphast))
+
 (executable
  (name boot_js)
  (modes byte js)
@@ -51,7 +70,12 @@
 (rule
  (targets embedded_fs.js)
  (action
-  (run %{bin:jsoo_fs} -I . -o %{targets} %{dep:examples.ml} %{dep:test_dynlink.js})))
+  (run %{bin:jsoo_fs}
+    ; lol hack?
+    -I .
+    -o %{targets}
+    %{dep:examples.ml}
+    %{dep:test_dynlink.js})))
 
 (rule
  (targets export.txt)
@@ -65,12 +89,17 @@
  (action
   (run
     jsoo_listunits
-    -o
-    %{targets}
+    -o %{targets}
     stdlib
     graphics
     str
     dynlink
+    dynlink
+    js_of_ocaml
+    js_of_ocaml-lwt
+    js_of_ocaml-tyxml
+    js_of_ocaml-toplevel
+    js_of_ocaml-compiler
     js_of_ocaml-compiler.runtime
     js_of_ocaml-lwt.graphics
     js_of_ocaml-ppx.as-lib
@@ -80,15 +109,11 @@
     tyxml.functor:html_types.cmi
     react
     reactiveData
-    js_of_ocaml
-    js_of_ocaml-lwt
-    js_of_ocaml-tyxml
-    js_of_ocaml-toplevel
-    dynlink)))
+    ppxlib)))
 
 (executables
  (names toplevel)
- (modules toplevel ppx_graph)
+ (modules toplevel)
  (flags
   (:standard -rectypes -linkall))
  (modes js)
@@ -97,39 +122,37 @@
    compile
    --pretty
    --Werror
-   --target-env
-   browser
-   --export
-   %{dep:export.txt}
+   --target-env browser
+   --export %{dep:export.txt}
    --toplevel
-   --disable
-   shortvar
+   --disable shortvar
    +toplevel.js
    +dynlink.js
    %{dep:embedded_fs.js}))
  (preprocess
-  (pps js_of_ocaml-ppx))
+  (pps js_of_ocaml-ppx ppxlib.metaquot))
  (libraries
-  js_of_ocaml-compiler
-  js_of_ocaml-tyxml
-  js_of_ocaml-toplevel
-  lwt
-  js_of_ocaml-lwt
-  ;; not used directly
-  graphics
-  js_of_ocaml.deriving
-  js_of_ocaml-lwt.graphics
-  js_of_ocaml-ppx.as-lib
-  compiler-libs
-  compiler-libs.common
-  compiler-libs.bytecomp
-  js_of_ocaml-compiler.runtime
-  ocp-indent.lib
-  react
-  reactiveData
-  str
-  log_js)
-)
+   fmt
+   js_of_ocaml-compiler
+   js_of_ocaml-tyxml
+   js_of_ocaml-toplevel
+   lwt
+   js_of_ocaml-lwt
+   ;; not used directly
+   graphics
+   js_of_ocaml.deriving
+   js_of_ocaml-lwt.graphics
+   js_of_ocaml-ppx.as-lib
+   compiler-libs
+   compiler-libs.common
+   compiler-libs.bytecomp
+   js_of_ocaml-compiler.runtime
+   ocp-indent.lib
+   react
+   reactiveData
+   str
+   log_js
+   ppxlib))
 
 ; (rule
 ;  (targets toplevel.js)

graphast.ml

@@ -0,0 +1,997 @@
+(* 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"

ppx_graph.ml

@@ -1,11 +0,0 @@
-open Ppxlib
-open Log_js
-
-let log_info pp exp =
-  Log.info (fun m -> m "ppx_graph: %a" pp exp);
-  exp
-
-let init () =
-  Driver.register_transformation
-    ~impl:(log_info Ocaml_common.Pprintast.structure)
-    "ppx_graph"

toplevel.ml

@@ -28,7 +28,7 @@ module Graphics_support = struct
   let init elt = Graphics_js.open_canvas elt
 end
 
-open Log_js
+module Log = Log_js.Log
 
 module Ppx_support = struct
   let init () =
@@ -618,6 +618,7 @@ let run _ =
   in
   Sys_js.set_channel_filler stdin readline;
   setup_share_button ~output;
+  Ppx_graph.setup_graph ~container ~textbox;
   setup_examples ~container ~textbox;
   setup_pseudo_fs ();
   setup_toplevel ();