Merge pull request #1944 from voodoos/fix-destruct-pprintast-hang

Fix destruct pprintast hang

Author: voodoos

CHANGES.md

@@ -17,6 +17,8 @@ unreleased
       to scopes bit masks when backtracking the typer cache (#1935)
     - Add a new selection field to outline results that contains the location of
       the symbol itself. (#1942)
+    - Fix destruct hanging when printing patterns with (::). (#1944, fixes
+      ocaml/ocaml-lsp#1489)
   + ocaml-index
     - Improve the granularity of index reading by segmenting the marshalization
       of the involved data-structures. (#1889)

src/ocaml/parsing/pprintast.ml

@@ -548,37 +548,28 @@ and pattern_or ctxt f x =
       pp f "@[<hov0>%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats
 
 and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
-  let rec pattern_list_helper f = function
-    | {ppat_desc =
-         Ppat_construct
-           ({ txt = Lident("::") ;_},
-            Some ([], {ppat_desc = Ppat_tuple([pat1; pat2]);_}));
-       ppat_attributes = []}
-
-      ->
-        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
-    | p -> pattern1 ctxt f p
-  in
   if x.ppat_attributes <> [] then pattern ctxt f x
   else match x.ppat_desc with
     | Ppat_variant (l, Some p) ->
         pp f "@[<2>`%a@;%a@]" ident_of_name l (simple_pattern ctxt) p
     | Ppat_construct (({txt=Lident("()"|"[]"|"true"|"false");_}), _) ->
         simple_pattern ctxt f x
-    | Ppat_construct (({txt;_} as li), po) ->
+    | Ppat_construct (
+        {txt=Lident("::");_},
+        Some ([], {ppat_desc = Ppat_tuple([pat1; pat2]);_}))
+      when x.ppat_attributes = [] ->
+        pp f "%a::%a" (simple_pattern ctxt) pat1 (pattern1 ctxt) pat2 (*RA*)
+    | Ppat_construct (li, po) ->
         (* FIXME The third field always false *)
-        if txt = Lident "::" then
-          pp f "%a" pattern_list_helper x
-        else
-          (match po with
-           | Some ([], x) ->
-               (* [true] and [false] are handled above *)
-               pp f "%a@;%a"  value_longident_loc li (simple_pattern ctxt) x
-           | Some (vl, x) ->
-               pp f "%a@ (type %a)@;%a" value_longident_loc li
-                 (list ~sep:"@ " ident_of_name_loc) vl
-                 (simple_pattern ctxt) x
-           | None -> pp f "%a" value_longident_loc li)
+        (match po with
+          | Some ([], x) ->
+              (* [true] and [false] are handled above *)
+              pp f "%a@;%a"  value_longident_loc li (simple_pattern ctxt) x
+          | Some (vl, x) ->
+              pp f "%a@ (type %a)@;%a" value_longident_loc li
+                (list ~sep:"@ " ident_of_name_loc) vl
+                (simple_pattern ctxt) x
+          | None -> pp f "%a" value_longident_loc li)
     | _ -> simple_pattern ctxt f x
 
 and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =

tests/test-dirs/lsp-issue1489.t

@@ -0,0 +1,25 @@
+  $ cat >repro.ml <<'EOF'
+  > type t = ( :: )
+  > let f (x: t) =  x
+  > EOF
+
+This should not hang and return a matching.
+  $ $MERLIN single case-analysis -start 2:16 -end 2:17 \
+  > -filename repro.ml <repro.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 16
+        },
+        "end": {
+          "line": 2,
+          "col": 17
+        }
+      },
+      "match x with | (::) -> _"
+    ],
+    "notifications": []
+  }