parser crashes on polymorphic variant type (#540)

* fix crash on polymorphic variant type

* add testcase

* fix pattern matching priority in parsePolymorphicVariantType

* Put parseTagName at the toplevel.

Co-authored-by: sehoon <sehoon@sehoonui-MacBookPro.local>
Co-authored-by: Cristiano Calcagno <cristianoc@users.noreply.github.com>

Author: 3 people

src/res_core.ml

@@ -4968,19 +4968,7 @@ and parsePolymorphicVariantType ~attrs p =
     Parser.optional p Bar |> ignore;
     let rowField = parseTagSpecFull p in
     let rowFields = parseTagSpecFulls p in
-    let tagNames =
-      if p.token == GreaterThan
-      then begin
-        Parser.next p;
-        let rec loop p = match p.Parser.token with
-          | Rbracket -> []
-          | _ ->
-            let (ident, _loc) = parseHashIdent ~startPos:p.startPos p in
-            ident :: loop p
-        in
-        loop p
-      end
-      else [] in
+    let tagNames = parseTagNames p in
     let variant =
       let loc = mkLoc startPos p.prevEndPos in
       Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed (Some tagNames) in
@@ -4995,6 +4983,20 @@ and parsePolymorphicVariantType ~attrs p =
     Parser.expect Rbracket p;
     variant
 
+and parseTagName p =
+  match p.Parser.token with
+  | Hash ->
+    let (ident, _loc) = parseHashIdent ~startPos:p.startPos p in
+    Some ident
+  | _ -> None
+
+and parseTagNames p =
+  if p.Parser.token == GreaterThan then
+    (Parser.next p;
+    parseRegion p ~grammar:Grammar.TagNames ~f:parseTagName)
+  else
+    []
+
 and parseTagSpecFulls p =
   match p.Parser.token with
   | Rbracket ->
@@ -6449,4 +6451,4 @@ let parseSpecification p : Parsetree.signature =
 
 (* module structure on the file level *)
 let parseImplementation p : Parsetree.structure =
-  parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion
+  parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion

src/res_grammar.ml

@@ -58,6 +58,7 @@ type t =
   | JsFfiImport
   | Pattern
   | AttributePayload
+  | TagNames
 
 let toString = function
   | OpenDescription -> "an open description"
@@ -118,6 +119,7 @@ let toString = function
   | Pattern -> "pattern"
   | ExprFor -> "a for expression"
   | AttributePayload -> "an attribute payload"
+  | TagNames -> "tag names"
 
 let isSignatureItemStart = function
   | Token.At
@@ -336,6 +338,7 @@ let isListElement grammar token =
   | JsxAttribute -> isJsxAttributeStart token
   | JsFfiImport -> isJsFfiImportStart token
   | AttributePayload -> token = Lparen
+  | TagNames -> token = Hash
   | _ -> false
 
 let isListTerminator grammar token =
@@ -361,6 +364,7 @@ let isListTerminator grammar token =
   | PackageConstraint, token when token <> And -> true
   | ConstructorDeclaration, token when token <> Bar -> true
   | AttributePayload, Rparen -> true
+  | TagNames, Rbracket -> true
 
   | _ -> false
 

tests/parsing/infiniteLoops/expected/polymorphicVariantType.res.txt

@@ -0,0 +1,9 @@
+
+  Syntax error!
+  tests/parsing/infiniteLoops/polymorphicVariantType.res:1:14
+
+  1 │ type x = [<y>
+
+  Did you forget a `]` here?
+
+type nonrec x = [< y]

tests/parsing/infiniteLoops/polymorphicVariantType.res

@@ -0,0 +1 @@
+type x = [<y>