Syntactic completion

src/analysis/syntactic_completion.mli

@@ -0,0 +1,28 @@
+(* {{{ COPYING *(
+
+  This file is part of Merlin, an helper for ocaml editors
+
+  Copyright (C) 2013 - 2021  Frédéric Bour  <frederic.bour(_)lakaban.net>
+
+  Permission is hereby granted, free of charge, to any person obtaining a
+  copy of this software and associated documentation files (the "Software"),
+  to deal in the Software without restriction, including without limitation the
+  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+  sell copies of the Software, and to permit persons to whom the Software is
+  furnished to do so, subject to the following conditions:
+
+  The above copyright notice and this permission notice shall be included in
+  all copies or substantial portions of the Software.
+
+  The Software is provided "as is", without warranty of any kind, express or
+  implied, including but not limited to the warranties of merchantability,
+  fitness for a particular purpose and noninfringement. In no event shall
+  the authors or copyright holders be liable for any claim, damages or other
+  liability, whether in an action of contract, tort or otherwise, arising
+  from, out of or in connection with the software or the use or other dealings
+  in the Software.
+
+)* }}} *)
+
+val completion_for_parser :
+  'a Parser_raw.MenhirInterpreter.env -> (string * string) list

src/frontend/ocamlmerlin/query_json.ml

@@ -212,6 +212,7 @@ let string_of_completion_kind = function
   | `MethodCall  -> "#"
   | `Exn         -> "Exn"
   | `Class       -> "Class"
+  | `Syntax      -> "Syntax"
 
 let with_location ?(skip_none=false) loc assoc =
   if skip_none && loc = Location.none then

src/frontend/query_commands.ml

@@ -418,16 +418,32 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
         Some (Locate.get_doc ~config ~env ~local_defs
                 ~comments:(Mpipeline.reader_comments pipeline) ~pos)
     in
+    let syntactic =
+      let entries =
+        match Mpipeline.reader_snapshot_for_completion pipeline with
+        | None -> []
+        | Some (Snapshot env) -> Syntactic_completion.completion_for_parser env
+      in
+      List.filter_map entries ~f:begin fun (compl, suffix) ->
+        if String.is_prefixed ~by:prefix compl then
+          Some {Query_protocol.Compl.
+                 name = compl; kind = `Syntax;
+                 desc = suffix; info = ""; deprecated = false;
+               }
+        else None
+      end
+    in
     let entries =
       Printtyp.wrap_printing_env env ~verbosity @@ fun () ->
       Completion.branch_complete config ~kinds ?get_doc ?target_type prefix branch |>
       print_completion_entries ~with_types config source
-    and context = match context with
+    and context =  match context  with
       | `Application context when no_labels ->
         `Application {context with Compl.labels = []}
       | context -> context
     in
-    {Compl. entries; context }
+    let entries = entries @ syntactic in
+    { Compl. entries; context }
 
   | Expand_prefix (prefix, pos, kinds, with_types) ->
     let pipeline, typer = for_completion pipeline pos in

src/frontend/query_protocol.ml

@@ -31,7 +31,7 @@ struct
   type 'desc raw_entry = {
     name: string;
     kind: [`Value|`Constructor|`Variant|`Label|
-           `Module|`Modtype|`Type|`MethodCall];
+           `Module|`Modtype|`Type|`MethodCall|`Syntax];
     desc: 'desc;
     info: 'desc;
     deprecated: bool;

src/kernel/mpipeline.ml

@@ -118,6 +118,8 @@ let reader_lexer_errors  t = (fst (reader t)).Mreader.lexer_errors
 let reader_parser_errors t = (fst (reader t)).Mreader.parser_errors
 let reader_no_labels_for_completion t =
   (fst (reader t)).Mreader.no_labels_for_completion
+let reader_snapshot_for_completion t =
+  (fst (reader t)).Mreader.snapshot_for_completion
 
 let ppx_parsetree t = (ppx t).Ppx.parsetree
 let ppx_errors    t = (ppx t).Ppx.errors

src/kernel/mpipeline.mli

@@ -15,6 +15,7 @@ val reader_parsetree : t -> Mreader.parsetree
 val reader_lexer_errors : t -> exn list
 val reader_parser_errors : t -> exn list
 val reader_no_labels_for_completion : t -> bool
+val reader_snapshot_for_completion : t -> Mreader_parser.snapshot option
 
 val ppx_parsetree : t -> Mreader.parsetree
 val ppx_errors : t -> exn list

src/kernel/mreader.ml

@@ -14,6 +14,7 @@ type result = {
   comments      : comment list;
   parsetree     : parsetree;
   no_labels_for_completion : bool;
+  snapshot_for_completion : Mreader_parser.snapshot option;
 }
 
 (* Normal entry point *)
@@ -51,9 +52,10 @@ let normal_parse ?for_completion config source =
   and parser_errors = Mreader_parser.errors parser
   and parsetree = Mreader_parser.result parser
   and comments = Mreader_lexer.comments lexer
+  and snapshot_for_completion = Mreader_parser.snapshot parser
   in
   { config; lexer_errors; parser_errors; comments; parsetree;
-    no_labels_for_completion; }
+    no_labels_for_completion; snapshot_for_completion }
 
 (* Pretty-printing *)
 
@@ -168,7 +170,7 @@ let parse ?for_completion config source =
   | Some (`No_labels no_labels_for_completion, parsetree) ->
     let (lexer_errors, parser_errors, comments) = ([], [], []) in
     { config; lexer_errors; parser_errors; comments; parsetree;
-      no_labels_for_completion; }
+      no_labels_for_completion; snapshot_for_completion = None }
   | None -> normal_parse ?for_completion config source
 
 (* Update config after parse *)

src/kernel/mreader.mli

@@ -12,6 +12,7 @@ type result = {
   comments      : comment list;
   parsetree     : parsetree;
   no_labels_for_completion : bool;
+  snapshot_for_completion : Mreader_parser.snapshot option;
 }
 
 type pretty_parsetree = Extend_protocol.Reader.pretty_parsetree

src/kernel/mreader_lexer.ml

@@ -41,7 +41,7 @@ type t = {
   keywords: keywords;
   config: Mconfig.t;
   source: Msource.t;
-  items: item list;
+  rev_items: item list;
 }
 
 let get_tokens keywords pos text =
@@ -83,13 +83,13 @@ let initial_position config =
 
 let make warnings keywords config source =
   Msupport.catch_errors warnings (ref []) @@ fun () ->
-  let items =
+  let rev_items =
     get_tokens keywords
     (initial_position config)
     (Msource.text source)
     []
   in
-  { keywords; items; config; source }
+  { keywords; rev_items; config; source }
 
 let item_start = function
   | Triple (_,s,_) -> s
@@ -118,16 +118,16 @@ let rev_filter_map ~f lst =
   aux [] lst
 
 let tokens t =
-  rev_filter_map t.items
+  rev_filter_map t.rev_items
     ~f:(function Triple t -> Some t | _ -> None)
 
 let errors t =
-  rev_filter_map t.items
+  rev_filter_map t.rev_items
     ~f:(function Error (err, loc) -> Some (Lexer_raw.Error (err, loc))
                | _ -> None)
 
 let comments t =
-  rev_filter_map t.items
+  rev_filter_map t.rev_items
     ~f:(function Comment t -> Some t | _ -> None)
 
 open Parser_raw
@@ -325,36 +325,32 @@ let for_completion t pos =
     | Triple ((LABEL _ | OPTLABEL _), _, _) -> no_labels := true
     | _ -> ()
   in
-  let rec aux acc = function
+  let fake_ident = Triple (LIDENT "", pos, pos) in
+  let rec aux suffix = function
     (* Cursor is before item: continue *)
     | item :: items when Lexing.compare_pos (item_start item) pos >= 0 ->
-      aux (item :: acc) items
+      aux (item :: suffix) items
 
     (* Cursor is in the middle of item: stop *)
-    | item :: _ when Lexing.compare_pos (item_end item) pos > 0 ->
+    | item :: items when Lexing.compare_pos (item_end item) pos > 0 ->
       check_label item;
-      raise Exit
+      (item :: suffix, items)
 
     (* Cursor is at the end *)
-    | ((Triple (token, _, loc_end) as item) :: _) as items
+    | (Triple (token, _, loc_end) as item) :: items
       when Lexing.compare_pos pos loc_end = 0 ->
       check_label item;
       begin match token with
-        (* Already on identifier, no need to introduce *)
-        | UIDENT _ | LIDENT _ -> raise Exit
-        | _ -> acc, items
+        (* Already on identifier, no need to introduce a fake identifier *)
+        | UIDENT _ | LIDENT _ -> (suffix, item :: items)
+        | _ -> (item :: fake_ident :: suffix, items)
       end
 
-    | items -> acc, items
-  in
-  let t =
-    match aux [] t.items with
-    | exception Exit -> t
-    | acc, items ->
-      {t with items =
-                List.rev_append acc (Triple (LIDENT "", pos, pos) :: items)}
+    | rev_prefix -> (fake_ident :: suffix, rev_prefix)
   in
-  (!no_labels, t)
+  let suffix, rev_prefix = aux [] t.rev_items in
+  let rev_prefix = Triple (SNAPSHOT, pos, pos) :: rev_prefix in
+  (!no_labels, {t with rev_items = List.rev_append suffix rev_prefix})
 
 let identifier_suffix ident =
   match List.last ident with

src/kernel/mreader_parser.ml

@@ -72,22 +72,28 @@ type steps =[
   | `Structure of (Parsetree.structure step * Mreader_lexer.triple) list
 ]
 
+type snapshot = Snapshot : _ Parser_raw.MenhirInterpreter.env -> snapshot
+
 type t = {
   kind: kind;
   tree: tree;
   steps: steps;
   errors: exn list;
   lexer: Mreader_lexer.t;
+  snapshot: snapshot option;
 }
 
 let eof_token = (Parser_raw.EOF, Lexing.dummy_pos, Lexing.dummy_pos)
 
 let errors_ref = ref []
 
-let resume_parse =
+let resume_parse snapshot =
   let rec normal acc tokens = function
     | I.InputNeeded env as checkpoint ->
       let token, tokens = match tokens with
+        | (Parser_raw.SNAPSHOT, _, _) :: token :: tokens ->
+          snapshot := Some (Snapshot env);
+          token, tokens
         | token :: tokens -> token, tokens
         | [] -> eof_token, []
       in
@@ -165,17 +171,17 @@ let seek_step steps tokens =
   in
   aux [] (steps, tokens)
 
-let parse initial steps tokens initial_pos =
+let parse snapshot initial steps tokens initial_pos =
   let acc, tokens = seek_step steps tokens in
   let step =
     match acc with
     | (step, _) :: _ -> step
     | [] -> Correct (initial initial_pos)
   in
-  let acc, result = resume_parse acc tokens step in
+  let acc, result = resume_parse snapshot acc tokens step in
   List.rev acc, result
 
-let run_parser warnings lexer previous kind =
+let run_parser snapshot warnings lexer previous kind =
   Msupport.catch_errors warnings errors_ref @@ fun () ->
   let tokens = Mreader_lexer.tokens lexer in
   let initial_pos = Mreader_lexer.initial_position lexer in
@@ -187,7 +193,7 @@ let run_parser warnings lexer previous kind =
     in
     let steps, result =
       let state = Parser_raw.Incremental.implementation in
-      parse state steps tokens initial_pos in
+      parse snapshot state steps tokens initial_pos in
     `Structure steps, `Implementation result
   | MLI ->
     let steps = match previous with
@@ -196,16 +202,19 @@ let run_parser warnings lexer previous kind =
     in
     let steps, result =
       let state = Parser_raw.Incremental.interface in
-      parse state steps tokens initial_pos in
+      parse snapshot state steps tokens initial_pos in
     `Signature steps, `Interface result
 
 let make warnings lexer kind =
   errors_ref := [];
-  let steps, tree = run_parser warnings lexer `None kind in
+  let snapshot = ref None in
+  let steps, tree = run_parser snapshot warnings lexer `None kind in
   let errors = !errors_ref in
   errors_ref := [];
-  {kind; steps; tree; errors; lexer}
+  {kind; steps; tree; errors; lexer; snapshot = !snapshot}
 
 let result t = t.tree
 
 let errors t = t.errors
+
+let snapshot t = t.snapshot

src/kernel/mreader_parser.mli

@@ -33,6 +33,8 @@ type kind =
 
 type t
 
+type snapshot = Snapshot : _ Parser_raw.MenhirInterpreter.env -> snapshot
+
 val make : Warnings.state -> Mreader_lexer.t -> kind -> t
 
 type tree = [
@@ -43,3 +45,5 @@ type tree = [
 val result : t -> tree
 
 val errors : t -> exn list
+
+val snapshot : t -> snapshot option

src/ocaml/preprocess/complete/dune

@@ -0,0 +1,3 @@
+(executable
+ (name gen_complete)
+ (libraries unix menhirSdk))