Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Better classification: such colors, much wow #9511

Merged
merged 16 commits into from
Jun 23, 2020
Merged
Show file tree
Hide file tree
Changes from 10 commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
248 changes: 199 additions & 49 deletions src/fsharp/service/SemanticClassification.fs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -24,30 +23,46 @@ type SemanticClassificationType =
| ReferenceType
| ValueType
| UnionCase
| UnionCaseField
| Function
| Property
| MutableVar
| Module
| NameSpace
| Printf
| ComputationExpression
| IntrinsicFunction
| Enumeration
| Interface
| TypeArgument
| Operator
| Disposable
| DisposableType
| DisposableValue
| Method
| ExtensionMethod
| Constructor
cartermp marked this conversation as resolved.
Show resolved Hide resolved
| 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
Expand All @@ -56,18 +71,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) =
Expand All @@ -89,6 +99,9 @@ module TcResolutionsExtensions =
let isDisposableTy (ty: TType) =
protectAssemblyExplorationNoReraise false false (fun () -> Infos.ExistsHeadTypeInEntireHierarchy g amap range0 ty g.tcref_System_IDisposable)

let isValRefDisposable (vref: ValRef) =
not (vref.DisplayName = "_") && not (vref.DisplayName = "__") && isDisposableTy vref.Type

let isStructTyconRef (tyconRef: TyconRef) =
let ty = generalizedTyconRef tyconRef
let underlyingTy = stripTyEqnsAndMeasureEqns g ty
Expand Down Expand Up @@ -116,61 +129,198 @@ 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 ->
cartermp marked this conversation as resolved.
Show resolved Hide resolved
if isValRefDisposable vref then
add m SemanticClassificationType.DisposableValue
elif Option.isSome vref.LiteralValue then
add m SemanticClassificationType.Literal
elif not vref.IsCompiledAsTopLevel 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 _ | Item.DelegateCtor _ | Item.FakeInterfaceCtor _), _, _, _, _, m ->
add m SemanticClassificationType.Constructor

cartermp marked this conversation as resolved.
Show resolved Hide resolved
| 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
cartermp marked this conversation as resolved.
Show resolved Hide resolved
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()
)
Expand Down
24 changes: 20 additions & 4 deletions src/fsharp/service/SemanticClassification.fsi
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,6 @@

namespace FSharp.Compiler.SourceCodeServices

open FSharp.Compiler
open FSharp.Compiler.AccessibilityLogic
open FSharp.Compiler.Import
open FSharp.Compiler.NameResolution
Expand All @@ -16,25 +15,42 @@ type SemanticClassificationType =
| ReferenceType
| ValueType
| UnionCase
| UnionCaseField
| Function
| Property
| MutableVar
| Module
| NameSpace
| Printf
| ComputationExpression
| IntrinsicFunction
| Enumeration
| Interface
| TypeArgument
| Operator
| Disposable
| DisposableType
| DisposableValue
| Method
| ExtensionMethod
| Constructor
| Literal
| RecordField
| MutableRecordField
| RecordFieldAsFunction
| Exception
| Field
| Event
| Delegate
| NamedArgument
| Value
| LocalValue
| Type
| TypeDef

/// Extension methods for the TcResolutions type.
[<AutoOpen>]
module internal TcResolutionsExtensions =

val (|CNR|) : cnr: CapturedNameResolution -> (Item * ItemOccurence * DisplayEnv * NameResolutionEnv * AccessorDomain * range)

type TcResolutions with

member GetSemanticClassification: g: TcGlobals * amap: ImportMap * formatSpecifierLocations: (range * int) [] * range: range option -> struct(range * SemanticClassificationType) []
Loading