Better classification: such colors, much wow

src/fsharp/service/SemanticClassification.fs

@@ -10,7 +10,6 @@ open FSharp.Compiler
 open FSharp.Compiler.AbstractIL.Internal.Library 
 open FSharp.Compiler.Infos
 open FSharp.Compiler.ErrorLogger
-open FSharp.Compiler.Lib
 open FSharp.Compiler.NameResolution
 open FSharp.Compiler.PrettyNaming
 open FSharp.Compiler.Range
@@ -24,30 +23,47 @@ type SemanticClassificationType =
  | ReferenceType
  | ValueType
  | UnionCase
+ | UnionCaseField
  | Function
  | Property
  | MutableVar
  | Module
+ | NameSpace
  | Printf
  | ComputationExpression
  | IntrinsicFunction
  | Enumeration
  | Interface
  | TypeArgument
  | Operator
- | Disposable
+ | DisposableType
+ | DisposableValue
+ | Method
+ | ExtensionMethod
+ | ConstructorForReferenceType
+ | ConstructorForValueType
+ | Literal
+ | RecordField
+ | MutableRecordField
+ | RecordFieldAsFunction
+ | Exception
+ | Field
+ | Event
+ | Delegate
+ | NamedArgument
+ | Value
+ | LocalValue
+ | Type
+ | TypeDef
 
 [<AutoOpen>]
 module TcResolutionsExtensions =
-
  let (|CNR|) (cnr:CapturedNameResolution) =
  (cnr.Item, cnr.ItemOccurence, cnr.DisplayEnv, cnr.NameResolutionEnv, cnr.AccessorDomain, cnr.Range)
 
  type TcResolutions with
-
  member sResolutions.GetSemanticClassification(g: TcGlobals, amap: Import.ImportMap, formatSpecifierLocations: (range * int) [], range: range option) : struct(range * SemanticClassificationType) [] =
- ErrorScope.Protect Range.range0 
- (fun () -> 
+ ErrorScope.Protect Range.range0 (fun () ->
  let (|LegitTypeOccurence|_|) = function
  | ItemOccurence.UseInType
  | ItemOccurence.UseInAttribute
@@ -56,18 +72,13 @@ module TcResolutionsExtensions =
  | ItemOccurence.Pattern _ -> Some()
  | _ -> None
 
- let (|OptionalArgumentAttribute|_|) ttype =
- match ttype with
- | TType.TType_app(tref, _) when tref.Stamp = g.attrib_OptionalArgumentAttribute.TyconRef.Stamp -> Some()
- | _ -> None
-
  let (|KeywordIntrinsicValue|_|) (vref: ValRef) =
  if valRefEq g g.raise_vref vref ||
- valRefEq g g.reraise_vref vref ||
- valRefEq g g.typeof_vref vref ||
- valRefEq g g.typedefof_vref vref ||
- valRefEq g g.sizeof_vref vref ||
- valRefEq g g.nameof_vref vref then Some()
+valRefEq g g.reraise_vref vref ||
+valRefEq g g.typeof_vref vref ||
+valRefEq g g.typedefof_vref vref ||
+valRefEq g g.sizeof_vref vref ||
+valRefEq g g.nameof_vref vref then Some()
  else None
 
  let (|EnumCaseFieldInfo|_|) (rfinfo : RecdFieldInfo) =
@@ -87,7 +98,15 @@ module TcResolutionsExtensions =
  sResolutions.CapturedNameResolutions :> seq<_>
 
  let isDisposableTy (ty: TType) =
+ not (typeEquiv g ty g.system_IDisposable_ty) &&
  protectAssemblyExplorationNoReraise false false (fun () -> Infos.ExistsHeadTypeInEntireHierarchy g amap range0 ty g.tcref_System_IDisposable)
+
+ let isDiscard (str: string) = str.StartsWith("_")
+
+ let isValRefDisposable (vref: ValRef) =
+ not (isDiscard vref.DisplayName) &&
+ // For values, we actually do want to color things if they literally are IDisposables 
+ protectAssemblyExplorationNoReraise false false (fun () -> Infos.ExistsHeadTypeInEntireHierarchy g amap range0 vref.Type g.tcref_System_IDisposable)
 
  let isStructTyconRef (tyconRef: TyconRef) = 
  let ty = generalizedTyconRef tyconRef
@@ -116,61 +135,206 @@ module TcResolutionsExtensions =
  // 'seq' in 'seq { ... }' gets colored as keywords
  | (Item.Value vref), ItemOccurence.Use, _, _, _, m when valRefEq g g.seq_vref vref ->
  add m SemanticClassificationType.ComputationExpression
+
  | (Item.Value vref), _, _, _, _, m when isValRefMutable vref ->
  add m SemanticClassificationType.MutableVar
+
  | Item.Value KeywordIntrinsicValue, ItemOccurence.Use, _, _, _, m ->
  add m SemanticClassificationType.IntrinsicFunction
+
  | (Item.Value vref), _, _, _, _, m when isFunction g vref.Type ->
  if valRefEq g g.range_op_vref vref || valRefEq g g.range_step_op_vref vref then 
  ()
  elif vref.IsPropertyGetterMethod || vref.IsPropertySetterMethod then
  add m SemanticClassificationType.Property
+ elif vref.IsMember then
+ add m SemanticClassificationType.Method
  elif IsOperatorName vref.DisplayName then
  add m SemanticClassificationType.Operator
  else
  add m SemanticClassificationType.Function
- | Item.RecdField rfinfo, _, _, _, _, m when isRecdFieldMutable rfinfo ->
- add m SemanticClassificationType.MutableVar
- | Item.RecdField rfinfo, _, _, _, _, m when isFunction g rfinfo.FieldType ->
- add m SemanticClassificationType.Function
- | Item.RecdField EnumCaseFieldInfo, _, _, _, _, m ->
- add m SemanticClassificationType.Enumeration
- | Item.MethodGroup _, _, _, _, _, m ->
- add m SemanticClassificationType.Function
- // custom builders, custom operations get colored as keywords
+
+ | (Item.Value vref), _, _, _, _, m ->
+ if isValRefDisposable vref then
+ add m SemanticClassificationType.DisposableValue
+ elif Option.isSome vref.LiteralValue then
+ add m SemanticClassificationType.Literal
+ elif not vref.IsCompiledAsTopLevel && not(isDiscard vref.DisplayName) then
+ add m SemanticClassificationType.LocalValue
+ else
+ add m SemanticClassificationType.Value
+
+ | Item.RecdField rfinfo, _, _, _, _, m ->
+ match rfinfo with
+ | EnumCaseFieldInfo ->
+ add m SemanticClassificationType.Enumeration
+ | _ ->
+ if isRecdFieldMutable rfinfo then
+ add m SemanticClassificationType.MutableRecordField
+ elif isFunTy g rfinfo.FieldType then
+ add m SemanticClassificationType.RecordFieldAsFunction
+ else
+ add m SemanticClassificationType.RecordField
+
+ | Item.AnonRecdField(_, tys, idx, m), _, _, _, _, _ ->
+ let ty = tys.[idx]
+
+ // It's not currently possible for anon record fields to be mutable, but they can be ref cells
+ if isRefCellTy g ty then
+ add m SemanticClassificationType.MutableRecordField
+ elif isFunTy g ty then
+ add m SemanticClassificationType.RecordFieldAsFunction
+ else
+ add m SemanticClassificationType.RecordField
+
+ | Item.Property (_, pinfo :: _), _, _, _, _, m ->
+ if not pinfo.IsIndexer then
+ add m SemanticClassificationType.Property
+
+ | Item.CtorGroup (_, minfos), _, _, _, _, m ->
+ if minfos |> List.forall (fun minfo -> isDisposableTy minfo.ApparentEnclosingType) then
+ add m SemanticClassificationType.DisposableType
+ elif minfos |> List.forall (fun minfo -> isStructTy g minfo.ApparentEnclosingType) then
+ add m SemanticClassificationType.ConstructorForValueType
+ else
+ add m SemanticClassificationType.ConstructorForReferenceType
+
+ | (Item.DelegateCtor _ | Item.FakeInterfaceCtor _), _, _, _, _, m ->
+ add m SemanticClassificationType.ConstructorForReferenceType
+
+ | Item.MethodGroup (_, minfos, _), _, _, _, _, m ->
+ if minfos |> List.forall (fun minfo -> minfo.IsExtensionMember || minfo.IsCSharpStyleExtensionMember) then
+ add m SemanticClassificationType.ExtensionMethod
+ else
+ add m SemanticClassificationType.Method
+
  | (Item.CustomBuilder _ | Item.CustomOperation _), ItemOccurence.Use, _, _, _, m ->
  add m SemanticClassificationType.ComputationExpression
- // types get colored as types when they occur in syntactic types or custom attributes
- // type variables get colored as types when they occur in syntactic types custom builders, custom operations get colored as keywords
- | Item.Types (_, [OptionalArgumentAttribute]), LegitTypeOccurence, _, _, _, _ -> ()
- | Item.CtorGroup(_, [MethInfo.FSMeth(_, OptionalArgumentAttribute, _, _)]), LegitTypeOccurence, _, _, _, _ -> ()
- | Item.Types(_, types), LegitTypeOccurence, _, _, _, m when types |> List.exists (isInterfaceTy g) -> 
- add m SemanticClassificationType.Interface
- | Item.Types(_, types), LegitTypeOccurence, _, _, _, m when types |> List.exists (isStructTy g) -> 
- add m SemanticClassificationType.ValueType
+
+ // Special case measures for struct types
  | Item.Types(_, TType_app(tyconRef, TType_measure _ :: _) :: _), LegitTypeOccurence, _, _, _, m when isStructTyconRef tyconRef ->
  add m SemanticClassificationType.ValueType
- | Item.Types(_, types), LegitTypeOccurence, _, _, _, m when types |> List.exists isDisposableTy ->
- add m SemanticClassificationType.Disposable
- | Item.Types _, LegitTypeOccurence, _, _, _, m -> 
- add m SemanticClassificationType.ReferenceType
+
+ | Item.Types (_, ty :: _), LegitTypeOccurence, _, _, _, m ->
+ let reprToClassificationType repr tcref = 
+ match repr with
+ | TFSharpObjectRepr om -> 
+ match om.fsobjmodel_kind with 
+ | TTyconClass -> SemanticClassificationType.ReferenceType
+ | TTyconInterface -> SemanticClassificationType.Interface
+ | TTyconStruct -> SemanticClassificationType.ValueType
+ | TTyconDelegate _ -> SemanticClassificationType.Delegate
+ | TTyconEnum _ -> SemanticClassificationType.Enumeration
+ | TRecdRepr _
+ | TUnionRepr _ -> 
+ if isStructTyconRef tcref then
+ SemanticClassificationType.ValueType
+ else
+ SemanticClassificationType.Type
+ | TILObjectRepr (TILObjectReprData (_, _, td)) -> 
+ if td.IsClass then
+ SemanticClassificationType.ReferenceType
+ elif td.IsStruct then
+ SemanticClassificationType.ValueType
+ elif td.IsInterface then
+ SemanticClassificationType.Interface
+ elif td.IsEnum then
+ SemanticClassificationType.Enumeration
+ else
+ SemanticClassificationType.Delegate
+ | TAsmRepr _ -> SemanticClassificationType.TypeDef
+ | TMeasureableRepr _-> SemanticClassificationType.TypeDef 
+#if !NO_EXTENSIONTYPING
+ | TProvidedTypeExtensionPoint _-> SemanticClassificationType.TypeDef 
+ | TProvidedNamespaceExtensionPoint _-> SemanticClassificationType.TypeDef 
+#endif
+ | TNoRepr -> SemanticClassificationType.ReferenceType
+
+ let ty = stripTyEqns g ty
+ if isDisposableTy ty then
+ add m SemanticClassificationType.DisposableType
+ else
+ match tryTcrefOfAppTy g ty with
+ | ValueSome tcref ->
+ add m (reprToClassificationType tcref.TypeReprInfo tcref)
+ | ValueNone ->
+ if isStructTupleTy g ty then
+ add m SemanticClassificationType.ValueType
+ elif isRefTupleTy g ty then
+ add m SemanticClassificationType.ReferenceType
+ elif isFunction g ty then
+ add m SemanticClassificationType.Function
+ elif isTyparTy g ty then
+ add m SemanticClassificationType.ValueType
+ else
+ add m SemanticClassificationType.TypeDef 
+
  | (Item.TypeVar _ ), LegitTypeOccurence, _, _, _, m ->
  add m SemanticClassificationType.TypeArgument
- | Item.UnqualifiedType tyconRefs, LegitTypeOccurence, _, _, _, m ->
- if tyconRefs |> List.exists (fun tyconRef -> tyconRef.Deref.IsStructOrEnumTycon) then
- add m SemanticClassificationType.ValueType
- else add m SemanticClassificationType.ReferenceType
- | Item.CtorGroup(_, minfos), LegitTypeOccurence, _, _, _, m ->
- if minfos |> List.exists (fun minfo -> isStructTy g minfo.ApparentEnclosingType) then
- add m SemanticClassificationType.ValueType
- else add m SemanticClassificationType.ReferenceType
+
  | Item.ExnCase _, LegitTypeOccurence, _, _, _, m ->
- add m SemanticClassificationType.ReferenceType
- | Item.ModuleOrNamespaces refs, LegitTypeOccurence, _, _, _, m when refs |> List.exists (fun x -> x.IsModule) ->
- add m SemanticClassificationType.Module
+ add m SemanticClassificationType.Exception
+
+ | Item.ModuleOrNamespaces (modref :: _), LegitTypeOccurence, _, _, _, m ->
+ if modref.IsNamespace then
+ add m SemanticClassificationType.NameSpace
+ else
+ add m SemanticClassificationType.Module
+
  | (Item.ActivePatternCase _ | Item.UnionCase _ | Item.ActivePatternResult _), _, _, _, _, m ->
  add m SemanticClassificationType.UnionCase
- | _ -> ())
+
+ | Item.UnionCaseField _, _, _, _, _, m ->
+ add m SemanticClassificationType.UnionCaseField
+
+ | Item.ILField _, _, _, _, _, m ->
+ add m SemanticClassificationType.Field
+
+ | Item.Event _, _, _, _, _, m ->
+ add m SemanticClassificationType.Event
+
+ | (Item.ArgName _ | Item.SetterArg _), _, _, _, _, m ->
+ add m SemanticClassificationType.NamedArgument
+
+ | Item.SetterArg _, _, _, _, _, m ->
+ add m SemanticClassificationType.Property
+
+ | Item.UnqualifiedType (tcref :: _), LegitTypeOccurence, _, _, _, m ->
+ if tcref.IsEnumTycon || tcref.IsILEnumTycon then
+ add m SemanticClassificationType.Enumeration
+ elif tcref.IsExceptionDecl then
+ add m SemanticClassificationType.Exception
+ elif tcref.IsFSharpDelegateTycon then
+ add m SemanticClassificationType.Delegate
+ elif tcref.IsFSharpInterfaceTycon then
+ add m SemanticClassificationType.Interface
+ elif tcref.IsFSharpStructOrEnumTycon then
+ add m SemanticClassificationType.ValueType
+ elif tcref.IsModule then
+ add m SemanticClassificationType.Module
+ elif tcref.IsNamespace then
+ add m SemanticClassificationType.NameSpace
+ elif tcref.IsUnionTycon || tcref.IsRecordTycon then
+ if isStructTyconRef tcref then
+ add m SemanticClassificationType.ValueType
+ else
+ add m SemanticClassificationType.UnionCase
+ elif tcref.IsILTycon then
+ let (TILObjectReprData (_, _, tydef)) = tcref.ILTyconInfo
+
+ if tydef.IsInterface then
+ add m SemanticClassificationType.Interface
+ elif tydef.IsDelegate then
+ add m SemanticClassificationType.Delegate
+ elif tydef.IsEnum then
+ add m SemanticClassificationType.Enumeration
+ elif tydef.IsStruct then
+ add m SemanticClassificationType.ValueType
+ else
+ add m SemanticClassificationType.ReferenceType
+
+ | _ ->
+ ())
  results.AddRange(formatSpecifierLocations |> Array.map (fun (m, _) -> struct(m, SemanticClassificationType.Printf)))
  results.ToArray()
  )