diff --git a/CHANGELOG.md b/CHANGELOG.md index 85c966bbd3c..7395b6d3c88 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -77,6 +77,7 @@ #### :house: Internal +- Remove the S-expression parsetree printer (`res_parser -print sexp`). https://github.com/rescript-lang/rescript/pull/8803 - Use one set of OCaml warning flags for the whole repository, including the editor analysis and tools. https://github.com/rescript-lang/rescript/pull/8796 - Remove the unused `Packed` and `Partial_class_expr` constructors from the `.cmt` format and bump its magic number. https://github.com/rescript-lang/rescript/pull/8793 - Make `dict` an abstract type instead of a record with a hidden field. https://github.com/rescript-lang/rescript/pull/8752 diff --git a/compiler/syntax/cli/res_cli.ml b/compiler/syntax/cli/res_cli.ml index c703d35c262..da701416e81 100644 --- a/compiler/syntax/cli/res_cli.ml +++ b/compiler/syntax/cli/res_cli.ml @@ -32,15 +32,14 @@ end = struct NOT use it in production**!\n\n" ^ "Usage:\n res_parser \n\n" ^ "Examples:\n" ^ " res_parser myFile.res\n" ^ " res_parser -print ml myFile.res\n" - ^ " res_parser -print sexp -interface myFile.resi\n\n" ^ "Options are:" + ^ " res_parser -print ast -interface myFile.resi\n\n" ^ "Options are:" let spec = [ ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); ( "-print", Arg.String (fun txt -> print := txt), - "Print either ml, ast, sexp, comments, tokens, doc or res. Default: res" - ); + "Print either ml, ast, comments, tokens, doc or res. Default: res" ); ( "-width", Arg.Int (fun w -> width := w), "Specify the line length for the printer (formatter)" ); @@ -77,15 +76,14 @@ module Cli_arg_processor = struct match target with | "ml" -> Res_driver_ml_printer.print_engine | "ast" -> Res_ast_debugger.print_engine - | "sexp" -> Res_ast_debugger.sexp_print_engine | "comments" -> Res_ast_debugger.comments_print_engine | "tokens" -> Res_token_debugger.token_print_engine | "res" -> Res_driver.print_engine | "doc" -> Res_ast_debugger.doc_print_engine | target -> print_endline - ("-print needs to be either ml, ast, sexp, comments, tokens, doc or \ - res. You provided " ^ target); + ("-print needs to be either ml, ast, comments, tokens, doc or res. \ + You provided " ^ target); exit 1 in diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index abf056739fe..b41e3d7b1c1 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -1,4 +1,3 @@ -module Doc = Res_doc module Comment_table = Res_comments_table let print_engine = @@ -12,1096 +11,6 @@ let print_engine = Printast.interface Format.std_formatter signature); } -module Sexp : sig - type t - - val atom : string -> t - val list : t list -> t - val to_string : t -> string -end = struct - type t = Atom of string | List of t list - - let atom s = Atom s - let list l = List l - - let rec to_doc t = - match t with - | Atom s -> Doc.text s - | List [] -> Doc.text "()" - | List [sexpr] -> Doc.concat [Doc.lparen; to_doc sexpr; Doc.rparen] - | List (hd :: tail) -> - Doc.group - (Doc.concat - [ - Doc.lparen; - to_doc hd; - Doc.indent - (Doc.concat - [Doc.line; Doc.join ~sep:Doc.line (List.map to_doc tail)]); - Doc.rparen; - ]) - - let to_string sexpr = - let doc = to_doc sexpr in - Doc.to_string ~width:80 doc -end - -module Sexp_ast = struct - open Parsetree - - let map_empty ~f items = - match items with - | [] -> [Sexp.list []] - | items -> List.map f items - - let string txt = - Sexp.atom ("\"" ^ Ext_ident.unwrap_uppercase_exotic txt ^ "\"") - - let char c = Sexp.atom ("'" ^ Char.escaped c ^ "'") - - let opt_char oc = - match oc with - | None -> Sexp.atom "None" - | Some c -> Sexp.list [Sexp.atom "Some"; char c] - - let longident l = - let rec loop l = - match l with - | Longident.Lident ident -> Sexp.list [Sexp.atom "Lident"; string ident] - | Longident.Ldot (lident, txt) -> - Sexp.list [Sexp.atom "Ldot"; loop lident; string txt] - in - Sexp.list [Sexp.atom "longident"; loop l] - - let closed_flag flag = - match flag with - | Asttypes.Closed -> Sexp.atom "Closed" - | Open -> Sexp.atom "Open" - - let direction_flag flag = - match flag with - | Asttypes.Upto -> Sexp.atom "Upto" - | Downto -> Sexp.atom "Downto" - - let rec_flag flag = - match flag with - | Asttypes.Recursive -> Sexp.atom "Recursive" - | Nonrecursive -> Sexp.atom "Nonrecursive" - - let override_flag flag = - match flag with - | Asttypes.Override -> Sexp.atom "Override" - | Fresh -> Sexp.atom "Fresh" - - let private_flag flag = - match flag with - | Asttypes.Public -> Sexp.atom "Public" - | Private -> Sexp.atom "Private" - - let mutable_flag flag = - match flag with - | Asttypes.Immutable -> Sexp.atom "Immutable" - | Mutable -> Sexp.atom "Mutable" - - let variance v = - match v with - | Asttypes.Covariant -> Sexp.atom "Covariant" - | Contravariant -> Sexp.atom "Contravariant" - | Invariant -> Sexp.atom "Invariant" - - let arg_label_loc lbl = - match lbl with - | Asttypes.Nolabel -> Sexp.atom "Nolabel" - | Labelled {txt} -> Sexp.list [Sexp.atom "Labelled"; string txt] - | Optional {txt} -> Sexp.list [Sexp.atom "Optional"; string txt] - - let constant c = - let sexpr = - match c with - | Pconst_integer (txt, tag) -> - Sexp.list [Sexp.atom "Pconst_integer"; string txt; opt_char tag] - | Pconst_char {source; semantic} -> - Sexp.list - [ - Sexp.atom "Pconst_char"; - string source; - Sexp.atom (string_of_int semantic); - ] - | Pconst_string payload -> - Sexp.list - [ - Sexp.atom "Pconst_string"; - string (String_literal.string_source payload); - string (String_literal.string_semantic payload); - ] - | Pconst_json source -> Sexp.list [Sexp.atom "Pconst_json"; string source] - | Pconst_raw_source source -> - Sexp.list [Sexp.atom "Pconst_raw_source"; string source] - | Pconst_float (txt, tag) -> - Sexp.list [Sexp.atom "Pconst_float"; string txt; opt_char tag] - in - Sexp.list [Sexp.atom "constant"; sexpr] - - let rec structure s = - Sexp.list (Sexp.atom "structure" :: List.map structure_item s) - - and structure_item si = - let desc = - match si.pstr_desc with - | Pstr_eval (expr, attrs) -> - Sexp.list [Sexp.atom "Pstr_eval"; expression expr; attributes attrs] - | Pstr_value (flag, vbs) -> - Sexp.list - [ - Sexp.atom "Pstr_value"; - rec_flag flag; - Sexp.list (map_empty ~f:value_binding vbs); - ] - | Pstr_primitive vd -> - Sexp.list [Sexp.atom "Pstr_primitive"; value_description vd] - | Pstr_type (flag, tds) -> - Sexp.list - [ - Sexp.atom "Pstr_type"; - rec_flag flag; - Sexp.list (map_empty ~f:type_declaration tds); - ] - | Pstr_typext typext -> - Sexp.list [Sexp.atom "Pstr_type"; type_extension typext] - | Pstr_exception ec -> - Sexp.list [Sexp.atom "Pstr_exception"; extension_constructor ec] - | Pstr_module mb -> Sexp.list [Sexp.atom "Pstr_module"; module_binding mb] - | Pstr_recmodule mbs -> - Sexp.list - [ - Sexp.atom "Pstr_recmodule"; - Sexp.list (map_empty ~f:module_binding mbs); - ] - | Pstr_modtype mod_typ_decl -> - Sexp.list - [Sexp.atom "Pstr_modtype"; module_type_declaration mod_typ_decl] - | Pstr_open open_desc -> - Sexp.list [Sexp.atom "Pstr_open"; open_description open_desc] - | Pstr_include id -> - Sexp.list [Sexp.atom "Pstr_include"; include_declaration id] - | Pstr_attribute attr -> - Sexp.list [Sexp.atom "Pstr_attribute"; attribute attr] - | Pstr_extension (ext, attrs) -> - Sexp.list [Sexp.atom "Pstr_extension"; extension ext; attributes attrs] - in - Sexp.list [Sexp.atom "structure_item"; desc] - - and include_declaration id = - Sexp.list - [ - Sexp.atom "include_declaration"; - module_expression id.pincl_mod; - attributes id.pincl_attributes; - ] - - and open_description od = - Sexp.list - [ - Sexp.atom "open_description"; - longident od.popen_lid.Asttypes.txt; - attributes od.popen_attributes; - ] - - and module_type_declaration mtd = - Sexp.list - [ - Sexp.atom "module_type_declaration"; - string mtd.pmtd_name.Asttypes.txt; - (match mtd.pmtd_type with - | None -> Sexp.atom "None" - | Some mod_type -> Sexp.list [Sexp.atom "Some"; module_type mod_type]); - attributes mtd.pmtd_attributes; - ] - - and module_binding mb = - Sexp.list - [ - Sexp.atom "module_binding"; - string mb.pmb_name.Asttypes.txt; - module_expression mb.pmb_expr; - attributes mb.pmb_attributes; - ] - - and module_expression me = - let desc = - match me.pmod_desc with - | Pmod_ident mod_name -> - Sexp.list [Sexp.atom "Pmod_ident"; longident mod_name.Asttypes.txt] - | Pmod_structure s -> Sexp.list [Sexp.atom "Pmod_structure"; structure s] - | Pmod_functor (lbl, opt_mod_type, mod_expr) -> - Sexp.list - [ - Sexp.atom "Pmod_functor"; - string lbl.Asttypes.txt; - (match opt_mod_type with - | None -> Sexp.atom "None" - | Some mod_type -> - Sexp.list [Sexp.atom "Some"; module_type mod_type]); - module_expression mod_expr; - ] - | Pmod_apply (call_mod_expr, mod_expr_arg) -> - Sexp.list - [ - Sexp.atom "Pmod_apply"; - module_expression call_mod_expr; - module_expression mod_expr_arg; - ] - | Pmod_constraint (mod_expr, mod_type) -> - Sexp.list - [ - Sexp.atom "Pmod_constraint"; - module_expression mod_expr; - module_type mod_type; - ] - | Pmod_unpack expr -> Sexp.list [Sexp.atom "Pmod_unpack"; expression expr] - | Pmod_extension ext -> - Sexp.list [Sexp.atom "Pmod_extension"; extension ext] - | Pmod_await mod_expr -> - Sexp.list [Sexp.atom "Pmod_await"; module_expression mod_expr] - in - Sexp.list [Sexp.atom "module_expr"; desc; attributes me.pmod_attributes] - - and module_type mt = - let desc = - match mt.pmty_desc with - | Pmty_ident longident_loc -> - Sexp.list [Sexp.atom "Pmty_ident"; longident longident_loc.Asttypes.txt] - | Pmty_signature s -> Sexp.list [Sexp.atom "Pmty_signature"; signature s] - | Pmty_functor (lbl, opt_mod_type, mod_type) -> - Sexp.list - [ - Sexp.atom "Pmty_functor"; - string lbl.Asttypes.txt; - (match opt_mod_type with - | None -> Sexp.atom "None" - | Some mod_type -> - Sexp.list [Sexp.atom "Some"; module_type mod_type]); - module_type mod_type; - ] - | Pmty_alias longident_loc -> - Sexp.list [Sexp.atom "Pmty_alias"; longident longident_loc.Asttypes.txt] - | Pmty_extension ext -> - Sexp.list [Sexp.atom "Pmty_extension"; extension ext] - | Pmty_typeof mod_expr -> - Sexp.list [Sexp.atom "Pmty_typeof"; module_expression mod_expr] - | Pmty_with (mod_type, with_constraints) -> - Sexp.list - [ - Sexp.atom "Pmty_with"; - module_type mod_type; - Sexp.list (map_empty ~f:with_constraint with_constraints); - ] - in - Sexp.list [Sexp.atom "module_type"; desc; attributes mt.pmty_attributes] - - and with_constraint wc = - match wc with - | Pwith_type (longident_loc, td) -> - Sexp.list - [ - Sexp.atom "Pmty_with"; - longident longident_loc.Asttypes.txt; - type_declaration td; - ] - | Pwith_module (l1, l2) -> - Sexp.list - [ - Sexp.atom "Pwith_module"; - longident l1.Asttypes.txt; - longident l2.Asttypes.txt; - ] - | Pwith_typesubst (longident_loc, td) -> - Sexp.list - [ - Sexp.atom "Pwith_typesubst"; - longident longident_loc.Asttypes.txt; - type_declaration td; - ] - | Pwith_modsubst (l1, l2) -> - Sexp.list - [ - Sexp.atom "Pwith_modsubst"; - longident l1.Asttypes.txt; - longident l2.Asttypes.txt; - ] - - and signature s = - Sexp.list (Sexp.atom "signature" :: List.map signature_item s) - - and signature_item si = - let descr = - match si.psig_desc with - | Psig_value vd -> - Sexp.list [Sexp.atom "Psig_value"; value_description vd] - | Psig_type (flag, type_declarations) -> - Sexp.list - [ - Sexp.atom "Psig_type"; - rec_flag flag; - Sexp.list (map_empty ~f:type_declaration type_declarations); - ] - | Psig_typext typ_ext -> - Sexp.list [Sexp.atom "Psig_typext"; type_extension typ_ext] - | Psig_exception ext_constr -> - Sexp.list [Sexp.atom "Psig_exception"; extension_constructor ext_constr] - | Psig_module mod_decl -> - Sexp.list [Sexp.atom "Psig_module"; module_declaration mod_decl] - | Psig_recmodule mod_decls -> - Sexp.list - [ - Sexp.atom "Psig_recmodule"; - Sexp.list (map_empty ~f:module_declaration mod_decls); - ] - | Psig_modtype mod_typ_decl -> - Sexp.list - [Sexp.atom "Psig_modtype"; module_type_declaration mod_typ_decl] - | Psig_open open_desc -> - Sexp.list [Sexp.atom "Psig_open"; open_description open_desc] - | Psig_include incl_decl -> - Sexp.list [Sexp.atom "Psig_include"; include_description incl_decl] - | Psig_attribute attr -> - Sexp.list [Sexp.atom "Psig_attribute"; attribute attr] - | Psig_extension (ext, attrs) -> - Sexp.list [Sexp.atom "Psig_extension"; extension ext; attributes attrs] - in - Sexp.list [Sexp.atom "signature_item"; descr] - - and include_description id = - Sexp.list - [ - Sexp.atom "include_description"; - module_type id.pincl_mod; - attributes id.pincl_attributes; - ] - - and module_declaration md = - Sexp.list - [ - Sexp.atom "module_declaration"; - string md.pmd_name.Asttypes.txt; - module_type md.pmd_type; - attributes md.pmd_attributes; - ] - - and value_binding vb = - Sexp.list - [ - Sexp.atom "value_binding"; - pattern vb.pvb_pat; - (match vb.pvb_constraint with - | None -> Sexp.atom "None" - | Some {pvc_newtypes; pvc_type} -> - Sexp.list - [ - Sexp.atom "Some"; - Sexp.list - (map_empty - ~f:(fun ({txt} : string Asttypes.loc) -> string txt) - pvc_newtypes); - core_type pvc_type; - ]); - expression vb.pvb_expr; - attributes vb.pvb_attributes; - ] - - and value_description vd = - Sexp.list - [ - Sexp.atom "value_description"; - string vd.pval_name.Asttypes.txt; - core_type vd.pval_type; - Sexp.list - (match vd.pval_prim with - | None -> [] - | Some (Prim_name s) -> [string s] - | Some (Prim_ffi {name}) -> [string name; string ""] - | Some (Prim_inline_const _) -> [string ""]); - attributes vd.pval_attributes; - ] - - and type_declaration td = - Sexp.list - [ - Sexp.atom "type_declaration"; - string td.ptype_name.Asttypes.txt; - Sexp.list - [ - Sexp.atom "ptype_params"; - Sexp.list - (map_empty - ~f:(fun (typexpr, var) -> - Sexp.list [core_type typexpr; variance var]) - td.ptype_params); - ]; - Sexp.list - [ - Sexp.atom "ptype_cstrs"; - Sexp.list - (map_empty - ~f:(fun (typ1, typ2, _loc) -> - Sexp.list [core_type typ1; core_type typ2]) - td.ptype_cstrs); - ]; - Sexp.list [Sexp.atom "ptype_kind"; type_kind td.ptype_kind]; - Sexp.list - [ - Sexp.atom "ptype_manifest"; - (match td.ptype_manifest with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); - ]; - Sexp.list [Sexp.atom "ptype_private"; private_flag td.ptype_private]; - Sexp.list - [ - Sexp.atom "ptype_origin"; - Sexp.atom - (match td.ptype_origin with - | Declared -> "Declared" - | Inline_record_definition -> "Inline_record_definition"); - ]; - attributes td.ptype_attributes; - ] - - and extension_constructor ec = - Sexp.list - [ - Sexp.atom "extension_constructor"; - string ec.pext_name.Asttypes.txt; - extension_constructor_kind ec.pext_kind; - attributes ec.pext_attributes; - ] - - and extension_constructor_kind kind = - match kind with - | Pext_decl (args, opt_typ_expr) -> - Sexp.list - [ - Sexp.atom "Pext_decl"; - constructor_arguments args; - (match opt_typ_expr with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); - ] - | Pext_rebind longident_loc -> - Sexp.list [Sexp.atom "Pext_rebind"; longident longident_loc.Asttypes.txt] - - and type_extension te = - Sexp.list - [ - Sexp.atom "type_extension"; - Sexp.list - [Sexp.atom "ptyext_path"; longident te.ptyext_path.Asttypes.txt]; - Sexp.list - [ - Sexp.atom "ptyext_parms"; - Sexp.list - (map_empty - ~f:(fun (typexpr, var) -> - Sexp.list [core_type typexpr; variance var]) - te.ptyext_params); - ]; - Sexp.list - [ - Sexp.atom "ptyext_constructors"; - Sexp.list - (map_empty ~f:extension_constructor te.ptyext_constructors); - ]; - Sexp.list [Sexp.atom "ptyext_private"; private_flag te.ptyext_private]; - attributes te.ptyext_attributes; - ] - - and type_kind kind = - match kind with - | Ptype_abstract -> Sexp.atom "Ptype_abstract" - | Ptype_variant constr_decls -> - Sexp.list - [ - Sexp.atom "Ptype_variant"; - Sexp.list (map_empty ~f:constructor_declaration constr_decls); - ] - | Ptype_record lbl_decls -> - Sexp.list - [ - Sexp.atom "Ptype_record"; - Sexp.list (map_empty ~f:label_declaration lbl_decls); - ] - | Ptype_open -> Sexp.atom "Ptype_open" - - and constructor_declaration cd = - Sexp.list - [ - Sexp.atom "constructor_declaration"; - string cd.pcd_name.Asttypes.txt; - Sexp.list [Sexp.atom "pcd_args"; constructor_arguments cd.pcd_args]; - Sexp.list - [ - Sexp.atom "pcd_res"; - (match cd.pcd_res with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); - ]; - attributes (Ast_helper.Type.constructor_attributes cd); - ] - - and constructor_arguments args = - match args with - | Pcstr_tuple types -> - Sexp.list - [Sexp.atom "Pcstr_tuple"; Sexp.list (map_empty ~f:core_type types)] - | Pcstr_record lds -> - Sexp.list - [ - Sexp.atom "Pcstr_record"; - Sexp.list (map_empty ~f:label_declaration lds); - ] - - and label_declaration ld = - Sexp.list - [ - Sexp.atom "label_declaration"; - string ld.pld_name.Asttypes.txt; - mutable_flag ld.pld_mutable; - core_type ld.pld_type; - attributes ld.pld_attributes; - ] - - and expression expr = - let desc = - match expr.pexp_desc with - | Pexp_braces {expr = inner; braces_loc} -> - Sexp.list - [ - Sexp.atom "Pexp_braces"; - Sexp.list - [ - Sexp.atom "braces_loc"; - Sexp.atom (string_of_int braces_loc.Location.loc_start.pos_cnum); - Sexp.atom (string_of_int braces_loc.loc_end.pos_cnum); - ]; - expression inner; - ] - | Pexp_ident longident_loc -> - Sexp.list [Sexp.atom "Pexp_ident"; longident longident_loc.Asttypes.txt] - | Pexp_constant c -> Sexp.list [Sexp.atom "Pexp_constant"; constant c] - | Pexp_let (flag, vbs, expr) -> - Sexp.list - [ - Sexp.atom "Pexp_let"; - rec_flag flag; - Sexp.list (map_empty ~f:value_binding vbs); - expression expr; - ] - | Pexp_fun {newtypes; params; body} -> - Sexp.list - [ - Sexp.atom "Pexp_fun"; - Sexp.list - (map_empty - ~f:(fun ((name : string Location.loc), attrs) -> - Sexp.list - [Sexp.atom "newtype"; string name.txt; attributes attrs]) - newtypes); - Sexp.list - (map_empty - ~f:(fun {p_lbl; p_default; p_pat} -> - Sexp.list - [ - arg_label_loc p_lbl; - (match p_default with - | None -> Sexp.atom "None" - | Some expr -> - Sexp.list [Sexp.atom "Some"; expression expr]); - pattern p_pat; - ]) - params); - expression body; - ] - | Pexp_apply {funct = expr; args} -> - Sexp.list - [ - Sexp.atom "Pexp_apply"; - expression expr; - Sexp.list - (map_empty - ~f:(fun (arg_lbl, expr) -> - Sexp.list [arg_label_loc arg_lbl; expression expr]) - args); - ] - | Pexp_match (expr, cases) -> - Sexp.list - [ - Sexp.atom "Pexp_match"; - expression expr; - Sexp.list (map_empty ~f:case cases); - ] - | Pexp_try (expr, cases) -> - Sexp.list - [ - Sexp.atom "Pexp_try"; - expression expr; - Sexp.list (map_empty ~f:case cases); - ] - | Pexp_tuple exprs -> - Sexp.list - [Sexp.atom "Pexp_tuple"; Sexp.list (map_empty ~f:expression exprs)] - | Pexp_construct (longident_loc, {txt = exprs}) -> - Sexp.list - [ - Sexp.atom "Pexp_construct"; - longident longident_loc.Asttypes.txt; - Sexp.list (map_empty ~f:expression exprs); - ] - | Pexp_variant (lbl, {txt = exprs}) -> - Sexp.list - [ - Sexp.atom "Pexp_variant"; - string lbl; - Sexp.list (map_empty ~f:expression exprs); - ] - | Pexp_record (rows, opt_expr) -> - Sexp.list - [ - Sexp.atom "Pexp_record"; - Sexp.list - (map_empty - ~f:(fun {lid = longident_loc; x = expr} -> - Sexp.list - [longident longident_loc.Asttypes.txt; expression expr]) - rows); - (match opt_expr with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - ] - | Pexp_field (expr, longident_loc) -> - Sexp.list - [ - Sexp.atom "Pexp_field"; - expression expr; - longident longident_loc.Asttypes.txt; - ] - | Pexp_setfield (expr1, longident_loc, expr2) -> - Sexp.list - [ - Sexp.atom "Pexp_setfield"; - expression expr1; - longident longident_loc.Asttypes.txt; - expression expr2; - ] - | Pexp_array exprs -> - Sexp.list - [Sexp.atom "Pexp_array"; Sexp.list (map_empty ~f:expression exprs)] - | Pexp_dict entries -> - Sexp.list - [ - Sexp.atom "Pexp_dict"; - Sexp.list - (map_empty - ~f:(function - | Parsetree.Pdict_entry (key, e) -> - Sexp.list - [Sexp.atom "Pdict_entry"; string key.txt; expression e] - | Pdict_spread e -> - Sexp.list [Sexp.atom "Pdict_spread"; expression e]) - entries); - ] - | Pexp_ifthenelse (expr1, expr2, opt_expr) -> - Sexp.list - [ - Sexp.atom "Pexp_ifthenelse"; - expression expr1; - expression expr2; - (match opt_expr with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - ] - | Pexp_ternary (condition, consequent, alternate) -> - Sexp.list - [ - Sexp.atom "Pexp_ternary"; - expression condition; - expression consequent; - expression alternate; - ] - | Pexp_sequence (expr1, expr2) -> - Sexp.list - [Sexp.atom "Pexp_sequence"; expression expr1; expression expr2] - | Pexp_break -> Sexp.atom "Pexp_break" - | Pexp_continue -> Sexp.atom "Pexp_continue" - | Pexp_while (expr1, expr2) -> - Sexp.list [Sexp.atom "Pexp_while"; expression expr1; expression expr2] - | Pexp_for (pat, e1, e2, flag, e3) -> - Sexp.list - [ - Sexp.atom "Pexp_for"; - pattern pat; - expression e1; - expression e2; - direction_flag flag; - expression e3; - ] - | Pexp_for_of (pat, e1, e2) -> - Sexp.list - [Sexp.atom "Pexp_for_of"; pattern pat; expression e1; expression e2] - | Pexp_for_await_of (pat, e1, e2) -> - Sexp.list - [ - Sexp.atom "Pexp_for_await_of"; - pattern pat; - expression e1; - expression e2; - ] - | Pexp_constraint (expr, typexpr) -> - Sexp.list - [Sexp.atom "Pexp_constraint"; expression expr; core_type typexpr] - | Pexp_coerce (expr, typexpr) -> - Sexp.list [Sexp.atom "Pexp_coerce"; expression expr; core_type typexpr] - | Pexp_object_get _ -> Sexp.list [Sexp.atom "Pexp_object_get"] - | Pexp_object_set (e1, _, e2) -> - Sexp.list [Sexp.atom "Pexp_object_set"; expression e1; expression e2] - | Pexp_object_literal fields -> - Sexp.list - [ - Sexp.atom "Pexp_object_literal"; - Sexp.list - (map_empty - ~f:(fun ((s : string Asttypes.loc), e) -> - Sexp.list [Sexp.atom s.txt; expression e]) - fields); - ] - | Pexp_letmodule (mod_name, mod_expr, expr) -> - Sexp.list - [ - Sexp.atom "Pexp_letmodule"; - string mod_name.Asttypes.txt; - module_expression mod_expr; - expression expr; - ] - | Pexp_letexception (ext_constr, expr) -> - Sexp.list - [ - Sexp.atom "Pexp_letexception"; - extension_constructor ext_constr; - expression expr; - ] - | Pexp_assert expr -> Sexp.list [Sexp.atom "Pexp_assert"; expression expr] - | Pexp_pack mod_expr -> - Sexp.list [Sexp.atom "Pexp_pack"; module_expression mod_expr] - | Pexp_open (flag, longident_loc, expr) -> - Sexp.list - [ - Sexp.atom "Pexp_open"; - override_flag flag; - longident longident_loc.Asttypes.txt; - expression expr; - ] - | Pexp_extension ext -> - Sexp.list [Sexp.atom "Pexp_extension"; extension ext] - | Pexp_regexp {pattern; flags} -> - Sexp.list [Sexp.atom "Pexp_regexp"; string pattern; string flags] - | Pexp_template {source_segments; values} -> - Sexp.list - [ - Sexp.atom "Pexp_template"; - Sexp.list - (List.map (fun {Asttypes.txt} -> string txt) source_segments); - Sexp.list (List.map expression values); - ] - | Pexp_tagged_template {tag; raw_sources; values} -> - Sexp.list - [ - Sexp.atom "Pexp_tagged_template"; - expression tag; - Sexp.list (List.map (fun {Asttypes.txt} -> string txt) raw_sources); - Sexp.list (List.map expression values); - ] - | Pexp_await e -> Sexp.list [Sexp.atom "Pexp_await"; expression e] - | Pexp_jsx_element (Jsx_fragment {jsx_fragment_children = xs}) -> - Sexp.list - [ - Sexp.atom "Pexp_jsx_fragment"; Sexp.list (map_empty ~f:expression xs); - ] - | Pexp_jsx_element (Jsx_unary_element {jsx_unary_element_props = props}) - -> - Sexp.list - [ - Sexp.atom "Pexp_jsx_unary_element"; - Sexp.list (map_empty ~f:jsx_prop props); - ] - | Pexp_jsx_element - (Jsx_container_element - { - jsx_container_element_props = props; - jsx_container_element_children = xs; - }) -> - Sexp.list - [ - Sexp.atom "Pexp_jsx_container_element"; - Sexp.list (map_empty ~f:jsx_prop props); - Sexp.list (map_empty ~f:expression xs); - ] - in - Sexp.list [Sexp.atom "expression"; desc] - - and jsx_prop = function - | JSXPropPunning (_, name) -> Sexp.atom name.txt - | JSXPropValue (name, _, expr) -> - Sexp.list [Sexp.atom name.txt; expression expr] - | JSXPropSpreading (_, expr) -> expression expr - - and case c = - Sexp.list - [ - Sexp.atom "case"; - Sexp.list [Sexp.atom "pc_lhs"; pattern c.pc_lhs]; - Sexp.list - [ - Sexp.atom "pc_guard"; - (match c.pc_guard with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - ]; - Sexp.list [Sexp.atom "pc_rhs"; expression c.pc_rhs]; - ] - - and pattern p = - let descr = - match p.ppat_desc with - | Ppat_any -> Sexp.atom "Ppat_any" - | Ppat_var var -> - Sexp.list [Sexp.atom "Ppat_var"; string var.Location.txt] - | Ppat_alias (p, alias) -> - Sexp.list [Sexp.atom "Ppat_alias"; pattern p; string alias.txt] - | Ppat_constant c -> Sexp.list [Sexp.atom "Ppat_constant"; constant c] - | Ppat_interval (lo, hi) -> - Sexp.list [Sexp.atom "Ppat_interval"; constant lo; constant hi] - | Ppat_tuple patterns -> - Sexp.list - [Sexp.atom "Ppat_tuple"; Sexp.list (map_empty ~f:pattern patterns)] - | Ppat_construct (longident_loc, {txt = patterns}) -> - Sexp.list - [ - Sexp.atom "Ppat_construct"; - longident longident_loc.Location.txt; - Sexp.list (map_empty ~f:pattern patterns); - ] - | Ppat_variant (lbl, {txt = patterns}) -> - Sexp.list - [ - Sexp.atom "Ppat_variant"; - string lbl; - Sexp.list (map_empty ~f:pattern patterns); - ] - | Ppat_dict entries -> - Sexp.list - [ - Sexp.atom "Ppat_dict"; - Sexp.list - (map_empty - ~f:(fun {Parsetree.pdp_key; pdp_pattern; pdp_optional} -> - Sexp.list - [ - string pdp_key.txt; - Sexp.atom - (if pdp_optional then "optional" else "required"); - pattern pdp_pattern; - ]) - entries); - ] - | Ppat_record (rows, flag, rest) -> - Sexp.list - [ - Sexp.atom "Ppat_record"; - closed_flag flag; - Sexp.list - (map_empty - ~f:(fun {lid = longident_loc; x = p} -> - Sexp.list [longident longident_loc.Location.txt; pattern p]) - rows); - (match rest with - | None -> Sexp.atom "None" - | Some {rest_name; rest_type; _} -> - Sexp.list - [ - Sexp.atom "Some"; - Sexp.list - [ - Sexp.atom rest_name.txt; - (match rest_type with - | None -> Sexp.atom "None" - | Some type_expr -> - Sexp.list [Sexp.atom "Some"; core_type type_expr]); - ]; - ]); - ] - | Ppat_array patterns -> - Sexp.list - [Sexp.atom "Ppat_array"; Sexp.list (map_empty ~f:pattern patterns)] - | Ppat_or (p1, p2) -> - Sexp.list [Sexp.atom "Ppat_or"; pattern p1; pattern p2] - | Ppat_constraint (p, typexpr) -> - Sexp.list [Sexp.atom "Ppat_constraint"; pattern p; core_type typexpr] - | Ppat_type longident_loc -> - Sexp.list [Sexp.atom "Ppat_type"; longident longident_loc.Location.txt] - | Ppat_variant_spread longident_loc -> - Sexp.list - [ - Sexp.atom "Ppat_variant_spread"; longident longident_loc.Location.txt; - ] - | Ppat_unpack string_loc -> - Sexp.list [Sexp.atom "Ppat_unpack"; string string_loc.Location.txt] - | Ppat_exception p -> Sexp.list [Sexp.atom "Ppat_exception"; pattern p] - | Ppat_extension ext -> - Sexp.list [Sexp.atom "Ppat_extension"; extension ext] - in - Sexp.list [Sexp.atom "pattern"; descr] - - and object_field field = - match field with - | Otag (lbl_loc, attrs, typexpr) -> - Sexp.list - [ - Sexp.atom "Otag"; - string lbl_loc.txt; - attributes attrs; - core_type typexpr; - ] - | Oinherit typexpr -> Sexp.list [Sexp.atom "Oinherit"; core_type typexpr] - - and row_field field = - match field with - | Rtag (label_loc, attrs, truth, types) -> - Sexp.list - [ - Sexp.atom "Rtag"; - string label_loc.txt; - attributes attrs; - Sexp.atom (if truth then "true" else "false"); - Sexp.list - (map_empty - ~f:(fun {Location.txt = types} -> - Sexp.list (map_empty ~f:core_type types)) - types); - ] - | Rinherit typexpr -> Sexp.list [Sexp.atom "Rinherit"; core_type typexpr] - - and package_type (mod_name_loc, package_constraints) = - Sexp.list - [ - Sexp.atom "package_type"; - longident mod_name_loc.Asttypes.txt; - Sexp.list - (map_empty - ~f:(fun (mod_name_loc, typexpr) -> - Sexp.list - [longident mod_name_loc.Asttypes.txt; core_type typexpr]) - package_constraints); - ] - - and core_type typexpr = - let desc = - match typexpr.ptyp_desc with - | Ptyp_any -> Sexp.atom "Ptyp_any" - | Ptyp_var var -> Sexp.list [Sexp.atom "Ptyp_var"; string var] - | Ptyp_arrow {params; ret} -> - Sexp.list - [ - Sexp.atom "Ptyp_arrow"; - Sexp.list - (map_empty - ~f:(fun (p : Parsetree.arg) -> - Sexp.list [arg_label_loc p.lbl; core_type p.typ]) - params); - core_type ret; - ] - | Ptyp_tuple types -> - Sexp.list - [Sexp.atom "Ptyp_tuple"; Sexp.list (map_empty ~f:core_type types)] - | Ptyp_constr (longident_loc, types) -> - Sexp.list - [ - Sexp.atom "Ptyp_constr"; - longident longident_loc.txt; - Sexp.list (map_empty ~f:core_type types); - ] - | Ptyp_alias (typexpr, alias) -> - Sexp.list [Sexp.atom "Ptyp_alias"; core_type typexpr; string alias] - | Ptyp_object (fields, flag) -> - Sexp.list - [ - Sexp.atom "Ptyp_object"; - closed_flag flag; - Sexp.list (map_empty ~f:object_field fields); - ] - | Ptyp_variant (fields, flag, opt_labels) -> - Sexp.list - [ - Sexp.atom "Ptyp_variant"; - Sexp.list (map_empty ~f:row_field fields); - closed_flag flag; - (match opt_labels with - | None -> Sexp.atom "None" - | Some lbls -> Sexp.list (map_empty ~f:string lbls)); - ] - | Ptyp_poly (lbls, typexpr) -> - Sexp.list - [ - Sexp.atom "Ptyp_poly"; - Sexp.list (map_empty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); - core_type typexpr; - ] - | Ptyp_package package -> - Sexp.list [Sexp.atom "Ptyp_package"; package_type package] - | Ptyp_extension ext -> - Sexp.list [Sexp.atom "Ptyp_extension"; extension ext] - in - Sexp.list [Sexp.atom "core_type"; desc] - - and payload p = - match p with - | PStr s -> Sexp.list (Sexp.atom "PStr" :: map_empty ~f:structure_item s) - | PSig s -> Sexp.list [Sexp.atom "PSig"; signature s] - | PTyp ct -> Sexp.list [Sexp.atom "PTyp"; core_type ct] - | PPat (pat, opt_expr) -> - Sexp.list - [ - Sexp.atom "PPat"; - pattern pat; - (match opt_expr with - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr] - | None -> Sexp.atom "None"); - ] - - and attribute (string_loc, p) = - Sexp.list - [Sexp.atom "attribute"; Sexp.atom string_loc.Asttypes.txt; payload p] - - and extension (string_loc, p) = - Sexp.list - [Sexp.atom "extension"; Sexp.atom string_loc.Asttypes.txt; payload p] - - and attributes attrs = - let sexprs = map_empty ~f:attribute attrs in - Sexp.list (Sexp.atom "attributes" :: sexprs) - - let print_engine = - Res_driver. - { - print_implementation = - (fun ~width:_ ~filename:_ ~comments:_ parsetree -> - parsetree |> structure |> Sexp.to_string |> print_string); - print_interface = - (fun ~width:_ ~filename:_ ~comments:_ parsetree -> - parsetree |> signature |> Sexp.to_string |> print_string); - } -end - -let sexp_print_engine = Sexp_ast.print_engine - let comments_print_engine = { Res_driver.print_implementation = diff --git a/compiler/syntax/src/res_ast_debugger.mli b/compiler/syntax/src/res_ast_debugger.mli index beb92d8224d..5e07c6433c4 100644 --- a/compiler/syntax/src/res_ast_debugger.mli +++ b/compiler/syntax/src/res_ast_debugger.mli @@ -1,4 +1,3 @@ val print_engine : Res_driver.print_engine -val sexp_print_engine : Res_driver.print_engine val comments_print_engine : Res_driver.print_engine val doc_print_engine : Res_driver.print_engine diff --git a/scripts/test_syntax.sh b/scripts/test_syntax.sh index bacf555ffaa..c615a3b9f0a 100755 --- a/scripts/test_syntax.sh +++ b/scripts/test_syntax.sh @@ -91,9 +91,6 @@ if [[ $ROUNDTRIP_TEST = 1 ]]; then find syntax_tests/data/{idempotency,printer} -name "*.res" -o -name "*.resi" >temp/files.txt while read file; do { mkdir -p temp/$(dirname $file) - sexpAst1=temp/$file.sexp - sexpAst2=temp/$file.2.sexp - sexpAst3=temp/$file.3.sexp rescript1=temp/$file.res rescript2=temp/$file.2.res @@ -102,21 +99,11 @@ if [[ $ROUNDTRIP_TEST = 1 ]]; then *.resi ) resIntf=-interface ;; esac - # First pass: original file -> AST1 and text1 - $DUNE_BIN_DIR/res_parser $resIntf -print sexp $file > $sexpAst1 + # Format the original file, then format the result again $DUNE_BIN_DIR/res_parser $resIntf -print res $file > $rescript1 - - # Second pass: text1 -> AST2 and text2 - $DUNE_BIN_DIR/res_parser $resIntf -print sexp $rescript1 > $sexpAst2 $DUNE_BIN_DIR/res_parser $resIntf -print res $rescript1 > $rescript2 - # Third pass: text2 -> AST3 (to check idempotency after normalization) - $DUNE_BIN_DIR/res_parser $resIntf -print sexp $rescript2 > $sexpAst3 - - # Check AST idempotency: AST2 should equal AST3 (allows AST1 != AST2 for canonicalization) - diff --unified $sexpAst2 $sexpAst3 - [[ "$?" = 1 ]] && echo 1 > $roundtripTestsResult - # Check text idempotency: text1 should equal text2 + # Check idempotency: formatting the formatted text must not change it diff --unified $rescript1 $rescript2 [[ "$?" = 1 ]] && echo 1 > $roundtripTestsResult } & maybeWait