diff --git a/dune b/dune index cab1f6e..7fd5a0f 100644 --- a/dune +++ b/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) diff --git a/graphast.ml b/graphast.ml new file mode 100644 index 0000000..0009b0c --- /dev/null +++ b/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 " %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 "@ "; + 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 " %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 "@ "; + pattern ppf pc_lhs; + (match pc_guard with + | None -> () + | Some g -> + line ppf "@ "; + expression ppf g); + expression ppf pc_rhs + + and value_binding ppf x = + line ppf " "; + attributes ppf x.pvb_attributes; + pattern ppf x.pvb_pat; + expression ppf x.pvb_expr + + and binding_op ppf x = + line ppf " %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 " %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_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:@[ %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" diff --git a/ppx_graph.ml b/ppx_graph.ml deleted file mode 100644 index 15e7868..0000000 --- a/ppx_graph.ml +++ /dev/null @@ -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" diff --git a/toplevel.ml b/toplevel.ml index abbadb3..316bdfd 100644 --- a/toplevel.ml +++ b/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 ();