who knows what was going on here
This commit is contained in:
cqc
997
graphast.ml
Normal file
997
graphast.ml
Normal file
@ -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"
|
||||
Reference in New Issue
Block a user