Fix race in graph checking of type extensions (#19062)

Author: majocha

docs/release-notes/.FSharp.Compiler.Service/11.0.0.md

@@ -9,6 +9,7 @@
 * Type relations cache: handle potentially "infinite" types ([PR #19010](https://github.com/dotnet/fsharp/pull/19010))  
 * Disallow recursive structs with lifted type parameters ([Issue #18993](https://github.com/dotnet/fsharp/issues/18993), [PR #19031](https://github.com/dotnet/fsharp/pull/19031))
 * Fix units-of-measure changes not invalidating incremental builds. ([Issue #19049](https://github.com/dotnet/fsharp/issues/19049))
+* Fix race in graph checking of type extensions. ([PR #19062](https://github.com/dotnet/fsharp/pull/19062))
 * Type relations cache: handle unsolved type variables ([Issue #19037](https://github.com/dotnet/fsharp/issues/19037)) ([PR #19040](https://github.com/dotnet/fsharp/pull/19040))
 
 ### Added

src/Compiler/Checking/CheckDeclarations.fs

@@ -4217,18 +4217,7 @@ module TcDeclarations =
             let resInfo = TypeNameResolutionStaticArgsInfo.FromTyArgs synTypars.Length
             let tcref =
                 match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurrence.Binding OpenQualified envForDecls.NameEnv ad longPath resInfo PermitDirectReferenceToGeneratedType.No with
-                | Result res ->
-                    // Update resolved type parameters with the names from the source.
-                    let _, tcref, _ = res
-                    if tcref.TyparsNoRange.Length = synTypars.Length then
-                        (tcref.TyparsNoRange, synTypars)
-                        ||> List.zip
-                        |> List.iter (fun (typar, SynTyparDecl.SynTyparDecl (typar = tp)) ->
-                            let (SynTypar(ident = untypedIdent; staticReq = sr)) = tp
-                            if typar.StaticReq = sr then
-                                typar.SetIdent(untypedIdent)
-                        )
-
+                | Result (_, tcref, _) ->
                     tcref
 
                 | Exception exn ->

src/Compiler/Checking/NicePrint.fs

@@ -724,7 +724,7 @@ module PrintTypes =
             (sprintf "%s%s%s"
                 (if denv.showStaticallyResolvedTyparAnnotations then prefixOfStaticReq typar.StaticReq else "'")
                 (if denv.showInferenceTyparAnnotations then prefixOfInferenceTypar typar else "")
-                typar.DisplayName)
+                (typar.DeclaredName |> Option.defaultValue typar.Name))
         |> mkNav typar.Range
         |> wordL
 
@@ -1199,12 +1199,12 @@ module PrintTypes =
     let prettyArgInfos denv allTyparInst =
         function 
         | [] -> [(denv.g.unit_ty, ValReprInfo.unnamedTopArg1)] 
-        | infos -> infos |> List.map (map1Of2 (instType allTyparInst)) 
+        | infos -> infos |> List.map (map1Of2 (instType allTyparInst))
 
     // Layout: type spec - class, datatype, record, abbrev 
     let prettyLayoutOfMemberSigCore denv memberToParentInst (typarInst, methTypars: Typars, argInfos, retTy) = 
         let niceMethodTypars, allTyparInst = 
-            let methTyparNames = methTypars |> List.mapi (fun i tp -> if (PrettyTypes.NeedsPrettyTyparName tp) then sprintf "a%d" (List.length memberToParentInst + i) else tp.Name)
+            let methTyparNames = methTypars |> List.mapi (fun i tp -> if (PrettyTypes.NeedsPrettyTyparName tp) then sprintf "a%d" (List.length memberToParentInst + i) else tp.DeclaredName |> Option.defaultValue tp.Name )
             PrettyTypes.NewPrettyTypars memberToParentInst methTypars methTyparNames
 
         let retTy = instType allTyparInst retTy
@@ -1245,7 +1245,7 @@ module PrintTypes =
         let _niceMethodTypars, typarInst =
             let memberToParentInst = List.empty
             let typars = argInfos |> List.choose (function TType_var (typar, _),_ -> Some typar | _ -> None)
-            let methTyparNames = typars |> List.mapi (fun i tp -> if (PrettyTypes.NeedsPrettyTyparName tp) then sprintf "a%d" (List.length memberToParentInst + i) else tp.Name)
+            let methTyparNames = typars |> List.mapi (fun i tp -> if (PrettyTypes.NeedsPrettyTyparName tp) then sprintf "a%d" (List.length memberToParentInst + i) else tp.DeclaredName |> Option.defaultValue tp.Name)
             PrettyTypes.NewPrettyTypars memberToParentInst typars methTyparNames
 
         let retTy = instType typarInst retTy

src/Compiler/Checking/SignatureConformance.fs

@@ -143,6 +143,9 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) =
                   if check then
                       errorR (Error(FSComp.SR.typrelSigImplNotCompatibleCompileTimeRequirementsDiffer(), m))
 
+                  if not (PrettyTypes.NeedsPrettyTyparName implTypar) then
+                      implTypar.PreserveDeclaredName()
+                  
                   // Adjust the actual type parameter name to look like the signature
                   implTypar.SetIdent (mkSynId implTypar.Range sigTypar.Id.idText)     
 

src/Compiler/TypedTree/TypedTree.fs

@@ -2260,6 +2260,9 @@ type TyparOptionalData =
 
       /// Set to true if the typar is contravariant, i.e. declared as <in T> in C#
       mutable typar_is_contravariant: bool
+
+      /// The declared name of the type parameter.
+      mutable typar_declared_name: string option
     }
 
     [<DebuggerBrowsable(DebuggerBrowsableState.Never)>]
@@ -2361,10 +2364,10 @@ type Typar =
     member x.SetAttribs attribs = 
         match attribs, x.typar_opt_data with
         | [], None -> ()
-        | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_constraints = []; typar_is_contravariant = false } when doc.IsEmpty ->
+        | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_constraints = []; typar_is_contravariant = false; typar_declared_name = None } when doc.IsEmpty ->
             x.typar_opt_data <- None
         | _, Some optData -> optData.typar_attribs <- attribs
-        | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs; typar_is_contravariant = false }
+        | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs; typar_is_contravariant = false; typar_declared_name = None }
 
     /// Get the XML documentation for the type parameter
     member x.XmlDoc =
@@ -2382,7 +2385,20 @@ type Typar =
     member x.SetILName il_name =
         match x.typar_opt_data with
         | Some optData -> optData.typar_il_name <- il_name
-        | _ -> x.typar_opt_data <- Some { typar_il_name = il_name; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = []; typar_is_contravariant = false }
+        | _ -> x.typar_opt_data <- Some { typar_il_name = il_name; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = []; typar_is_contravariant = false; typar_declared_name = None}
+
+    /// Get the declared name of the type parameter
+    member x.DeclaredName =
+        match x.typar_opt_data with
+        | Some optData -> optData.typar_declared_name
+        | _ -> None
+
+    /// Save the name as the declared name of the type parameter if it is not already set
+    member x.PreserveDeclaredName() =
+        match x.typar_opt_data with
+        | Some optData when optData.typar_declared_name = None -> optData.typar_declared_name <- Some x.Name
+        | None -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = []; typar_is_contravariant = false; typar_declared_name = Some x.Name }
+        | _ -> ()
 
     /// Indicates the display name of a type variable
     member x.DisplayName = if x.Name = "?" then "?"+string x.Stamp else x.Name
@@ -2391,17 +2407,17 @@ type Typar =
     member x.SetConstraints cs =
         match cs, x.typar_opt_data with
         | [], None -> ()
-        | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_attribs = [];typar_is_contravariant = false } when doc.IsEmpty ->
+        | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_attribs = [];typar_is_contravariant = false; typar_declared_name = None } when doc.IsEmpty ->
             x.typar_opt_data <- None
         | _, Some optData -> optData.typar_constraints <- cs
-        | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = cs; typar_attribs = []; typar_is_contravariant = false }
+        | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = cs; typar_attribs = []; typar_is_contravariant = false; typar_declared_name = None }
 
     /// Marks the typar as being contravariant
     member x.MarkAsContravariant() = 
         match x.typar_opt_data with
         | Some optData -> optData.typar_is_contravariant <- true
         | _ ->
-            x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = []; typar_is_contravariant = true }
+            x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = []; typar_is_contravariant = true; typar_declared_name = None }
 
     /// Creates a type variable that contains empty data, and is not yet linked. Only used during unpickling of F# metadata.
     static member NewUnlinked() : Typar = 
@@ -2423,7 +2439,7 @@ type Typar =
         x.typar_solution <- tg.typar_solution
         match tg.typar_opt_data with
         | Some tg -> 
-            let optData = { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs; typar_is_contravariant = tg.typar_is_contravariant }
+            let optData = { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs; typar_is_contravariant = tg.typar_is_contravariant; typar_declared_name = tg.typar_declared_name }
             x.typar_opt_data <- Some optData
         | None -> ()
 
@@ -6183,7 +6199,7 @@ type Construct() =
             typar_opt_data =
                 match attribs with
                 | [] -> None
-                | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs; typar_is_contravariant = false  } } 
+                | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs; typar_is_contravariant = false; typar_declared_name = None } }
 
     /// Create a new type parameter node for a declared type parameter
     static member NewRigidTypar nm m =

src/Compiler/TypedTree/TypedTree.fsi

@@ -1494,6 +1494,9 @@ type TyparOptionalData =
 
         /// Set to true if the typar is contravariant, i.e. declared as <in T> in C#
         mutable typar_is_contravariant: bool
+
+        /// The declared name of the type parameter.
+        mutable typar_declared_name: string option
     }
 
     override ToString: unit -> string
@@ -1562,6 +1565,9 @@ type Typar =
     /// Set the IL name of the type parameter
     member SetILName: il_name: string option -> unit
 
+    /// Saves the name as the declared name of the type parameter if it is not already set.
+    member PreserveDeclaredName: unit -> unit
+
     /// Sets the identifier associated with a type variable
     member SetIdent: id: Ident -> unit
 
@@ -1594,6 +1600,9 @@ type Typar =
     [<DebuggerBrowsable(DebuggerBrowsableState.Never)>]
     member DebugText: string
 
+    /// Gets the declared name of the type parameter.
+    member DeclaredName: string option
+
     /// Indicates the display name of a type variable
     member DisplayName: string
 

src/Compiler/TypedTree/TypedTreeBasics.fs

@@ -197,7 +197,7 @@ let mkTyparTy (tp:Typar) =
 // For fresh type variables clear the StaticReq when copying because the requirement will be re-established through the
 // process of type inference.
 let copyTypar clearStaticReq (tp: Typar) = 
-    let optData = tp.typar_opt_data |> Option.map (fun tg -> { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs; typar_is_contravariant = tg.typar_is_contravariant  })
+    let optData = tp.typar_opt_data |> Option.map (fun tg -> { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs; typar_is_contravariant = tg.typar_is_contravariant; typar_declared_name = tg.typar_declared_name })
     let flags = if clearStaticReq then tp.typar_flags.WithStaticReq(TyparStaticReq.None) else tp.typar_flags
     Typar.New { typar_id = tp.typar_id
                 typar_flags = flags

src/Compiler/TypedTree/TypedTreePickle.fs

@@ -2406,6 +2406,7 @@ let u_tyar_spec_data st =
                         typar_constraints = e
                         typar_attribs = c
                         typar_is_contravariant = false
+                        typar_declared_name = None
                     }
     }
 

tests/FSharp.Compiler.ComponentTests/Signatures/TypeTests.fs

@@ -308,4 +308,38 @@ let foo = Foo()
         | :? FSharpMemberOrFunctionOrValue as mfv ->
             Assert.False(mfv.IsUnionCaseTester, "IsUnionCaseTester returned true")
             Assert.True(mfv.IsConstructor)
-        | _ -> failwith "Expected FSharpMemberOrFunctionOrValue"
+        | _ -> failwith "Expected FSharpMemberOrFunctionOrValue"
+
+
+
+[<Fact>]
+let ``Type extension type parameters do not overwrite the type being extended`` () =
+    let one =
+        FSharpWithFileName "One.fs" """
+module One
+
+type GenericType<'ActualType> = {
+    Value: 'ActualType
+}
+"""
+
+    let two =
+        FsSourceWithFileName "Two.fs" """
+module Two
+type One.GenericType<'U> with
+    member x.Print () = printfn "%A" x.Value
+"""
+
+    let three =
+        FsSourceWithFileName "Three.fs" """
+module Three
+
+open One
+
+type GenericType<'X> with
+    member _.Nothing() = ignore ()
+"""
+
+    one |> withAdditionalSourceFiles [ two; three ]
+    |> compile
+    |> verifyILContains [ ".Print<ActualType>" ]

tests/FSharp.Compiler.ComponentTests/TypeChecks/TyparNameTests.fs

@@ -141,3 +141,32 @@ let array2D (rows: seq<#seq<'T>>) : 'T[,] = failwith "todo"
             getGenericParametersNamesFor signatureFile "A" "array2D" implementationFile
 
         Assert.Equal<string array>([| "a"; "T" |], names)
+
+    [<Fact>]
+    let ``Type extension type parameters are preserved as declared name`` () =
+        let one =
+            FSharpWithFileName "One.fs" """
+module One
+
+type GenericType<'ActualType> = {
+    Value: 'ActualType
+}
+    """
+            |> withFileName "One.fs"
+
+        let two =
+            FsSourceWithFileName "Two.fs" """
+module Two
+type One.GenericType<'DeclaredType> with
+    member x.Print () = printfn "%A" x.Value
+    """
+
+        let result =         
+            one |> withAdditionalSourceFile two
+            |> typecheckProject false CompilerAssertHelpers.UseTransparentCompiler
+
+        let typar =
+            result.AssemblySignature.Entities[0].MembersFunctionsAndValues[0].GenericParameters[0].TypeParameter
+
+        Assert.Equal(Some "DeclaredType", typar.DeclaredName)
+        Assert.Equal("ActualType", typar.Name)