From 85be609dd7bb6770528451b759e6066f76ce3a1d Mon Sep 17 00:00:00 2001 From: Jordan Date: Fri, 24 Jul 2020 13:54:21 -0700 Subject: [PATCH] Reason V4 [Stacked Diff 3/n #2614] [Parse Hashtags for polymorphic variants] Summary: Implements parsing for "hashtags" polymorphic variant constructors. Since Reason Syntax still supports object syntax, we needed to rearrange some syntactic real estate to make this work. ```reason let red = #FF000; let isRed = color => switch(color) { | #FF0000 => true | _ => false }; let callAMethod = someObject::methodName(isRed, "testing red"); let templateLiteral = ` String template literals are still using backticks. String template literals are still using backticks. `; ``` Test Plan: Reviewers: CC: --- .../autoUpgradeAngleBrackets.re | 14 + .../autoUpgradeAngleBracketsNoVersionAttr.re | 13 + .../autoUpgradeDoNotAutoUpgrade.re | 5 + .../expected_output/oo_3_dot_8.re | 50 ++- .../expected_output/typeParameters.re | 36 +- .../input/autoUpgradeAngleBrackets.re | 14 + .../autoUpgradeAngleBracketsNoVersionAttr.re | 12 + .../input/autoUpgradeDoNotAutoUpgrade.re | 5 + .../typeCheckedTests/input/oo_3_dot_8.re | 50 ++- .../unit_tests/expected_output/class_types.re | 12 + .../expected_output/class_types_3_dot_8.re | 2 +- formatTest/unit_tests/input/class_types.re | 15 + .../unit_tests/input/class_types_3_dot_8.re | 2 +- .../reason_declarative_lexer.mll | 167 +++++-- src/reason-parser/reason_lexer.ml | 14 +- src/reason-parser/reason_parser.mly | 166 ++++--- src/reason-parser/reason_pprint_ast.ml | 121 +++-- src/reason-parser/reason_single_parser.ml | 18 +- src/reason-version/reason_version.ml | 412 +++++++++++++----- src/refmt/refmt_args.ml | 31 ++ src/refmt/refmt_impl.ml | 6 + 21 files changed, 824 insertions(+), 341 deletions(-) create mode 100644 formatTest/typeCheckedTests/expected_output/autoUpgradeAngleBrackets.re create mode 100644 formatTest/typeCheckedTests/expected_output/autoUpgradeAngleBracketsNoVersionAttr.re create mode 100644 formatTest/typeCheckedTests/expected_output/autoUpgradeDoNotAutoUpgrade.re create mode 100644 formatTest/typeCheckedTests/input/autoUpgradeAngleBrackets.re create mode 100644 formatTest/typeCheckedTests/input/autoUpgradeAngleBracketsNoVersionAttr.re create mode 100644 formatTest/typeCheckedTests/input/autoUpgradeDoNotAutoUpgrade.re diff --git a/formatTest/typeCheckedTests/expected_output/autoUpgradeAngleBrackets.re b/formatTest/typeCheckedTests/expected_output/autoUpgradeAngleBrackets.re new file mode 100644 index 000000000..003bf1a80 --- /dev/null +++ b/formatTest/typeCheckedTests/expected_output/autoUpgradeAngleBrackets.re @@ -0,0 +1,14 @@ +/** + * Even if you have an explicit v3.6 marker. + * This whole file wil be auto-upaded to 3.8 becase something uses + * angle brackets. + */; +[@reason.version 3.8]; +let watchThisIsOldStyle: list = [1, 2]; + +let watchThisIsOldStylePoly = #hello; + +/** + * This will cause the whole file to be promoted. + */ +let x: list = [1, 3]; diff --git a/formatTest/typeCheckedTests/expected_output/autoUpgradeAngleBracketsNoVersionAttr.re b/formatTest/typeCheckedTests/expected_output/autoUpgradeAngleBracketsNoVersionAttr.re new file mode 100644 index 000000000..98d5e9041 --- /dev/null +++ b/formatTest/typeCheckedTests/expected_output/autoUpgradeAngleBracketsNoVersionAttr.re @@ -0,0 +1,13 @@ +[@reason.version 3.8]; +/** + * Test auto-promotion based on feature inference even if no version + * tag. By default you're using the old 3.7. + */ +let watchThisIsOldStyle: list = [1, 2]; + +let watchThisIsOldStylePoly = #hello; + +/** + * This will cause the whole file to be promoted. + */ +let x: list = [1, 3]; diff --git a/formatTest/typeCheckedTests/expected_output/autoUpgradeDoNotAutoUpgrade.re b/formatTest/typeCheckedTests/expected_output/autoUpgradeDoNotAutoUpgrade.re new file mode 100644 index 000000000..297875baa --- /dev/null +++ b/formatTest/typeCheckedTests/expected_output/autoUpgradeDoNotAutoUpgrade.re @@ -0,0 +1,5 @@ +[@reason.version 3.7]; +/** + * This should just print a 3.7 version attr at the top. + */ +let watchThisIsOldStyle: list(int) = [1, 2]; diff --git a/formatTest/typeCheckedTests/expected_output/oo_3_dot_8.re b/formatTest/typeCheckedTests/expected_output/oo_3_dot_8.re index 4c8d3be15..4660068db 100644 --- a/formatTest/typeCheckedTests/expected_output/oo_3_dot_8.re +++ b/formatTest/typeCheckedTests/expected_output/oo_3_dot_8.re @@ -2,13 +2,36 @@ [@reason.version 3.8]; +type canStillDefineConst = + | [] + | ::(int, canStillDefineConst); + class virtual stack <'a> (init) = { + as self; /* * The "as this" is implicit and will be formatted away. */ val virtual dummy: unit; val mutable v: list<'a> = init; pub virtual implementMe: int => int; + pub is_empty = () => + switch (v) { + | [] => true + | _ => false + }; + pub is_empty_unitless = + switch (v) { + | [] => true + | _ => false + }; + pub empty_unitless = { + v = []; + self; + }; + pub empty = () => { + v = []; + self; + }; pub pop = switch (v) { | [hd, ...tl] => @@ -90,6 +113,15 @@ class extendedStackAcknowledgeOverride let inst = (new extendedStack)([1, 2]); +let wasItFull = + !inst::empty()::empty_unitless::is_empty(); +// this is the same +let wasItFull' = + !inst::empty()::empty_unitless::is_empty(); + +let orig_not = (!); +let (!) = o => o::empty(); + /** * Recursive classes. */ @@ -195,7 +227,7 @@ let acceptsOpenAnonObjAsArg = y: int, }, ) => - o#x + o#y; + o::x + o::y; let acceptsClosedAnonObjAsArg = ( o: { @@ -204,7 +236,7 @@ let acceptsClosedAnonObjAsArg = y: int, }, ) => - o#x + o#y; + o::x + o::y; let res = acceptsOpenAnonObjAsArg({ pub x = 0; @@ -346,13 +378,13 @@ let x: tupleClass = { pub pr = (10, 10) }; -let x: #tupleClass = x; +let x: *tupleClass = x; let incrementMyClassInstance: - (int, #tupleClass) => - #tupleClass = + (int, *tupleClass) => + *tupleClass = (i, inst) => { - let (x, y) = inst#pr; + let (x, y) = inst::pr; {pub pr = (x + i, y + i)}; }; @@ -361,7 +393,7 @@ class myClassWithNoTypeParams = {}; * The #myClassWithNoTypeParams should be treated as "simple" */ type optionalMyClassSubtype<'a> = - option<#myClassWithNoTypeParams> as 'a; + option<*myClassWithNoTypeParams> as 'a; /** * Remember, "class type" is really "class_instance_type" (which is the type of @@ -398,7 +430,7 @@ class addablePoint: one: addablePointClassType, two: addablePointClassType, ) => - one#x + two#x + one#y + two#x; + one::x + two::x + one::y + two::x; pub x: int = init; pub y = init; }; @@ -412,7 +444,7 @@ class addablePoint2: one: addablePointClassType, two: addablePointClassType, ) => - one#x + two#x + one#y + two#x; + one::x + two::x + one::y + two::x; pub x: int = init; pub y = init; }; diff --git a/formatTest/typeCheckedTests/expected_output/typeParameters.re b/formatTest/typeCheckedTests/expected_output/typeParameters.re index 1af0200a4..c3bc2a35c 100644 --- a/formatTest/typeCheckedTests/expected_output/typeParameters.re +++ b/formatTest/typeCheckedTests/expected_output/typeParameters.re @@ -1,29 +1,29 @@ /** * Testing type parameters. */; -[@reason.version 3.7]; +[@reason.version 3.8]; -type threeThings('t) = ('t, 't, 't); -type listOf('t) = list('t); +type threeThings<'t> = ('t, 't, 't); +type listOf<'t> = list<'t>; -type underscoreParam(_) = +type underscoreParam<_> = | Underscored; -type underscoreParamCovariance(+_) = +type underscoreParamCovariance<+_> = | Underscored; -type underscoreParamContravariance(-_) = +type underscoreParamContravariance<-_> = | Underscored; -type tickParamCovariance(+'a) = +type tickParamCovariance<+'a> = | Underscored; -type tickParamContravariance(-'a) = +type tickParamContravariance<-'a> = | Underscored; -let x: option(list('a)) = None; -type myFunctionType('a) = ( - list(('a, 'a)), - int => option(list('a)), +let x: option> = None; +type myFunctionType<'a> = ( + list<('a, 'a)>, + int => option>, ); -let funcAnnoted = (~a: list(int)=[0, 1], ()) => a; +let funcAnnoted = (~a: list=[0, 1], ()) => a; /** * Syntax that would be likely to conflict with lexing parsing of < > syntax. @@ -46,12 +46,12 @@ let isSuperGreaterThanEqNegFive3 = zero >>= (-5); let jsx = (~children, ()) => 0; -type t('a) = 'a; -let optionArg = (~arg: option(t(int))=?, ()) => arg; +type t<'a> = 'a; +let optionArg = (~arg: option>=?, ()) => arg; let optionArgList = - (~arg: option(list(list(int)))=?, ()) => arg; -let defaultJsxArg = (~arg: t(int)=, ()) => arg; -let defaultFalse = (~arg: t(bool)=!true, ()) => arg; + (~arg: option>>=?, ()) => arg; +let defaultJsxArg = (~arg: t=, ()) => arg; +let defaultFalse = (~arg: t=!true, ()) => arg; /* Doesn't work on master either let defaultTrue = (~arg:t= !!true) => arg; */ /** diff --git a/formatTest/typeCheckedTests/input/autoUpgradeAngleBrackets.re b/formatTest/typeCheckedTests/input/autoUpgradeAngleBrackets.re new file mode 100644 index 000000000..0b6323b46 --- /dev/null +++ b/formatTest/typeCheckedTests/input/autoUpgradeAngleBrackets.re @@ -0,0 +1,14 @@ +/** + * Even if you have an explicit v3.6 marker. + * This whole file wil be auto-upaded to 3.8 becase something uses + * angle brackets. + */ +[@reason.version 3.6]; +let watchThisIsOldStyle : list(int) = [1, 2]; + +let watchThisIsOldStylePoly = `hello; + +/** + * This will cause the whole file to be promoted. + */ +let x : list = [1, 3]; diff --git a/formatTest/typeCheckedTests/input/autoUpgradeAngleBracketsNoVersionAttr.re b/formatTest/typeCheckedTests/input/autoUpgradeAngleBracketsNoVersionAttr.re new file mode 100644 index 000000000..a472558ab --- /dev/null +++ b/formatTest/typeCheckedTests/input/autoUpgradeAngleBracketsNoVersionAttr.re @@ -0,0 +1,12 @@ +/** + * Test auto-promotion based on feature inference even if no version + * tag. By default you're using the old 3.7. + */ +let watchThisIsOldStyle : list(int) = [1, 2]; + +let watchThisIsOldStylePoly = `hello; + +/** + * This will cause the whole file to be promoted. + */ +let x : list = [1, 3]; diff --git a/formatTest/typeCheckedTests/input/autoUpgradeDoNotAutoUpgrade.re b/formatTest/typeCheckedTests/input/autoUpgradeDoNotAutoUpgrade.re new file mode 100644 index 000000000..717c00fc6 --- /dev/null +++ b/formatTest/typeCheckedTests/input/autoUpgradeDoNotAutoUpgrade.re @@ -0,0 +1,5 @@ +/** + * This should just print a 3.7 version attr at the top. + */ +let watchThisIsOldStyle : list(int) = [1, 2]; + diff --git a/formatTest/typeCheckedTests/input/oo_3_dot_8.re b/formatTest/typeCheckedTests/input/oo_3_dot_8.re index 1f036b5e2..f4077aeb7 100644 --- a/formatTest/typeCheckedTests/input/oo_3_dot_8.re +++ b/formatTest/typeCheckedTests/input/oo_3_dot_8.re @@ -2,13 +2,36 @@ [@reason.version 3.8]; +type canStillDefineConst = + | [] + | :: (int, canStillDefineConst); + class virtual stack('a) (init) = { + as self; /* * The "as this" is implicit and will be formatted away. */ val virtual dummy: unit; val mutable v: list<'a> = init; pub virtual implementMe: int => int; + pub is_empty = () => + switch (v) { + | [] => true + | _ => false + }; + pub is_empty_unitless = + switch (v) { + | [] => true + | _ => false + }; + pub empty_unitless = { + v = []; + self + }; + pub empty = () => { + v = []; + self; + }; pub pop = switch (v) { | [hd, ...tl] => @@ -90,6 +113,15 @@ class extendedStackAcknowledgeOverride let inst = (new extendedStack)([1, 2]); +let wasItFull = !inst::empty()::empty_unitless::is_empty(); +// this is the same +let wasItFull' = !(inst::empty()::empty_unitless::is_empty()); + +let orig_not = (!); +let (!) = o => o::empty(); + + + /** * Recursive classes. */ @@ -195,7 +227,7 @@ let acceptsOpenAnonObjAsArg = y: int, }, ) => - o#x + o#y; + o::x + o::y; let acceptsClosedAnonObjAsArg = ( o: { @@ -204,7 +236,7 @@ let acceptsClosedAnonObjAsArg = y: int, }, ) => - o#x + o#y; + o::x + o::y; let res = acceptsOpenAnonObjAsArg({ pub x = 0; @@ -346,13 +378,13 @@ let x: tupleClass = { pub pr = (10, 10) }; -let x: #tupleClass = x; +let x: *tupleClass = x; let incrementMyClassInstance: - (int, #tupleClass) => - #tupleClass = + (int, *tupleClass) => + *tupleClass = (i, inst) => { - let (x, y) = inst#pr; + let (x, y) = inst::pr; {pub pr = (x + i, y + i)}; }; @@ -361,7 +393,7 @@ class myClassWithNoTypeParams = {}; * The #myClassWithNoTypeParams should be treated as "simple" */ type optionalMyClassSubtype<'a> = - option< #myClassWithNoTypeParams> as 'a; + option< *myClassWithNoTypeParams> as 'a; /** * Remember, "class type" is really "class_instance_type" (which is the type of @@ -398,7 +430,7 @@ class addablePoint: one: addablePointClassType, two: addablePointClassType, ) => - one#x + two#x + one#y + two#x; + one::x + two::x + one::y + two::x; pub x: int = init; pub y = init; }; @@ -412,7 +444,7 @@ class addablePoint2: one: addablePointClassType, two: addablePointClassType, ) => - one#x + two#x + one#y + two#x; + one::x + two::x + one::y + two::x; pub x: int = init; pub y = init; }; diff --git a/formatTest/unit_tests/expected_output/class_types.re b/formatTest/unit_tests/expected_output/class_types.re index c43771745..abe8156b9 100644 --- a/formatTest/unit_tests/expected_output/class_types.re +++ b/formatTest/unit_tests/expected_output/class_types.re @@ -37,3 +37,15 @@ class type t = { class type t = { open M; }; + +class intTuplesTuples = + class tupleClass( + #tupleClass(int, int), + #tupleClass(int, int), + ); + +class intTuplesTuples = + class tupleClass( + #tupleClass(int, int), + #tupleClass(int, int), + ); diff --git a/formatTest/unit_tests/expected_output/class_types_3_dot_8.re b/formatTest/unit_tests/expected_output/class_types_3_dot_8.re index 11e7e9714..42bf7ff59 100644 --- a/formatTest/unit_tests/expected_output/class_types_3_dot_8.re +++ b/formatTest/unit_tests/expected_output/class_types_3_dot_8.re @@ -10,7 +10,7 @@ class type bzz = { class type t = { as 'a; - constraint 'a = #s; + constraint 'a = *s; }; /* https://github.com/facebook/reason/issues/2037 */ diff --git a/formatTest/unit_tests/input/class_types.re b/formatTest/unit_tests/input/class_types.re index 168306e5a..8a3b4cd0a 100644 --- a/formatTest/unit_tests/input/class_types.re +++ b/formatTest/unit_tests/input/class_types.re @@ -35,3 +35,18 @@ class type t = { class type t = { open M; }; + +class intTuplesTuples = ( + class tupleClass( + (#tupleClass(int,int)), + (#tupleClass(int,int)) + ) +); + + +class intTuplesTuples = ( + class tupleClass( + (*tupleClass(int,int)), + (*tupleClass(int,int)) + ) +); diff --git a/formatTest/unit_tests/input/class_types_3_dot_8.re b/formatTest/unit_tests/input/class_types_3_dot_8.re index 50382cf3a..7ea0c7c50 100644 --- a/formatTest/unit_tests/input/class_types_3_dot_8.re +++ b/formatTest/unit_tests/input/class_types_3_dot_8.re @@ -11,7 +11,7 @@ class type bzz = { }; class type t = { as 'a; - constraint 'a = #s + constraint 'a = *s }; /* https://github.com/facebook/reason/issues/2037 */ diff --git a/src/reason-parser/reason_declarative_lexer.mll b/src/reason-parser/reason_declarative_lexer.mll index bd135b1e7..f1a3b20b2 100644 --- a/src/reason-parser/reason_declarative_lexer.mll +++ b/src/reason-parser/reason_declarative_lexer.mll @@ -306,7 +306,6 @@ let update_loc lexbuf file line absolute chars = pos_lnum = if absolute then line else pos.pos_lnum + line; pos_bol = pos.pos_cnum - chars; } - } @@ -325,6 +324,7 @@ let identchar_latin1 = let operator_chars = ['!' '$' '%' '&' '+' '-' ':' '<' '=' '>' '?' '@' '^' '|' '~' '#' '.'] | ( '\\'? ['/' '*'] ) + let dotsymbolchar = ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|' '\\' 'a'-'z' 'A'-'Z' '_' '0'-'9'] let kwdopchar = ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|' '.' '!'] @@ -346,6 +346,27 @@ let float_literal = ('.' ['0'-'9' '_']* )? (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? +(* Will parse a patch version, as well as a leading v, and then we will just + * drop those. This is to gracefully handle if the user accidentally typed a v + * out in front or a patch version. It will be printed away. It will be printed + * back into the standard form [@reason.version 3.8] so that someone can + * contribute to a codebase that hasn't upgraded yet, but test a new version of + * Reason Syntax. + * + * Accepts: + * [@reason.version 3.8] + * [@reason.version 3.8.9] + * [@reason.version v3.8] + * [@reason.version v3.8.9] + * Eventually support: + * [@reason.3.8] + *) +let version_attribute = + "[@reason.version " + 'v'?(['0'-'9']+ as major) + '.' (['0'-'9']+ as minor) + (('.' ['0'-'9']+)? as _patch) ']' + let hex_float_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']* @@ -354,20 +375,20 @@ let hex_float_literal = let literal_modifier = ['G'-'Z' 'g'-'z'] -rule token state = parse +rule base_token extends_tokenizer state = parse | "\\" newline { raise_error (Location.curr lexbuf) (Illegal_character (Lexing.lexeme_char lexbuf 0)); update_loc lexbuf None 1 false 0; - token state lexbuf + extends_tokenizer state lexbuf } | newline { update_loc lexbuf None 1 false 0; - token state lexbuf + extends_tokenizer state lexbuf } | blank + - { token state lexbuf } + { extends_tokenizer state lexbuf } | "_" { UNDERSCORE } | "~" @@ -381,14 +402,20 @@ rule token state = parse try Hashtbl.find keyword_table s with Not_found -> LIDENT s } - | "`" (lowercase | uppercase) identchar * - { let s = Lexing.lexeme lexbuf in - let word = String.sub s 1 (String.length s - 1) in - match Hashtbl.find keyword_table word with - | exception Not_found -> NAMETAG word - | _ -> - raise_error (Location.curr lexbuf) (Keyword_as_tag word); - LIDENT "thisIsABugReportThis" + | "`" ((lowercase | uppercase) identchar *) + { + if Reason_version.fast_parse_supports_HashVariantsColonMethodCallStarClassTypes () then ( + set_lexeme_length lexbuf 1; + SHARP_3_7 + ) else ( + let s = Lexing.lexeme lexbuf in + let word = String.sub s 1 (String.length s - 1) in + match Hashtbl.find keyword_table word with + | exception Not_found -> NAMETAG word + | _ -> + raise_error (Location.curr lexbuf) (Keyword_as_tag word); + LIDENT "thisIsABugReportThis" + ) } | lowercase_latin1 identchar_latin1 * { Ocaml_util.warn_latin1 lexbuf; LIDENT (Lexing.lexeme lexbuf) } @@ -465,23 +492,7 @@ rule token state = parse { CHAR (char_for_hexadecimal_code lexbuf 3) } | "'" (("\\" _) as esc) { raise_error (Location.curr lexbuf) (Illegal_escape esc); - token state lexbuf - } - | "#=<" - { (* Allow parsing of foo#= *) - set_lexeme_length lexbuf 2; - SHARPEQUAL - } - | "#=" - { SHARPEQUAL } - | "#" operator_chars+ - { SHARPOP (lexeme_operator lexbuf) } - (* File name / line number source mapping # n string\n *) - | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* - ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? - [^ '\010' '\013'] * newline - { update_loc lexbuf name (int_of_string num) true 0; - token state lexbuf + extends_tokenizer state lexbuf } | "&" { AMPERSAND } | "&&" { AMPERAMPER } @@ -497,30 +508,19 @@ rule token state = parse set_lexeme_length lexbuf 2; EQUALGREATER } - | "#" { SHARP } | "." { DOT } | ".." { DOTDOT } | "..."{ DOTDOTDOT } | ":" { COLON } - | "::" { COLONCOLON } | ":=" { COLONEQUAL } | ":>" { COLONGREATER } | ";" { SEMI } | ";;" { SEMISEMI } - | "<" { LESS } | "=" { EQUAL } | "[" { LBRACKET } | "[|" { LBRACKETBAR } | "[<" { LBRACKETLESS } | "[>" { LBRACKETGREATER } - | "<" (((uppercase identchar* '.')* - (lowercase_no_under | lowercase identchar identchar*)) as tag) - (* Parsing <_ helps resolve no conflicts in the parser and creates other - * challenges with splitting up INFIXOP0 tokens (in Reason_parser_single) - * so we don't do it. *) - { LESSIDENT tag } - | "<" ((uppercase identchar*) as tag) - { LESSUIDENT tag } | ">..." { GREATERDOTDOTDOT } (* Allow parsing of Pexp_override: * let z = {}; @@ -599,7 +599,7 @@ rule token state = parse set_lexeme_length lexbuf 1; GREATER } - | "[@reason.version " (['0'-'9']+ as major) '.' (['0'-'9']+ as minor) (('.' ['0'-'9']+)? as _patch) ']' { + | version_attribute { (* Special case parsing of attribute so that we can special case its * parsing. Parses x.y.z even though it is not valid syntax otherwise - * just gracefully remove the last number. The parser will ignore this @@ -607,7 +607,11 @@ rule token state = parse * the attribute into the footer of the file. Then the printer will ensure * it is formatted at the top of the file, ideally after the first file * floating doc comment. *) - VERSION_ATTRIBUTE (int_of_string major, int_of_string minor) + (* TODO: Error if version has already been set explicitly in token stream *) + let major = int_of_string major in + let minor = int_of_string minor in + Reason_version.record_explicit_version_in_ast_if_not_yet major minor; + VERSION_ATTRIBUTE (major, minor) } | "[@" { LBRACKETAT } | "[%" { LBRACKETPERCENT } @@ -627,6 +631,19 @@ rule token state = parse | "<..>" { LESSDOTDOTGREATER } | '\\'? ['~' '?' '!'] operator_chars+ { PREFIXOP (lexeme_operator lexbuf) } + (* The parsing of various LESS* needs to happen after parsing all the other + * tokens that start with < except before parsing INFIXOP0 *) + | "<" (blank | newline) { + set_lexeme_length lexbuf 1; + LESS_THEN_SPACE + } + | "<" + (* Parsing <_ helps resolve no conflicts in the parser and creates other + * challenges with splitting up INFIXOP0 tokens (in Reason_parser_single) + * so we don't do it. *) + { + LESS_THEN_NOT_SPACE + } | '\\'? ['=' '<' '>' '|' '&' '$'] operator_chars* { (* See decompose_token in Reason_single_parser.ml for how let `x=-1` is lexed @@ -677,12 +694,14 @@ rule token state = parse { LETOP (lexeme_operator lexbuf) } | "and" kwdopchar dotsymbolchar * { ANDOP (lexeme_operator lexbuf) } - | eof { EOF } + | eof { + EOF } | _ - { raise_error + { + raise_error (Location.curr lexbuf) (Illegal_character (Lexing.lexeme_char lexbuf 0)); - token state lexbuf + extends_tokenizer state lexbuf } and enter_comment state = parse @@ -799,7 +818,6 @@ and comment buffer firstloc nestedloc = parse { store_lexeme buffer lexbuf; comment buffer firstloc nestedloc lexbuf } - | "'" newline "'" { store_lexeme buffer lexbuf; update_loc lexbuf None 1 false 1; @@ -826,6 +844,61 @@ and comment buffer firstloc nestedloc = parse comment buffer firstloc nestedloc lexbuf } + +and token_v3_7 state = parse + (* All of the sharpops need to be duplicated as well because they + * need to take priority over # *) + | "#=<" + { (* Allow parsing of foo#= *) + set_lexeme_length lexbuf 2; + SHARPEQUAL + } + | "#=" { SHARPEQUAL } + | "#" operator_chars+ + { SHARPOP (lexeme_operator lexbuf) } + (* File name / line number source mapping # n string\n *) + | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* + ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? + [^ '\010' '\013'] * newline + { update_loc lexbuf name (int_of_string num) true 0; + token_v3_7 state lexbuf + } + | "#" { SHARP_3_7 } + | "::" { COLONCOLON_3_7 } + (* EOF must be handled here because there's no way to unlex it before + * dispatching to the base lexer *) + | eof { EOF } + | _ { + set_lexeme_length lexbuf 0; + base_token token_v3_7 state lexbuf } + +and token_v3_8 state = parse + (* All of the sharpops need to be duplicated as well because they + * need to take priority over # *) + | "#=<" + { (* Allow parsing of foo#= *) + set_lexeme_length lexbuf 2; + SHARPEQUAL + } + | "#=" { SHARPEQUAL } + | "#" operator_chars+ + { SHARPOP (lexeme_operator lexbuf) } + (* File name / line number source mapping # n string\n *) + | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* + ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? + [^ '\010' '\013'] * newline + { update_loc lexbuf name (int_of_string num) true 0; + token_v3_8 state lexbuf + } + | "#" { SHARP_3_8 } + | "::" { COLONCOLON_3_8 } + (* EOF must be handled here because there's no way to unlex it before + * dispatching to the base lexer *) + | eof { EOF } + | _ { + set_lexeme_length lexbuf 0; + base_token token_v3_8 state lexbuf } + (** [string rawbuf txtbuf lexbuf] parses a string from [lexbuf]. The string contents is stored in two buffers: - [rawbuf] for the text as it literally appear in the source diff --git a/src/reason-parser/reason_lexer.ml b/src/reason-parser/reason_lexer.ml index c8f3e1a0d..48ff24972 100644 --- a/src/reason-parser/reason_lexer.ml +++ b/src/reason-parser/reason_lexer.ml @@ -32,16 +32,20 @@ let init ?insert_completion_ident lexbuf = let lexbuf state = state.lexbuf -let rec comment_capturing_tokenizer tokenizer = - fun state -> +let rec comment_capturing_version_switching_token state = + let tokenizer = + if Reason_version.fast_parse_supports_HashVariantsColonMethodCallStarClassTypes () then + Reason_declarative_lexer.token_v3_8 + else + Reason_declarative_lexer.token_v3_7 + in match tokenizer state.declarative_lexer_state state.lexbuf with | COMMENT (s, comment_loc) -> state.comments <- (s, comment_loc) :: state.comments; - comment_capturing_tokenizer tokenizer state + comment_capturing_version_switching_token state | tok -> tok - -let token a = (comment_capturing_tokenizer Reason_declarative_lexer.token) a +let token = comment_capturing_version_switching_token let token_after_interpolation_region state = Reason_declarative_lexer.token_in_template_string_region diff --git a/src/reason-parser/reason_parser.mly b/src/reason-parser/reason_parser.mly index 789ef163a..27a646b51 100644 --- a/src/reason-parser/reason_parser.mly +++ b/src/reason-parser/reason_parser.mly @@ -1133,7 +1133,8 @@ let add_brace_attr expr = %token CHAR %token CLASS %token COLON -%token COLONCOLON +%token COLONCOLON_3_7 +(* See COLONCOLON_3_8 which is only parsed in newer Reason Syntax and with SHARP precedence *) %token COLONEQUAL %token COLONGREATER %token COMMA @@ -1185,9 +1186,8 @@ let add_brace_attr expr = %token LBRACKETGREATER %token LBRACKETPERCENT %token LBRACKETPERCENTPERCENT -%token LESS -%token LESSIDENT [@recover.expr ""] [@recover.cost 2] -%token LESSUIDENT [@recover.expr ""] [@recover.cost 2] +%token LESS_THEN_SPACE +%token LESS_THEN_NOT_SPACE %token LESSGREATER %token LESSSLASHGREATER %token LESSDOTDOTGREATER @@ -1228,7 +1228,10 @@ let add_brace_attr expr = %token LESSSLASHIDENTGREATER [@recover.expr ""] [@recover.cost 2] %token SEMI %token SEMISEMI -%token SHARP +%token SHARP_3_7 +(* SHARP operator for v3.8+ *) +%token SHARP_3_8 +%token COLONCOLON_3_8 %token SHARPOP %token SHARPEQUAL %token SIG @@ -1292,10 +1295,11 @@ conflicts. %right OR BARBAR (* expr (e || e || e) *) %right AMPERSAND AMPERAMPER (* expr (e && e && e) *) -%left INFIXOP0 LESS GREATER GREATERDOTDOTDOT (* expr (e OP e OP e) *) +(* Menhir says that it is useless to include LESS_THEN_NOT_SPACE in the following list *) +%left INFIXOP0 LESS_THEN_SPACE GREATER GREATERDOTDOTDOT (* expr (e OP e OP e) *) %left LESSDOTDOTGREATER (* expr (e OP e OP e) *) %right INFIXOP1 (* expr (e OP e OP e) *) -%right COLONCOLON (* expr (e :: e :: e) *) +%right COLONCOLON_3_7 (* expr (e :: e :: e) *) %left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ (* expr (e OP e OP e) *) %left PERCENT INFIXOP3 SLASHGREATER STAR (* expr (e OP e OP e) *) %right INFIXOP4 (* expr (e OP e OP e) *) @@ -1383,7 +1387,8 @@ conflicts. (* PREFIXOP and BANG precedence *) %nonassoc below_DOT_AND_SHARP (* practically same as below_SHARP but we convey purpose *) -%nonassoc SHARP (* simple_expr/toplevel_directive *) +%nonassoc SHARP_3_7 (* simple_expr/toplevel_directive *) +%nonassoc COLONCOLON_3_8 (* e::methodA::methodB is (e::methodA)::methodB *) %nonassoc below_DOT (* We need SHARPEQUAL to have lower precedence than `[` to make e.g. @@ -1450,7 +1455,7 @@ conflicts. implementation: structure EOF { - let itms = Reason_version.Ast_nodes.inject_attr_from_version_impl $1 in + let itms = Reason_version.Ast_nodes.inject_attr_to_instruct_printing_impl $1 in apply_mapper_to_structure itms reason_mapper } ; @@ -1458,7 +1463,7 @@ implementation: interface: signature EOF { - let itms = Reason_version.Ast_nodes.inject_attr_from_version_intf $1 in + let itms = Reason_version.Ast_nodes.inject_attr_to_instruct_printing_intf $1 in apply_mapper_to_signature itms reason_mapper } ; @@ -2737,18 +2742,12 @@ jsx_arguments: ; jsx_start_tag_and_args: - as_loc(LESSIDENT) jsx_arguments - { let name = Longident.parse $1.txt in - (jsx_component {$1 with txt = name} $2, name) - } - | LESS as_loc(LIDENT) jsx_arguments + | LESS_THEN_NOT_SPACE as_loc(LIDENT) jsx_arguments { let name = Longident.parse $2.txt in (jsx_component {$2 with txt = name} $3, name) } - | LESS as_loc(mod_ext_longident) jsx_arguments + | LESS_THEN_NOT_SPACE as_loc(mod_ext_longident) jsx_arguments { jsx_component $2 $3, $2.txt } - | as_loc(mod_ext_lesslongident) jsx_arguments - { jsx_component $1 $2, $1.txt } ; jsx_start_tag_and_args_without_leading_less: @@ -2838,7 +2837,7 @@ jsx_without_leading_less: (Nolabel, mkexp_constructor_unit loc loc) ] loc } - | jsx_start_tag_and_args_without_leading_less greater_spread simple_expr_no_call LESSSLASHIDENTGREATER { + | jsx_start_tag_and_args_without_leading_less greater_spread simple_expr_no_call LESSSLASHIDENTGREATER { let (component, start) = $1 in let loc = mklocation $symbolstartpos $endpos in (* TODO: Make this tag check simply a warning *) @@ -2857,6 +2856,11 @@ optional_expr_extension: | item_extension_sugar { fun exp -> expression_extension $1 exp } ; +%inline coloncolon: + | COLONCOLON_3_7 { $1 } + | COLONCOLON_3_8 { $1 } +; + (* * Parsing of expressions is quite involved as it depends on context. * At the top-level of a structure, expressions can't have attributes @@ -2910,7 +2914,7 @@ mark_position_exp | FOR optional_expr_extension LPAREN pattern IN expr direction_flag expr RPAREN simple_expr { $2 (mkexp (Pexp_for($4, $6, $8, $7, $10))) } - | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN + | LPAREN coloncolon RPAREN LPAREN expr COMMA expr RPAREN { let loc_colon = mklocation $startpos($2) $endpos($2) in let loc = mklocation $symbolstartpos $endpos in mkexp_cons loc_colon (mkexp ~ghost:true ~loc (Pexp_tuple[$5;$7])) loc @@ -3027,6 +3031,11 @@ parenthesized_expr: filter_raise_spread_syntax msg $2 }; +%inline send: + | SHARP_3_7 {$1} + | COLONCOLON_3_8 {$1} +; + %inline bigarray_access: DOT LBRACE lseparated_nonempty_list(COMMA, expr) COMMA? RBRACE { $3 } @@ -3138,7 +3147,7 @@ parenthesized_expr: let exp = Exp.mk ~loc ~attrs:[] (Pexp_override $4) in mkexp (Pexp_open(od, exp)) } - | E SHARP as_loc(label) + | E send as_loc(label) { mkexp (Pexp_send($1, $3)) } | E as_loc(SHARPOP) simple_expr_no_call { mkinfixop $1 (mkoperator $2) $3 } @@ -3732,14 +3741,14 @@ mark_position_pat | name_tag simple_pattern { mkpat (Ppat_variant($1, Some $2)) } - | pattern_without_or as_loc(COLONCOLON) pattern_without_or + | pattern_without_or as_loc(coloncolon) pattern_without_or { syntax_error $2.loc ":: is not supported in Reason, please use [hd, ...tl] instead"; let loc = mklocation $symbolstartpos $endpos in mkpat_cons (mkpat ~ghost:true ~loc (Ppat_tuple[$1;$3])) loc } - | LPAREN COLONCOLON RPAREN LPAREN pattern_without_or COMMA pattern_without_or RPAREN + | LPAREN coloncolon RPAREN LPAREN pattern_without_or COMMA pattern_without_or RPAREN { let loc = mklocation $symbolstartpos $endpos in mkpat_cons (mkpat ~ghost:true ~loc (Ppat_tuple[$5;$7])) loc } @@ -3782,6 +3791,10 @@ simple_pattern_ident: as_loc(val_ident) { mkpat ~loc:$1.loc (Ppat_var $1) } ; +%inline polyvariant_pat: + | SHARP_3_7 type_longident { mkpat (Ppat_type ($2)) } + | STAR type_longident { mkpat (Ppat_type ($2)) } + simple_pattern_not_ident: mark_position_pat ( UNDERSCORE @@ -3798,8 +3811,7 @@ mark_position_pat { mkpat (Ppat_construct ($1, None)) } | name_tag { mkpat (Ppat_variant ($1, None)) } - | SHARP type_longident - { mkpat (Ppat_type ($2)) } + | polyvariant_pat { $1 } | LPAREN lseparated_nonempty_list(COMMA, pattern_optional_constraint) COMMA? RPAREN { match $2 with | [] -> (* This shouldn't be possible *) @@ -4507,26 +4519,8 @@ non_arrowed_core_type: | lseparated_nonempty_list(COMMA, protected_type) COMMA? {$1} ; -%inline first_less_than_type_ident: - LESSIDENT { Lident $1 } - -(* Since the Lapply (p1, p2)) $1 $2 - } -; - - - - - - - mty_longident: | ident { Lident $1 } @@ -4894,7 +4863,7 @@ class_longident: (* Toplevel directives *) toplevel_directive: - SHARP as_loc(ident) embedded + SHARP_3_7 as_loc(ident) embedded ( (* empty *) { None } | STRING { let (s, _, _) = $1 in Some(Pdir_string s) } | INT { let (n, m) = $1 in Some(Pdir_int (n, m)) } @@ -4923,7 +4892,11 @@ toplevel_directive: opt_LET_MODULE: MODULE { () } | LET MODULE { () }; -%inline name_tag: NAMETAG { $1 }; +%inline name_tag: + | NAMETAG { $1 } + | SHARP_3_8 LIDENT { $2 } + | SHARP_3_8 UIDENT { $2 } +; %inline label: LIDENT { $1 }; @@ -5043,7 +5016,7 @@ attribute: (* Just ignore the attribute in the AST at this point, but record its version, * then we wil add it back at the "top" of the file. *) let major, minor = $1 in - Reason_version.set_explicit (major, minor); + Reason_version.record_explicit_version_in_ast_if_not_yet major minor; let attr_payload = Reason_version.Ast_nodes.mk_version_attr_payload major minor in let loc = mklocation $symbolstartpos $endpos in { attr_name = {loc; txt="reason.version"}; @@ -5209,8 +5182,15 @@ lseparated_nonempty_list_aux(sep, X): %inline parenthesized(X): delimited(LPAREN, X, RPAREN) { $1 }; +%inline either_kind_of_less: + | LESS_THEN_NOT_SPACE { $1 } + | LESS_THEN_SPACE { $1 } + (*Less than followed by one or more X, then greater than *) -%inline lessthangreaterthanized(X): delimited(LESS, X, GREATER) { $1 }; +%inline lessthangreaterthanized(X): delimited(either_kind_of_less, X, GREATER) { + Reason_version.refine_inferred Reason_version.AngleBracketTypes; + $1 +}; (*Less than followed by one or more X, then greater than *) %inline loptioninline(X): ioption(X) { match $1 with None -> [] | Some x -> x}; diff --git a/src/reason-parser/reason_pprint_ast.ml b/src/reason-parser/reason_pprint_ast.ml index 8a6e89f88..32bc87211 100644 --- a/src/reason-parser/reason_pprint_ast.ml +++ b/src/reason-parser/reason_pprint_ast.ml @@ -1063,27 +1063,6 @@ let makeAppList = function | [hd] -> hd | l -> makeList ~inline:(true, true) ~postSpace:true ~break:IfNeed l -let makeTup ?(wrap=("", ""))?(trailComma=true) ?(uncurried = false) l = - let (lwrap, rwrap) = wrap in - let lparen = lwrap ^ (if uncurried then "(. " else "(") in - makeList - ~wrap:(lparen, ")" ^ rwrap) - ~sep:(if trailComma then commaTrail else commaSep) - ~postSpace:true - ~break:IfNeed l - -(* Makes angle brackets < > *) -let typeParameterBookends ?(wrap=("", ""))?(trailComma=true) l = - let useAngle = Reason_version.supports Reason_version.AngleBracketTypes in - let left = if useAngle then "<" else "(" in - let right = if useAngle then ">" else ")" in - let (lwrap, rwrap) = wrap in - let lparen = lwrap ^ left in - makeList - ~wrap:(lparen, right ^ rwrap) - ~sep:(if trailComma then commaTrail else commaSep) - ~postSpace:true - ~break:IfNeed l let ensureSingleTokenSticksToLabel x = let listConfigIfCommentsInterleaved cfg = @@ -1156,6 +1135,53 @@ let atom ?loc str = let style = { Easy_format.atom_style = Some "atomClss" } in source_map ?loc (Layout.Easy (Easy_format.Atom(str, style))) +let makeTup ?(wrap=("", ""))?(trailComma=true) ?(uncurried = false) l = + let (lwrap, rwrap) = wrap in + let lparen = lwrap ^ (if uncurried then "(. " else "(") in + makeList + ~wrap:(lparen, ")" ^ rwrap) + ~sep:(if trailComma then commaTrail else commaSep) + ~postSpace:true + ~break:IfNeed l + +(* Makes angle brackets < > *) +let typeParameterBookends ?(wrap=("", ""))?(trailComma=true) l = + let useAngle = Reason_version.print_supports Reason_version.AngleBracketTypes in + let left = if useAngle then "<" else "(" in + let right = if useAngle then ">" else ")" in + let (lwrap, rwrap) = wrap in + let lparen = lwrap ^ left in + makeList + ~wrap:(lparen, right ^ rwrap) + ~sep:(if trailComma then commaTrail else commaSep) + ~postSpace:true + ~break:IfNeed l + +let classTypeIdent formattedLongIdent = + let useStar = Reason_version.print_supports Reason_version.HashVariantsColonMethodCallStarClassTypes in + if useStar then + makeList [atom "*"; formattedLongIdent] + else makeList [atom "#"; formattedLongIdent] + +(* For matching on polymorphic variant types *) +let typePattern formattedLongIdent = + let useStar = Reason_version.print_supports Reason_version.HashVariantsColonMethodCallStarClassTypes in + if useStar then + makeList [atom "*"; formattedLongIdent] + else makeList [atom "#"; formattedLongIdent] + +let methodSend formattedObj = + let useColon = + Reason_version.print_supports Reason_version.HashVariantsColonMethodCallStarClassTypes in + if useColon then + label ~break:`Never formattedObj (atom "::") + else makeList [formattedObj; atom "#"] + +let polyVariantToken () = + let useColon = + Reason_version.print_supports Reason_version.HashVariantsColonMethodCallStarClassTypes in + if useColon then "#" else "`" + (** Take x,y,z and n and generate [x, y, z, ...n] *) let makeES6List ?wrap:((lwrap,rwrap)=("", "")) lst last = makeList @@ -2893,7 +2919,7 @@ let printer = object(self:'self) add_bar fullLbl in - let prefix = if polymorphic then "`" else "" in + let prefix = if polymorphic then polyVariantToken () else "" in let sourceMappedName = atom ~loc:pcd_name.loc (prefix ^ pcd_name.txt) in let sourceMappedNameWithAttributes = let layout = match stdAttrs with @@ -3213,14 +3239,14 @@ let printer = object(self:'self) | (Closed,Some tl) -> ("<", tl) | (Open,_) -> (">", []) in let node_list = List.mapi variant_helper l in - let ll = (List.map (fun t -> atom ("`" ^ t)) tl) in + let ll = (List.map (fun t -> atom (polyVariantToken () ^ t)) tl) in let tag_list = makeList ~postSpace:true ~break:IfNeed ((atom ">")::ll) in let type_list = if tl != [] then node_list@[tag_list] else node_list in makeList ~wrap:("[" ^ designator,"]") ~pad:(true, false) ~postSpace:true ~break:IfNeed type_list - | Ptyp_class (li, []) -> makeList [atom "#"; self#longident_loc li] + | Ptyp_class (li, []) -> classTypeIdent (self#longident_loc li) | Ptyp_class (li, l) -> label - (makeList [atom "#"; self#longident_loc li]) + (classTypeIdent (self#longident_loc li)) (typeParameterBookends (List.map self#core_type l)) | Ptyp_extension e -> self#extension e | Ptyp_arrow (_, _, _) @@ -3340,7 +3366,7 @@ let printer = object(self:'self) raise (NotPossible "Should never see embedded attributes on poly variant") else source_map ~loc:x.ppat_loc - (self#constructor_pattern (atom ("`" ^ l)) p + (self#constructor_pattern (atom (polyVariantToken () ^ l)) p ~polyVariant:true ~arityIsClear:true) | Ppat_lazy p -> label ~space:true (atom "lazy") (self#simple_pattern p) | Ppat_construct (({txt} as li), po) when not (txt = Lident "::")-> (* FIXME The third field always false *) @@ -3513,8 +3539,7 @@ let printer = object(self:'self) label (label (self#longident_loc lid) (atom ("."))) (if needsParens then formatPrecedence pat else pat) - | Ppat_type li -> - makeList [atom "#"; self#longident_loc li] + | Ppat_type li -> typePattern (self#longident_loc li) | Ppat_record (l, closed) -> self#patternRecord l closed | Ppat_tuple l -> @@ -3524,7 +3549,7 @@ let printer = object(self:'self) (self#constant ?raw_literal c) | Ppat_interval (c1, c2) -> makeList ~postSpace:true [self#constant c1; atom ".."; self#constant c2] - | Ppat_variant (l, None) -> makeList[atom "`"; atom l] + | Ppat_variant (l, None) -> makeList[atom (polyVariantToken ()); atom l] | Ppat_constraint (p, ct) -> formatPrecedence (self#pattern x) | Ppat_lazy p ->formatPrecedence (label ~space:true (atom "lazy") (self#simple_pattern p)) @@ -4399,7 +4424,7 @@ let printer = object(self:'self) if arityAttrs != [] then raise (NotPossible "Should never see embedded attributes on poly variant") else - FunctionApplication [self#constructor_expression ~polyVariant:true ~arityIsClear:true stdAttrs (atom ("`" ^ l)) eo] + FunctionApplication [self#constructor_expression ~polyVariant:true ~arityIsClear:true stdAttrs (atom (polyVariantToken () ^ l)) eo] (* TODO: Should protect this identifier *) | Pexp_setinstvar (s, rightExpr) -> let rightItm = self#unparseResolvedRule ( @@ -6515,7 +6540,7 @@ let printer = object(self:'self) [formatCoerce (self#unparseExpr e) optFormattedType (self#core_type ct)] ) | Pexp_variant (l, None) -> - Some (ensureSingleTokenSticksToLabel (atom ("`" ^ l))) + Some (ensureSingleTokenSticksToLabel (atom (polyVariantToken () ^ l))) | Pexp_record (l, eo) -> Some (self#unparseRecord l eo) | Pexp_array l -> Some (self#unparseSequence ~construct:`Array l) @@ -6555,7 +6580,7 @@ let printer = object(self:'self) in let lhs = self#simple_enough_to_be_lhs_dot_send e in let lhs = if needparens then makeList ~wrap:("(",")") [lhs] else lhs in - Some (label (makeList [lhs; atom "#";]) (atom s.txt)) + Some (label (methodSend lhs) (atom s.txt)) | _ -> None in match item with @@ -8417,16 +8442,26 @@ let record_version_mapper super = let super_structure_item = super.Ast_mapper.structure_item in let super_signature_item = super.Ast_mapper.signature_item in let structure_item mapper structure_item = - (match Reason_version.Ast_nodes.extract_version_attribute_structure_item structure_item with - | None -> () - | Some(mjr, mnr) -> Reason_version.set_explicit (mjr, mnr)); - super_structure_item mapper structure_item + let mapped = + match Reason_version.Ast_nodes.is_structure_version_attribute structure_item with + | None -> structure_item + | Some(_updater, mjr, mnr) -> + Reason_version.print_version.major <- mjr; + Reason_version.print_version.minor <- mnr; + structure_item + in + super_structure_item mapper mapped in let signature_item mapper signature_item = - (match Reason_version.Ast_nodes.extract_version_attribute_signature_item signature_item with - | None -> () - | Some(mjr, mnr) -> Reason_version.set_explicit (mjr, mnr)); - super_signature_item mapper signature_item + let mapped = + match Reason_version.Ast_nodes.is_sig_version_attribute signature_item with + | None -> signature_item + | Some(_updater, mjr, mnr) -> + Reason_version.print_version.major <- mjr; + Reason_version.print_version.minor <- mnr; + signature_item + in + super_signature_item mapper mapped in { super with Ast_mapper.structure_item; Ast_mapper.signature_item } @@ -8465,15 +8500,13 @@ let signature (comments : Comment.t list) ppf x = List.iter (fun comment -> printer#trackComment comment) comments; format_layout ppf ~comments (printer#signature - (Reason_version.Ast_nodes.inject_attr_from_version_intf - (apply_mapper_to_signature x preprocessing_mapper))) + ((apply_mapper_to_signature x preprocessing_mapper))) let structure (comments : Comment.t list) ppf x = List.iter (fun comment -> printer#trackComment comment) comments; format_layout ppf ~comments (printer#structure - (Reason_version.Ast_nodes.inject_attr_from_version_impl - (apply_mapper_to_structure x preprocessing_mapper))) + ((apply_mapper_to_structure x preprocessing_mapper))) let expression ppf x = format_layout ppf diff --git a/src/reason-parser/reason_single_parser.ml b/src/reason-parser/reason_single_parser.ml index baf4c5c46..60e36296c 100644 --- a/src/reason-parser/reason_single_parser.ml +++ b/src/reason-parser/reason_single_parser.ml @@ -185,9 +185,19 @@ let common_remaining_infix_token pcur = | ['+'; '.'] -> Some(Reason_parser.PLUSDOT, pcur, advance pnext 1) | ['!'] -> Some(Reason_parser.BANG, pcur, pnext) | ['>'] -> Some(Reason_parser.GREATER, pcur, pnext) - | ['<'] -> Some(Reason_parser.LESS, pcur, pnext) - | ['#'] -> Some(Reason_parser.SHARP, pcur, pnext) - | [':'] -> Some(Reason_parser.COLON, pcur, pnext) + (* Return the more liberal of the two `LESS_THEN_SPACE`, + `LESS_THEN_NOT_SPACE` because terms can either parse with either, or + LESS_THEN_NOT_SPACE, so return the one that some rules demand, and others + can tolerate. *) + | ['<'] -> Some(Reason_parser.LESS_THEN_NOT_SPACE, pcur, pnext) + | ['*'] -> Some(Reason_parser.STAR, pcur, pnext) + | ['#'] -> + if Reason_version.fast_parse_supports_HashVariantsColonMethodCallStarClassTypes () then + Some(Reason_parser.SHARP_3_8, pcur, pnext) + else + Some(Reason_parser.SHARP_3_7, pcur, pnext) + | [':'] -> + Some(Reason_parser.COLON, pcur, pnext) | _ -> None let rec decompose_token pos0 split = @@ -209,7 +219,7 @@ let rec decompose_token pos0 split = | Some(r) -> Some(List.rev (r :: revFirstTwo))) (* For type parameters type t<+'a> = .. and t<#classNameOrPolyVariantKind>*) | '<' :: tl -> - let less = [Reason_parser.LESS, pcur, pnext] in + let less = [Reason_parser.LESS_THEN_NOT_SPACE, pcur, pnext] in if tl == [] then Some less else (match common_remaining_infix_token pcur tl with diff --git a/src/reason-version/reason_version.ml b/src/reason-version/reason_version.ml index 000371c54..7e38ae518 100644 --- a/src/reason-version/reason_version.ml +++ b/src/reason-version/reason_version.ml @@ -10,77 +10,216 @@ open Asttypes open Ast_helper type file_version = { - major : int; - minor : int; + mutable major : int; + mutable minor : int; } type package_version = { - major : int; - minor : int; - patch : int; + pkg_major : int; + pkg_minor : int; + pkg_patch : int; } type feature = | AngleBracketTypes + | HashVariantsColonMethodCallStarClassTypes (** * Tracks the current package version of Reason parser/printer. This is - * primarily for printing the version with `refmt --version`. + * primarily for printing the version with `refmt --version`, but could also + * used for defaulting printed version in attributes if not specified. *) let package_version = { - major = 3; - minor = 7; - patch = 0; + pkg_major = 3; + pkg_minor = 8; + pkg_patch = 0; } let package_version_string = - (string_of_int package_version.major) ^ + (string_of_int package_version.pkg_major) ^ "." ^ - (string_of_int package_version.minor) ^ + (string_of_int package_version.pkg_minor) ^ "." ^ - (string_of_int package_version.patch) + (string_of_int package_version.pkg_patch) (** - * Tracks the file version recorded in attribute. Defaults to 3.6 - - * the version before Reason's refmt began recording versions in - * editor formatting. +Version to begin parsing with, absent information stating otherwise +(attributes/forced command line) +*) +let default_file_version = {major = 3; minor = 7} + +(** * A combination of version_in_ast_attr, cli_arg_parse_version and + default_file_version together make up the effective parse version. Each one + has priority over the next. *) + +let unspecified () = {major = -1; minor = -1} + +(** +Tracks the file version recorded in the AST itself. +*) +let version_in_ast_attr = {major = -1; minor = -1} + +(** Records an explicit version to instruct parsing. This would mean that observing + an attribute with [@reason.version 3.8] is not necessary to get the lexer/parser + to begin parsing in version 3.8. *) +let cli_arg_parse_version = {major = -1; minor = -1} + +(** Track use of features that would automatically "upgrade"/promote the user. + There is a subset of features that would correctly lex/parse in an older + version, *or* a newer version, despite only being printed in the newer + version of Reason Syntax. + At the end of parsing, the inferred_promote_version will map replace + ast version nodes with the newly upgraded version so that if it was persisted + in binary form to disk, it could be input into refmt, as if that were the explicitly + set file version in the ast. *) +let inferred_promote_version = {major = -1; minor = -1} + +(** Records an explicit version to instruct printing. This would be something + that was *not* parsed but was explicitly set. It's kind of like + inferred_promote_version, but explicitly set instead of being inferred by usage. + - Command line arguments to force printing to a specific version. + - Some future explicit tag such as [@reason.upgradeTo 3.8] *) +let cli_arg_promote_version = {major = -1; minor = -1} + +(* Print version starts out as the default, but then before printing we search for + any attributes in the AST that tell us to print differently, and if found we + update this. *) +let print_version = default_file_version + +let all_supported_file_versions = [ + default_file_version; + {major = 3; minor = 8} +] + +let latest_version_for_package = + List.nth all_supported_file_versions (List.length all_supported_file_versions - 1) + + +let is_set file_version = + file_version.major > 0 && file_version.minor > 0 + +let is_set_maj_min maj min = + maj > 0 && min > 0 + +let set_explicit_parse_version maj min = + cli_arg_parse_version.major <- maj; + cli_arg_parse_version.minor <- min + +let set_explicit_promote_version maj min = + cli_arg_promote_version.major <- maj; + cli_arg_promote_version.minor <- min + +(** + * We refine the inferred version based on feature usage. *) -let explicit_file_version = {contents = None} - -(** We start out with an inferred file version of 3.6, the last minor version - * that did not format a version into the file. *) -let infered_file_version = {contents = {major = 3; minor = 6;}} - -let set_explicit (major, minor) = - explicit_file_version.contents <- Some {major; minor} - -let effective () = match explicit_file_version.contents with - | Some efv -> efv - | None -> infered_file_version.contents - -let within - ~inclusive:lower_inclusive - (low_mjr, low_mnr) - ~inclusive:upper_inclusive - (up_mjr, up_mnr) = - let ev = effective () in - let mjr, mnr = ev.major, ev.minor in - let lower_meets = - if lower_inclusive then mjr > low_mjr || (mjr == low_mjr && mnr >= low_mnr) - else mjr > low_mjr || (mjr == low_mjr && mnr > low_mnr) - in - let upper_meets = - if upper_inclusive then mjr < up_mjr || (mjr == up_mjr && mnr <= up_mnr) - else mjr < up_mjr || (mjr == up_mjr && mnr < up_mnr) - in - lower_meets && upper_meets +let refine_inferred feature_used = match feature_used with + | AngleBracketTypes + | HashVariantsColonMethodCallStarClassTypes -> ( + let upgrade_to_maj = 3 in + let upgrade_to_min = 8 in + if inferred_promote_version.major < upgrade_to_maj || + (inferred_promote_version.major == upgrade_to_maj && + inferred_promote_version.minor < upgrade_to_min) then ( + inferred_promote_version.major <- upgrade_to_maj; + inferred_promote_version.minor <- upgrade_to_min + ) + ) + +let record_explicit_version_in_ast_if_not_yet major minor = + if not (is_set version_in_ast_attr) then ( + version_in_ast_attr.major <- major; + version_in_ast_attr.minor <- minor + ) -let at_least (major, minor) = - within ~inclusive:true (major, minor) ~inclusive:true (10000,0) +(* Allocationless accessor that allows previewing effective version. + - First any observed version token in the ASt. + - Then abscent that, any cli --parse-version. + - Then the default parse version. + *) +let effective_parse_version_major () = + if version_in_ast_attr.major >= 0 then + version_in_ast_attr.major + else + (if cli_arg_parse_version.major >= 0 then cli_arg_parse_version.major else default_file_version.major) + +(* Allocationless accessor that allows previewing effective version. + - First any observed version token in the ASt. + - Then abscent that, any cli --parse-version. + - Then the default parse version. + *) +let effective_parse_version_minor () = + if version_in_ast_attr.minor >= 0 then + version_in_ast_attr.minor + else + (if cli_arg_parse_version.minor >= 0 then cli_arg_parse_version.minor else default_file_version.minor) + +(* Effective version to promote to. Unlike effective_parse_version_major, what + * you pass as the command line --promote-version takes precedence over what is + * observed in the AST (such as inferred upgrades) *) +let effective_promote_version_major () = + if cli_arg_promote_version.major >= 0 then + cli_arg_promote_version.major + else ( + if inferred_promote_version.major >= 0 then + inferred_promote_version.major + else + effective_parse_version_major () + ) + +let effective_promote_version_minor () = + if cli_arg_promote_version.minor >= 0 then + cli_arg_promote_version.minor + else ( + if inferred_promote_version.minor >= 0 then + inferred_promote_version.minor + else + effective_parse_version_minor () + ) + +let version_within mjr mnr ~inclusive:low_incl (low_mjr, low_mnr) ~inclusive:up_inc (up_mjr, up_mnr) = + let lower_meets = + if low_incl then mjr > low_mjr || (mjr == low_mjr && mnr >= low_mnr) + else mjr > low_mjr || (mjr == low_mjr && mnr > low_mnr) + in + let upper_meets = + if up_inc then mjr < up_mjr || (mjr == up_mjr && mnr <= up_mnr) + else mjr < up_mjr || (mjr == up_mjr && mnr < up_mnr) + in + lower_meets && upper_meets + +let parse_version_within ~inclusive = + let mjr = effective_parse_version_major () in + let mnr = effective_parse_version_minor () in + (* Since this relies on side effects, we need to not use partial application + * without any label *) + version_within mjr mnr ~inclusive + +let print_version_within ~inclusive = + let mjr = print_version.major in + let mnr = print_version.minor in + (* Since this relies on side effects, we need to not use partial application + * without any label *) + version_within mjr mnr ~inclusive + +(* Fast version of checker to be able to use in tight lexer loops *) +let fast_parse_supports_HashVariantsColonMethodCallStarClassTypes () = + let mjr = effective_parse_version_major () in + let mnr = effective_parse_version_minor () in + (mjr == 3 && mnr >= 8) || mjr > 3 + +let parse_version_at_least (major, minor) = + parse_version_within ~inclusive:true (major, minor) ~inclusive:true (10000,0) + +let print_version_at_least (major, minor) = + print_version_within ~inclusive:true (major, minor) ~inclusive:true (10000,0) -let supports = function - | AngleBracketTypes -> at_least (3, 8) +let parse_supports = function + | AngleBracketTypes -> parse_version_at_least (3, 8) + | HashVariantsColonMethodCallStarClassTypes -> parse_version_at_least (3, 8) +let print_supports = function + | AngleBracketTypes -> print_version_at_least (3, 8) + | HashVariantsColonMethodCallStarClassTypes -> print_version_at_least (3, 8) let dummy_loc () = { loc_start = Lexing.dummy_pos; @@ -101,7 +240,76 @@ let _split_on_char sep_char str = done; String.sub str 0 j.contents :: r.contents +(** + * A note on "promotion". + * We will infer that we should auto-upgrade based on usage of certain + * features. + * + * Promotion either upgrades the version tag during injection of the + * (otherwise) default version tag, or it upgrades/rewrites tags during print + * time if tags were already present. + *) module Ast_nodes = struct + let parse_version v = + match _split_on_char '.' v, "0" with + | ([maj], mnr) + | ([maj; ""], mnr) + | (maj :: mnr :: _, _) -> + let imaj, imin = int_of_string maj, int_of_string mnr in + Some (imaj, imin) + | _ -> None + + let is_structure_version_attribute = function + | { pstr_desc=( + Pstr_attribute ({ + attr_name={txt="reason.version"; _}; + attr_payload = + PStr [ + {pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Pconst_float(v, _)); _} as b,_); _} as c + ]; + _ + } as a) + ); _ + } as structure_item -> + (match parse_version v with + | Some(imaj, imin) -> + let updater new_maj new_min = + let new_v = string_of_int new_maj ^ "." ^ string_of_int new_min in + let new_payload_desc = { + c with + pstr_desc=Pstr_eval({b with pexp_desc=Pexp_constant(Pconst_float(new_v, None))},[]) + } in + let new_pstr_desc = Pstr_attribute {a with attr_payload = PStr [new_payload_desc]} in + {structure_item with pstr_desc = new_pstr_desc} + in + Some (updater, imaj, imin) + | _ -> None) + | _ -> None + + let is_sig_version_attribute = function + | { psig_desc=( + Psig_attribute ({ + attr_name={txt="reason.version"; _}; + attr_payload = PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Pconst_float(v, _)); _} as b, _); _} as c]; + _ + } as a) + ); _ + } as sig_item -> + (match parse_version v with + | Some(imaj, imin) -> + let updater new_maj new_min = + let new_v = string_of_int new_maj ^ "." ^ string_of_int new_min in + let new_payload_desc = { + c with + pstr_desc=Pstr_eval({b with pexp_desc=Pexp_constant(Pconst_float(new_v, None))},[]) + } in + let new_psig_desc = Psig_attribute {a with attr_payload = PStr [new_payload_desc]} in + {sig_item with psig_desc = new_psig_desc} + in + Some (updater, imaj, imin) + | _ -> None) + | _ -> None + let mk_warning_attribute_payload ~loc msg = let exp = Exp.mk ~loc (Pexp_constant (Pconst_string(msg, None))) in let item = { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } in @@ -114,79 +322,63 @@ module Ast_nodes = struct let item = { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } in PStr [item] + (* let should_promote ~inferred_min ~inferred_maj ~explicit = *) + (* let {major = inf_major; minor = inf_minor} = inferred in *) + (* let {major = exp_major; minor = exp_minor} = explicit in *) + (* is_set inferred && *) + (* (not (is_set explicit) || *) + (* inf_major > exp_major || inf_major == exp_major && inf_minor > exp_minor) *) + + (* + * splice_fallback is the splicer that will place an attribute at the best + * possible place. It starts out as just inserting at the head, but if a + * better place is discovered (according to insert_after) a new splice_fallback + * is created - then used if an update never occured. + *) + let replace_or_inject_item ~attribute_tester ~insert_after ~creator maj min items = + let rec impl ~splicer ~rev_prev items = + match items with + | [] -> + let loc = dummy_loc () in + let attr_payload = mk_version_attr_payload maj min in + let created = (creator ~loc {attr_name={loc; txt="reason.version"}; attr_payload; attr_loc=loc}) in + splicer created + | hd :: tl -> + (match attribute_tester hd with + | None -> + let splicer = + if insert_after hd then fun itm -> List.rev rev_prev @ hd :: itm :: tl else splicer + in + impl ~splicer ~rev_prev:(hd :: rev_prev) tl + | Some(updater, _old_maj, _old_min) -> (List.rev rev_prev) @ updater maj min :: tl + ) + in + impl ~splicer:(fun itm -> itm :: items) ~rev_prev:[] items + (** Creates an attribute to inject into the AST if it was not already present *) - let inject_attr_from_version itms ~insert_after ~creator = - let loc = dummy_loc () in - match explicit_file_version.contents with - | None -> - let major, minor = package_version.major, package_version.minor in - let attr_payload = mk_version_attr_payload major minor in - let created = (creator ~loc {attr_name={loc; txt="reason.version"}; attr_payload; attr_loc=loc}) in - (match itms with - | first :: rest when insert_after first -> - first :: created :: rest - | _ -> created :: itms - ) - | Some efv -> begin - if efv.major > package_version.major || - (efv.major == package_version.major && efv.minor > package_version.minor) then - let efv_mjr = string_of_int efv.major in - let efv_mnr = string_of_int efv.minor in - let pkg_mjr = string_of_int package_version.major in - let pkg_mnr = string_of_int package_version.minor in - let msg = - "This file specifies a reason.version " ^ efv_mjr ^ "." ^ efv_mnr ^ - " which is greater than the package version " ^ pkg_mjr ^ "." ^ pkg_mnr ^ - " Either upgrade the Reason package or lower the version specified in [@reason.version ]." in - (* let loc = match itms with *) - (* | hd :: _ -> hd.pstr_loc *) - (* | [] -> loc *) - (* in *) - let attr_payload = mk_warning_attribute_payload ~loc msg in - let created = (creator ~loc {attr_name={loc; txt="ocaml.ppwarn"}; attr_payload; attr_loc=loc}) in - created :: itms - else itms - end + let inject_attr_for_printing ~attribute_tester ~insert_after ~creator itms = + let major = effective_promote_version_major () in + let minor = effective_promote_version_minor () in + replace_or_inject_item ~attribute_tester ~insert_after ~creator major minor itms - let inject_attr_from_version_impl itms = + (* Injects a version attribute if none was present. We don't do any inferred promotion here. + * The reason is that this will already happen in the printer if parsing and printing are done + * within the same process (the mutable inferred version will be retained and used to inform + * the printer which version of the syntax to print to (and how it should replace version attributes + * with rewritten ones according to the version that was inferred. *) + let inject_attr_to_instruct_printing_impl itms = let insert_after = function | {pstr_desc = Pstr_attribute {attr_name = {txt="ocaml.doc"|"ocaml.text"; _}; _}; _} -> true | _ -> false in let creator = (fun ~loc x -> Str.mk ~loc (Pstr_attribute x)) in - inject_attr_from_version itms ~insert_after ~creator + inject_attr_for_printing ~attribute_tester:is_structure_version_attribute ~insert_after ~creator itms - let inject_attr_from_version_intf itms = + let inject_attr_to_instruct_printing_intf itms = let insert_after = function | {psig_desc = Psig_attribute {attr_name = {txt="ocaml.doc"|"ocaml.text"; _}; _}; _} -> true | _ -> false in let creator = (fun ~loc x -> Sig.mk ~loc (Psig_attribute x)) in - inject_attr_from_version itms ~insert_after ~creator - - let extract_version_attribute_structure_item structure_item = - (match structure_item with - | {pstr_desc=(Pstr_attribute { - attr_name={txt="reason.version"; _}; - attr_payload = PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Pconst_float(v, _)); _},_); _}]; - _ - }); _} -> - (match _split_on_char '.' v with - | [maj] | [maj; ""] -> Some (int_of_string maj, 0) - | maj :: mnr :: _ -> Some (int_of_string maj, int_of_string mnr) - | _ -> None); - | _ -> None) - - let extract_version_attribute_signature_item sig_item = - (match sig_item with - | {psig_desc=(Psig_attribute { - attr_name={txt="reason.version"; _}; - attr_payload = PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Pconst_float(v, _)); _},_); _}]; - _ - }); _} -> - (match _split_on_char '.' v with - | [maj] | [maj; ""] -> Some (int_of_string maj, 0) - | maj :: mnr :: _ -> Some (int_of_string maj, int_of_string mnr) - | _ -> None); - | _ -> None) + inject_attr_for_printing ~attribute_tester:is_sig_version_attribute ~insert_after ~creator itms end diff --git a/src/refmt/refmt_args.ml b/src/refmt/refmt_args.ml index ca371517e..7890b6e66 100644 --- a/src/refmt/refmt_args.ml +++ b/src/refmt/refmt_args.ml @@ -45,6 +45,37 @@ let print_width = let doc = "wrapping width for printing the AST" in Arg.(value & opt (int) (80) & info ["w"; "print-width"] ~docv ~doc) +let _version_options = + List.map + (fun fv -> + let major, minor = string_of_int fv.Reason_version.major, string_of_int fv.minor in + (major ^ "." ^ minor), fv) + Reason_version.all_supported_file_versions + +let unspecified_version = Reason_version.unspecified () +let version_options = ("default", unspecified_version) :: _version_options + +let parse_version = + let docv = "INT.INT" in + let doc = + "Sets the default assumed print of Reason Syntax to parse. \ + Usually refmt will assume 3.7, until it sees otherwise such as [@reason.version 3.8]. \ + Passing x.y for this option causes refmt to assume x.y until it an attribute requesting \ + otherwise." in + let opts = Arg.enum version_options in + Arg.(value & opt opts unspecified_version & info ["parse-version"] ~docv ~doc) + +let promote_version = + let docv = "INT.INT" in + let doc = + "Forces the parser to rewrite the Reason Syntax version attribute at \ + parse time, causing the printer to print it in the promoted version. \ + If no existing attribute was present, one will be injected at parse time \ + as usual." in + let opts = Arg.enum version_options in + Arg.(value & opt opts unspecified_version & info ["promote-version"] ~docv ~doc) + + let heuristics_file = let doc = "load path as a heuristics file to specify which constructors carry a tuple \ diff --git a/src/refmt/refmt_impl.ml b/src/refmt/refmt_impl.ml index 8b3403a9b..51d407a64 100644 --- a/src/refmt/refmt_impl.ml +++ b/src/refmt/refmt_impl.ml @@ -29,6 +29,8 @@ let refmt print_width heuristics_file in_place + parse_version + promote_version input_files = let refmt_single input_file = @@ -59,6 +61,8 @@ let refmt | (true, _) -> Some input_file | (false, _) -> None in + Reason_version.set_explicit_parse_version parse_version.Reason_version.major parse_version.minor; + Reason_version.set_explicit_promote_version promote_version.Reason_version.major promote_version.minor; let (module Printer : Printer_maker.PRINTER) = if interface then (module Reason_interface_printer) else (module Reason_implementation_printer) @@ -117,6 +121,8 @@ let refmt_t = $ print_width $ heuristics_file $ in_place + $ parse_version + $ promote_version $ input let () =