Merge branch 'semantic-highlighting' of github.com:zth/rescript-vscode into semantic-highlighting

Author: zth

analysis/src/SemanticTokens.ml

@@ -3,7 +3,15 @@ module Token = struct
 
   (* This needs to stay synced with the same legend in `server.ts` *)
   (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *)
-  type tokenType = Keyword | Variable | Type | JsxTag | Namespace
+  type tokenType =
+    | Keyword
+    | Variable
+    | Type
+    | JsxTag
+    | Namespace
+    | EnumMember
+    | Property
+
   type tokenModifiers = NoModifier
 
   let tokenTypeToString = function
@@ -12,13 +20,17 @@ module Token = struct
     | Type -> "2"
     | JsxTag -> "3"
     | Namespace -> "4"
+    | EnumMember -> "5"
+    | Property -> "6"
 
   let tokenTypeDebug = function
     | Keyword -> "Keyword"
     | Variable -> "Variable"
     | Type -> "Type"
     | JsxTag -> "JsxTag"
     | Namespace -> "Namespace"
+    | EnumMember -> "EnumMember"
+    | Property -> "Property"
 
   let tokenModifiersToString = function NoModifier -> "0"
 
@@ -87,8 +99,8 @@ let emitFromLoc ~loc ~type_ emitter =
   emitter |> emitFromPos posStart posEnd ~type_
 
 let emitLongident ?(backwards = false) ?(jsx = false)
-    ?(moduleToken = Token.Namespace) ~pos ~lid ~debug emitter =
-  let variableToken = if jsx then Token.JsxTag else Variable in
+    ?(lowerCaseToken = if jsx then Token.JsxTag else Variable)
+    ?(upperCaseToken = Token.Namespace) ~pos ~lid ~debug emitter =
   let rec flatten acc lid =
     match lid with
     | Longident.Lident txt -> txt :: acc
@@ -100,13 +112,13 @@ let emitLongident ?(backwards = false) ?(jsx = false)
   let rec loop pos segments =
     match segments with
     | [id] when isUppercaseId id || isLowercaseId id ->
-      let type_ = if isUppercaseId id then moduleToken else variableToken in
+      let type_ = if isUppercaseId id then upperCaseToken else lowerCaseToken in
       if debug then
         Printf.printf "Lident: %s %s %s\n" id (posToString pos)
           (Token.tokenTypeDebug type_);
       emitter |> emitFromPos pos (fst pos, snd pos + String.length id) ~type_
     | id :: segments when isUppercaseId id || isLowercaseId id ->
-      let type_ = if isUppercaseId id then moduleToken else variableToken in
+      let type_ = if isUppercaseId id then upperCaseToken else lowerCaseToken in
       if debug then
         Printf.printf "Ldot: %s %s %s\n" id (posToString pos)
           (Token.tokenTypeDebug type_);
@@ -142,6 +154,18 @@ let emitType ~id ~debug ~loc emitter =
   if debug then Printf.printf "Type: %s %s\n" id (locToString loc);
   emitter |> emitFromLoc ~loc ~type_:Token.Type
 
+let emitRecordLabel ~(label : Longident.t Location.loc) ~debug emitter =
+  emitter
+  |> emitLongident ~lowerCaseToken:Token.Property
+       ~pos:(Utils.tupleOfLexing label.loc.loc_start)
+       ~lid:label.txt ~debug
+
+let emitVariant ~(name : Longident.t Location.loc) ~debug emitter =
+  emitter
+  |> emitLongident ~upperCaseToken:Token.EnumMember
+       ~pos:(Utils.tupleOfLexing name.loc.loc_start)
+       ~lid:name.txt ~debug
+
 let parser ~debug ~emitter ~path =
   let processTypeArg (coreType : Parsetree.core_type) =
     if debug then Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc)
@@ -167,6 +191,13 @@ let parser ~debug ~emitter ~path =
     | Ppat_var {loc; txt = id} ->
       if isLowercaseId id then emitter |> emitVariable ~id ~debug ~loc;
       Ast_mapper.default_mapper.pat mapper p
+    | Ppat_record (cases, _) ->
+      cases
+      |> List.iter (fun (label, _) -> emitter |> emitRecordLabel ~label ~debug);
+      Ast_mapper.default_mapper.pat mapper p
+    | Ppat_construct (name, _) ->
+      emitter |> emitVariant ~name ~debug;
+      Ast_mapper.default_mapper.pat mapper p
     | _ -> Ast_mapper.default_mapper.pat mapper p
   in
   let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) =
@@ -212,6 +243,16 @@ let parser ~debug ~emitter ~path =
       ->
       if debug then Printf.printf "BinaryExp: %s\n" (locToString pexp_loc);
       Ast_mapper.default_mapper.expr mapper e
+    | Pexp_record (cases, _) ->
+      cases
+      |> List.iter (fun (label, _) -> emitter |> emitRecordLabel ~label ~debug);
+      Ast_mapper.default_mapper.expr mapper e
+    | Pexp_field (_, label) | Pexp_setfield (_, label, _) ->
+      emitter |> emitRecordLabel ~label ~debug;
+      Ast_mapper.default_mapper.expr mapper e
+    | Pexp_construct (name, _) ->
+      emitter |> emitVariant ~name ~debug;
+      Ast_mapper.default_mapper.expr mapper e
     | _ -> Ast_mapper.default_mapper.expr mapper e
   in
   let module_expr (mapper : Ast_mapper.mapper) (me : Parsetree.module_expr) =
@@ -242,7 +283,7 @@ let parser ~debug ~emitter ~path =
     match mt.pmty_desc with
     | Pmty_ident {txt = lid; loc} ->
       emitter
-      |> emitLongident ~moduleToken:Token.Type
+      |> emitLongident ~upperCaseToken:Token.Type
            ~pos:(Utils.tupleOfLexing loc.loc_start)
            ~lid ~debug;
       Ast_mapper.default_mapper.module_type mapper mt
@@ -251,7 +292,7 @@ let parser ~debug ~emitter ~path =
   let module_type_declaration (mapper : Ast_mapper.mapper)
       (mtd : Parsetree.module_type_declaration) =
     emitter
-    |> emitLongident ~moduleToken:Token.Type
+    |> emitLongident ~upperCaseToken:Token.Type
          ~pos:(Utils.tupleOfLexing mtd.pmtd_name.loc.loc_start)
          ~lid:(Longident.Lident mtd.pmtd_name.txt) ~debug;
     Ast_mapper.default_mapper.module_type_declaration mapper mtd
@@ -264,11 +305,29 @@ let parser ~debug ~emitter ~path =
          ~lid:od.popen_lid.txt ~debug;
     Ast_mapper.default_mapper.open_description mapper od
   in
+  let label_declaration (mapper : Ast_mapper.mapper)
+      (ld : Parsetree.label_declaration) =
+    emitter
+    |> emitRecordLabel
+         ~label:{loc = ld.pld_name.loc; txt = Longident.Lident ld.pld_name.txt}
+         ~debug;
+    Ast_mapper.default_mapper.label_declaration mapper ld
+  in
+  let constructor_declaration (mapper : Ast_mapper.mapper)
+      (cd : Parsetree.constructor_declaration) =
+    emitter
+    |> emitVariant
+         ~name:{loc = cd.pcd_name.loc; txt = Longident.Lident cd.pcd_name.txt}
+         ~debug;
+    Ast_mapper.default_mapper.constructor_declaration mapper cd
+  in
 
   let mapper =
     {
       Ast_mapper.default_mapper with
+      constructor_declaration;
       expr;
+      label_declaration;
       module_declaration;
       module_binding;
       module_expr;

analysis/tests/src/Parser.res

@@ -53,4 +53,16 @@ open XX.YY
 
 type tt = t
 
-// ^par 
+// ^par
+
+module T = {
+  type someRecord<'typeParameter> = {
+    someField: int,
+    someOtherField: string,
+    theParam: 'typeParameter,
+  }
+
+  type someEnum = A | B | C
+}
+
+let foo = x => x.T.someField

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

@@ -1,5 +1,5 @@
 Parse tests/src/Parser.res
-structure items:15 diagnostics:0 
+structure items:17 diagnostics:0 
 Lident: M (0,7) Namespace
 Lident: C (1,9) Namespace
 Lident: Component (1,13) Namespace
@@ -52,4 +52,20 @@ Ldot: XX (51,5) Namespace
 Lident: YY (51,8) Namespace
 Type: tt (53,5)->(53,7)
 Type: t (53,10)->(53,11)
+Lident: T (57,7) Namespace
+Type: someRecord (58,7)->(58,17)
+Lident: someField (59,4) Property
+Type: int (59,15)->(59,18)
+Lident: someOtherField (60,4) Property
+Type: string (60,20)->(60,26)
+Lident: theParam (61,4) Property
+Type: someEnum (64,7)->(64,15)
+Lident: A (64,18) EnumMember
+Lident: B (64,22) EnumMember
+Lident: C (64,26) EnumMember
+Ldot: T (67,17) Namespace
+Lident: someField (67,19) Property
+Lident: x (67,15) Variable
+Lident: x (67,10) Variable
+Lident: foo (67,4) Variable
 

server/src/server.ts

@@ -760,7 +760,15 @@ function onMessage(msg: m.Message) {
           completionProvider: { triggerCharacters: [".", ">", "@", "~", '"'] },
           semanticTokensProvider: {
             legend: {
-              tokenTypes: ["keyword", "variable", "type", "jsx-tag", "namespace"],
+              tokenTypes: [
+                "keyword",
+                "variable",
+                "type",
+                "jsx-tag",
+                "namespace",
+                "enumMember",
+                "property",
+              ],
               tokenModifiers: [],
             },
             documentSelector: null,