From 3307d4804188c86e0138c8c8108e4c78ad5436d3 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: --- esy.json | 2 +- .../expected_output/arityConversion.re | 1 + .../expected_output/attributes.re | 2 +- .../autoUpgradeAngleBrackets.re | 14 + .../autoUpgradeAngleBracketsNoVersionAttr.re | 13 + .../autoUpgradeDoNotAutoUpgrade.re | 5 + .../expected_output/comments.re | 1 + .../expected_output/comments.rei | 9 +- .../expected_output/comments.rei.4.07.0 | 1 + .../expected_output/comments.rei.4.07.1 | 1 + .../expected_output/comments.rei.4.08.0 | 1 + .../expected_output/comments.rei.4.09.0 | 1 + .../expected_output/mlSyntax.re | 4 +- .../expected_output/oo_3_dot_8.re | 50 +- .../expected_output/typeParameters.re | 40 +- .../expected_output/typeParameters_3_dot_8.re | 4 + .../expected_output/variants_3_dot_8.re | 545 ++++++++++++++++++ .../typeCheckedTests/input/arityConversion.ml | 2 + .../input/autoUpgradeAngleBrackets.re | 14 + .../autoUpgradeAngleBracketsNoVersionAttr.re | 12 + .../input/autoUpgradeDoNotAutoUpgrade.re | 5 + formatTest/typeCheckedTests/input/comments.ml | 3 + .../typeCheckedTests/input/comments.mli | 3 + .../input/features406.4.06.0.ml | 1 + .../input/features408.4.08.0.ml | 1 + .../input/features408.4.08.0.mli | 1 + .../typeCheckedTests/input/knownMlIssues.ml | 1 + formatTest/typeCheckedTests/input/mlSyntax.ml | 1 + .../typeCheckedTests/input/mlVariants.ml | 1 + .../typeCheckedTests/input/oo_3_dot_8.re | 50 +- .../typeCheckedTests/input/pervasive.mli | 3 +- .../input/specificMLSyntax.4.04.0.ml | 1 + .../typeCheckedTests/input/typeParameters.re | 6 + .../input/typeParameters_3_dot_8.re | 8 + .../input/variants_3_dot_8.re | 466 +++++++++++++++ .../unit_tests/expected_output/class_types.re | 12 + .../expected_output/class_types_3_dot_8.re | 2 +- .../expected_output/ocaml_identifiers.re | 2 +- formatTest/unit_tests/input/class_types.re | 15 + .../unit_tests/input/class_types_3_dot_8.re | 2 +- .../unit_tests/input/ocaml_identifiers.ml | 3 +- src/reason-parser/dune | 2 +- .../reason_declarative_lexer.mll | 167 ++++-- src/reason-parser/reason_lexer.ml | 14 +- src/reason-parser/reason_parser.mly | 195 ++++--- src/reason-parser/reason_pprint_ast.ml | 123 ++-- src/reason-parser/reason_single_parser.ml | 18 +- src/reason-version/dune | 2 + src/reason-version/reason_version.ml | 432 ++++++++++---- src/refmt/refmt_args.ml | 31 + src/refmt/refmt_impl.ml | 6 + src/rtop/reason_util.ml | 2 +- src/rtop/reason_utop.ml | 2 +- 53 files changed, 1942 insertions(+), 361 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/expected_output/variants_3_dot_8.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 create mode 100644 formatTest/typeCheckedTests/input/variants_3_dot_8.re diff --git a/esy.json b/esy.json index a1051a524..03b6d3af6 100644 --- a/esy.json +++ b/esy.json @@ -85,6 +85,6 @@ }, "scripts": { "test": "esy x make test-once-installed", - "doc": "esy dune build @doc" + "doc": "esy build dune build @doc" } } diff --git a/formatTest/typeCheckedTests/expected_output/arityConversion.re b/formatTest/typeCheckedTests/expected_output/arityConversion.re index 737d0e6b8..f03595db5 100644 --- a/formatTest/typeCheckedTests/expected_output/arityConversion.re +++ b/formatTest/typeCheckedTests/expected_output/arityConversion.re @@ -1,4 +1,5 @@ [@reason.version 3.7]; + Some((1, 2, 3)); type bcd = diff --git a/formatTest/typeCheckedTests/expected_output/attributes.re b/formatTest/typeCheckedTests/expected_output/attributes.re index 4b4448366..8d3fd665b 100644 --- a/formatTest/typeCheckedTests/expected_output/attributes.re +++ b/formatTest/typeCheckedTests/expected_output/attributes.re @@ -7,9 +7,9 @@ * This has a nice side effect when printing the terms: * If a node has attributes attached to it, */; -[@reason.version 3.7]; /**Floating comment text should be removed*/; +[@reason.version 3.7]; /** * Core language features: 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/comments.re b/formatTest/typeCheckedTests/expected_output/comments.re index 9bee88955..530e1e7ec 100644 --- a/formatTest/typeCheckedTests/expected_output/comments.re +++ b/formatTest/typeCheckedTests/expected_output/comments.re @@ -1,6 +1,7 @@ /* **** comment */ /*** comment */ /** docstring */; + [@reason.version 3.7]; /* comment */ diff --git a/formatTest/typeCheckedTests/expected_output/comments.rei b/formatTest/typeCheckedTests/expected_output/comments.rei index a5ec2cc99..8bc5460c0 100644 --- a/formatTest/typeCheckedTests/expected_output/comments.rei +++ b/formatTest/typeCheckedTests/expected_output/comments.rei @@ -1,15 +1,16 @@ /* **** comment */ /*** comment */ -/*** docstring */ +/** docstring */; + +[@reason.version 3.7]; + /* comment */ -/*** docstring */ +/** docstring */; /*** comment */ /**** comment */ /***** comment */ /** */; -[@reason.version 3.7]; - /*** */ /**** */ diff --git a/formatTest/typeCheckedTests/expected_output/comments.rei.4.07.0 b/formatTest/typeCheckedTests/expected_output/comments.rei.4.07.0 index 7749a396e..8bc5460c0 100644 --- a/formatTest/typeCheckedTests/expected_output/comments.rei.4.07.0 +++ b/formatTest/typeCheckedTests/expected_output/comments.rei.4.07.0 @@ -1,6 +1,7 @@ /* **** comment */ /*** comment */ /** docstring */; + [@reason.version 3.7]; /* comment */ diff --git a/formatTest/typeCheckedTests/expected_output/comments.rei.4.07.1 b/formatTest/typeCheckedTests/expected_output/comments.rei.4.07.1 index 7749a396e..8bc5460c0 100644 --- a/formatTest/typeCheckedTests/expected_output/comments.rei.4.07.1 +++ b/formatTest/typeCheckedTests/expected_output/comments.rei.4.07.1 @@ -1,6 +1,7 @@ /* **** comment */ /*** comment */ /** docstring */; + [@reason.version 3.7]; /* comment */ diff --git a/formatTest/typeCheckedTests/expected_output/comments.rei.4.08.0 b/formatTest/typeCheckedTests/expected_output/comments.rei.4.08.0 index 7749a396e..8bc5460c0 100644 --- a/formatTest/typeCheckedTests/expected_output/comments.rei.4.08.0 +++ b/formatTest/typeCheckedTests/expected_output/comments.rei.4.08.0 @@ -1,6 +1,7 @@ /* **** comment */ /*** comment */ /** docstring */; + [@reason.version 3.7]; /* comment */ diff --git a/formatTest/typeCheckedTests/expected_output/comments.rei.4.09.0 b/formatTest/typeCheckedTests/expected_output/comments.rei.4.09.0 index 7749a396e..8bc5460c0 100644 --- a/formatTest/typeCheckedTests/expected_output/comments.rei.4.09.0 +++ b/formatTest/typeCheckedTests/expected_output/comments.rei.4.09.0 @@ -1,6 +1,7 @@ /* **** comment */ /*** comment */ /** docstring */; + [@reason.version 3.7]; /* comment */ diff --git a/formatTest/typeCheckedTests/expected_output/mlSyntax.re b/formatTest/typeCheckedTests/expected_output/mlSyntax.re index 98290479c..a314853f3 100644 --- a/formatTest/typeCheckedTests/expected_output/mlSyntax.re +++ b/formatTest/typeCheckedTests/expected_output/mlSyntax.re @@ -1,8 +1,8 @@ /* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */ -/** +/*** * Testing pattern matching using ml syntax to exercise nesting of cases. - */; + */ [@reason.version 3.7]; type xyz = 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..21bee45a2 100644 --- a/formatTest/typeCheckedTests/expected_output/typeParameters.re +++ b/formatTest/typeCheckedTests/expected_output/typeParameters.re @@ -1,29 +1,33 @@ /** * Testing type parameters. */; -[@reason.version 3.7]; +[@reason.version 3.8]; -type threeThings('t) = ('t, 't, 't); -type listOf('t) = list('t); +module type ListItem = {let x: int;}; -type underscoreParam(_) = +let myListOfModules: list = []; + +type threeThings<'t> = ('t, 't, 't); +type listOf<'t> = list<'t>; + +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 +50,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/expected_output/typeParameters_3_dot_8.re b/formatTest/typeCheckedTests/expected_output/typeParameters_3_dot_8.re index c3bc2a35c..21bee45a2 100644 --- a/formatTest/typeCheckedTests/expected_output/typeParameters_3_dot_8.re +++ b/formatTest/typeCheckedTests/expected_output/typeParameters_3_dot_8.re @@ -3,6 +3,10 @@ */; [@reason.version 3.8]; +module type ListItem = {let x: int;}; + +let myListOfModules: list = []; + type threeThings<'t> = ('t, 't, 't); type listOf<'t> = list<'t>; diff --git a/formatTest/typeCheckedTests/expected_output/variants_3_dot_8.re b/formatTest/typeCheckedTests/expected_output/variants_3_dot_8.re new file mode 100644 index 000000000..aa0165731 --- /dev/null +++ b/formatTest/typeCheckedTests/expected_output/variants_3_dot_8.re @@ -0,0 +1,545 @@ +[@reason.version 3.8]; + +/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */ + +type tt<'a> = int; + +module LocalModule = { + type accessedThroughModule = + | AccessedThroughModule; + type accessedThroughModuleWithArg = + | AccessedThroughModuleWith(int) + | AccessedThroughModuleWithTwo(int, int); +}; + +type notTupleVariant = + | NotActuallyATuple(int, int); +type attr1 = ..; +type attr1 += + | A(int); +type attr1 += + | Point(int, int); +type attr1 += + | PointA({ + a: int, + b: int, + }); + +type notTupleVariantExtraParens = + | NotActuallyATuple2(int, int); + +type simpleTupleVariant = + | SimpleActuallyATuple((int, int)); + +type tupleVariant = + | ActuallyATuple((int, int)); + +let intTuple = (20, 20); + +let notTupled: notTupleVariant = + NotActuallyATuple(10, 10); + +/* Doesn't work because we've correctly annotated parse tree nodes with explicit_arity! */ +/* let notTupled: notTupleVariant = NotActuallyATuple (10, 10); */ +let funcOnNotActuallyATuple = + (NotActuallyATuple(x, y)) => + x + y; + +/* let funcOnNotActuallyATuple (NotActuallyATuple (x, y)) = x + y; */ +/* let notTupled: notTupleVariant = NotActuallyATuple intTuple; /*Doesn't work! */ */ +/* At least the above acts as proof that there *is* a distinction that is + honored. */ +let simpleTupled: simpleTupleVariant = + SimpleActuallyATuple((10, 10)); + +let simpleTupled: simpleTupleVariant = + SimpleActuallyATuple(intTuple); + +/*Works! */ +let NotActuallyATuple(x, y) = + NotActuallyATuple(10, 20); + +let yesTupled: tupleVariant = + ActuallyATuple((10, 10)); + +let yesTupled: tupleVariant = + ActuallyATuple(intTuple); + +type threeForms = + | FormOne(int) + | FormTwo(int) + | FormThree; + +let doesntCareWhichForm = x => + switch (x) { + | FormOne(q) + | FormTwo(q) => 10 + | FormThree => 20 + }; + +let doesntCareWhichFormAs = x => + switch (x) { + | FormOne(q) as _ppp + | FormTwo(q) as _ppp => 10 + | FormThree => 20 + }; +type otherThingInheritedFrom = [ | #Base]; +type colorList1 = [ + otherThingInheritedFrom + | #Red + | #Black +]; + +type colorList2 = [ + | #Red + | #Black + | otherThingInheritedFrom +]; +type foo = [ | #foo]; +type colorList3 = [ + colorList2 + | foo + | #Red + | #Black + | foo +]; + +/** + * In order to get this to typecheck you must admit the row variable. But it strangely + * does not type check on 4.06 and earlier. + * + * Therefore, we are including this in the unit tests but not the type checked tests. + + type lessThanGreaterThan<'a> = + [< | #Red | #Black | #Blue > #Red #Black] as 'a; + +*/ + +type colorList<'a> = + [< + | #Red(int, int) &(int) + | #Black&(int, int) &(int) + | #Blue + ] as 'a; + +1 + doesntCareWhichForm(FormOne(10)); + +1 + doesntCareWhichForm(FormTwo(10)); + +1 + doesntCareWhichForm(FormThree); + +/* Destructured matching at function definition */ +let accessDeeply = + (LocalModule.AccessedThroughModule) => 10; + +let accessDeeplyWithArg = + ( + LocalModule.AccessedThroughModuleWith(x) | + LocalModule.AccessedThroughModuleWithTwo( + _, + x, + ), + ) => x; + +/* Destructured matching *not* at function definition */ +let accessDeeply = x => + switch (x) { + | LocalModule.AccessedThroughModule => 10 + }; + +let accessDeeplyWithArg = x => + switch (x) { + | LocalModule.AccessedThroughModuleWith(x) => 10 + | _ => 0 + }; + +/* In OCaml's syntax, to capture the wrapped data, you do: + * + * let myFunc x = function | `Blah (p as retVal) -> retVal` + * + * In OCaml's syntax, to capture the entire pattern you do: + * + * let myFunc x = function | `Blah p as retVal -> retVal` + */ +let accessDeeply = x => + switch (x) { + | LocalModule.AccessedThroughModule as _ppp => 1 + }; + +let accessDeeplyWithArg = x => + switch (x) { + | LocalModule.AccessedThroughModuleWith( + x as retVal, + ) => + retVal + 1 + | LocalModule.AccessedThroughModuleWithTwo( + x as retVal1, + y as retVal2, + ) => + retVal1 + retVal2 + 1 + }; + +/* Just to show that by default `as` captures much less aggresively */ +let rec accessDeeplyWithArgRecursive = + (x, count) => + switch (x) { + | LocalModule.AccessedThroughModuleWith(x) as entirePattern => + /* It captures the whole pattern */ + if (count > 0) { + 0; + } else { + accessDeeplyWithArgRecursive( + entirePattern, + count - 1, + ); + } + | LocalModule.AccessedThroughModuleWithTwo( + x, + y, + ) as entirePattern => + /* It captures the whole pattern */ + if (count > 0) { + 0; + } else { + accessDeeplyWithArgRecursive( + entirePattern, + count - 1, + ); + } + }; + +accessDeeplyWithArgRecursive( + LocalModule.AccessedThroughModuleWith(10), + 10, +); + +type combination<'a> = + | HeresTwoConstructorArguments(int, int); + +/** But then how do we parse matches in function arguments? */ +/* We must require parenthesis around construction matching in function args only*/ +let howWouldWeMatchFunctionArgs = + (HeresTwoConstructorArguments(x, y)) => + x + y; + +/* How would we annotate said arg? */ +let howWouldWeMatchFunctionArgs = + ( + HeresTwoConstructorArguments(x, y): + combination<'wat>, + ) => + x + y; + +let matchingTwoCurriedConstructorsInTuple = x => + switch (x) { + | ( + HeresTwoConstructorArguments(x, y), + HeresTwoConstructorArguments(a, b), + ) => + x + y + a + b + }; + +type twoCurriedConstructors = + | TwoCombos( + combination, + combination, + ); + +let matchingTwoCurriedConstructorInConstructor = + x => + switch (x) { + | TwoCombos( + HeresTwoConstructorArguments(x, y), + HeresTwoConstructorArguments(a, b), + ) => + a + b + x + y + }; + +type twoCurriedConstructorsPolyMorphic<'a> = + | TwoCombos( + combination<'a>, + combination<'a>, + ); + +/* Matching records */ +type pointRecord = { + x: int, + y: int, +}; + +type alsoHasARecord = + | Blah + | AlsoHasARecord(int, int, pointRecord); + +let result = + switch ( + AlsoHasARecord(10, 10, {x: 10, y: 20}) + ) { + | Blah => 1000 + | AlsoHasARecord(a, b, {x, y}) => + a + b + x + y + }; + +let rec commentPolymorphicCases: + 'a. + option<'a> => int + = + fun + | Some(a) => 1 + /* Comment on one */ + | None => 0; +type numbers = + | Zero + | One(int) + | Three(int, int, int); +let something = Zero; +let testSwitch = + switch (something) { + | Zero + | One(_) => 10 + | Three(_, _, _) => 100 + }; + +let thisWillCompileButLetsSeeHowItFormats = + fun + | Zero + | Three(_, _, _) => 10 + | One(_) => 20; + +/* Comment on two */ +/** + * GADTs. + */ +type term<_> = + | Int(int): term + | Add: term<(int, int) => int> + | App(term<'b => 'a>, term<'b>): term<'a>; + +let rec eval: type a. term => a = + fun + | Int(n) => n + /* a = int */ + | Add => ((x, y) => x + y) + /* a = int => int => int */ + | App(f, x) => eval(f, eval(x)); + +let rec eval: type a. term => a = + x => + switch (x) { + | Int(n) => n + /* a = int */ + | Add => ((x, y) => x + y) + /* a = int => int => int */ + | App(f, x) => eval(f, eval(x)) + }; + +/* eval called at types (b=>a) and b for fresh b */ +let evalArg = App(App(Add, Int(1)), Int(1)); + +let two = + eval(App(App(Add, Int(1)), Int(1))); + +type someVariant = + | Purple(int) + | Yellow(int); + +let Purple(x) | Yellow(x) = + switch (Yellow(100), Purple(101)) { + | (Yellow(y), Purple(p)) => Yellow(p + y) + | (Purple(p), Yellow(y)) => Purple(y + p) + | (Purple(p), Purple(y)) => Yellow(y + p) + | (Yellow(p), Yellow(y)) => Purple(y + p) + }; + +type tuples = + | Zero + | One(int) + | Two(int, int) + | OneTuple(int, int); + +let myTuple = OneTuple(20, 30); + +let res = + switch (myTuple) { + | Two(y, z) => + try(Two(y, z)) { + | Invalid_argument(_) => Zero + } + | One(_) => + switch (One(4)) { + | One(_) => Zero + | _ => Zero + } + | _ => Zero + }; + +/* FIXME type somePolyVariant = [ `Purple int | `Yellow int]; */ + +let ylw = #Yellow((100, 100)); + +let prp = #Purple((101, 100)); + +let res = + switch (ylw, prp) { + | (#Yellow(y, y2), #Purple(p, p2)) => + #Yellow((p + y, 0)) + | (#Purple(p, p2), #Yellow(y, y2)) => + #Purple((y + p, 0)) + | (#Purple(p, p2), #Purple(y, y2)) => + #Yellow((y + p, 0)) + | (#Yellow(p, p2), #Yellow(y, y2)) => + #Purple((y + p, 0)) + }; + +let ylw = #Yellow(100); + +let prp = #Purple(101); + +let res = + switch (ylw, prp) { + | (#Yellow(y), #Purple(p)) => #Yellow(p + y) + | (#Purple(p), #Yellow(y)) => #Purple(y + p) + | (#Purple(p), #Purple(y)) => #Yellow(y + p) + | (#Yellow(p), #Yellow(y)) => #Purple(y + p) + }; + +/* + * Now try polymorphic variants with *actual* tuples. + * You'll notice that these become indistinguishable from multiple constructor + * args! explicit_arity doesn't work on polymorphic variants! + * + * Way to resolve this (should also work for non-polymorphic variants): + * + * If you see *one* simple expr list that is a tuple, generate: + * Pexp_tuple (Pexp_tuple ..)) + * + * If you see *one* simple expr list that is *not* a tuple, generate: + * Pexp.. + * + * If you see *multiple* simple exprs, generate: + * Pexp_tuple.. + * + * Though, I'm not sure this will even work. + */ +let ylw = #Yellow((100, 100)); + +let prp = #Purple((101, 101)); + +let res = + switch (ylw, prp) { + | (#Yellow(y, y2), #Purple(p, p2)) => + #Yellow((p + y, 0)) + | (#Purple(p, p2), #Yellow(y, y2)) => + #Purple((y + p, 0)) + | (#Purple(p, p2), #Purple(y, y2)) => + #Yellow((y + p, 0)) + | (#Yellow(p, p2), #Yellow(y, y2)) => + #Purple((y + p, 0)) + }; + +type contentHolder<'a> = + | ContentHolderWithReallyLongNameCauseBreak( + 'a, + ) + | ContentHolder('a); + +/* + * When pretty printed, this appears to be multi-argument constructors. + */ +let prp = #Purple((101, 101)); + +let res = + switch (prp) { + | #Yellow(y, y2) => #Yellow((y2 + y, 0)) + | #Purple(p, p2) => #Purple((p2 + p, 0)) + }; + +/* + * Testing extensible variants + */ +type attr = ..; + +/* `of` is optional */ +type attr += + | StrString(string); + +type attr += + | Point2(int, int); + +type attr += + | Float(float) + | Char(char); + +type tag<'props> = ..; + +type titleProps = {title: string}; + +type tag<'props> += + | Title: tag + | Count(int): tag; + +module Graph = { + type node = ..; + type node += + | Str; +}; + +type Graph.node += + | Str = Graph.Str; + +type water = ..; + +type water += + pri + | Ocean; + +type water += + pri + | MineralWater + | SpringWater + | TapWater + | TableWater; +module Expr = { + type Graph.node += + | Node + | Atom; +}; +module F = { + type Graph.node += + pri + | Node = Expr.Node; +}; + +type Graph.node += + pri + | Node = Expr.Node + | Atom = Expr.Atom; + +type singleUnit = + | MyConstructorWithSingleUnitArg(unit); +/* without single unit arg sugar */ +MyConstructorWithSingleUnitArg(); +/* with single unit arg sugar */ +MyConstructorWithSingleUnitArg(); +/* without single unit arg sugar */ +#polyVariantWithSingleUnitArg(); +/* with single unit arg sugar */ +#polyVariantWithSingleUnitArg(); + +let x = #Poly; + +/* Format doc attrs consistent: https://github.com/facebook/reason/issues/2187 */ +type t = + | /** This is some documentation that might be fairly long and grant a line break */ + A + | /** Shorter docs */ + B + | /** Some more longer docs over here that make sense to break lines on too */ + C; + +/* https://github.com/facebook/reason/issues/1828 */ +type widget_state = [ + | #DEFAULT /* here */ + | #HOVER + | #ACTIVE +]; diff --git a/formatTest/typeCheckedTests/input/arityConversion.ml b/formatTest/typeCheckedTests/input/arityConversion.ml index d464f9172..5a7a76bb9 100644 --- a/formatTest/typeCheckedTests/input/arityConversion.ml +++ b/formatTest/typeCheckedTests/input/arityConversion.ml @@ -1,3 +1,5 @@ +[@@@reason.version 3.7] +;; Some (1, 2, 3) type bcd = TupleConstructor of (int * int) | MultiArgumentsConstructor of int * int 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/comments.ml b/formatTest/typeCheckedTests/input/comments.ml index b710320fc..4891b41c0 100644 --- a/formatTest/typeCheckedTests/input/comments.ml +++ b/formatTest/typeCheckedTests/input/comments.ml @@ -1,6 +1,9 @@ (* **** comment *) (*** comment *) (** docstring *) + +[@@@reason.version 3.7] + (* comment *) (** docstring *) (*** comment *) diff --git a/formatTest/typeCheckedTests/input/comments.mli b/formatTest/typeCheckedTests/input/comments.mli index 3c749db48..3bf8c001e 100644 --- a/formatTest/typeCheckedTests/input/comments.mli +++ b/formatTest/typeCheckedTests/input/comments.mli @@ -1,6 +1,9 @@ (* **** comment *) (*** comment *) (** docstring *) + +[@@@reason.version 3.7] + (* comment *) (** docstring *) (*** comment *) diff --git a/formatTest/typeCheckedTests/input/features406.4.06.0.ml b/formatTest/typeCheckedTests/input/features406.4.06.0.ml index 4be05c44b..1a634d7dc 100644 --- a/formatTest/typeCheckedTests/input/features406.4.06.0.ml +++ b/formatTest/typeCheckedTests/input/features406.4.06.0.ml @@ -1,3 +1,4 @@ +[@@@reason.version 3.7] module EM = struct (** Exception *) exception E of int * int diff --git a/formatTest/typeCheckedTests/input/features408.4.08.0.ml b/formatTest/typeCheckedTests/input/features408.4.08.0.ml index 52e986cae..fcd35b65a 100644 --- a/formatTest/typeCheckedTests/input/features408.4.08.0.ml +++ b/formatTest/typeCheckedTests/input/features408.4.08.0.ml @@ -1,3 +1,4 @@ +[@@@reason.version 3.7] open struct type t = string end diff --git a/formatTest/typeCheckedTests/input/features408.4.08.0.mli b/formatTest/typeCheckedTests/input/features408.4.08.0.mli index faf535a98..6e86b694a 100644 --- a/formatTest/typeCheckedTests/input/features408.4.08.0.mli +++ b/formatTest/typeCheckedTests/input/features408.4.08.0.mli @@ -1,3 +1,4 @@ +[@@@reason.version 3.7] module X : sig type t end diff --git a/formatTest/typeCheckedTests/input/knownMlIssues.ml b/formatTest/typeCheckedTests/input/knownMlIssues.ml index 47529ca40..2230a3895 100644 --- a/formatTest/typeCheckedTests/input/knownMlIssues.ml +++ b/formatTest/typeCheckedTests/input/knownMlIssues.ml @@ -1,3 +1,4 @@ +[@@@reason.version 3.7] (* [x] fixed *) type t2 = int * int (* attributed to entire type not binding *) diff --git a/formatTest/typeCheckedTests/input/mlSyntax.ml b/formatTest/typeCheckedTests/input/mlSyntax.ml index e501ecec2..ad2da79ed 100644 --- a/formatTest/typeCheckedTests/input/mlSyntax.ml +++ b/formatTest/typeCheckedTests/input/mlSyntax.ml @@ -3,6 +3,7 @@ (** * Testing pattern matching using ml syntax to exercise nesting of cases. *) +[@@@reason.version 3.7] type xyz = diff --git a/formatTest/typeCheckedTests/input/mlVariants.ml b/formatTest/typeCheckedTests/input/mlVariants.ml index 603edee27..ddbc282fc 100644 --- a/formatTest/typeCheckedTests/input/mlVariants.ml +++ b/formatTest/typeCheckedTests/input/mlVariants.ml @@ -1,3 +1,4 @@ +[@@@reason.version 3.7] (* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. *) type polyVariantsInMl = [ 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/typeCheckedTests/input/pervasive.mli b/formatTest/typeCheckedTests/input/pervasive.mli index 7a6400e32..22c36a6b7 100644 --- a/formatTest/typeCheckedTests/input/pervasive.mli +++ b/formatTest/typeCheckedTests/input/pervasive.mli @@ -1,5 +1,6 @@ +[@@@reason.version 3.7] val ( = ) : 'a -> 'a -> bool val ( <> ) : 'a -> 'a -> bool -val not : bool -> bool \ No newline at end of file +val not : bool -> bool diff --git a/formatTest/typeCheckedTests/input/specificMLSyntax.4.04.0.ml b/formatTest/typeCheckedTests/input/specificMLSyntax.4.04.0.ml index e1f0df6fa..32d3452d8 100644 --- a/formatTest/typeCheckedTests/input/specificMLSyntax.4.04.0.ml +++ b/formatTest/typeCheckedTests/input/specificMLSyntax.4.04.0.ml @@ -1,3 +1,4 @@ +[@@@reason.version 3.7] module Foo = struct type t = { name: string } end diff --git a/formatTest/typeCheckedTests/input/typeParameters.re b/formatTest/typeCheckedTests/input/typeParameters.re index 08e084825..f6e183c60 100644 --- a/formatTest/typeCheckedTests/input/typeParameters.re +++ b/formatTest/typeCheckedTests/input/typeParameters.re @@ -3,6 +3,12 @@ */ [@reason.version 3.7]; +module type ListItem = { + let x : int; +}; + +let myListOfModules: list(module ListItem) = []; + type threeThings<'t> = ('t, 't, 't); type listOf<'t> = list<'t>; diff --git a/formatTest/typeCheckedTests/input/typeParameters_3_dot_8.re b/formatTest/typeCheckedTests/input/typeParameters_3_dot_8.re index c7d6710bf..810aa0b20 100644 --- a/formatTest/typeCheckedTests/input/typeParameters_3_dot_8.re +++ b/formatTest/typeCheckedTests/input/typeParameters_3_dot_8.re @@ -3,6 +3,14 @@ */ [@reason.version 3.8]; + +module type ListItem = { + let x : int; +}; + +let myListOfModules: list = []; + + type threeThings<'t> = ('t, 't, 't); type listOf<'t> = list<'t>; diff --git a/formatTest/typeCheckedTests/input/variants_3_dot_8.re b/formatTest/typeCheckedTests/input/variants_3_dot_8.re new file mode 100644 index 000000000..9e1797229 --- /dev/null +++ b/formatTest/typeCheckedTests/input/variants_3_dot_8.re @@ -0,0 +1,466 @@ +[@reason.version 3.8]; + +/* Copyright (c) 2015-present, Facebook, Inc. All rights reserved. */ + +type tt<'a> = int; + +module LocalModule = { + type accessedThroughModule = + | AccessedThroughModule; + type accessedThroughModuleWithArg = + | AccessedThroughModuleWith(int) + | AccessedThroughModuleWithTwo(int, int); +}; + +type notTupleVariant = + | NotActuallyATuple(int, int); +type attr1 = ..; +type attr1 += + | A(int); +type attr1 += + | Point(int, int); +type attr1 += + | PointA({ + a: int, + b: int, + }); + +type notTupleVariantExtraParens = + | NotActuallyATuple2(int, int); + +type simpleTupleVariant = + | SimpleActuallyATuple((int, int)); + +type tupleVariant = + | ActuallyATuple((int, int)); + +let intTuple = (20, 20); + +let notTupled: notTupleVariant = NotActuallyATuple(10, 10); + +/* Doesn't work because we've correctly annotated parse tree nodes with explicit_arity! */ +/* let notTupled: notTupleVariant = NotActuallyATuple (10, 10); */ +let funcOnNotActuallyATuple = (NotActuallyATuple(x, y)) => x + y; + +/* let funcOnNotActuallyATuple (NotActuallyATuple (x, y)) = x + y; */ +/* let notTupled: notTupleVariant = NotActuallyATuple intTuple; /*Doesn't work! */ */ +/* At least the above acts as proof that there *is* a distinction that is + honored. */ +let simpleTupled: simpleTupleVariant = SimpleActuallyATuple((10, 10)); + +let simpleTupled: simpleTupleVariant = SimpleActuallyATuple(intTuple); + +/*Works! */ +let NotActuallyATuple(x, y) = NotActuallyATuple(10, 20); + +let yesTupled: tupleVariant = ActuallyATuple((10, 10)); + +let yesTupled: tupleVariant = ActuallyATuple(intTuple); + +type threeForms = + | FormOne(int) + | FormTwo(int) + | FormThree; + +let doesntCareWhichForm = x => + switch (x) { + | FormOne(q) + | FormTwo(q) => 10 + | FormThree => 20 + }; + +let doesntCareWhichFormAs = x => + switch (x) { + | FormOne(q) as _ppp + | FormTwo(q) as _ppp => 10 + | FormThree => 20 + }; +type otherThingInheritedFrom = [ | #Base]; +type colorList1 = [ otherThingInheritedFrom | #Red | #Black]; + +type colorList2 = [ | #Red | #Black | otherThingInheritedFrom]; +type foo = [ | #foo]; +type colorList3 = [ colorList2 | foo | #Red | #Black | foo]; + +/** + * In order to get this to typecheck you must admit the row variable. But it strangely + * does not type check on 4.06 and earlier. + * + * Therefore, we are including this in the unit tests but not the type checked tests. + + type lessThanGreaterThan<'a> = + [< | #Red | #Black | #Blue > #Red #Black] as 'a; + +*/ + + +type colorList<'a> = + [< | #Red(int, int) &(int) | #Black&(int, int) &(int) | #Blue] as 'a; + +1 + doesntCareWhichForm(FormOne(10)); + +1 + doesntCareWhichForm(FormTwo(10)); + +1 + doesntCareWhichForm(FormThree); + +/* Destructured matching at function definition */ +let accessDeeply = (LocalModule.AccessedThroughModule) => 10; + +let accessDeeplyWithArg = + ( + LocalModule.AccessedThroughModuleWith(x) | + LocalModule.AccessedThroughModuleWithTwo(_, x), + ) => x; + +/* Destructured matching *not* at function definition */ +let accessDeeply = x => + switch (x) { + | LocalModule.AccessedThroughModule => 10 + }; + +let accessDeeplyWithArg = x => + switch (x) { + | LocalModule.AccessedThroughModuleWith(x) => 10 + | _ => 0 + }; + +/* In OCaml's syntax, to capture the wrapped data, you do: + * + * let myFunc x = function | `Blah (p as retVal) -> retVal` + * + * In OCaml's syntax, to capture the entire pattern you do: + * + * let myFunc x = function | `Blah p as retVal -> retVal` + */ +let accessDeeply = x => + switch (x) { + | LocalModule.AccessedThroughModule as _ppp => 1 + }; + +let accessDeeplyWithArg = x => + switch (x) { + | LocalModule.AccessedThroughModuleWith(x as retVal) => retVal + 1 + | LocalModule.AccessedThroughModuleWithTwo(x as retVal1, y as retVal2) => + retVal1 + retVal2 + 1 + }; + +/* Just to show that by default `as` captures much less aggresively */ +let rec accessDeeplyWithArgRecursive = (x, count) => + switch (x) { + | LocalModule.AccessedThroughModuleWith(x) as entirePattern => + /* It captures the whole pattern */ + if (count > 0) { + 0; + } else { + accessDeeplyWithArgRecursive(entirePattern, count - 1); + } + | LocalModule.AccessedThroughModuleWithTwo(x, y) as entirePattern => + /* It captures the whole pattern */ + if (count > 0) { + 0; + } else { + accessDeeplyWithArgRecursive(entirePattern, count - 1); + } + }; + +accessDeeplyWithArgRecursive(LocalModule.AccessedThroughModuleWith(10), 10); + +type combination<'a> = + | HeresTwoConstructorArguments(int, int); + +/** But then how do we parse matches in function arguments? */ +/* We must require parenthesis around construction matching in function args only*/ +let howWouldWeMatchFunctionArgs = (HeresTwoConstructorArguments(x, y)) => + x + y; + +/* How would we annotate said arg? */ +let howWouldWeMatchFunctionArgs = + (HeresTwoConstructorArguments(x, y): combination<'wat>) => + x + y; + +let matchingTwoCurriedConstructorsInTuple = x => + switch (x) { + | (HeresTwoConstructorArguments(x, y), HeresTwoConstructorArguments(a, b)) => + x + y + a + b + }; + +type twoCurriedConstructors = + | TwoCombos(combination, combination); + +let matchingTwoCurriedConstructorInConstructor = x => + switch (x) { + | TwoCombos( + HeresTwoConstructorArguments(x, y), + HeresTwoConstructorArguments(a, b), + ) => + a + b + x + y + }; + +type twoCurriedConstructorsPolyMorphic<'a> = + | TwoCombos(combination<'a>, combination<'a>); + +/* Matching records */ +type pointRecord = { + x: int, + y: int, +}; + +type alsoHasARecord = + | Blah + | AlsoHasARecord(int, int, pointRecord); + +let result = + switch (AlsoHasARecord(10, 10, {x: 10, y: 20})) { + | Blah => 1000 + | AlsoHasARecord(a, b, {x, y}) => a + b + x + y + }; + +let rec commentPolymorphicCases: 'a. option<'a> => int = + fun + | Some(a) => 1 + /* Comment on one */ + | None => 0; +type numbers = + | Zero + | One(int) + | Three(int, int, int); +let something = Zero; +let testSwitch = + switch (something) { + | Zero + | One(_) => 10 + | Three(_, _, _) => 100 + }; + +let thisWillCompileButLetsSeeHowItFormats = + fun + | Zero + | Three(_, _, _) => 10 + | One(_) => 20; + +/* Comment on two */ +/** + * GADTs. + */ +type term<_> = + | Int(int): term + | Add: term<(int, int) => int> + | App(term<'b => 'a>, term<'b>): term<'a>; + +let rec eval: type a. term => a = + fun + | Int(n) => n + /* a = int */ + | Add => ((x, y) => x + y) + /* a = int => int => int */ + | App(f, x) => eval(f, eval(x)); + +let rec eval: type a. term => a = + x => + switch (x) { + | Int(n) => n + /* a = int */ + | Add => ((x, y) => x + y) + /* a = int => int => int */ + | App(f, x) => eval(f, eval(x)) + }; + +/* eval called at types (b=>a) and b for fresh b */ +let evalArg = App(App(Add, Int(1)), Int(1)); + +let two = eval(App(App(Add, Int(1)), Int(1))); + +type someVariant = + | Purple(int) + | Yellow(int); + +let Purple(x) | Yellow(x) = + switch (Yellow(100), Purple(101)) { + | (Yellow(y), Purple(p)) => Yellow(p + y) + | (Purple(p), Yellow(y)) => Purple(y + p) + | (Purple(p), Purple(y)) => Yellow(y + p) + | (Yellow(p), Yellow(y)) => Purple(y + p) + }; + +type tuples = + | Zero + | One(int) + | Two(int, int) + | OneTuple(int, int); + +let myTuple = OneTuple(20, 30); + +let res = + switch (myTuple) { + | Two(y, z) => + try(Two(y, z)) { + | Invalid_argument(_) => Zero + } + | One(_) => + switch (One(4)) { + | One(_) => Zero + | _ => Zero + } + | _ => Zero + }; + +/* FIXME type somePolyVariant = [ `Purple int | `Yellow int]; */ + +let ylw = #Yellow((100, 100)); + +let prp = #Purple((101, 100)); + +let res = + switch (ylw, prp) { + | (#Yellow(y, y2), #Purple(p, p2)) => #Yellow((p + y, 0)) + | (#Purple(p, p2), #Yellow(y, y2)) => #Purple((y + p, 0)) + | (#Purple(p, p2), #Purple(y, y2)) => #Yellow((y + p, 0)) + | (#Yellow(p, p2), #Yellow(y, y2)) => #Purple((y + p, 0)) + }; + +let ylw = #Yellow(100); + +let prp = #Purple(101); + +let res = + switch (ylw, prp) { + | (#Yellow(y), #Purple(p)) => #Yellow(p + y) + | (#Purple(p), #Yellow(y)) => #Purple(y + p) + | (#Purple(p), #Purple(y)) => #Yellow(y + p) + | (#Yellow(p), #Yellow(y)) => #Purple(y + p) + }; + +/* + * Now try polymorphic variants with *actual* tuples. + * You'll notice that these become indistinguishable from multiple constructor + * args! explicit_arity doesn't work on polymorphic variants! + * + * Way to resolve this (should also work for non-polymorphic variants): + * + * If you see *one* simple expr list that is a tuple, generate: + * Pexp_tuple (Pexp_tuple ..)) + * + * If you see *one* simple expr list that is *not* a tuple, generate: + * Pexp.. + * + * If you see *multiple* simple exprs, generate: + * Pexp_tuple.. + * + * Though, I'm not sure this will even work. + */ +let ylw = #Yellow((100, 100)); + +let prp = #Purple((101, 101)); + +let res = + switch (ylw, prp) { + | (#Yellow(y, y2), #Purple(p, p2)) => #Yellow((p + y, 0)) + | (#Purple(p, p2), #Yellow(y, y2)) => #Purple((y + p, 0)) + | (#Purple(p, p2), #Purple(y, y2)) => #Yellow((y + p, 0)) + | (#Yellow(p, p2), #Yellow(y, y2)) => #Purple((y + p, 0)) + }; + +type contentHolder<'a> = + | ContentHolderWithReallyLongNameCauseBreak('a) + | ContentHolder('a); + +/* + * When pretty printed, this appears to be multi-argument constructors. + */ +let prp = #Purple((101, 101)); + +let res = + switch (prp) { + | #Yellow(y, y2) => #Yellow((y2 + y, 0)) + | #Purple(p, p2) => #Purple((p2 + p, 0)) + }; + +/* + * Testing extensible variants + */ +type attr = ..; + +/* `of` is optional */ +type attr += + | StrString(string); + +type attr += + | Point2(int, int); + +type attr += + | Float(float) + | Char(char); + +type tag<'props> = ..; + +type titleProps = {title: string}; + +type tag<'props> += + | Title: tag + | Count(int): tag; + +module Graph = { + type node = ..; + type node += + | Str; +}; + +type Graph.node += + | Str = Graph.Str; + +type water = ..; + +type water += + pri + | Ocean; + +type water += + pri + | MineralWater + | SpringWater + | TapWater + | TableWater; +module Expr = { + type Graph.node += + | Node + | Atom; +}; +module F ={ + type Graph.node += + pri + | Node = Expr.Node; +} + +type Graph.node += + pri + | Node = Expr.Node + | Atom = Expr.Atom; + +type singleUnit = + | MyConstructorWithSingleUnitArg(unit); +/* without single unit arg sugar */ +MyConstructorWithSingleUnitArg(); +/* with single unit arg sugar */ +MyConstructorWithSingleUnitArg(); +/* without single unit arg sugar */ +#polyVariantWithSingleUnitArg(); +/* with single unit arg sugar */ +#polyVariantWithSingleUnitArg(); + +let x = #Poly; + +/* Format doc attrs consistent: https://github.com/facebook/reason/issues/2187 */ +type t = + | /** This is some documentation that might be fairly long and grant a line break */ + A + | /** Shorter docs */ + B + | /** Some more longer docs over here that make sense to break lines on too */ + C; + +/* https://github.com/facebook/reason/issues/1828 */ +type widget_state = [ + | #DEFAULT /* here */ + | #HOVER + | #ACTIVE +]; 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/expected_output/ocaml_identifiers.re b/formatTest/unit_tests/expected_output/ocaml_identifiers.re index f0acc8ca0..945520670 100644 --- a/formatTest/unit_tests/expected_output/ocaml_identifiers.re +++ b/formatTest/unit_tests/expected_output/ocaml_identifiers.re @@ -1,5 +1,5 @@ -[@reason.version 3.7]; /* Type names (supported with PR#2342) */ +[@reason.version 3.7]; module T = { type pub_ = unit; }; 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/formatTest/unit_tests/input/ocaml_identifiers.ml b/formatTest/unit_tests/input/ocaml_identifiers.ml index 61182be31..ea330e6fc 100644 --- a/formatTest/unit_tests/input/ocaml_identifiers.ml +++ b/formatTest/unit_tests/input/ocaml_identifiers.ml @@ -1,4 +1,5 @@ (* Type names (supported with PR#2342) *) +[@@@reason.version 3.7] module T = struct type pub = unit end @@ -92,4 +93,4 @@ let x = List.map (fun y -> (); y) -let newType (type method_) () = () \ No newline at end of file +let newType (type method_) () = () diff --git a/src/reason-parser/dune b/src/reason-parser/dune index ed7c91640..f553e6938 100644 --- a/src/reason-parser/dune +++ b/src/reason-parser/dune @@ -86,7 +86,7 @@ (public_name reason) (wrapped false) (flags - (:standard -w -9-52 -safe-string)) + (:standard -short-paths -w -9-52 -safe-string)) (modules ocaml_util reason_syntax_util reason_comment reason_attributes reason_layout reason_heuristics reason_location reason_toolchain_conf reason_toolchain_reason reason_toolchain_ocaml reason_toolchain 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..8dc9280ea 100644 --- a/src/reason-parser/reason_parser.mly +++ b/src/reason-parser/reason_parser.mly @@ -946,6 +946,12 @@ let rewriteFunctorApp module_name elt loc = else mkexp ~loc (Pexp_ident {txt=Ldot (module_name, elt); loc}) + +let rec jsx_has_functor_app = function + | Lident _ -> false + | Ldot (l, _) -> jsx_has_functor_app l + | Lapply (_, _) -> true + let jsx_component lid attrs children loc = let is_module_name = function | Lident s @@ -1024,6 +1030,12 @@ let raise_record_trailing_semi_error loc = "Record entries are separated by comma; \ we've found a semicolon instead." +let raise_functor_app_with_lident_access loc = + syntax_error_exp loc + "JSX syntax does not allow accessing a specific lower cased identifier \ + after functor application such as " + + let raise_record_trailing_semi_error' loc = (Some (raise_record_trailing_semi_error loc), []) @@ -1133,7 +1145,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 +1198,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 +1240,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 +1307,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 +1399,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 +1467,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 +1475,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 +2754,26 @@ 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 - { let name = Longident.parse $2.txt in + | 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) DOT LIDENT jsx_arguments + { + if jsx_has_functor_app $2.txt then + let name = Longident.parse $4 in + (fun _children _loc -> + raise_functor_app_with_lident_access (mklocation $startpos($4) $endpos($4))), + name + else ( + let name = Ldot($2.txt, $4) in + let loc_long_ident = mklocation $startpos($2) $endpos($4) in + (jsx_component {loc = loc_long_ident; txt = name} $5, name) + ) + } + | 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 +2863,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 +2882,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 +2940,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 +3057,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 +3173,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 +3767,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 +3817,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 +3837,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 +4545,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 +4890,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 +4919,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 +5043,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 +5209,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..2ccd2d157 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 @@ -2837,7 +2863,7 @@ let printer = object(self:'self) let ct = self#core_type arg in let ct = match arg.ptyp_desc with | Ptyp_tuple _ -> ct - | _ -> typeParameterBookends [ct] + | _ -> formatPrecedence ct in if i == 0 && not opt_ampersand then ct @@ -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/dune b/src/reason-version/dune index 2ebd0782b..8aa69dc93 100644 --- a/src/reason-version/dune +++ b/src/reason-version/dune @@ -3,4 +3,6 @@ (public_name reason.version) (modules reason_version) (libraries ocaml-migrate-parsetree) + (flags + (:standard -short-paths -safe-string)) ) diff --git a/src/reason-version/reason_version.ml b/src/reason-version/reason_version.ml index 000371c54..e2236d2e0 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,75 @@ 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_between) a new splice_fallback + * is created - then used if an update never occured. + *) + let replace_or_inject_item ~attribute_tester ~insert_between ~creator maj min items = + let rec impl ~splicer ~rev_prev items = + match (items : 'a list) 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_between rev_prev items then fun itm -> List.rev rev_prev @ itm :: items 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_between ~creator itms = + let major = effective_promote_version_major () in + let minor = effective_promote_version_minor () in + replace_or_inject_item ~attribute_tester ~insert_between ~creator major minor itms - let inject_attr_from_version_impl itms = - let insert_after = function - | {pstr_desc = Pstr_attribute {attr_name = {txt="ocaml.doc"|"ocaml.text"; _}; _}; _} -> true + (* 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 is_floating_str_comment = function + | {pstr_desc = Pstr_attribute {attr_name = {txt="ocaml.doc"|"ocaml.text"; _}; _}; _} -> true + | _ -> false + let is_floating_sig_comment = function + | {psig_desc = Psig_attribute {attr_name = {txt="ocaml.doc"|"ocaml.text"; _}; _}; _} -> true + | _ -> false + let inject_attr_to_instruct_printing_impl itms = + (* Inserts after the first one or two floating comments *) + let insert_between rev_prev remaining = match rev_prev, remaining with + | [second; first], _third when is_floating_str_comment second && is_floating_str_comment first -> true + | [first], (second :: _) when is_floating_str_comment first && not (is_floating_str_comment second) -> true + | [first], [] when is_floating_str_comment first -> 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_between ~creator itms - let inject_attr_from_version_intf itms = - let insert_after = function - | {psig_desc = Psig_attribute {attr_name = {txt="ocaml.doc"|"ocaml.text"; _}; _}; _} -> true + let inject_attr_to_instruct_printing_intf itms = + (* Inserts after the first one or two floating comments *) + let insert_between rev_prev remaining = match rev_prev, remaining with + | [second; first], _third when is_floating_sig_comment second && is_floating_sig_comment first -> true + | [first], (second :: _) when is_floating_sig_comment first && not (is_floating_sig_comment second) -> true + | [first], [] when is_floating_sig_comment first -> 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_between ~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 () = diff --git a/src/rtop/reason_util.ml b/src/rtop/reason_util.ml index 056fa1464..fbead1f64 100644 --- a/src/rtop/reason_util.ml +++ b/src/rtop/reason_util.ml @@ -1,5 +1,5 @@ (** - * Some of this was coppied from @whitequark's m17n project. + * Some of this was coppied from whitequark's m17n project. *) (* * Portions Copyright (c) 2015-present, Facebook, Inc. diff --git a/src/rtop/reason_utop.ml b/src/rtop/reason_utop.ml index 1b053f9bc..18605d7f5 100644 --- a/src/rtop/reason_utop.ml +++ b/src/rtop/reason_utop.ml @@ -1,5 +1,5 @@ (** - * Some of this was coppied from @whitequark's m17n project. + * Some of this was coppied from whitequark's m17n project. *) (* * Portions Copyright (c) 2015-present, Facebook, Inc.