implement exhaustive switch completion

Author: zth

analysis/src/CompletionBackEnd.ml

@@ -232,6 +232,7 @@ let detail name (kind : Completion.kind) =
           |> String.concat ", ")
         ^ ")")
     ^ "\n\n" ^ s
+  | Snippet s -> s
 
 let findAllCompletions ~(env : QueryEnv.t) ~prefix ~exact ~namesUsed
     ~(completionContext : Completable.completionContext) =
@@ -552,6 +553,7 @@ let mkItem ~name ~kind ~detail ~deprecated ~docstring =
       sortText = None;
       insertText = None;
       insertTextFormat = None;
+      filterText = None;
     }
 
 let completionToItem
@@ -563,14 +565,15 @@ let completionToItem
       sortText;
       insertText;
       insertTextFormat;
+      filterText;
     } =
   let item =
     mkItem ~name
       ~kind:(Completion.kindToInt kind)
       ~deprecated ~detail:(detail name kind) ~docstring
   in
   if !Cfg.supportsSnippets then
-    {item with sortText; insertText; insertTextFormat}
+    {item with sortText; insertText; insertTextFormat; filterText}
   else item
 
 let completionsGetTypeEnv = function
@@ -1304,3 +1307,69 @@ let rec processCompletable ~debug ~full ~scope ~env ~pos ~forHover
           in
           items @ regularCompletions
         | _ -> items)))
+  | CexhaustiveSwitch {contextPath; exprLoc} ->
+    let range = Utils.rangeOfLoc exprLoc in
+    let printFailwithStr num =
+      "${" ^ string_of_int num ^ ":failwith(\"todo\")}"
+    in
+    let withExhaustiveItem ~cases ?(startIndex = 0) (c : Completion.t) =
+      (* We don't need to write out `switch` here since we know that's what the
+         user has already written. Just complete for the rest. *)
+      let newText =
+        c.name ^ " {\n"
+        ^ (cases
+          |> List.mapi (fun index caseText ->
+                 "| " ^ caseText ^ " => "
+                 ^ printFailwithStr (startIndex + index + 1))
+          |> String.concat "\n")
+        ^ "\n}"
+        |> Utils.indent range.start.character
+      in
+      [
+        c;
+        {
+          c with
+          name = c.name ^ " (exhaustive switch)";
+          filterText = Some c.name;
+          insertTextFormat = Some Snippet;
+          insertText = Some newText;
+          kind = Snippet "insert exhaustive switch for value";
+        };
+      ]
+    in
+    let completionsForContextPath =
+      contextPath
+      |> getCompletionsForContextPath ~full ~opens ~rawOpens ~allFiles ~pos ~env
+           ~exact:forHover ~scope
+    in
+    completionsForContextPath
+    |> List.map (fun (c : Completion.t) ->
+           match c.kind with
+           | Value typExpr -> (
+             match typExpr |> TypeUtils.extractType ~env:c.env ~package with
+             | Some (Tvariant v) ->
+               withExhaustiveItem c
+                 ~cases:
+                   (v.constructors
+                   |> List.map (fun (constructor : Constructor.t) ->
+                          constructor.cname.txt
+                          ^
+                          match constructor.args with
+                          | Args [] -> ""
+                          | _ -> "(_)"))
+             | Some (Tpolyvariant v) ->
+               withExhaustiveItem c
+                 ~cases:
+                   (v.constructors
+                   |> List.map (fun (constructor : polyVariantConstructor) ->
+                          "| #" ^ constructor.name
+                          ^
+                          match constructor.args with
+                          | [] -> ""
+                          | _ -> "(_)"))
+             | Some (Toption (_env, _typ)) ->
+               withExhaustiveItem c ~cases:["Some($1)"; "None"] ~startIndex:1
+             | Some (Tbool _) -> withExhaustiveItem c ~cases:["true"; "false"]
+             | _ -> [c])
+           | _ -> [c])
+    |> List.flatten

analysis/src/CompletionFrontEnd.ml

@@ -353,14 +353,18 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor ~text =
   let unsetLookingForPat () = lookingForPat := None in
   (* Identifies expressions where we can do typed pattern or expr completion. *)
   let typedCompletionExpr (exp : Parsetree.expression) =
-    if
-      exp.pexp_loc
-      |> CursorPosition.classifyLoc ~pos:posBeforeCursor
-      = HasCursor
-    then
+    if exp.pexp_loc |> CursorPosition.locHasCursor ~pos:posBeforeCursor then
       match exp.pexp_desc with
-      | Pexp_match (_exp, []) ->
-        (* No cases means there's no `|` yet in the switch *) ()
+      (* No cases means there's no `|` yet in the switch *)
+      | Pexp_match (({pexp_desc = Pexp_ident _} as expr), []) -> (
+        if locHasCursor expr.pexp_loc then
+          (* We can do exhaustive switch completion if this is an ident we can
+             complete from. *)
+          match exprToContextPath expr with
+          | None -> ()
+          | Some contextPath ->
+            setResult (CexhaustiveSwitch {contextPath; exprLoc = exp.pexp_loc}))
+      | Pexp_match (_expr, []) -> ()
       | Pexp_match
           ( exp,
             [

analysis/src/Protocol.ml

@@ -47,6 +47,7 @@ type completionItem = {
   tags: int list;
   detail: string;
   sortText: string option;
+  filterText: string option;
   insertTextFormat: insertTextFormat option;
   insertText: string option;
   documentation: markupContent option;
@@ -129,6 +130,7 @@ let stringifyCompletionItem c =
           | None -> null
           | Some doc -> stringifyMarkupContent doc) );
       ("sortText", optWrapInQuotes c.sortText);
+      ("filterText", optWrapInQuotes c.filterText);
       ("insertText", optWrapInQuotes c.insertText);
       ( "insertTextFormat",
         match c.insertTextFormat with

analysis/src/SharedTypes.ml

@@ -305,19 +305,21 @@ module Completion = struct
     | PolyvariantConstructor of polyVariantConstructor * string
     | Field of field * string
     | FileModule of string
+    | Snippet of string
 
   type t = {
     name: string;
     sortText: string option;
     insertText: string option;
+    filterText: string option;
     insertTextFormat: Protocol.insertTextFormat option;
     env: QueryEnv.t;
     deprecated: string option;
     docstring: string list;
     kind: kind;
   }
 
-  let create ~kind ~env ?(docstring = []) name =
+  let create ~kind ~env ?(docstring = []) ?filterText name =
     {
       name;
       env;
@@ -327,10 +329,11 @@ module Completion = struct
       sortText = None;
       insertText = None;
       insertTextFormat = None;
+      filterText;
     }
 
-  let createWithSnippet ~name ?insertText ~kind ~env ?sortText ?(docstring = [])
-      () =
+  let createWithSnippet ~name ?insertText ~kind ~env ?sortText ?filterText
+      ?(docstring = []) () =
     {
       name;
       env;
@@ -340,6 +343,7 @@ module Completion = struct
       sortText;
       insertText;
       insertTextFormat = Some Protocol.Snippet;
+      filterText;
     }
 
   (* https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_completion *)
@@ -354,6 +358,7 @@ module Completion = struct
     | Field (_, _) -> 5
     | Type _ -> 22
     | Value _ -> 12
+    | Snippet _ -> 15
 end
 
 module Env = struct
@@ -613,6 +618,7 @@ module Completable = struct
         prefix: string;
         fallback: t option;
       }
+    | CexhaustiveSwitch of {contextPath: contextPath; exprLoc: Location.t}
 
   (** An extracted type from a type expr *)
   type extractedType =
@@ -720,6 +726,8 @@ module Completable = struct
         ^ (nestedPaths
           |> List.map (fun nestedPath -> nestedPathToString nestedPath)
           |> String.concat ", "))
+    | CexhaustiveSwitch {contextPath} ->
+      "CexhaustiveSwitch " ^ contextPathToString contextPath
 end
 
 module CursorPosition = struct

analysis/src/Utils.ml

@@ -181,4 +181,28 @@ let rec getUnqualifiedName txt =
   match txt with
   | Longident.Lident fieldName -> fieldName
   | Ldot (t, _) -> getUnqualifiedName t
-  | _ -> ""
+  | _ -> ""
+
+let indent n text =
+  let spaces = String.make n ' ' in
+  let len = String.length text in
+  let text =
+    if len != 0 && text.[len - 1] = '\n' then String.sub text 0 (len - 1)
+    else text
+  in
+  let lines = String.split_on_char '\n' text in
+  match lines with
+  | [] -> ""
+  | [line] -> line
+  | line :: lines ->
+    line ^ "\n"
+    ^ (lines |> List.map (fun line -> spaces ^ line) |> String.concat "\n")
+
+let mkPosition (pos : Pos.t) =
+  let line, character = pos in
+  {Protocol.line; character}
+
+let rangeOfLoc (loc : Location.t) =
+  let start = loc |> Loc.start |> mkPosition in
+  let end_ = loc |> Loc.end_ |> mkPosition in
+  {Protocol.start; end_}

analysis/src/Xform.ml

@@ -252,21 +252,6 @@ module AddTypeAnnotation = struct
         | _ -> ()))
 end
 
-let indent n text =
-  let spaces = String.make n ' ' in
-  let len = String.length text in
-  let text =
-    if len != 0 && text.[len - 1] = '\n' then String.sub text 0 (len - 1)
-    else text
-  in
-  let lines = String.split_on_char '\n' text in
-  match lines with
-  | [] -> ""
-  | [line] -> line
-  | line :: lines ->
-    line ^ "\n"
-    ^ (lines |> List.map (fun line -> spaces ^ line) |> String.concat "\n")
-
 let parse ~filename =
   let {Res_driver.parsetree = structure; comments} =
     Res_driver.parsingEngine.parseImplementation ~forPrinter:false ~filename
@@ -283,15 +268,15 @@ let parse ~filename =
     structure
     |> Res_printer.printImplementation ~width:!Res_cli.ResClflags.width
          ~comments:(comments |> filterComments ~loc:expr.pexp_loc)
-    |> indent range.start.character
+    |> Utils.indent range.start.character
   in
   let printStructureItem ~(range : Protocol.range)
       (item : Parsetree.structure_item) =
     let structure = [item] in
     structure
     |> Res_printer.printImplementation ~width:!Res_cli.ResClflags.width
          ~comments:(comments |> filterComments ~loc:item.pstr_loc)
-    |> indent range.start.character
+    |> Utils.indent range.start.character
   in
   (structure, printExpr, printStructureItem)
 

analysis/tests/src/ExhaustiveSwitch.res

@@ -0,0 +1,19 @@
+type someVariant = One | Two | Three(option<bool>)
+type somePolyVariant = [#one | #two | #three(option<bool>)]
+
+let withSomeVariant = One
+let withSomePoly: somePolyVariant = #one
+let someBool = true
+let someOpt = Some(true)
+
+// switch withSomeVarian
+//                      ^com
+
+// switch withSomePol
+//                   ^com
+
+// switch someBoo
+//               ^com
+
+// switch someOp
+//              ^com

analysis/tests/src/expected/ExhaustiveSwitch.res.txt

@@ -0,0 +1,80 @@
+Complete src/ExhaustiveSwitch.res 8:24
+XXX Not found!
+Completable: CexhaustiveSwitch Value[withSomeVarian]
+[{
+    "label": "withSomeVariant",
+    "kind": 12,
+    "tags": [],
+    "detail": "someVariant",
+    "documentation": null
+  }, {
+    "label": "withSomeVariant (exhaustive switch)",
+    "kind": 15,
+    "tags": [],
+    "detail": "insert exhaustive switch for value",
+    "documentation": null,
+    "filterText": "withSomeVariant",
+    "insertText": "withSomeVariant {\n   | One => ${1:failwith(\"todo\")}\n   | Two => ${2:failwith(\"todo\")}\n   | Three(_) => ${3:failwith(\"todo\")}\n   }",
+    "insertTextFormat": 2
+  }]
+
+Complete src/ExhaustiveSwitch.res 11:21
+XXX Not found!
+Completable: CexhaustiveSwitch Value[withSomePol]
+[{
+    "label": "withSomePoly",
+    "kind": 12,
+    "tags": [],
+    "detail": "somePolyVariant",
+    "documentation": null
+  }, {
+    "label": "withSomePoly (exhaustive switch)",
+    "kind": 15,
+    "tags": [],
+    "detail": "insert exhaustive switch for value",
+    "documentation": null,
+    "filterText": "withSomePoly",
+    "insertText": "withSomePoly {\n   | | #one => ${1:failwith(\"todo\")}\n   | | #three(_) => ${2:failwith(\"todo\")}\n   | | #two => ${3:failwith(\"todo\")}\n   }",
+    "insertTextFormat": 2
+  }]
+
+Complete src/ExhaustiveSwitch.res 14:17
+XXX Not found!
+Completable: CexhaustiveSwitch Value[someBoo]
+[{
+    "label": "someBool",
+    "kind": 12,
+    "tags": [],
+    "detail": "bool",
+    "documentation": null
+  }, {
+    "label": "someBool (exhaustive switch)",
+    "kind": 15,
+    "tags": [],
+    "detail": "insert exhaustive switch for value",
+    "documentation": null,
+    "filterText": "someBool",
+    "insertText": "someBool {\n   | true => ${1:failwith(\"todo\")}\n   | false => ${2:failwith(\"todo\")}\n   }",
+    "insertTextFormat": 2
+  }]
+
+Complete src/ExhaustiveSwitch.res 17:16
+XXX Not found!
+Completable: CexhaustiveSwitch Value[someOp]
+[{
+    "label": "someOpt",
+    "kind": 12,
+    "tags": [],
+    "detail": "option<bool>",
+    "documentation": null
+  }, {
+    "label": "someOpt (exhaustive switch)",
+    "kind": 15,
+    "tags": [],
+    "detail": "insert exhaustive switch for value",
+    "documentation": null,
+    "filterText": "someOpt",
+    "insertText": "someOpt {\n   | Some($1) => ${2:failwith(\"todo\")}\n   | None => ${3:failwith(\"todo\")}\n   }",
+    "insertTextFormat": 2
+  }]
+