From e5645f54d22bf7ea16c40c04b1650d0bc1c70f95 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 15 Nov 2024 12:16:54 +0100 Subject: [PATCH 1/5] Represent raw identifiers in Parsetree Most strings in the extended Parsetree are replaced by the 'ident' type, which represents the original syntax used to write the identifier. The new representation can differentiate regular identifiers from parenthesed operators (`( >>= )`), raw identifiers (`\#foo`) and constructors (`[]`, `true`). --- vendor/ocaml-common/longident.mli | 58 ------- vendor/parser-extended/ast_mapper.ml | 2 +- vendor/parser-extended/asttypes.mli | 9 +- vendor/parser-extended/lexer.mll | 21 ++- vendor/parser-extended/longident.ml | 56 ++++++ vendor/parser-extended/parser.mly | 160 ++++++++++-------- vendor/parser-extended/parsetree.mli | 52 +++--- vendor/parser-extended/printast.ml | 68 ++++---- .../longident.ml | 5 +- 9 files changed, 233 insertions(+), 198 deletions(-) delete mode 100644 vendor/ocaml-common/longident.mli create mode 100644 vendor/parser-extended/longident.ml rename vendor/{ocaml-common => parser-standard}/longident.ml (99%) diff --git a/vendor/ocaml-common/longident.mli b/vendor/ocaml-common/longident.mli deleted file mode 100644 index 8704a7780e..0000000000 --- a/vendor/ocaml-common/longident.mli +++ /dev/null @@ -1,58 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Long identifiers, used in parsetree. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - To print a longident, see {!Pprintast.longident}, using - {!Format.asprintf} to convert to a string. - -*) - -type t = - Lident of string - | Ldot of t * string - | Lapply of t * t - -val flatten: t -> string list -val unflatten: string list -> t option -(** For a non-empty list [l], [unflatten l] is [Some lid] where [lid] is - the long identifier created by concatenating the elements of [l] - with [Ldot]. - [unflatten []] is [None]. -*) - -val last: t -> string -val parse: string -> t -[@@deprecated "this function may misparse its input,\n\ -use \"Parse.longident\" or \"Longident.unflatten\""] -(** - - This function is broken on identifiers that are not just "Word.Word.word"; - for example, it returns incorrect results on infix operators - and extended module paths. - - If you want to generate long identifiers that are a list of - dot-separated identifiers, the function {!unflatten} is safer and faster. - {!unflatten} is available since OCaml 4.06.0. - - If you want to parse any identifier correctly, use the long-identifiers - functions from the {!Parse} module, in particular {!Parse.longident}. - They are available since OCaml 4.11, and also provide proper - input-location support. - -*) diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 1a41d863a8..da1dc44493 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -120,7 +120,7 @@ module FP = struct let map_param_val sub ((lab, def, p) : pparam_val) : pparam_val = (sub.arg_label sub lab, map_opt (sub.expr sub) def, sub.pat sub p) - let map_param_newtype sub (ty : string loc list) : string loc list = + let map_param_newtype sub (ty : 'a loc list) : 'a loc list = List.map (map_loc sub) ty let map_expr sub = function diff --git a/vendor/parser-extended/asttypes.mli b/vendor/parser-extended/asttypes.mli index a277629af1..2b919b3378 100644 --- a/vendor/parser-extended/asttypes.mli +++ b/vendor/parser-extended/asttypes.mli @@ -52,7 +52,8 @@ type obj_closed_flag = | OClosed | OOpen of Location.t -type label = string +type ident = string * Longident.src_kind +type label = ident type 'a loc = 'a Location.loc = { txt : 'a; @@ -61,10 +62,10 @@ type 'a loc = 'a Location.loc = { type arg_label = Nolabel - | Labelled of string loc (** [label:T -> ...] *) - | Optional of string loc (** [?label:T -> ...] *) + | Labelled of label loc (** [label:T -> ...] *) + | Optional of label loc (** [?label:T -> ...] *) -type variant_var = string loc loc (** [`A] *) +type variant_var = ident loc loc (** [`A] *) type variance_and_injectivity = string loc list diff --git a/vendor/parser-extended/lexer.mll b/vendor/parser-extended/lexer.mll index 0a97404a3f..818509ab3f 100644 --- a/vendor/parser-extended/lexer.mll +++ b/vendor/parser-extended/lexer.mll @@ -404,6 +404,7 @@ let hex_float_literal = ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )? (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? let literal_modifier = ['G'-'Z' 'g'-'z'] +let raw_ident_escape = "\\#" rule token = parse | ('\\' as bs) newline { @@ -422,25 +423,31 @@ rule token = parse | ".~" { error lexbuf (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) } + | "~" raw_ident_escape (lowercase identchar * as name) ':' + { LABEL (name, true) } | "~" (lowercase identchar * as name) ':' { check_label_name lexbuf name; - LABEL name } + LABEL (name, false) } | "~" (lowercase_latin1 identchar_latin1 * as name) ':' { warn_latin1 lexbuf; - LABEL name } + LABEL (name, false) } | "?" { QUESTION } + | "?" raw_ident_escape (lowercase identchar * as name) ':' + { OPTLABEL (name, true) } | "?" (lowercase identchar * as name) ':' { check_label_name lexbuf name; - OPTLABEL name } + OPTLABEL (name, false) } | "?" (lowercase_latin1 identchar_latin1 * as name) ':' { warn_latin1 lexbuf; - OPTLABEL name } + OPTLABEL (name, false) } + | raw_ident_escape (lowercase identchar * as name) + { LIDENT (name, true) } | lowercase identchar * as name { try Hashtbl.find keyword_table name - with Not_found -> LIDENT name } + with Not_found -> LIDENT (name, false) } | lowercase_latin1 identchar_latin1 * as name - { warn_latin1 lexbuf; LIDENT name } + { warn_latin1 lexbuf; LIDENT (name, false) } | uppercase identchar * as name { UIDENT name } (* No capitalized keywords *) | uppercase_latin1 identchar_latin1 * as name @@ -494,7 +501,7 @@ rule token = parse { CHAR (char_for_octal_code lexbuf 3, s) } | "\'" ("\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] as s) "\'" { CHAR (char_for_hexadecimal_code lexbuf 3, s) } - | "\'" ("\\" _ as esc) + | "\'" ("\\" [^ '#'] as esc) { error lexbuf (Illegal_escape (esc, None)) } | "\'\'" { error lexbuf Empty_character_literal } diff --git a/vendor/parser-extended/longident.ml b/vendor/parser-extended/longident.ml new file mode 100644 index 0000000000..637b3d6462 --- /dev/null +++ b/vendor/parser-extended/longident.ml @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type src_kind = Lnormal | Lraw | Loperator | Lconstruct + +type t = + Lident of string * src_kind + | Ldot of t * string * src_kind + | Lapply of t * t + +(* +let rec flat accu = function + Lident s -> s :: accu + | Ldot(lid, s) -> flat (s :: accu) lid + | Lapply(_, _) -> Misc.fatal_error "Longident.flat" + +let flatten lid = flat [] lid +*) + +let last = function + Lident (s, src) -> s, src + | Ldot(_, s, src) -> s, src + | Lapply(_, _) -> Misc.fatal_error "Longident.last" + +(* +let rec split_at_dots s pos = + try + let dot = String.index_from s pos '.' in + String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) + with Not_found -> + [String.sub s pos (String.length s - pos)] + +let unflatten l = + match l with + | [] -> None + | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) + +let parse s = + match unflatten (split_at_dots s 0) with + | None -> Lident "" (* should not happen, but don't put assert false + so as not to crash the toplevel (see Genprintval) *) + | Some v -> v +*) + diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 17743e39a8..cb657a6610 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -114,8 +114,10 @@ let mkrhs rhs loc = mkloc rhs (make_loc loc) let ghrhs rhs loc = mkloc rhs (ghost_loc loc) *) -let mk_optional lbl loc = Optional (mkrhs lbl loc) -let mk_labelled lbl loc = Labelled (mkrhs lbl loc) +let mkident (name, is_raw) = name, if is_raw then Lraw else Lnormal + +let mk_optional lbl loc = Optional (mkrhs (mkident lbl) loc) +let mk_labelled lbl loc = Labelled (mkrhs (mkident lbl) loc) let push_loc x acc = if x.Location.loc_ghost @@ -132,8 +134,8 @@ let reloc_typ ~loc x = { x with ptyp_loc = make_loc loc; ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack } -let mkexpvar ~loc (name : string) = - mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc)) +let mkexpvar ~loc (s, src) = + mkexp ~loc (Pexp_ident(mkrhs (Lident (s, src)) loc)) let mkoperator ~loc (name : string) = mkrhs name loc @@ -141,6 +143,9 @@ let mkoperator ~loc (name : string) = let mkpatvar ~loc name = mkpat ~loc (Ppat_var (mkrhs name loc)) +let mklident (name, src) = Lident (name, src) +let mkldot p (name, src) = Ldot (p, name, src) + (* Ghost expressions and patterns: expressions and patterns that do not appear explicitly in the @@ -316,11 +321,11 @@ let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc = let make_ghost x = { x with loc = { x.loc with loc_ghost = true }} -let loc_last (id : Longident.t Location.loc) : string Location.loc = +let loc_last (id : Longident.t Location.loc) : ident Location.loc = loc_map Longident.last id -let loc_lident (id : string Location.loc) : Longident.t Location.loc = - loc_map (fun x -> Lident x) id +let loc_lident (id : ident Location.loc) : Longident.t Location.loc = + loc_map (fun (s, src) -> Lident (s, src)) id (* let exp_of_longident lid = @@ -336,6 +341,9 @@ let pat_of_label lbl = Pat.mk ~loc:lbl.loc (Ppat_var (loc_last lbl)) *) +let ignore_label_src lbl = + loc_map fst lbl + let wrap_exp_attrs ~loc body (ext, attrs) = let ghexp = ghexp ~loc in (* todo: keep exact location for the entire attribute *) @@ -672,7 +680,7 @@ let mk_directive ~loc name arg = %token INHERIT "inherit" %token INITIALIZER "initializer" %token INT "42" (* just an example *) -%token LABEL "~label:" (* just an example *) +%token LABEL "~label:" (* just an example *) %token LAZY "lazy" %token LBRACE "{" %token LBRACELESS "{<" @@ -685,7 +693,7 @@ let mk_directive ~loc name arg = %token LESS "<" %token LESSMINUS "<-" %token LET "let" -%token LIDENT "lident" (* just an example *) +%token LIDENT "lident" (* just an example *) %token LPAREN "(" %token LBRACKETAT "[@" %token LBRACKETATAT "[@@" @@ -702,7 +710,7 @@ let mk_directive ~loc name arg = %token OBJECT "object" %token OF "of" %token OPEN "open" -%token OPTLABEL "?label:" (* just an example *) +%token OPTLABEL "?label:" (* just an example *) %token OR "or" /* %token PARSER "parser" */ %token PERCENT "%" @@ -1848,7 +1856,7 @@ module_type_subst: attrs1 = attributes virt = virtual_flag params = formal_class_parameters - id = mkrhs(LIDENT) + id = mkrhs(lident) cfb = class_fun_binding attrs2 = post_item_attributes { @@ -1864,7 +1872,7 @@ module_type_subst: attrs1 = attributes virt = virtual_flag params = formal_class_parameters - id = mkrhs(LIDENT) + id = mkrhs(lident) cfb = class_fun_binding attrs2 = post_item_attributes { @@ -1958,7 +1966,7 @@ class_self_pattern: ; class_field: | INHERIT override_flag attributes class_expr - self = preceded(AS, mkrhs(LIDENT))? + self = preceded(AS, mkrhs(lident))? post_item_attributes { let docs = symbol_docs $sloc in mkcf ~loc:$sloc (Pcf_inherit ($2, $4, self)) ~attrs:($3@$6) ~docs } @@ -2127,7 +2135,7 @@ constrain_field: attrs1 = attributes virt = virtual_flag params = formal_class_parameters - id = mkrhs(LIDENT) + id = mkrhs(lident) COLON cty = class_type attrs2 = post_item_attributes @@ -2143,7 +2151,7 @@ constrain_field: attrs1 = attributes virt = virtual_flag params = formal_class_parameters - id = mkrhs(LIDENT) + id = mkrhs(lident) COLON cty = class_type attrs2 = post_item_attributes @@ -2165,7 +2173,7 @@ class_type_declarations: attrs1 = attributes virt = virtual_flag params = formal_class_parameters - id = mkrhs(LIDENT) + id = mkrhs(lident) EQUAL csig = class_signature attrs2 = post_item_attributes @@ -2181,7 +2189,7 @@ class_type_declarations: attrs1 = attributes virt = virtual_flag params = formal_class_parameters - id = mkrhs(LIDENT) + id = mkrhs(lident) EQUAL csig = class_signature attrs2 = post_item_attributes @@ -2240,17 +2248,17 @@ seq_expr: ; labeled_simple_pattern: QUESTION LPAREN label_let_pattern opt_default RPAREN - { mk_optional (fst $3) $sloc, $4, snd $3 } + { Optional (mkrhs (fst $3) $sloc), $4, snd $3 } | QUESTION label_var - { mk_optional (fst $2) $sloc, None, snd $2 } + { Optional (mkrhs (fst $2) $sloc), None, snd $2 } | OPTLABEL LPAREN let_pattern opt_default RPAREN { mk_optional $1 $sloc, $4, $3 } | OPTLABEL pattern_var { mk_optional $1 $sloc, None, $2 } | TILDE LPAREN label_let_pattern RPAREN - { mk_labelled (fst $3) $sloc, None, snd $3 } + { Labelled (mkrhs (fst $3) $sloc), None, snd $3 } | TILDE label_var - { mk_labelled (fst $2) $sloc, None, snd $2 } + { Labelled (mkrhs (fst $2) $sloc), None, snd $2 } | LABEL simple_pattern { mk_labelled $1 $sloc, None, $2 } | simple_pattern @@ -2259,7 +2267,7 @@ labeled_simple_pattern: pattern_var: mkpat( - mkrhs(LIDENT) { Ppat_var $1 } + mkrhs(lident) { Ppat_var $1 } | UNDERSCORE { Ppat_any } ) { $1 } ; @@ -2277,7 +2285,7 @@ label_let_pattern: mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) } ; %inline label_var: - mkrhs(LIDENT) + mkrhs(lident) { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) } ; let_pattern: @@ -2447,7 +2455,7 @@ simple_expr: | BEGIN ext_attributes seq_expr END { Pexp_beginend $3, $2 } | BEGIN ext_attributes END - { Pexp_construct (mkloc (Lident "()") (make_loc $sloc), None), $2 } + { Pexp_construct (mkloc (Lident ("()", Lconstruct)) (make_loc $sloc), None), $2 } | BEGIN ext_attributes seq_expr error { unclosed "begin" $loc($1) "end" $loc($4) } | NEW ext_attributes mkrhs(class_longident) @@ -2499,7 +2507,7 @@ simple_expr: { Pexp_extension $1 } | UNDERSCORE { Pexp_hole } - | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident "()"}) + | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident ("()", Lconstruct)}) { Pexp_open(od, mkexp ~loc:($loc($3)) (Pexp_construct($3, None))) } | mod_longident DOT LPAREN seq_expr error { unclosed "(" $loc($3) ")" $loc($5) } @@ -2535,7 +2543,7 @@ simple_expr: | od=open_dot_declaration DOT LBRACKET expr_semi_list RBRACKET { let list_exp = mkexp ~loc:($startpos($3), $endpos) (Pexp_list $4) in Pexp_open(od, list_exp) } - | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"}) + | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident ("[]", Lconstruct)}) { Pexp_open(od, mkexp ~loc:$loc($3) (Pexp_construct($3, None))) } | mod_longident DOT LBRACKET expr_semi_list error @@ -2555,21 +2563,21 @@ labeled_simple_expr: { Nolabel, $1 } | LABEL simple_expr %prec below_HASH { mk_labelled $1 $sloc, $2 } - | TILDE label = LIDENT + | TILDE label = lident { let loc = $loc(label) in - mk_labelled label $sloc, mkexpvar ~loc label } - | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN - { mk_labelled label $sloc, + Labelled (mkrhs label $sloc), mkexpvar ~loc label } + | TILDE LPAREN label = lident ty = type_constraint RPAREN + { Labelled (mkrhs label $sloc), mkexp_constraint ~loc:($startpos($2), $endpos) (mkexpvar ~loc:$loc(label) label) ty } - | QUESTION label = LIDENT + | QUESTION label = lident { let loc = $loc(label) in - mk_optional label $sloc, mkexpvar ~loc label } + Optional (mkrhs label $sloc), mkexpvar ~loc label } | OPTLABEL simple_expr %prec below_HASH { mk_optional $1 $sloc, $2 } ; %inline lident_list: - xs = mkrhs(LIDENT)+ + xs = mkrhs(lident)+ { xs } ; %inline let_ident: @@ -2608,8 +2616,8 @@ let_binding_body: | let_binding_body_no_punning { let p,args,tc,e = $1 in (p,args,tc,e,false) } /* BEGIN AVOID */ - | val_ident %prec below_HASH - { (mkpatvar ~loc:$loc $1, [], None, Pfunction_body (mkexpvar ~loc:$loc $1), true) } + | mkrhs(val_ident) %prec below_HASH + { (mkpat ~loc:$loc (Ppat_var ($1)), [], None, Pfunction_body (mkexp ~loc:$loc (Pexp_ident (loc_lident $1))), true) } (* The production that allows puns is marked so that [make list-parse-errors] does not attempt to exploit it. That would be problematic because it would then generate bindings such as [let x], which are rejected by the @@ -2651,9 +2659,9 @@ letop_binding_body: pat = let_ident strict_binding(seq_expr) { let args, tc, exp = $2 in (pat, args, tc, exp, false) } - | val_ident + | mkrhs(val_ident) (* Let-punning *) - { (mkpatvar ~loc:$loc $1, [], None, (mkexpvar ~loc:$loc $1), true) } + { (mkpatvar ~loc:$loc $1.txt, [], None, (mkexp ~loc:$loc (Pexp_ident (loc_lident $1))), true) } | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr { (pat, [], Some (Pvc_constraint { locally_abstract_univars = []; typ }), exp, false) } | pat = pattern_no_exn EQUAL exp = seq_expr @@ -2911,9 +2919,9 @@ simple_pattern_not_ident: { Ppat_type ($2) } | mkrhs(mod_longident) DOT simple_delimited_pattern { Ppat_open($1, $3) } - | mkrhs(mod_longident) DOT mkrhs(LBRACKET RBRACKET {Lident "[]"}) + | mkrhs(mod_longident) DOT mkrhs(LBRACKET RBRACKET {Lident ("[]", Lconstruct)}) { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) } - | mkrhs(mod_longident) DOT mkrhs(LPAREN RPAREN {Lident "()"}) + | mkrhs(mod_longident) DOT mkrhs(LPAREN RPAREN {Lident ("()", Lconstruct)}) { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) } | mkrhs(mod_longident) DOT LPAREN pattern RPAREN { Ppat_open ($1, $4) } @@ -3061,7 +3069,7 @@ generic_type_declaration(flag, kind): attrs1 = attributes flag = flag params = type_parameters - id = mkrhs(LIDENT) + id = mkrhs(lident) kind_priv_manifest = kind cstrs = constraints attrs2 = post_item_attributes @@ -3078,7 +3086,7 @@ generic_type_declaration(flag, kind): AND attrs1 = attributes params = type_parameters - id = mkrhs(LIDENT) + id = mkrhs(lident) kind_priv_manifest = kind cstrs = constraints attrs2 = post_item_attributes @@ -3466,7 +3474,7 @@ function_type: ; %inline arg_label: | label = optlabel - { mk_optional label $sloc } + { Optional (mkrhs label $sloc) } | label = LIDENT COLON { mk_labelled label $sloc } | /* empty */ @@ -3690,8 +3698,14 @@ meth_list: { Of.inherit_ ~loc:(make_loc $sloc) ty } ; +%inline lident: + LIDENT { mkident $1 } +; +%inline uident: + UIDENT { ($1, Lconstruct) } +; %inline label: - LIDENT { $1 } + lident { $1 } ; /* Constants */ @@ -3721,17 +3735,17 @@ signed_constant: /* Identifiers and long identifiers */ ident: - UIDENT { $1 } - | LIDENT { $1 } + uident { $1 } + | lident { $1 } ; val_extra_ident: - | LPAREN operator RPAREN { $2 } + | LPAREN operator RPAREN { ($2, Loperator) } | LPAREN operator error { unclosed "(" $loc($1) ")" $loc($3) } | LPAREN error { expecting $loc($2) "operator" } | LPAREN MODULE error { expecting $loc($3) "module-expr" } ; val_ident: - LIDENT { $1 } + lident { $1 } | val_extra_ident { $1 } ; operator: @@ -3777,47 +3791,49 @@ index_mod: ; %inline constr_extra_ident: - | LPAREN COLONCOLON RPAREN { "::" } + | LPAREN COLONCOLON RPAREN { ("::", Loperator) } ; constr_extra_nonprefix_ident: - | LBRACKET RBRACKET { "[]" } - | LPAREN RPAREN { "()" } - | FALSE { "false" } - | TRUE { "true" } + | LBRACKET RBRACKET { ("[]", Lconstruct) } + | LPAREN RPAREN { ("()", Lconstruct) } + | FALSE { ("false", Lconstruct) } + | TRUE { ("true", Lconstruct) } ; constr_ident: - UIDENT { $1 } + uident { $1 } | constr_extra_ident { $1 } | constr_extra_nonprefix_ident { $1 } ; constr_longident: mod_longident %prec below_DOT { $1 } /* A.B.x vs (A).B.x */ - | mod_longident DOT constr_extra_ident { Ldot($1,$3) } - | constr_extra_ident { Lident $1 } - | constr_extra_nonprefix_ident { Lident $1 } + | mod_longident DOT constr_extra_ident { mkldot $1 $3 } + | constr_extra_ident { mklident $1 } + | constr_extra_nonprefix_ident { mklident $1 } ; mk_longident(prefix,final): - | final { Lident $1 } - | prefix DOT final { Ldot($1,$3) } + | final { mklident $1 } + | prefix DOT final { mkldot $1 $3 } ; val_longident: mk_longident(mod_longident, val_ident) { $1 } ; label_longident: - mk_longident(mod_longident, LIDENT) { $1 } + mk_longident(mod_longident, lident) { $1 } ; type_longident: - mk_longident(mod_ext_longident, LIDENT) { $1 } + mk_longident(mod_ext_longident, lident) { $1 } (* Allow identifiers like [t/42]. *) - | LIDENT SLASH TYPE_DISAMBIGUATOR { Lident ($1 ^ "/" ^ $3) } + | LIDENT SLASH TYPE_DISAMBIGUATOR + { let name, src = mkident $1 in + Lident (name ^ "/" ^ $3, src) } ; mod_longident: - mk_longident(mod_longident, UIDENT) { $1 } + mk_longident(mod_longident, uident) { $1 } ; mod_ext_longident_: - UIDENT { Lident $1 } - | UIDENT SLASH TYPE_DISAMBIGUATOR { Lident ($1 ^ "/" ^ $3) } - | mod_ext_longident DOT UIDENT { Ldot($1,$3) } + uident { mklident $1 } + | UIDENT SLASH TYPE_DISAMBIGUATOR { Lident ($1 ^ "/" ^ $3, Lconstruct) } + | mod_ext_longident DOT UIDENT { Ldot($1,$3,Lconstruct) } ; mod_ext_longident: mod_ext_longident_ { $1 } @@ -3830,10 +3846,10 @@ mty_longident: mk_longident(mod_ext_longident,ident) { $1 } ; clty_longident: - mk_longident(mod_ext_longident,LIDENT) { $1 } + mk_longident(mod_ext_longident,lident) { $1 } ; class_longident: - mk_longident(mod_longident,LIDENT) { $1 } + mk_longident(mod_longident,lident) { $1 } ; /* BEGIN AVOID */ @@ -3844,7 +3860,7 @@ any_longident: | mk_longident (mod_ext_longident, ident | constr_extra_ident | val_extra_ident { $1 } ) { $1 } - | constr_extra_nonprefix_ident { Lident $1 } + | constr_extra_nonprefix_ident { mklident $1 } ; /* END AVOID */ @@ -3853,7 +3869,7 @@ any_longident: toplevel_directive: HASH dir = mkrhs(ident) arg = ioption(mk_directive_arg(toplevel_directive_argument)) - { mk_directive ~loc:$sloc dir arg } + { mk_directive ~loc:$sloc (ignore_label_src dir) arg } ; %inline toplevel_directive_argument: @@ -3976,14 +3992,14 @@ additive: | PLUSDOT { "+." } ; optlabel: - | OPTLABEL { $1 } - | QUESTION LIDENT COLON { $2 } + | OPTLABEL { mkident $1 } + | QUESTION lident COLON { $2 } ; /* Attributes and extensions */ single_attr_id: - LIDENT { $1 } + LIDENT { fst $1 } | UIDENT { $1 } | AND { "and" } | AS { "as" } diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index e19ef81c47..b8dc4e47d6 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -107,7 +107,7 @@ and arrow_param = and core_type_desc = | Ptyp_any (** [_] *) - | Ptyp_var of string (** A type variable such as ['a] *) + | Ptyp_var of ident (** A type variable such as ['a] *) | Ptyp_arrow of arrow_param list * core_type (** [Ptyp_arrow(lbl, T1, T2)] represents: - [T1 -> T2] when [lbl] is @@ -142,7 +142,7 @@ and core_type_desc = - [T #tconstr] when [l=[T]], - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. *) - | Ptyp_alias of core_type * string loc (** [T as 'a]. *) + | Ptyp_alias of core_type * ident loc (** [T as 'a]. *) | Ptyp_variant of row_field list * closed_flag * variant_var list option (** [Ptyp_variant([`A;`B], flag, labels)] represents: - [[ `A|`B ]] @@ -158,7 +158,7 @@ and core_type_desc = when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, and [labels] is [Some ["X";"Y"]]. *) - | Ptyp_poly of string loc list * core_type + | Ptyp_poly of ident loc list * core_type (** ['a1 ... 'an. T] Can only appear in the following context: @@ -217,7 +217,7 @@ and object_field = { } and object_field_desc = - | Otag of label loc * core_type + | Otag of ident loc * core_type | Oinherit of core_type (** {2 Patterns} *) @@ -232,8 +232,8 @@ and pattern = and pattern_desc = | Ppat_any (** The pattern [_]. *) - | Ppat_var of string loc (** A variable pattern such as [x] *) - | Ppat_alias of pattern * string loc + | Ppat_var of ident loc (** A variable pattern such as [x] *) + | Ppat_alias of pattern * ident loc (** An alias pattern such as [P as 'a] *) | Ppat_constant of constant (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) @@ -247,7 +247,7 @@ and pattern_desc = Invariant: [n >= 2] *) - | Ppat_construct of Longident.t loc * (string loc list * pattern) option + | Ppat_construct of Longident.t loc * (ident loc list * pattern) option (** [Ppat_construct(C, args)] represents: - [C] when [args] is [None], - [C P] when [args] is [Some ([], P)] @@ -394,10 +394,10 @@ and expression_desc = - [(E :> T)] when [from] is [None], - [(E : T0 :> T)] when [from] is [Some T0]. *) - | Pexp_send of expression * label loc (** [E # m] *) + | Pexp_send of expression * ident loc (** [E # m] *) | Pexp_new of Longident.t loc (** [new M.c] *) - | Pexp_setinstvar of label loc * expression (** [x <- 2] *) - | Pexp_override of (label loc * expression) list + | Pexp_setinstvar of ident loc * expression (** [x <- 2] *) + | Pexp_override of (ident loc * expression) list (** [{< x1 = E1; ...; xn = En >}] *) | Pexp_letmodule of string option loc * functor_parameter loc list * module_expr * expression (** [let module M = ME in E] *) @@ -505,7 +505,7 @@ and function_param_desc = Note: If [E0] is provided, only {{!Asttypes.arg_label.Optional}[Optional]} is allowed. *) - | Pparam_newtype of string loc list + | Pparam_newtype of ident loc list (** [Pparam_newtype x] represents the parameter [(type x)]. [x] carries the location of the identifier, whereas the [pparam_loc] on the enclosing [function_param] node is the location of the [(type x)] @@ -554,7 +554,7 @@ and type_constraint = and value_description = { - pval_name: string loc; + pval_name: ident loc; pval_type: core_type; pval_prim: string loc list; pval_attributes: ext_attrs; (** [... [\@\@id1] [\@\@id2]] *) @@ -571,7 +571,7 @@ and value_description = and type_declaration = { - ptype_name: string loc; + ptype_name: ident loc; ptype_params: (core_type * variance_and_injectivity) list; (** [('a1,...'an) t] *) ptype_cstrs: (core_type * core_type * Location.t) list; @@ -616,7 +616,7 @@ and type_kind = and label_declaration = { - pld_name: string loc; + pld_name: ident loc; pld_mutable: mutable_flag; pld_type: core_type; pld_loc: Location.t; @@ -635,8 +635,8 @@ and label_declaration = and constructor_declaration = { - pcd_name: string loc; - pcd_vars: string loc list; + pcd_name: ident loc; + pcd_vars: ident loc list; pcd_args: constructor_arguments; pcd_res: core_type option; pcd_loc: Location.t; @@ -676,7 +676,7 @@ and type_extension = and extension_constructor = { - pext_name: string loc; + pext_name: ident loc; pext_kind: extension_constructor_kind; pext_loc: Location.t; pext_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) @@ -691,7 +691,7 @@ and type_exception = (** Definition of a new exception ([exception E]). *) and extension_constructor_kind = - | Pext_decl of string loc list * constructor_arguments * core_type option + | Pext_decl of ident loc list * constructor_arguments * core_type option (** [Pext_decl(existentials, c_args, t_opt)] describes a new extension constructor. It can be: - [C of T1 * ... * Tn] when: @@ -760,9 +760,9 @@ and class_type_field = and class_type_field_desc = | Pctf_inherit of class_type (** [inherit CT] *) - | Pctf_val of (label loc * mutable_virtual * core_type) + | Pctf_val of (ident loc * mutable_virtual * core_type) (** [val x: T] *) - | Pctf_method of (label loc * private_virtual * core_type) + | Pctf_method of (ident loc * private_virtual * core_type) (** [method x: T] *) | Pctf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) | Pctf_attribute of attribute (** [[\@\@\@id]] *) @@ -772,7 +772,7 @@ and 'a class_infos = { pci_virt: virtual_flag; pci_params: (core_type * variance_and_injectivity) list; - pci_name: string loc; + pci_name: ident loc; pci_args: class_function_param list; pci_constraint: class_type option; pci_expr: 'a; @@ -849,7 +849,7 @@ and class_field = } and class_field_desc = - | Pcf_inherit of override_flag * class_expr * string loc option + | Pcf_inherit of override_flag * class_expr * ident loc option (** [Pcf_inherit(flag, CE, s)] represents: - [inherit CE] when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} @@ -864,14 +864,14 @@ and class_field_desc = when [flag] is {{!Asttypes.override_flag.Override}[Override]} and [s] is [Some x] *) - | Pcf_val of (label loc * mutable_virtual * class_field_value_kind) + | Pcf_val of (ident loc * mutable_virtual * class_field_value_kind) (** [Pcf_val(x,flag, kind)] represents: - [val x = E] - [val virtual x: T] - [val mutable x = E] - [val mutable virtual x: T] *) - | Pcf_method of (label loc * private_virtual * class_field_method_kind) + | Pcf_method of (ident loc * private_virtual * class_field_method_kind) (** - [method x = E] - [method virtual x: T] *) @@ -975,7 +975,7 @@ and module_substitution = and module_type_declaration = { - pmtd_name: string loc; + pmtd_name: ident loc; pmtd_type: module_type option; pmtd_ext_attrs : ext_attrs; pmtd_loc: Location.t; @@ -1106,7 +1106,7 @@ and structure_item_desc = and value_constraint = | Pvc_constraint of { - locally_abstract_univars:string loc list; + locally_abstract_univars:ident loc list; typ:core_type; } | Pvc_coercion of {ground:core_type option; coercion:core_type } diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index c2814ff22f..500ee21f09 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -71,10 +71,19 @@ let fmt_location f loc = fmt_cmts i f " after" a ) end +let fmt_label f (s, src) = + match src with + | Longident.Lraw -> fprintf f "\\#%s" s + | Loperator -> fprintf f "( %s )" s + | Lnormal | Lconstruct -> fprintf f "%s" s + +let fmt_label_loc f (x : label loc) = + fprintf f "\"%a\" %a" fmt_label x.txt fmt_location x.loc + 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.Lident (s, src) -> fmt_label f (s, src) + | Longident.Ldot (y, s, src) -> fprintf f "%a.%a" fmt_longident_aux y fmt_label (s, src) | Longident.Lapply (y, z) -> fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z @@ -175,12 +184,13 @@ let option i f ppf x = f (i+1) ppf x let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li +let label_loc i ppf l = line i ppf "%a\n" fmt_label_loc l let string i ppf s = line i ppf "\"%s\"\n" s let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s let arg_label i ppf = function | Nolabel -> line i ppf "Nolabel\n" - | Optional s -> line i ppf "Optional %a\n" fmt_string_loc s - | Labelled s -> line i ppf "Labelled %a\n" fmt_string_loc s + | Optional s -> line i ppf "Optional %a\n" fmt_label_loc s + | Labelled s -> line i ppf "Labelled %a\n" fmt_label_loc s let paren_kind i ppf = function | Paren -> line i ppf "Paren\n" @@ -189,11 +199,11 @@ let paren_kind i ppf = function let typevars ppf vs = List.iter (fun x -> - fprintf ppf " %a %a" Pprintast.tyvar x.txt fmt_location x.loc) vs + fprintf ppf " %a %a" Pprintast.tyvar (fst x.txt) fmt_location x.loc) vs let variant_var i ppf (x : variant_var) = line i ppf "variant_var %a\n" fmt_location x.loc; - string_loc (i+1) ppf x.txt + label_loc (i+1) ppf x.txt let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ptyp_loc; @@ -201,7 +211,7 @@ let rec core_type i ppf x = let i = i+1 in match x.ptyp_desc with | Ptyp_any -> line i ppf "Ptyp_any\n"; - | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ptyp_var (s) -> line i ppf "Ptyp_var %a\n" fmt_label s; | Ptyp_arrow (params, ct2) -> line i ppf "Ptyp_arrow\n"; list i arrow_param ppf params; @@ -223,7 +233,7 @@ let rec core_type i ppf x = line i ppf "Ptyp_class %a\n" fmt_longident_loc li; list i core_type ppf l | Ptyp_alias (ct, s) -> - line i ppf "Ptyp_alias \"%a\"\n" fmt_string_loc s; + line i ppf "Ptyp_alias \"%a\"\n" fmt_label_loc s; core_type i ppf ct; | Ptyp_poly (sl, ct) -> line i ppf "Ptyp_poly%a\n" typevars sl; @@ -249,7 +259,7 @@ and object_field i ppf x = let i = i+1 in match x.pof_desc with | Otag (l, t) -> - line i ppf "Otag %a\n" fmt_string_loc l; + line i ppf "Otag %a\n" fmt_label_loc l; core_type i ppf t | Oinherit ct -> line i ppf "Oinherit\n"; @@ -270,9 +280,9 @@ and pattern i ppf x = let i = i+1 in match x.ppat_desc with | Ppat_any -> line i ppf "Ppat_any\n"; - | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s; + | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_label_loc s; | Ppat_alias (p, s) -> - line i ppf "Ppat_alias %a\n" fmt_string_loc s; + line i ppf "Ppat_alias %a\n" fmt_label_loc s; pattern i ppf p; | Ppat_constant (c) -> line i ppf "Ppat_constant\n"; @@ -288,7 +298,7 @@ and pattern i ppf x = line i ppf "Ppat_construct %a\n" fmt_longident_loc li; option i (fun i ppf (vl, p) -> - list i string_loc ppf vl; + list i label_loc ppf vl; pattern i ppf p) ppf po | Ppat_variant (l, po) -> @@ -425,11 +435,11 @@ and expression i ppf x = option i core_type ppf cto1; core_type i ppf cto2; | Pexp_send (e, s) -> - line i ppf "Pexp_send %a\n" fmt_string_loc s; + line i ppf "Pexp_send %a\n" fmt_label_loc s; expression i ppf e; | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; | Pexp_setinstvar (s, e) -> - line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; + line i ppf "Pexp_setinstvar %a\n" fmt_label_loc s; expression i ppf e; | Pexp_override (l) -> line i ppf "Pexp_override\n"; @@ -524,7 +534,7 @@ and expr_function_param i ppf { pparam_desc = desc; pparam_loc = loc } = | Pparam_val p -> pparam_val i ppf ~loc p | Pparam_newtype tys -> List.iter (fun ty -> - line i ppf "Pparam_newtype \"%s\" %a\n" ty.txt fmt_location loc) + line i ppf "Pparam_newtype \"%a\" %a\n" fmt_label ty.txt fmt_location loc) tys and class_function_param i ppf { pparam_desc = desc; pparam_loc = loc } = @@ -551,7 +561,7 @@ and type_constraint i ppf constraint_ = core_type (i+1) ppf ty2 and value_description i ppf x = - line i ppf "value_description %a %a\n" fmt_string_loc + line i ppf "value_description %a %a\n" fmt_label_loc x.pval_name fmt_location x.pval_loc; ext_attrs i ppf x.pval_attributes; core_type (i+1) ppf x.pval_type; @@ -560,7 +570,7 @@ and value_description i ppf x = and type_parameter i ppf (x, _variance) = core_type i ppf x and type_declaration i ppf x = - line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name + line i ppf "type_declaration %a %a\n" fmt_label_loc x.ptype_name fmt_location x.ptype_loc; ext_attrs i ppf x.ptype_attributes; let i = i+1 in @@ -641,7 +651,7 @@ and extension_constructor i ppf x = line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; attributes i ppf x.pext_attributes; let i = i + 1 in - line i ppf "pext_name = %a\n" fmt_string_loc x.pext_name; + line i ppf "pext_name = %a\n" fmt_label_loc x.pext_name; line i ppf "pext_kind =\n"; extension_constructor_kind (i + 1) ppf x.pext_kind; @@ -693,11 +703,11 @@ and class_type_field i ppf x = line i ppf "Pctf_inherit\n"; class_type i ppf ct; | Pctf_val (s, mv, ct) -> - line i ppf "Pctf_val %a %a\n" fmt_string_loc s + line i ppf "Pctf_val %a %a\n" fmt_label_loc s fmt_mutable_virtual_flag mv; core_type (i+1) ppf ct; | Pctf_method (s, pv, ct) -> - line i ppf "Pctf_method %a %a\n" fmt_string_loc s + line i ppf "Pctf_method %a %a\n" fmt_label_loc s fmt_private_virtual_flag pv; core_type (i+1) ppf ct; | Pctf_constraint (ct1, ct2) -> @@ -718,7 +728,7 @@ and class_infos : 'a. _ -> (_ -> _ -> 'a -> _) -> _ -> _ -> 'a class_infos -> _ line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; list (i+1) type_parameter ppf x.pci_params; - line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_name = %a\n" fmt_label_loc x.pci_name; line i ppf "pci_args =\n"; list (i+1) class_function_param ppf x.pci_args; line i ppf "pci_constraint = %a\n" (fmt_opt (class_type i)) x.pci_constraint; @@ -778,14 +788,14 @@ and class_field i ppf x = | Pcf_inherit (ovf, ce, so) -> line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf; class_expr (i+1) ppf ce; - option (i+1) string_loc ppf so; + option (i+1) label_loc ppf so; | Pcf_val (s, mf, k) -> line i ppf "Pcf_val %a\n" fmt_mutable_virtual_flag mf; - line (i+1) ppf "%a\n" fmt_string_loc s; + line (i+1) ppf "%a\n" fmt_label_loc s; class_field_value_kind (i+1) ppf k | Pcf_method (s, pf, k) -> line i ppf "Pcf_method %a\n" fmt_private_virtual_flag pf; - line (i+1) ppf "%a\n" fmt_string_loc s; + line (i+1) ppf "%a\n" fmt_label_loc s; class_field_method_kind (i+1) ppf k | Pcf_constraint (ct1, ct2) -> line i ppf "Pcf_constraint\n"; @@ -1033,7 +1043,7 @@ and structure_item i ppf x = attribute i ppf "Pstr_attribute" a and module_type_declaration i ppf x = - line i ppf "module_type_declaration %a %a\n" fmt_string_loc x.pmtd_name + line i ppf "module_type_declaration %a %a\n" fmt_label_loc x.pmtd_name fmt_location x.pmtd_loc; ext_attrs i ppf x.pmtd_ext_attrs; modtype_declaration (i+1) ppf x.pmtd_type @@ -1060,7 +1070,7 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = and constructor_decl i ppf {pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes} = line i ppf "%a\n" fmt_location pcd_loc; - line (i+1) ppf "%a\n" fmt_string_loc pcd_name; + line (i+1) ppf "%a\n" fmt_label_loc pcd_name; if pcd_vars <> [] then line (i+1) ppf "pcd_vars =%a\n" typevars pcd_vars; attributes i ppf pcd_attributes; constructor_arguments (i+1) ppf pcd_args; @@ -1074,7 +1084,7 @@ and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= line i ppf "%a\n" fmt_location pld_loc; attributes i ppf pld_attributes; line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; - line (i+1) ppf "%a" fmt_string_loc pld_name; + line (i+1) ppf "%a" fmt_label_loc pld_name; core_type (i+1) ppf pld_type and longident_x_pattern i ppf (li, t, p) = @@ -1103,7 +1113,7 @@ and value_binding i ppf x = and value_constraint i ppf x = let pp_sep ppf () = Format.fprintf ppf "@ "; in - let pp_newtypes = Format.pp_print_list fmt_string_loc ~pp_sep in + let pp_newtypes = Format.pp_print_list fmt_label_loc ~pp_sep in match x with | Pvc_constraint { locally_abstract_univars = []; typ } -> core_type i ppf typ @@ -1146,7 +1156,7 @@ and binding_op i ppf x = expression (i+1) ppf x.pbop_exp; and string_x_expression i ppf (s, e) = - line i ppf " %a\n" fmt_string_loc s; + line i ppf " %a\n" fmt_label_loc s; expression (i+1) ppf e; and longident_x_expression i ppf (li, c, e) = diff --git a/vendor/ocaml-common/longident.ml b/vendor/parser-standard/longident.ml similarity index 99% rename from vendor/ocaml-common/longident.ml rename to vendor/parser-standard/longident.ml index eaafb02bee..c1cf11de9f 100644 --- a/vendor/ocaml-common/longident.ml +++ b/vendor/parser-standard/longident.ml @@ -18,19 +18,21 @@ type t = | Ldot of t * string | Lapply of t * t +(* let rec flat accu = function Lident s -> s :: accu | Ldot(lid, s) -> flat (s :: accu) lid | Lapply(_, _) -> Misc.fatal_error "Longident.flat" let flatten lid = flat [] lid +*) let last = function Lident s -> s | Ldot(_, s) -> s | Lapply(_, _) -> Misc.fatal_error "Longident.last" - +(* let rec split_at_dots s pos = try let dot = String.index_from s pos '.' in @@ -48,3 +50,4 @@ let parse s = | None -> Lident "" (* should not happen, but don't put assert false so as not to crash the toplevel (see Genprintval) *) | Some v -> v +*) From 4daebebfd4bd943e4ee9ce26b89324513af6c280 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 18 Nov 2024 11:07:05 +0100 Subject: [PATCH 2/5] Update Fmt_ast to new label representation This is mostly a type-directed refactoring. --- lib/Ast.ml | 13 +-- lib/Cmts.ml | 10 ++- lib/Extended_ast.ml | 14 +-- lib/Fmt_ast.ml | 192 ++++++++++++++++++++++-------------------- lib/Migrate_ast.ml | 8 -- lib/Migrate_ast.mli | 7 -- lib/Std_longident.ml | 16 +++- lib/Std_longident.mli | 4 +- lib/Sugar.mli | 2 +- 9 files changed, 140 insertions(+), 126 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 3d7731a20e..4bb56c2509 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -60,8 +60,8 @@ let longident_fit_margin (c : Conf.t) x = x * 3 < c.fmt_opts.margin.v * 2 let longident_is_simple c x = let rec length x = match x with - | Longident.Lident x -> String.length x - | Ldot (x, y) -> length x + 1 + String.length y + | Longident.Lident (x, _) -> String.length x + | Ldot (x, y, _) -> length x + 1 + String.length y | Lapply (x, y) -> length x + length y + 3 in longident_fit_margin c (length x) @@ -156,7 +156,8 @@ module Exp = struct | Pexp_construct (_, exp) -> Option.for_all exp ~f:is_trivial | Pexp_prefix (_, e) -> is_trivial e | Pexp_apply - ({pexp_desc= Pexp_ident {txt= Lident "not"; _}; _}, [(_, e1)]) -> + ({pexp_desc= Pexp_ident {txt= Lident ("not", _); _}; _}, [(_, e1)]) + -> is_trivial e1 | Pexp_variant (_, None) -> true | Pexp_array [] | Pexp_list [] -> true @@ -1618,7 +1619,8 @@ end = struct | Pexp_cons l -> Some (ColonColon, if exp == List.last_exn l then Right else Left) | Pexp_construct - ({txt= Lident "[]"; _}, Some {pexp_desc= Pexp_tuple [_; _]; _}) -> + ( {txt= Lident ("[]", Lconstruct); _} + , Some {pexp_desc= Pexp_tuple [_; _]; _} ) -> Some (Semi, Non) | Pexp_array _ | Pexp_list _ -> Some (Semi, Non) | Pexp_construct (_, Some _) @@ -2287,7 +2289,8 @@ end = struct true | ( Exp {pexp_desc= Pexp_infix (_, _, e1); _} , { pexp_desc= - Pexp_apply ({pexp_desc= Pexp_ident {txt= Lident "not"; _}; _}, _) + Pexp_apply + ({pexp_desc= Pexp_ident {txt= Lident ("not", _); _}; _}, _) ; _ } ) when not (e1 == exp) -> true diff --git a/lib/Cmts.ml b/lib/Cmts.ml index 820851ac14..ce54f459b1 100644 --- a/lib/Cmts.ml +++ b/lib/Cmts.ml @@ -26,10 +26,14 @@ module Layout_cache = struct let pattern_to_string e = Format.asprintf "%a" Printast.pattern e - let sexp_of_arg_label = function + let sexp_of_arg_label = + let sexp_of_label cstr lb = + Sexp.List [Atom cstr; sexp_of_string (fst lb.Location.txt)] + in + function | Asttypes.Nolabel -> Sexp.Atom "Nolabel" - | Labelled label -> List [Atom "Labelled"; sexp_of_string label.txt] - | Optional label -> List [Atom "Optional"; sexp_of_string label.txt] + | Labelled label -> sexp_of_label "Labelled" label + | Optional label -> sexp_of_label "Optional" label let sexp_of_t = function | Arg (label, expression) -> diff --git a/lib/Extended_ast.ml b/lib/Extended_ast.ml index 9a9172a112..3ce2ab0ebc 100644 --- a/lib/Extended_ast.ml +++ b/lib/Extended_ast.ml @@ -133,7 +133,7 @@ module Parse = struct match (t, v) with (* [{ x = x }] -> [{ x }] *) | _, Some {ppat_desc= Ppat_var {txt= v_txt; _}; ppat_attributes= []; _} - when Std_longident.field_alias ~field:f.txt (Lident v_txt) -> + when Std_longident.field_alias_label ~field:f.txt v_txt -> (f, t, None) (* [{ x = (x : t) }] -> [{ x : t}] *) | ( None @@ -147,7 +147,7 @@ module Parse = struct ; ppat_attributes= [] ; _ } ) when enable_short_field_annot - && Std_longident.field_alias ~field:f.txt (Lident v_txt) -> + && Std_longident.field_alias_label ~field:f.txt v_txt -> (f, Some t, None) | _ -> (f, t, Option.map ~f:(m.pat m) v) in @@ -163,7 +163,9 @@ module Parse = struct | {ppat_desc= Ppat_cons (_ :: _ :: _ :: _ as l); _} as p when match List.last_exn l with (* Empty lists are always represented as Lident [] *) - | { ppat_desc= Ppat_construct ({txt= Lident "[]"; loc= _}, None) + | { ppat_desc= + Ppat_construct + ({txt= Lident ("[]", Lconstruct); loc= _}, None) ; ppat_attributes= [] ; _ } -> true @@ -187,7 +189,9 @@ module Parse = struct | {pexp_desc= Pexp_cons (_ :: _ :: _ :: _ as l); _} as e when match List.last_exn l with (* Empty lists are always represented as Lident [] *) - | { pexp_desc= Pexp_construct ({txt= Lident "[]"; loc= _}, None) + | { pexp_desc= + Pexp_construct + ({txt= Lident ("[]", Lconstruct); loc= _}, None) ; pexp_attributes= [] ; _ } -> true @@ -208,7 +212,7 @@ module Parse = struct | { pexp_desc= Pexp_apply ( { pexp_desc= - Pexp_ident {txt= Lident op as longident; loc= loc_op} + Pexp_ident {txt= Lident (op, _) as longident; loc= loc_op} ; pexp_attributes= [] ; _ } , [(Nolabel, l); (Nolabel, r)] ) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f7b8d7008f..cbc2d7a1fa 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -239,16 +239,17 @@ let fmt_recmodule c ctx items fmt_item ast sub = (* In several places, a break such as [Fmt.force_break] is used to force the enclosing box to break across multiple lines. *) +let fmt_ident (s, src) = + match src with + | Longident.Lnormal | Lconstruct -> str s + | Lraw -> str "\\#" $ str s + | Loperator -> str "( " $ str s $ str " )" + let rec fmt_longident (li : Longident.t) = - let fmt_id id = - wrap_if - (Std_longident.String_id.is_symbol id) - (str "( ") (str " )") (str id) - in match li with - | Lident id -> fmt_id id - | Ldot (li, id) -> - hvbox 0 (fmt_longident li $ cut_break $ str "." $ fmt_id id) + | Lident (s, src) -> fmt_ident (s, src) + | Ldot (li, s, src) -> + hvbox 0 (fmt_longident li $ cut_break $ str "." $ fmt_ident (s, src)) | Lapply (li1, li2) -> hvbox 2 ( fmt_longident li1 @@ -262,11 +263,14 @@ let str_longident x = let fmt_str_loc c ?pre {txt; loc} = Cmts.fmt c loc (opt pre str $ str txt) -let fmt_str_loc_opt c ?pre ?(default = "_") {txt; loc} = - Cmts.fmt c loc (opt pre str $ str (Option.value ~default txt)) +let fmt_ident_loc c {txt; loc} = Cmts.fmt c loc (fmt_ident txt) + +let fmt_module_name_str_opt c ?pre ?(default = "_") {txt; loc} = + let s = match txt with Some s -> str s | None -> str default in + Cmts.fmt c loc (opt pre str $ s) let variant_var c ({txt= x; loc} : variant_var) = - Cmts.fmt c loc @@ (str "`" $ fmt_str_loc c x) + Cmts.fmt c loc @@ (str "`" $ fmt_ident_loc c x) let fmt_constant c ?epi {pconst_desc; pconst_loc= loc} = Cmts.fmt c loc @@ -362,8 +366,8 @@ let fmt_label lbl sep = (* No comment can be attached here. *) match lbl with | Nolabel -> noop - | Labelled l -> str "~" $ str l.txt $ sep - | Optional l -> str "?" $ str l.txt $ sep + | Labelled l -> str "~" $ fmt_ident l.txt $ sep + | Optional l -> str "?" $ fmt_ident l.txt $ sep let fmt_direction_flag = function | Upto -> space_break $ str "to " @@ -572,12 +576,15 @@ let fmt_quoted_string c key ext s maybe_delim = in Format_.sprintf "{%s%s|%s|%s}" key ext_and_delim s delim -let fmt_type_var s = - str "'" +let fmt_type_var lb = (* [' a'] is a valid type variable, the space is required to not lex as a char. https://github.com/ocaml/ocaml/pull/2034 *) - $ fmt_if (String.length s > 1 && Char.equal s.[1] '\'') (str " ") - $ str s + let space = + match lb with + | s, Longident.Lnormal -> String.length s > 1 && Char.equal s.[1] '\'' + | _ -> false + in + str "'" $ fmt_if space (str " ") $ fmt_ident lb let rec fmt_extension_aux c ctx ~key (ext, pld) = match (ext.txt, pld, ctx) with @@ -791,8 +798,8 @@ and fmt_arrow_param c ctx {pap_label= lI; pap_loc= locI; pap_type= tI} = let arg_label lbl = match lbl with | Nolabel -> None - | Labelled l -> Some (str l.txt $ str ":" $ cut_break) - | Optional l -> Some (str "?" $ str l.txt $ str ":" $ cut_break) + | Labelled l -> Some (fmt_ident l.txt $ str ":" $ cut_break) + | Optional l -> Some (str "?" $ fmt_ident l.txt $ str ":" $ cut_break) in let xtI = sub_typ ~ctx tI in let arg = @@ -1011,7 +1018,7 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx | `Loose | `Tight_decl -> true | `Tight -> false in - fmt_str_loc c lab_loc + fmt_ident_loc c lab_loc $ fmt_if field_loose (str " ") $ str ":" $ space_break $ fmt_core_type c (sub_typ ~ctx typ) @@ -1114,12 +1121,8 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) @@ match ppat_desc with | Ppat_any -> str "_" - | Ppat_var {txt; loc} -> - Cmts.fmt c loc - @@ wrap_if - (Std_longident.String_id.is_symbol txt) - (str "( ") (str " )") (str txt) - | Ppat_alias (pat, {txt; loc}) -> + | Ppat_var lb -> fmt_ident_loc c lb + | Ppat_alias (pat, lb) -> let paren_pat = match pat.ppat_desc with | Ppat_or _ | Ppat_tuple _ -> Some true @@ -1129,11 +1132,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) (wrap_fits_breaks_if ~space:false c.conf parens "(" ")" (hovbox 0 ( fmt_pattern c ?parens:paren_pat (sub_pat ~ctx pat) - $ space_break $ str "as" $ space_break - $ Cmts.fmt c loc - (wrap_if - (Std_longident.String_id.is_symbol txt) - (str "( ") (str " )") (str txt) ) ) ) ) + $ space_break $ str "as" $ space_break $ fmt_ident_loc c lb ) ) ) | Ppat_constant const -> fmt_constant c const | Ppat_interval (l, u) -> fmt_constant c l $ str " .. " $ fmt_constant c u | Ppat_tuple pats -> @@ -1143,7 +1142,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) hvbox 0 (Params.wrap_tuple ~parens ~no_parens_if_break:false c.conf (List.map pats ~f:(sub_pat ~ctx >> fmt_pattern c)) ) - | Ppat_construct ({txt= Lident (("()" | "[]") as txt); loc}, None) -> + | Ppat_construct ({txt= Lident ((("()" | "[]") as txt), _); loc}, None) -> let opn = txt.[0] and cls = txt.[1] in Cmts.fmt c loc (hvbox 0 @@ -1165,7 +1164,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) hvbox 0 (Params.parens c.conf ( str "type " - $ list names space_break (fmt_str_loc c) ) ) + $ list names space_break (fmt_ident_loc c) ) ) $ space_break ) $ fmt_pattern c (sub_pat ~ctx pat) ) ) ) | Ppat_variant (lbl, None) -> variant_var c lbl @@ -1314,7 +1313,8 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) fmt_constraint_opt pt ( str "module" $ fmt_extension_suffix c ext - $ char ' ' $ fmt_str_loc_opt c name ) + $ char ' ' + $ fmt_module_name_str_opt c name ) | Ppat_exception pat -> cbox 2 (Params.parens_if parens c.conf @@ -1340,7 +1340,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) | Ppat_array _ | Ppat_list _ | Ppat_record _ -> true | Ppat_tuple _ -> Poly.(c.conf.fmt_opts.parens_tuple_patterns.v = `Always) - | Ppat_construct ({txt= Lident "[]"; _}, None) -> true + | Ppat_construct ({txt= Lident ("[]", Lconstruct); _}, None) -> true | _ -> false in let opn, cls = if can_skip_parens then (".", "") else (".(", ")") in @@ -1359,7 +1359,7 @@ and fmt_param_val c ctx : pparam_val -> _ = function , _ ) ) ; ppat_attributes= [] ; _ } as pat ) ) - when String.equal l.txt txt -> + when Poly.equal l.txt txt -> let symbol = match lbl with Labelled _ -> "~" | _ -> "?" in let xpat = sub_pat ~ctx pat in cbox 0 (str symbol $ fmt_pattern ~box:true c xpat) @@ -1385,7 +1385,7 @@ and fmt_param_val c ctx : pparam_val -> _ = function | ( Optional l , Some exp , ({ppat_desc= Ppat_var {txt; loc= _}; ppat_attributes= []; _} as pat) ) - when String.equal l.txt txt -> + when Poly.equal l.txt txt -> let xexp = sub_exp ~ctx exp in let xpat = sub_pat ~ctx pat in cbox 0 @@ -1399,7 +1399,7 @@ and fmt_param_val c ctx : pparam_val -> _ = function Ppat_constraint ({ppat_desc= Ppat_var {txt; loc= _}; _}, _) ; ppat_attributes= [] ; _ } as pat ) ) - when String.equal l.txt txt -> + when Poly.equal l.txt txt -> let xexp = sub_exp ~ctx exp in let xpat = sub_pat ~ctx pat in cbox 0 @@ -1415,7 +1415,7 @@ and fmt_param_val c ctx : pparam_val -> _ = function | _ -> Some false in cbox 2 - ( str "?" $ str l.txt + ( str "?" $ fmt_ident l.txt $ wrap (str ":" $ cut_break $ str "(") (str ")") @@ -1428,7 +1428,7 @@ and fmt_param_newtype c = function | names -> cbox 0 (Params.parens c.conf - (str "type " $ list names space_break (fmt_str_loc c)) ) + (str "type " $ list names space_break (fmt_ident_loc c)) ) and fmt_expr_fun_arg c fp = let ctx = Fpe fp in @@ -1637,14 +1637,19 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0 box (disambiguate_parens_wrap body) $ Cmts.fmt_after c loc and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = + let is_pun_label {txt= lb, lb_src; _} ident ident_src = + String.equal lb ident + && Poly.equal lb_src ident_src + && List.is_empty arg.pexp_attributes + in match (lbl, arg.pexp_desc) with - | (Labelled l | Optional l), Pexp_ident {txt= Lident i; loc} - when String.equal l.txt i && List.is_empty arg.pexp_attributes -> + | (Labelled l | Optional l), Pexp_ident {txt= Lident (i, isrc); loc} + when is_pun_label l i isrc -> Cmts.fmt c loc @@ Cmts.fmt c ?eol arg.pexp_loc @@ fmt_label lbl noop | ( (Labelled l | Optional l) - , Pexp_constraint ({pexp_desc= Pexp_ident {txt= Lident i; _}; _}, _) ) - when String.equal l.txt i - && List.is_empty arg.pexp_attributes + , Pexp_constraint + ({pexp_desc= Pexp_ident {txt= Lident (i, isrc); _}; _}, _) ) + when is_pun_label l i isrc && Ocaml_version.( compare c.conf.opr_opts.ocaml_version.v Releases.v4_14_0 >= 0 ) -> @@ -2293,7 +2298,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ space_break $ str ": " $ fmt_core_type c (sub_typ ~ctx t) ) $ fmt_atrs ) ) - | Pexp_construct ({txt= Lident (("()" | "[]") as txt); loc}, None) -> + | Pexp_construct + ({txt= Lident ((("()" | "[]") as txt), Lconstruct); loc}, None) -> let opn = char txt.[0] and cls = char txt.[1] in pro $ Cmts.fmt c loc @@ -2470,8 +2476,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (parens || not (List.is_empty pexp_attributes)) c.conf ( hvbox 2 - (fmt_module c ctx keyword ~eqty:":" name args (Some xbody) - xmty + (fmt_module c ctx keyword ~eqty:":" (`Str name) args + (Some xbody) xmty ~attrs:(Ast_helper.Attr.ext_attrs ?ext ()) ~epi:(str "in") ~can_sparse ~rec_flag:false ) $ force_break @@ -2487,7 +2493,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens when List.is_empty e0.pexp_attributes -> true | Pexp_tuple _ -> Poly.(c.conf.fmt_opts.parens_tuple.v = `Always) - | Pexp_construct ({txt= Lident "[]"; _}, None) -> true + | Pexp_construct ({txt= Lident ("[]", Lconstruct); _}, None) -> true | _ -> false in let outer_parens = has_attr && parens in @@ -2826,7 +2832,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ hvbox 2 (Params.parens_if parens c.conf ( fmt_expression c (sub_exp ~ctx exp) - $ cut_break $ str "#" $ fmt_str_loc c meth $ fmt_atrs ) ) + $ cut_break $ str "#" $ fmt_ident_loc c meth $ fmt_atrs ) ) | Pexp_new {txt; loc} -> pro $ Cmts.fmt c loc @@ -2843,15 +2849,17 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_atrs ) ) | Pexp_override l -> ( let fmt_field ({txt; loc}, f) = + let is_field = function + | Longident.Lident (x, _) -> String.equal (fst txt) x + | _ -> false + in let eol = break 1 3 in - let txt = Longident.lident txt in match f.pexp_desc with | Pexp_ident {txt= txt'; loc} - when Std_longident.field_alias ~field:txt txt' - && List.is_empty f.pexp_attributes -> + when is_field txt' && List.is_empty f.pexp_attributes -> Cmts.fmt c ~eol loc @@ fmt_longident txt' | _ -> - Cmts.fmt c ~eol loc @@ fmt_longident txt + Cmts.fmt c ~eol loc @@ fmt_ident txt $ str " = " $ fmt_expression c (sub_exp ~ctx f) in @@ -2873,7 +2881,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ hvbox 0 (Params.Exp.wrap c.conf ~parens ( Params.parens_if has_attr c.conf - ( fmt_str_loc c name $ fmt_assign_arrow c + ( fmt_ident_loc c name $ fmt_assign_arrow c $ hvbox 2 (fmt_expression c (sub_exp ~ctx expr)) ) $ fmt_atrs ) ) | Pexp_indexop_access x -> @@ -3156,7 +3164,7 @@ and fmt_class_field c {ast= cf; _} = $ fmt_if (is_override override) (str "!") $ space_break $ ( fmt_class_expr c (sub_cl ~ctx cl) - $ opt parent (fun p -> str " as " $ fmt_str_loc c p) ) ) + $ opt parent (fun p -> str " as " $ fmt_ident_loc c p) ) ) | Pcf_method (name, pv, kind) -> let typ, eq, expr = fmt_class_field_method_kind c ctx kind in hvbox 2 @@ -3168,7 +3176,7 @@ and fmt_class_field c {ast= cf; _} = (Params.Indent.fun_type_annot c.conf) ( str "method" $ virtual_or_override kind $ fmt_private_virtual_flag c pv - $ str " " $ fmt_str_loc c name $ typ ) ) ) + $ str " " $ fmt_ident_loc c name $ typ ) ) ) $ eq ) $ expr ) | Pcf_val (name, mv, kind) -> @@ -3180,7 +3188,7 @@ and fmt_class_field c {ast= cf; _} = (box_fun_sig_args c 4 ( str "val" $ virtual_or_override kind $ fmt_mutable_virtual_flag c mv - $ str " " $ fmt_str_loc c name $ typ ) ) ) + $ str " " $ fmt_ident_loc c name $ typ ) ) ) $ eq ) $ expr ) | Pcf_constraint (t1, t2) -> @@ -3218,7 +3226,7 @@ and fmt_class_type_field c {ast= cf; _} = ( hovbox 4 ( str "method" $ fmt_private_virtual_flag c pv - $ space_break $ fmt_str_loc c name ) + $ space_break $ fmt_ident_loc c name ) $ str " :" $ space_break $ fmt_core_type c (sub_typ ~ctx ty) ) | Pctf_val (name, mv, ty) -> @@ -3226,7 +3234,7 @@ and fmt_class_type_field c {ast= cf; _} = ( hovbox 4 ( str "val" $ fmt_mutable_virtual_flag c mv - $ space_break $ fmt_str_loc c name ) + $ space_break $ fmt_ident_loc c name ) $ str " :" $ space_break $ fmt_core_type c (sub_typ ~ctx ty) ) | Pctf_constraint (t1, t2) -> @@ -3271,10 +3279,7 @@ and fmt_case c ctx ~first ~last case = $ p.close_paren_branch ) ) and fmt_value_description c ctx vd = - let {pval_name= {txt; loc}; pval_type; pval_prim; pval_attributes; pval_loc} - = - vd - in + let {pval_name; pval_type; pval_prim; pval_attributes; pval_loc} = vd in update_config_maybe_disabled_attrs c pval_loc pval_attributes @@ fun c -> let pre = if List.is_empty pval_prim then "val" else "external" in @@ -3295,11 +3300,7 @@ and fmt_value_description c ctx vd = ( str pre $ fmt_extension_suffix c ext $ fmt_attributes c ~pre:(Break (1, 0)) attrs_before - $ str " " - $ Cmts.fmt c loc - (wrap_if - (Std_longident.String_id.is_symbol txt) - (str "( ") (str " )") (str txt) ) + $ str " " $ fmt_ident_loc c pval_name $ fmt_core_type c ~pro:":" ~box: (not @@ -3385,8 +3386,8 @@ and fmt_type_declaration c ?(pre = "") ?name ?(eq = "=") {ast= decl; _} = (not (List.is_empty ptype_params)) 0 ( fmt_tydcl_params c ctx ptype_params - $ Option.value_map name ~default:(str txt) ~f:(fmt_longident_loc c) - ) + $ Option.value_map name ~default:(fmt_ident txt) + ~f:(fmt_longident_loc c) ) $ k ) in let fmt_manifest_kind = @@ -3467,7 +3468,7 @@ and fmt_label_declaration c ctx ?(last = false) decl = ( hovbox 2 ( fmt_mutable_flag ~pro:noop ~epi:space_break c pld_mutable - $ fmt_str_loc c pld_name + $ fmt_ident_loc c pld_name $ fmt_if field_loose (str " ") $ str ":" ) $ space_break @@ -3504,10 +3505,7 @@ and fmt_constructor_declaration c ctx ~first ~last:_ cstr_decl = $ Cmts.fmt_before c loc $ hvbox 2 ( hovbox ~name:"constructor_decl_name" 2 - ( wrap_if - (Std_longident.String_id.is_symbol txt) - (str "( ") (str " )") (str txt) - $ Cmts.fmt_after c loc ) + (fmt_ident txt $ Cmts.fmt_after c loc) $ fmt_constructor_arguments_result c ctx pcd_vars pcd_args pcd_res ) ) $ fmt_attributes_and_docstrings c pcd_attributes ) @@ -3643,7 +3641,7 @@ and fmt_extension_constructor c ctx ec = Cmts.fmt c pext_loc @@ hvbox 4 ( hvbox 2 - ( fmt_str_loc c pext_name + ( fmt_ident_loc c pext_name $ match pext_kind with | Pext_decl (_, (Pcstr_tuple [] | Pcstr_record (_, [])), None) -> @@ -3665,7 +3663,8 @@ and fmt_functor_param c ctx {loc; txt= arg} = (Cmts.fmt c loc (wrap (str "(") (str ")") (hovbox 0 - ( hovbox 0 (fmt_str_loc_opt c name $ space_break $ str ": ") + ( hovbox 0 + (fmt_module_name_str_opt c name $ space_break $ str ": ") $ compose_module (fmt_module_type c xmt) ~f:Fn.id ) ) ) ) and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) = @@ -3887,7 +3886,8 @@ and fmt_class_types c ~pre ~sep cls = $ fmt_virtual_flag c cl.pci_virt $ space_break $ fmt_class_params c ctx cl.pci_params - $ fmt_str_loc c cl.pci_name $ str " " $ str sep ) + $ fmt_ident_loc c cl.pci_name + $ str " " $ str sep ) $ space_break in hovbox 2 @@ -3920,7 +3920,7 @@ and fmt_class_exprs c cls = $ fmt_virtual_flag c cl.pci_virt $ space_break $ fmt_class_params c ctx cl.pci_params - $ fmt_str_loc c cl.pci_name ) + $ fmt_ident_loc c cl.pci_name ) $ fmt_if (not (List.is_empty xargs)) space_break $ wrap_fun_decl_args c (fmt_class_fun_args c xargs) ) in @@ -3965,7 +3965,9 @@ and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=") hovbox 1 ( pro $ Cmts.fmt_before c ~epi:space_break loc - $ str "(" $ align_opn $ fmt_str_loc_opt c name $ str " :" ) + $ str "(" $ align_opn + $ fmt_module_name_str_opt c name + $ str " :" ) $ fmt_or (Option.is_some blk.pro) (str " ") (break 1 2) and epi = str ")" $ Cmts.fmt_after c loc $ align_cls in compose_module' ~box:false ~pro ~epi blk @@ -4003,13 +4005,21 @@ and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=") fmt_docstring_around_item_attrs c ~force_before:(not single_line) ~fit:true attrs in + let name = + let fmt_name fmt_txt {txt; loc} = + Cmts.fmt c loc (Option.value_map txt ~f:fmt_txt ~default:(str "_")) + in + match name with + | `Str n -> fmt_name str n + | `Ident n -> fmt_name fmt_ident n + in let intro = hvbox 2 ( str keyword $ fmt_extension_suffix c ext $ fmt_attributes c ~pre:(Break (1, 0)) attrs_before $ fmt_if rec_flag (str " rec") - $ space_break $ fmt_str_loc_opt c name ) + $ space_break $ name ) in let compact = Poly.(c.conf.fmt_opts.let_module.v = `Compact) || not can_sparse @@ -4059,8 +4069,8 @@ and fmt_module_declaration c ~rec_flag ~first {ast= pmd; _} = match xmty.ast.pmty_desc with Pmty_alias _ -> None | _ -> Some ":" in Cmts.fmt c pmd_loc - (fmt_module ~rec_:rec_flag c ctx keyword pmd_name pmd_args None ?eqty - (Some xmty) ~rec_flag:(rec_flag && first) ~attrs ) + (fmt_module ~rec_:rec_flag c ctx keyword (`Str pmd_name) pmd_args None + ?eqty (Some xmty) ~rec_flag:(rec_flag && first) ~attrs ) and fmt_module_substitution c ctx pms = let {pms_name; pms_manifest; pms_ext_attrs= attrs; pms_loc} = pms in @@ -4073,7 +4083,7 @@ and fmt_module_substitution c ctx pms = ; pmty_loc= pms_loc ; pmty_attributes= [] } in - let pms_name = {pms_name with txt= Some pms_name.txt} in + let pms_name = `Str {pms_name with txt= Some pms_name.txt} in Cmts.fmt c pms_loc (fmt_module c ctx "module" ~eqty:":=" pms_name [] None (Some xmty) ~attrs ~rec_flag:false ) @@ -4082,7 +4092,7 @@ and fmt_module_type_declaration ?eqty c ctx pmtd = let {pmtd_name; pmtd_type; pmtd_ext_attrs= attrs; pmtd_loc} = pmtd in update_config_maybe_disabled_attrs c pmtd_loc attrs @@ fun c -> - let pmtd_name = {pmtd_name with txt= Some pmtd_name.txt} in + let pmtd_name = `Ident {pmtd_name with txt= Some pmtd_name.txt} in fmt_module ?eqty c ctx "module type" pmtd_name [] None ~rec_flag:false (Option.map pmtd_type ~f:(sub_mty ~ctx)) ~attrs @@ -4147,13 +4157,13 @@ and fmt_with_constraint c ctx ~pre = function str pre $ str " module " $ fmt_longident_loc c m1 $ str " := " $ fmt_longident_loc c m2 | Pwith_modtype (m1, m2) -> - let m1 = {m1 with txt= Some (str_longident m1.txt)} in + let m1 = `Str {m1 with txt= Some (str_longident m1.txt)} in let m2 = Some (sub_mty ~ctx m2) in str pre $ break 1 2 $ fmt_module c ctx "module type" m1 [] None ~rec_flag:false m2 ~attrs:Ast_helper.Attr.empty_ext_attrs | Pwith_modtypesubst (m1, m2) -> - let m1 = {m1 with txt= Some (str_longident m1.txt)} in + let m1 = `Str {m1 with txt= Some (str_longident m1.txt)} in let m2 = Some (sub_mty ~ctx m2) in str pre $ break 1 2 $ fmt_module c ctx ~eqty:":=" "module type" m1 [] None ~rec_flag:false @@ -4530,14 +4540,14 @@ and fmt_value_constraint c vc_opt = , fmt_constraint_sep c ":" $ hvbox 0 ( str "type " - $ list pvars (str " ") (fmt_str_loc c) + $ list pvars (str " ") (fmt_ident_loc c) $ str "." $ space_break $ fmt_core_type c (sub_typ ~ctx typ) ) ) | `After -> ( fmt_constraint_sep c ":" $ hvbox 0 ( str "type " - $ list pvars (str " ") (fmt_str_loc c) + $ list pvars (str " ") (fmt_ident_loc c) $ str "." ) , space_break $ fmt_core_type c (sub_typ ~ctx typ) ) ) | Pvc_coercion {ground; coercion} -> @@ -4683,7 +4693,7 @@ and fmt_module_binding c ~rec_flag ~first {ast= pmb; _} = in Cmts.fmt c pmb.pmb_loc (fmt_module ~rec_:rec_flag c ctx keyword ~rec_flag:(rec_flag && first) - ~eqty:":" pmb_name pmb.pmb_args (Some xbody) xmty ~attrs ) + ~eqty:":" (`Str pmb_name) pmb.pmb_args (Some xbody) xmty ~attrs ) let fmt_toplevel_directive c ~semisemi dir = let fmt_dir_arg = function diff --git a/lib/Migrate_ast.ml b/lib/Migrate_ast.ml index cd09bf4508..276fbbc958 100644 --- a/lib/Migrate_ast.ml +++ b/lib/Migrate_ast.ml @@ -128,11 +128,3 @@ module Location = struct in (c + String.length (String.strip s) + 1, mkloc (String.strip s) loc) ) end - -module Longident = struct - include Longident - - let lident s = - assert (not (String.contains s '.')) ; - Lident s -end diff --git a/lib/Migrate_ast.mli b/lib/Migrate_ast.mli index 14049f7de2..97e330122c 100644 --- a/lib/Migrate_ast.mli +++ b/lib/Migrate_ast.mli @@ -78,10 +78,3 @@ module Location : sig val of_lines : filename:string -> string list -> string loc list end - -module Longident : sig - include module type of Longident - - val lident : string -> t - (** Make a Lident from a dotless string *) -end diff --git a/lib/Std_longident.ml b/lib/Std_longident.ml index d0981058f2..fe338b4119 100644 --- a/lib/Std_longident.ml +++ b/lib/Std_longident.ml @@ -87,7 +87,7 @@ module String_id = struct let is_symbol i = is_prefix i || is_infix i || is_index_op i end -let test ~f = function Longident.Lident i -> f i | _ -> false +let test ~f = function Longident.Lident (i, _) -> f i | _ -> false let is_prefix = test ~f:String_id.is_prefix @@ -97,15 +97,23 @@ let is_infix = test ~f:String_id.is_infix let is_hash_getter = test ~f:String_id.is_hash_getter -let is_index_op i = Longident.last i |> String_id.is_index_op +let is_index_op i = + let s, _ = Longident.last i in + String_id.is_index_op s let is_symbol i = is_prefix i || is_infix i || is_index_op i let field_alias_str ~field y = match field with - | Ldot (_, x) | Lident x -> String.equal x y + | Ldot (_, x, _) | Lident (x, _) -> String.equal x y + | Lapply _ -> false + +let field_alias_label ~field (y, ysrc) = + match field with + | Ldot (_, x, xsrc) | Lident (x, xsrc) -> + String.equal x y && Poly.equal xsrc ysrc | Lapply _ -> false let field_alias ~field = function - | Lident x -> field_alias_str ~field x + | Lident (x, src) -> field_alias_label ~field (x, src) | Ldot _ | Lapply _ -> false diff --git a/lib/Std_longident.mli b/lib/Std_longident.mli index 2d650f3f7e..d703fa6d0e 100644 --- a/lib/Std_longident.mli +++ b/lib/Std_longident.mli @@ -35,8 +35,6 @@ val is_infix : Longident.t -> bool val is_prefix : Longident.t -> bool -val is_index_op : Longident.t -> bool - val is_symbol : Longident.t -> bool val is_hash_getter : Longident.t -> bool @@ -51,4 +49,6 @@ val is_monadic_binding : Longident.t -> bool val field_alias_str : field:Longident.t -> string -> bool +val field_alias_label : field:Longident.t -> Asttypes.label -> bool + val field_alias : field:Longident.t -> Longident.t -> bool diff --git a/lib/Sugar.mli b/lib/Sugar.mli index 577b8626e2..86eeaed29c 100644 --- a/lib/Sugar.mli +++ b/lib/Sugar.mli @@ -25,7 +25,7 @@ module Exp : sig end val sequence : - Cmts.t -> expression Ast.xt -> (label loc option * expression Ast.xt) list + Cmts.t -> expression Ast.xt -> (string loc option * expression Ast.xt) list (** [sequence cmts exp] returns the list of expressions (with the optional extension) from a sequence of expressions [exp]. *) From c70f8e4a2b7b394d03c24e348185b231b4fc2675 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 18 Nov 2024 17:30:41 +0100 Subject: [PATCH 3/5] test: Add raw_identifier from https://github.com/ocaml-ppx/ocamlformat/pull/2619 --- test/passing/gen/dune.inc | 15 ++ .../refs.default/raw_identifiers.ml.ref | 152 ++++++++++++++ .../refs.janestreet/raw_identifiers.ml.ref | 159 +++++++++++++++ .../refs.ocamlformat/raw_identifiers.ml.ref | 186 ++++++++++++++++++ test/passing/tests/raw_identifiers.ml | 167 ++++++++++++++++ 5 files changed, 679 insertions(+) create mode 100644 test/passing/refs.default/raw_identifiers.ml.ref create mode 100644 test/passing/refs.janestreet/raw_identifiers.ml.ref create mode 100644 test/passing/refs.ocamlformat/raw_identifiers.ml.ref create mode 100644 test/passing/tests/raw_identifiers.ml diff --git a/test/passing/gen/dune.inc b/test/passing/gen/dune.inc index fe9469a4ae..e78aeaea66 100644 --- a/test/passing/gen/dune.inc +++ b/test/passing/gen/dune.inc @@ -3832,6 +3832,21 @@ (alias runtest) (action (diff quoted_strings.ml.err quoted_strings.ml.stderr))) +(rule + (deps .ocamlformat dune-project) + (action + (with-stdout-to raw_identifiers.ml.stdout + (with-stderr-to raw_identifiers.ml.stderr + (run %{bin:ocamlformat} --name raw_identifiers.ml --margin-check %{dep:../tests/raw_identifiers.ml}))))) + +(rule + (alias runtest) + (action (diff raw_identifiers.ml.ref raw_identifiers.ml.stdout))) + +(rule + (alias runtest) + (action (diff raw_identifiers.ml.err raw_identifiers.ml.stderr))) + (rule (deps .ocamlformat dune-project) (action diff --git a/test/passing/refs.default/raw_identifiers.ml.ref b/test/passing/refs.default/raw_identifiers.ml.ref new file mode 100644 index 0000000000..089dd01349 --- /dev/null +++ b/test/passing/refs.default/raw_identifiers.ml.ref @@ -0,0 +1,152 @@ +module M : sig + class \#and : object + val mutable \#and : int + method \#and : int + end +end = struct + class \#and = + let \#and = 1 in + object + val mutable \#and = \#and + method \#and = 2 + end +end + +let obj = new M.\#and + +module M : sig + type \#and = int +end = struct + type \#and = string +end + +let x = (`\#let `\#and : [ `\#let of [ `\#and ] ]) +let (`\#let \#rec) = x +let f g ~\#let ?\#and ?(\#for = \#and) () = g ~\#let ?\#and () + +type t = '\#let +type \#mutable = { mutable \#mutable : \#mutable } + +let rec \#rec = { \#mutable = \#rec } + +type \#and = .. +type \#and += Foo +(* Not allowed in parser: type t += \#and *) + +let x = ( ++ ) +let x = \#let +let f ~\#let ?\#and () = 1 + +module type A = sig + type ('\#let, 'a) \#virtual = '\#let * 'a as '\#mutable + + val foo : '\#let 'a. 'a -> '\#let -> unit + + type foo = { \#let : int } +end + +module M = struct + let ((\#let, foo) as \#val) = (\#mutable, baz) + let _ = fun (type \#let foo) -> 1 + let f g ~\#let ?\#and ?(\#for = \#and) () = g ~\#let ?\#and () + + class \#let = + object + inherit \#val \#let as \#mutable + end +end + +type 'a \#for = 'a list +type 'a \#sig = 'a \#for +type \#true = bool +type _ t = \#in t +type '\#in t + +class ['\#in] c = c + +let f \#false = \#false + +type t = { x : int \#let } + +let x \#let = 42 +let x = f ~\#let:42 ~\#and:43 +let f ~\#let ~\#and : \#let * \#and = x;; + +kind_abbrev_ \#let = \#and + +type t = T : 'a list -> t + +let g x = + let (T (type \#for) (_ : \#for list)) = x in + () + +let ( lsl ) x y = x lsl y +let \#lsl x y = x lsl y + +module type \#sig = sig end + +module M = struct + let \#mod = 1 +end + +let _ = M.\#mod + +module type \#sig = M +module type M = \#sig +module type M = M with module type \#sig = \#sig +module type M = M with module type \#sig := \#sig + +let _ = \#sig.(()) + +(* Raw idents in module names are not allowed in parser: *) +(* let (module \#sig : S) = () *) +(* module \#sig (A : S) = M *) +(* module \#sig = M *) +(* module M (\#sig : S) = M *) +(* module M = M (functor (\#sig : S) -> struct end) *) +(* module type S = functor (\#sig : S) -> S' *) +(* module type M = M with module \#sig = \#sig *) +(* module type M = M with module \#sig := \#sig *) +let _ = + (* let module \#sig = \#sig in *) + (* let open \#sig in *) + () + +let%let _ = () +let _ = [%let ()] +let _ = () [@let] +let _ = () [@@let] +let f : type \#in. t = () +let f : '\#in. t = () +let \#mod : '\#mod. \#mod = \#mod +let mlet = M.\#let +let mtrue = M.\#true +let mmod = M.\#mod + +type tmod = M.\#mod +type tlet = M.\#let +type ttrue = M.\#true + +(* class \#mod = object end *) +let f : #M.\#mod -> _ = (new \#mod, new M.\#mod) + +class type \#mod = object end +class type \#let = \#mod + +module type \#mod = sig + type \#mod + + module type \#mod +end + +module type t = \#mod with type \#mod = M.\#mod and module type \#mod = M.\#mod + +type \#mod = [ `A | `B ] + +let g = function #\#mod | #M.\#mod -> () + +type \#mod = .. +type M.\#mod += A +type t = true of int + +let x = true 0 diff --git a/test/passing/refs.janestreet/raw_identifiers.ml.ref b/test/passing/refs.janestreet/raw_identifiers.ml.ref new file mode 100644 index 0000000000..fe6fd19fb7 --- /dev/null +++ b/test/passing/refs.janestreet/raw_identifiers.ml.ref @@ -0,0 +1,159 @@ +module M : sig + class \#and : object + val mutable \#and : int + method \#and : int + end +end = struct + class \#and = + let \#and = 1 in + object + val mutable \#and = \#and + method \#and = 2 + end +end + +let obj = new M.\#and + +module M : sig + type \#and = int +end = struct + type \#and = string +end + +let x = (`\#let `\#and : [ `\#let of [ `\#and ] ]) +let (`\#let \#rec) = x +let f g ~\#let ?\#and ?(\#for = \#and) () = g ~\#let ?\#and () + +type t = '\#let +type \#mutable = { mutable \#mutable : \#mutable } + +let rec \#rec = { \#mutable = \#rec } + +type \#and = .. +type \#and += Foo +(* Not allowed in parser: type t += \#and *) + +let x = ( ++ ) +let x = \#let +let f ~\#let ?\#and () = 1 + +module type A = sig + type ('\#let, 'a) \#virtual = '\#let * 'a as '\#mutable + + val foo : '\#let 'a. 'a -> '\#let -> unit + + type foo = { \#let : int } +end + +module M = struct + let ((\#let, foo) as \#val) = \#mutable, baz + let _ = fun (type \#let foo) -> 1 + let f g ~\#let ?\#and ?(\#for = \#and) () = g ~\#let ?\#and () + + class \#let = + object + inherit \#val \#let as \#mutable + end +end + +type 'a \#for = 'a list +type 'a \#sig = 'a \#for +type \#true = bool +type _ t = \#in t +type '\#in t + +class ['\#in] c = c + +let f \#false = \#false + +type t = { x : int \#let } + +let x \#let = 42 +let x = f ~\#let:42 ~\#and:43 +let f ~\#let ~\#and : \#let * \#and = x;; + +kind_abbrev_ \#let = \#and + +type t = T : 'a list -> t + +let g x = + let (T (type \#for) (_ : \#for list)) = x in + () +;; + +let ( lsl ) x y = x lsl y +let \#lsl x y = x lsl y + +module type \#sig = sig end + +module M = struct + let \#mod = 1 +end + +let _ = M.\#mod + +module type \#sig = M +module type M = \#sig +module type M = M with module type \#sig = \#sig +module type M = M with module type \#sig := \#sig + +let _ = \#sig.(()) + +(* Raw idents in module names are not allowed in parser: *) +(* let (module \#sig : S) = () *) +(* module \#sig (A : S) = M *) +(* module \#sig = M *) +(* module M (\#sig : S) = M *) +(* module M = M (functor (\#sig : S) -> struct end) *) +(* module type S = functor (\#sig : S) -> S' *) +(* module type M = M with module \#sig = \#sig *) +(* module type M = M with module \#sig := \#sig *) +let _ = + (* let module \#sig = \#sig in *) + (* let open \#sig in *) + () +;; + +let%let _ = () +let _ = [%let ()] +let _ = () [@let] +let _ = () [@@let] +let f : type \#in. t = () +let f : '\#in. t = () +let \#mod : '\#mod. \#mod = \#mod +let mlet = M.\#let +let mtrue = M.\#true +let mmod = M.\#mod + +type tmod = M.\#mod +type tlet = M.\#let +type ttrue = M.\#true + +(* class \#mod = object end *) +let f : #M.\#mod -> _ = new \#mod, new M.\#mod + +class type \#mod = object end +class type \#let = \#mod + +module type \#mod = sig + type \#mod + + module type \#mod +end + +module type t = \#mod with type \#mod = M.\#mod and module type \#mod = M.\#mod + +type \#mod = + [ `A + | `B + ] + +let g = function + | #\#mod | #M.\#mod -> () +;; + +type \#mod = .. +type M.\#mod += A +type t = true of int + +let x = true 0 diff --git a/test/passing/refs.ocamlformat/raw_identifiers.ml.ref b/test/passing/refs.ocamlformat/raw_identifiers.ml.ref new file mode 100644 index 0000000000..fe91af2ba2 --- /dev/null +++ b/test/passing/refs.ocamlformat/raw_identifiers.ml.ref @@ -0,0 +1,186 @@ +module M : sig + class \#and : object + val mutable \#and : int + + method \#and : int + end +end = struct + class \#and = + let \#and = 1 in + object + val mutable \#and = \#and + + method \#and = 2 + end +end + +let obj = new M.\#and + +module M : sig + type \#and = int +end = struct + type \#and = string +end + +let x = (`\#let `\#and : [`\#let of [`\#and]]) + +let (`\#let \#rec) = x + +let f g ~\#let ?\#and ?(\#for = \#and) () = g ~\#let ?\#and () + +type t = '\#let + +type \#mutable = {mutable \#mutable: \#mutable} + +let rec \#rec = {\#mutable= \#rec} + +type \#and = .. + +type \#and += Foo +(* Not allowed in parser: type t += \#and *) + +let x = ( ++ ) + +let x = \#let + +let f ~\#let ?\#and () = 1 + +module type A = sig + type ('\#let, 'a) \#virtual = '\#let * 'a as '\#mutable + + val foo : '\#let 'a. 'a -> '\#let -> unit + + type foo = {\#let: int} +end + +module M = struct + let ((\#let, foo) as \#val) = (\#mutable, baz) + + let _ = fun (type \#let foo) -> 1 + + let f g ~\#let ?\#and ?(\#for = \#and) () = g ~\#let ?\#and () + + class \#let = + object + inherit \#val \#let as \#mutable + end +end + +type 'a \#for = 'a list + +type 'a \#sig = 'a \#for + +type \#true = bool + +type _ t = \#in t + +type '\#in t + +class ['\#in] c = c + +let f \#false = \#false + +type t = {x: int \#let} + +let x \#let = 42 + +let x = f ~\#let:42 ~\#and:43 + +let f ~\#let ~\#and : \#let * \#and = x ;; + +kind_abbrev_ \#let = \#and + +type t = T : 'a list -> t + +let g x = + let (T (type \#for) (_ : \#for list)) = x in + () + +let ( lsl ) x y = x lsl y + +let \#lsl x y = x lsl y + +module type \#sig = sig end + +module M = struct + let \#mod = 1 +end + +let _ = M.\#mod + +module type \#sig = M + +module type M = \#sig + +module type M = M with module type \#sig = \#sig + +module type M = M with module type \#sig := \#sig + +let _ = \#sig.(()) + +(* Raw idents in module names are not allowed in parser: *) +(* let (module \#sig : S) = () *) +(* module \#sig (A : S) = M *) +(* module \#sig = M *) +(* module M (\#sig : S) = M *) +(* module M = M (functor (\#sig : S) -> struct end) *) +(* module type S = functor (\#sig : S) -> S' *) +(* module type M = M with module \#sig = \#sig *) +(* module type M = M with module \#sig := \#sig *) +let _ = + (* let module \#sig = \#sig in *) + (* let open \#sig in *) + () + +let%let _ = () + +let _ = [%let ()] + +let _ = () [@let] + +let _ = () [@@let] + +let f : type \#in. t = () + +let f : '\#in. t = () + +let \#mod : '\#mod. \#mod = \#mod + +let mlet = M.\#let + +let mtrue = M.\#true + +let mmod = M.\#mod + +type tmod = M.\#mod + +type tlet = M.\#let + +type ttrue = M.\#true + +(* class \#mod = object end *) +let f : #M.\#mod -> _ = (new \#mod, new M.\#mod) + +class type \#mod = object end + +class type \#let = \#mod + +module type \#mod = sig + type \#mod + + module type \#mod +end + +module type t = \#mod with type \#mod = M.\#mod and module type \#mod = M.\#mod + +type \#mod = [`A | `B] + +let g = function #\#mod | #M.\#mod -> () + +type \#mod = .. + +type M.\#mod += A + +type t = true of int + +let x = true 0 diff --git a/test/passing/tests/raw_identifiers.ml b/test/passing/tests/raw_identifiers.ml new file mode 100644 index 0000000000..e17d86c803 --- /dev/null +++ b/test/passing/tests/raw_identifiers.ml @@ -0,0 +1,167 @@ +module M : sig + class \#and : object + val mutable \#and : int + + method \#and : int + end +end = struct + class \#and = + let \#and = 1 in + object + val mutable \#and = \#and + + method \#and = 2 + end +end + +let obj = new M.\#and + +module M : sig + type \#and = int +end = struct + type \#and = string +end + +let x = (`\#let `\#and : [`\#let of [`\#and]]) + +let (`\#let \#rec) = x + +let f g ~\#let ?\#and ?(\#for = \#and) () = g ~\#let ?\#and () + +type t = '\#let + +type \#mutable = {mutable \#mutable: \#mutable} + +let rec \#rec = {\#mutable= \#rec} + +type \#and = .. + +type \#and += Foo +(* Not allowed in parser: type t += \#and *) + +let x = ( ++ ) + +let x = \#let + +let f ~\#let ?\#and () = 1 + +module type A = sig + type ('\#let, 'a) \#virtual = '\#let * 'a as '\#mutable + + val foo : '\#let 'a. 'a -> '\#let -> unit + + type foo = {\#let: int} +end + +module M = struct + let ((\#let, foo) as \#val) = (\#mutable, baz) + + let _ = fun (type \#let foo) -> 1 + + let f g ~\#let ?\#and ?(\#for = \#and) () = g ~\#let ?\#and () + + class \#let = + object + inherit \#val \#let as \#mutable + end +end + +type 'a \#for = 'a list + +type 'a \#sig = 'a \#for + +type \#true = bool + +type _ t = \#in t +type '\#in t + +class ['\#in] c = c + +let f \#false = \#false + +type t = {x: int \#let} + +let x \#let = 42 + +let x = f ~\#let:42 ~\#and:43 + +let f ~\#let ~\#and : \#let * \#and = x + +;; +kind_abbrev_ \#let = \#and + +type t = T : 'a list -> t + +let g x = + let (T (type \#for) (_ : \#for list)) = x in + () + +let ( lsl ) x y = x lsl y + +let \#lsl x y = x lsl y + +module type \#sig = sig end + +module M = struct let \#mod = 1 end + +let _ = M.\#mod +module type \#sig = M + +module type M = \#sig + +module type M = M with module type \#sig = \#sig +module type M = M with module type \#sig := \#sig + +let _ = \#sig.( () ) + +(* Raw idents in module names are not allowed in parser: *) +(* let (module \#sig : S) = () *) +(* module \#sig (A : S) = M *) +(* module \#sig = M *) +(* module M (\#sig : S) = M *) +(* module M = M (functor (\#sig : S) -> struct end) *) +(* module type S = functor (\#sig : S) -> S' *) +(* module type M = M with module \#sig = \#sig *) +(* module type M = M with module \#sig := \#sig *) +let _ = + (* let module \#sig = \#sig in *) + (* let open \#sig in *) + () + +let%\#let _ = () +let _ = [%\#let ()] +let _ = () [@\#let] +let _ = () [@@\#let] + +let f : type \#in. t = () +let f : '\#in. t = () + +let \#mod : '\#mod. \#mod = \#mod + +let mlet = M.\#let +let mtrue = M.\#true +let mmod = M.\#mod +type tmod = M.\#mod +type tlet = M.\#let +type ttrue = M.\#true + +(* class \#mod = object end *) +let f: #M.\#mod -> _ = new \#mod, new M.\#mod + +class type \#mod = object end +class type \#let = \#mod + +module type \#mod = sig type \#mod module type \#mod end + +module type t = + \#mod with type \#mod = M.\#mod + and module type \#mod = M.\#mod + +type \#mod = [`A | `B ] +let g = function #\#mod | #M.\#mod -> () + +type \#mod = .. +type M.\#mod += A + +type t = true of int +let x = true 0 From 1a52a54a44317740e0262249770b699959f68b94 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 18 Nov 2024 17:41:49 +0100 Subject: [PATCH 4/5] Update CHANGES --- CHANGES.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index ef6b91ba28..50968cd906 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,8 +8,9 @@ profile. This started with version 0.26.0. ### Highlight -- \* Support OCaml 5.2 syntax (#2519, #2544, #2590, #2596, @Julow, @EmileTrotignon) - This includes local open in types and the new representation for functions. +- \* Support OCaml 5.2 syntax (#2519, #2544, #2590, #2596, #2620, @Julow, @EmileTrotignon) + This includes local open in types, raw identifiers, and the new + representation for functions. This might change the formatting of some functions due to the formatting code being completely rewritten. From 5beaa9b3138b362337d3575d53ef3ad4551e362f Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 18 Nov 2024 17:50:31 +0100 Subject: [PATCH 5/5] Add comment --- vendor/parser-extended/longident.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/vendor/parser-extended/longident.ml b/vendor/parser-extended/longident.ml index 637b3d6462..59b8255792 100644 --- a/vendor/parser-extended/longident.ml +++ b/vendor/parser-extended/longident.ml @@ -13,7 +13,11 @@ (* *) (**************************************************************************) -type src_kind = Lnormal | Lraw | Loperator | Lconstruct +type src_kind = + | Lnormal (** [ident] *) + | Lraw (** [\#raw_ident] *) + | Loperator (** [( >>= )] *) + | Lconstruct (** [true] *) type t = Lident of string * src_kind