Fix finding references to interface methods

src/Compiler/Service/IncrementalBuild.fs

@@ -335,7 +335,7 @@ type BoundModel private (
                 if enableBackgroundItemKeyStoreAndSemanticClassification then
                     use _ = Activity.start "IncrementalBuild.CreateItemKeyStoreAndSemanticClassification" [|Activity.Tags.fileName, fileName|]
                     let sResolutions = sink.GetResolutions()
-                    let builder = ItemKeyStoreBuilder()
+                    let builder = ItemKeyStoreBuilder(tcGlobals)
                     let preventDuplicates = HashSet({ new IEqualityComparer<struct(pos * pos)> with
                                                         member _.Equals((s1, e1): struct(pos * pos), (s2, e2): struct(pos * pos)) = Position.posEq s1 s2 && Position.posEq e1 e2
                                                         member _.GetHashCode o = o.GetHashCode() })

src/Compiler/Service/ItemKey.fs

@@ -16,6 +16,8 @@ open FSharp.Compiler.Text.Range
 open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeBasics
 open FSharp.Compiler.Syntax.PrettyNaming
+open FSharp.Compiler.TypedTreeOps
+open FSharp.Compiler.TcGlobals
 
 #nowarn "9"
 #nowarn "51"
@@ -96,8 +98,75 @@ module ItemKeyTags =
     [<Literal>]
     let parameters = "p$p$"
 
+type DebugKeyStore() =
+
+    let mutable debugCurrentItem = ResizeArray()
+
+    member val Items = ResizeArray()
+
+    member _.WriteRange(m: range) = debugCurrentItem.Add("range", $"{m}")
+
+    member _.WriteEntityRef(eref: EntityRef) =
+        debugCurrentItem.Add("EntityRef", $"{eref}")
+
+    member _.WriteILType(ilTy: ILType) =
+        debugCurrentItem.Add("ILType", $"%A{ilTy}")
+
+    member _.WriteType isStandalone (ty: TType) =
+        debugCurrentItem.Add("Type", $"{isStandalone} %A{ty}")
+
+    member _.WriteMeasure isStandalone (ms: Measure) =
+        debugCurrentItem.Add("Measure", $"{isStandalone} %A{ms}")
+
+    member _.WriteTypar (isStandalone: bool) (typar: Typar) =
+        debugCurrentItem.Add("Typar", $"{isStandalone} %A{typar}")
+
+    member _.WriteValRef(vref: ValRef) =
+        debugCurrentItem.Add("ValRef", $"{vref}")
+
+    member _.WriteValue(vref: ValRef) =
+        debugCurrentItem.Add("Value", $"{vref}")
+
+    member _.WriteActivePatternCase (apInfo: ActivePatternInfo) index =
+        debugCurrentItem.Add("ActivePatternCase", $"{apInfo} {index}")
+
+    member this.FinishItem(item, length) =
+        debugCurrentItem.Add("length", $"{length}")
+        this.Items.Add(item, debugCurrentItem)
+        let itemCount = this.Items.Count
+        assert (itemCount > 0)
+        debugCurrentItem <- ResizeArray()
+
+    member _.New() = DebugKeyStore()
+
+type DebugKeyStoreNoop() =
+
+    member inline _.Items = Unchecked.defaultof<_>
+
+    member inline _.WriteRange(_m: range) = ()
+
+    member inline _.WriteEntityRef(_eref: EntityRef) = ()
+
+    member inline _.WriteILType(_ilTy: ILType) = ()
+
+    member inline _.WriteType _isStandalone (_ty: TType) = ()
+
+    member inline _.WriteMeasure _isStandalone (_ms: Measure) = ()
+
+    member inline _.WriteTypar (_isStandalone: bool) (_typar: Typar) = ()
+
+    member inline _.WriteValRef(_vref: ValRef) = ()
+
+    member inline _.WriteValue(_vref: ValRef) = ()
+
+    member inline _.WriteActivePatternCase (_apInfo: ActivePatternInfo) _index = ()
+
+    member inline _.FinishItem(_item, _length) = ()
+
+    member inline this.New() = this
+
 [<Sealed>]
-type ItemKeyStore(mmf: MemoryMappedFile, length) =
+type ItemKeyStore(mmf: MemoryMappedFile, length, tcGlobals, debugStore) =
 
     let rangeBuffer = Array.zeroCreate<byte> sizeof<range>
 
@@ -107,6 +176,8 @@ type ItemKeyStore(mmf: MemoryMappedFile, length) =
         if isDisposed then
             raise (ObjectDisposedException("ItemKeyStore"))
 
+    member _.DebugStore = debugStore
+
     member _.ReadRange(reader: byref<BlobReader>) =
         reader.ReadBytes(sizeof<range>, rangeBuffer, 0)
         MemoryMarshal.Cast<byte, range>(Span(rangeBuffer)).[0]
@@ -133,7 +204,7 @@ type ItemKeyStore(mmf: MemoryMappedFile, length) =
     member this.FindAll(item: Item) =
         checkDispose ()
 
-        let builder = ItemKeyStoreBuilder()
+        let builder = ItemKeyStoreBuilder(tcGlobals)
         builder.Write(range0, item)
 
         match builder.TryBuildAndReset() with
@@ -166,10 +237,13 @@ type ItemKeyStore(mmf: MemoryMappedFile, length) =
             isDisposed <- true
             mmf.Dispose()
 
-and [<Sealed>] ItemKeyStoreBuilder() =
+and [<Sealed>] ItemKeyStoreBuilder(tcGlobals: TcGlobals) =
 
     let b = BlobBuilder()
 
+    // Change this to DebugKeyStore() for debugging (DebugStore will be available on ItemKeyStore)
+    let mutable debug = DebugKeyStoreNoop()
+
     let writeChar (c: char) = b.WriteUInt16(uint16 c)
 
     let writeUInt16 (i: uint16) = b.WriteUInt16 i
@@ -181,16 +255,20 @@ and [<Sealed>] ItemKeyStoreBuilder() =
     let writeString (str: string) = b.WriteUTF16 str
 
     let writeRange (m: range) =
+        debug.WriteRange m
         let mutable m = m
         let ptr = &&m |> NativePtr.toNativeInt |> NativePtr.ofNativeInt<byte>
         b.WriteBytes(ptr, sizeof<range>)
 
     let writeEntityRef (eref: EntityRef) =
+        debug.WriteEntityRef eref
         writeString ItemKeyTags.entityRef
         writeString eref.CompiledName
         eref.CompilationPath.MangledPath |> List.iter (fun str -> writeString str)
 
     let rec writeILType (ilTy: ILType) =
+        debug.WriteILType ilTy
+
         match ilTy with
         | ILType.TypeVar n ->
             writeString "!"
@@ -231,6 +309,8 @@ and [<Sealed>] ItemKeyStoreBuilder() =
             writeILType mref.ReturnType
 
     let rec writeType isStandalone (ty: TType) =
+        debug.WriteType isStandalone ty
+
         match stripTyparEqns ty with
         | TType_forall (_, ty) -> writeType false ty
 
@@ -268,6 +348,8 @@ and [<Sealed>] ItemKeyStoreBuilder() =
                 writeString nm
 
     and writeMeasure isStandalone (ms: Measure) =
+        debug.WriteMeasure isStandalone ms
+
         match ms with
         | Measure.Var typar ->
             writeString ItemKeyTags.typeMeasureVar
@@ -278,20 +360,39 @@ and [<Sealed>] ItemKeyStoreBuilder() =
         | _ -> ()
 
     and writeTypar (isStandalone: bool) (typar: Typar) =
+        debug.WriteTypar isStandalone typar
+
         match typar.Solution with
         | Some ty -> writeType isStandalone ty
         | _ ->
             if isStandalone then
                 writeInt64 typar.Stamp
 
     let writeValRef (vref: ValRef) =
+        debug.WriteValRef vref
+
         match vref.MemberInfo with
         | Some memberInfo ->
             writeString ItemKeyTags.itemValueMember
-            writeEntityRef memberInfo.ApparentEnclosingEntity
+
+            match vref.IsOverrideOrExplicitImpl, vref.MemberInfo with
+            | true,
+              Some {
+                       ImplementedSlotSigs = slotSig :: _tail
+                   } -> slotSig.DeclaringType |> writeType false
+            | _ -> writeEntityRef memberInfo.ApparentEnclosingEntity
+
             writeString vref.LogicalName
             writeString ItemKeyTags.parameters
-            writeType false vref.Type
+
+            if vref.IsInstanceMember && isFunTy tcGlobals vref.Type then
+                // In case of an instance member, we will skip the type of "this" because it will differ
+                // between the definition and overrides. Also it's not needed to uniquely identify the reference.
+                destFunTy tcGlobals vref.Type |> snd
+            else
+                vref.Type
+            |> writeType false
+
         | _ ->
             writeString ItemKeyTags.itemValue
             writeString vref.LogicalName
@@ -307,6 +408,8 @@ and [<Sealed>] ItemKeyStoreBuilder() =
             | Parent eref -> writeEntityRef eref
 
     let writeValue (vref: ValRef) =
+        debug.WriteValue vref
+
         if vref.IsPropertyGetterMethod || vref.IsPropertySetterMethod then
             writeString ItemKeyTags.itemProperty
             writeString vref.PropertyName
@@ -322,6 +425,8 @@ and [<Sealed>] ItemKeyStoreBuilder() =
             writeValRef vref
 
     let writeActivePatternCase (apInfo: ActivePatternInfo) index =
+        debug.WriteActivePatternCase apInfo index
+
         writeString ItemKeyTags.itemActivePattern
 
         match apInfo.ActiveTagsWithRanges with
@@ -474,6 +579,7 @@ and [<Sealed>] ItemKeyStoreBuilder() =
         let postCount = b.Count
 
         fixup.WriteInt32(postCount - preCount)
+        debug.FinishItem(item, postCount - preCount)
 
     member _.TryBuildAndReset() =
         if b.Count > 0 then
@@ -495,7 +601,10 @@ and [<Sealed>] ItemKeyStoreBuilder() =
 
             b.Clear()
 
-            Some(new ItemKeyStore(mmf, length))
+            let result = Some(new ItemKeyStore(mmf, length, tcGlobals, debug.Items))
+            debug <- debug.New()
+            result
         else
             b.Clear()
+            debug <- debug.New()
             None

src/Compiler/Service/ItemKey.fsi

@@ -5,6 +5,7 @@ namespace FSharp.Compiler.CodeAnalysis
 open System
 open FSharp.Compiler.NameResolution
 open FSharp.Compiler.Text
+open FSharp.Compiler.TcGlobals
 
 /// Stores a list of item key strings and their ranges in a memory mapped file.
 [<Sealed>]
@@ -17,7 +18,7 @@ type internal ItemKeyStore =
 [<Sealed>]
 type internal ItemKeyStoreBuilder =
 
-    new: unit -> ItemKeyStoreBuilder
+    new: TcGlobals -> ItemKeyStoreBuilder
 
     member Write: range * Item -> unit
 

tests/FSharp.Compiler.ComponentTests/FSharpChecker/FindReferences.fs

@@ -533,71 +533,70 @@ match 2 with | Even -> () | Odd -> ()
 
 module Interfaces =
 
-    [<Fact>]
-    let ``We find all references to interface methods`` () =
-
-        let source = """
+    let project() =
+        let source1 = """
 type IInterface1 =
-    abstract member Method1 : int
+    abstract member Property1 : int
+    abstract member Method1: unit -> int
+    abstract member Method1: string -> int
 
 type IInterface2 =
-    abstract member Method2 : int
-
+    abstract member Property2 : int
+        """
+        let source2 = """
+open ModuleFirst
 type internal SomeType() =
 
     interface IInterface1 with
-        member _.Method1 =
-            42
+        member _.Property1 = 42
+        member _.Method1() = 43
+        member _.Method1(foo) = 43
 
     interface IInterface2 with
-        member this.Method2 =
-            (this :> IInterface1).Method1
+        member this.Property2 =
+            (this :> IInterface1).Property1
         """
 
-        SyntheticProject.Create( { sourceFile "Program" [] with Source = source } ).Workflow {
-            placeCursor "Program" "Method1"
-            findAllReferences (expectToFind [
-                "FileProgram.fs", 4, 20, 27
-                "FileProgram.fs", 12, 17, 24
-                "FileProgram.fs", 17, 12, 41 // Not sure why we get the whole range here, but it seems to work fine.
-            ])
-        }
+        SyntheticProject.Create( 
+            { sourceFile "First" [] with Source = source1 }, 
+            { sourceFile "Second" [] with Source = source2 } )
 
-    [<Fact>]
-    let ``We find all references to interface methods starting from implementation`` () =
-
-        let source1 = """
-type IInterface1 =
-    abstract member Method1 : int
-
-type IInterface2 =
-    abstract member Method2 : int
-        """
+    let property1Locations() = [
+        "FileFirst.fs", 4, 20, 29
+        "FileSecond.fs", 7, 17, 26
+        "FileSecond.fs", 13, 12, 43 // Not sure why we get the whole range here, but it seems to work fine.
+    ]
 
-        let source2 = """
-open ModuleFirst
+    let method1Locations() = [
+        "FileFirst.fs", 5, 20, 27
+        "FileSecond.fs", 8, 17, 24
+    ]
 
-type internal SomeType() =
+    [<Fact>]
+    let ``We find all references to interface properties`` () =
+        project().Workflow {
+            placeCursor "First" "Property1"
+            findAllReferences (expectToFind <| property1Locations())
+        }
 
-    interface IInterface1 with
-        member _.Method1 =
-            42
+    [<Fact>]
+    let ``We find all references to interface properties starting from implementation`` () =
+        project().Workflow {
+            placeCursor "Second" "Property1"
+            findAllReferences (expectToFind <| property1Locations())
+        }
 
-    interface IInterface2 with
-        member this.Method2 =
-            (this :> IInterface1).Method1
-        """
+    [<Fact>]
+    let ``We find all references to interface methods`` () =
+        project().Workflow {
+            placeCursor "First" "Method1"
+            findAllReferences (expectToFind <| method1Locations())
+        }
 
-        SyntheticProject.Create(
-            { sourceFile "First" [] with Source = source1 },
-            { sourceFile "Second" [] with Source = source2 }
-        ).Workflow {
+    [<Fact>]
+    let ``We find all references to interface methods starting from implementation`` () =
+        project().Workflow {
             placeCursor "Second" "Method1"
-            findAllReferences (expectToFind [
-                "FileFirst.fs", 4, 20, 27
-                "FileSecond.fs", 8, 17, 24
-                "FileSecond.fs", 13, 12, 41 // Not sure why we get the whole range here, but it seems to work fine.
-            ])
+            findAllReferences (expectToFind <| method1Locations())
         }
 
-