Merge main to release/net8

.fantomasignore

@@ -15,7 +15,6 @@ artifacts/
 # For some reason, it tries to format files from remotes (Processing .\.git\refs\remotes\<remote>\FSComp.fsi)
 .git/
 
-
 # Explicitly unformatted implementation
 src/Compiler/Checking/AccessibilityLogic.fs
 src/Compiler/Checking/AttributeChecking.fs
@@ -98,6 +97,7 @@ src/Compiler/Service/IncrementalBuild.fs
 src/Compiler/Service/ServiceAssemblyContent.fs
 src/Compiler/Service/ServiceDeclarationLists.fs
 src/Compiler/Service/ServiceErrorResolutionHints.fs
+vsintegration/src/FSharp.Editor/Common/CancellableTasks.fs
 
 # Fantomas limitations on signature files  (to investigate)
 

src/Compiler/Checking/CheckExpressions.fs

@@ -1807,10 +1807,17 @@ let BuildFieldMap (cenv: cenv) env isPartial ty (flds: ((Ident list * Ident) * '
     let fldResolutions =
         let allFields = flds |> List.map (fun ((_, ident), _) -> ident)
         flds
-        |> List.map (fun (fld, fldExpr) ->
-            let (fldPath, fldId) = fld
-            let frefSet = ResolveField cenv.tcSink cenv.nameResolver env.eNameResEnv ad ty fldPath fldId allFields
-            fld, frefSet, fldExpr)
+        |> List.choose (fun (fld, fldExpr) ->
+            try
+                let fldPath, fldId = fld
+                let frefSet = ResolveField cenv.tcSink cenv.nameResolver env.eNameResEnv ad ty fldPath fldId allFields
+                Some(fld, frefSet, fldExpr)
+            with e ->
+                errorRecoveryNoRange e
+                None
+        )
+
+    if fldResolutions.IsEmpty then None else
 
     let relevantTypeSets =
         fldResolutions |> List.map (fun (_, frefSet, _) ->
@@ -1870,7 +1877,7 @@ let BuildFieldMap (cenv: cenv) env isPartial ty (flds: ((Ident list * Ident) * '
                         Map.add fref2.FieldName fldExpr fs, (fref2.FieldName, fldExpr) :: rfldsList
 
                 | _ -> error(Error(FSComp.SR.tcRecordFieldInconsistentTypes(), m)))
-    tinst, tcref, fldsmap, List.rev rfldsList
+    Some(tinst, tcref, fldsmap, List.rev rfldsList)
 
 let rec ApplyUnionCaseOrExn (makerForUnionCase, makerForExnTag) m (cenv: cenv) env overallTy item =
     let g = cenv.g
@@ -2217,18 +2224,21 @@ module GeneralizationHelpers =
 //-------------------------------------------------------------------------
 
 let ComputeInlineFlag (memFlagsOption: SynMemberFlags option) isInline isMutable g attrs m =
-    let hasNoCompilerInliningAttribute() = HasFSharpAttribute g g.attrib_NoCompilerInliningAttribute attrs  
-    let isCtorOrAbstractSlot() =
+    let hasNoCompilerInliningAttribute () = HasFSharpAttribute g g.attrib_NoCompilerInliningAttribute attrs  
+
+    let isCtorOrAbstractSlot () =
         match memFlagsOption with
         | None -> false
         | Some x -> (x.MemberKind = SynMemberKind.Constructor) || x.IsDispatchSlot || x.IsOverrideOrExplicitImpl
 
+    let isExtern () = HasFSharpAttributeOpt g g.attrib_DllImportAttribute attrs
+
     let inlineFlag, reportIncorrectInlineKeywordUsage =
         // Mutable values may never be inlined
         // Constructors may never be inlined
         // Calls to virtual/abstract slots may never be inlined
         // Values marked with NoCompilerInliningAttribute or [<MethodImpl(MethodImplOptions.NoInlining)>] may never be inlined
-        if isMutable || isCtorOrAbstractSlot() || hasNoCompilerInliningAttribute() then
+        if isMutable || isCtorOrAbstractSlot() || hasNoCompilerInliningAttribute() || isExtern () then
             ValInline.Never, errorR
         elif HasMethodImplNoInliningAttribute g attrs then
             ValInline.Never, 
@@ -7362,7 +7372,10 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, m
         match flds with
         | [] -> []
         | _ ->
-            let tinst, tcref, _, fldsList = BuildFieldMap cenv env hasOrigExpr overallTy flds mWholeExpr
+            match BuildFieldMap cenv env hasOrigExpr overallTy flds mWholeExpr with
+            | None -> []
+            | Some(tinst, tcref, _, fldsList) ->
+
             let gtyp = mkAppTy tcref tinst
             UnifyTypes cenv env mWholeExpr overallTy gtyp
 
@@ -7393,7 +7406,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, m
             error(Error(errorInfo, mWholeExpr))
 
         if isFSharpObjModelTy g overallTy then errorR(Error(FSComp.SR.tcTypeIsNotARecordTypeNeedConstructor(), mWholeExpr))
-        elif not (isRecdTy g overallTy) then errorR(Error(FSComp.SR.tcTypeIsNotARecordType(), mWholeExpr))
+        elif not (isRecdTy g overallTy || fldsList.IsEmpty) then errorR(Error(FSComp.SR.tcTypeIsNotARecordType(), mWholeExpr))
 
     let superInitExprOpt , tpenv =
         match inherits, GetSuperTypeOfType g cenv.amap mWholeExpr overallTy with
@@ -7411,14 +7424,18 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, m
             errorR(InternalError("Unexpected failure in getting super type", mWholeExpr))
             None, tpenv
 
-    let expr, tpenv = TcRecordConstruction cenv overallTy env tpenv withExprInfoOpt overallTy fldsList mWholeExpr
+    if fldsList.IsEmpty && isTyparTy g overallTy then
+        SolveTypeAsError env.DisplayEnv cenv.css mWholeExpr overallTy
+        mkDefault (mWholeExpr, overallTy), tpenv
+    else
+        let expr, tpenv = TcRecordConstruction cenv overallTy env tpenv withExprInfoOpt overallTy fldsList mWholeExpr
 
-    let expr =
-        match superInitExprOpt  with
-        | _ when isStructTy g overallTy -> expr
-        | Some superInitExpr  -> mkCompGenSequential mWholeExpr superInitExpr  expr
-        | None -> expr
-    expr, tpenv
+        let expr =
+            match superInitExprOpt  with
+            | _ when isStructTy g overallTy -> expr
+            | Some superInitExpr  -> mkCompGenSequential mWholeExpr superInitExpr  expr
+            | None -> expr
+        expr, tpenv
 
 
 // Check '{| .... |}'

src/Compiler/Checking/CheckExpressions.fsi

@@ -895,7 +895,7 @@ val BuildFieldMap:
     ty: TType ->
     flds: ((Ident list * Ident) * 'T) list ->
     m: range ->
-        TypeInst * TyconRef * Map<string, 'T> * (string * 'T) list
+        (TypeInst * TyconRef * Map<string, 'T> * (string * 'T) list) option
 
 /// Check a long identifier 'Case' or 'Case argsR' that has been resolved to an active pattern case
 val TcPatLongIdentActivePatternCase:

src/Compiler/Checking/CheckPatterns.fs

@@ -435,7 +435,10 @@ and TcPatArrayOrList warnOnUpper cenv env vFlags patEnv ty isArray args m =
 
 and TcRecordPat warnOnUpper cenv env vFlags patEnv ty fieldPats m =
     let fieldPats = fieldPats |> List.map (fun (fieldId, _, fieldPat) -> fieldId, fieldPat)
-    let tinst, tcref, fldsmap, _fldsList = BuildFieldMap cenv env true ty fieldPats m
+    match BuildFieldMap cenv env true ty fieldPats m with
+    | None -> (fun _ -> TPat_error m), patEnv
+    | Some(tinst, tcref, fldsmap, _fldsList) ->
+
     let gtyp = mkAppTy tcref tinst
     let inst = List.zip (tcref.Typars m) tinst
 

src/Compiler/Checking/FindUnsolved.fs

@@ -8,6 +8,7 @@ open Internal.Utilities.Library
 open Internal.Utilities.Library.Extras
 open FSharp.Compiler
 open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Text
 open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeBasics
 open FSharp.Compiler.TypedTreeOps
@@ -29,14 +30,17 @@ type cenv =
     override _.ToString() = "<cenv>"
 
 /// Walk types, collecting type variables
-let accTy cenv _env ty =
+let accTy cenv _env (fallbackRange: Range option) ty =
     let normalizedTy = tryNormalizeMeasureInType cenv.g ty
     (freeInType CollectTyparsNoCaching normalizedTy).FreeTypars |> Zset.iter (fun tp -> 
-        if (tp.Rigidity <> TyparRigidity.Rigid) then 
+        if (tp.Rigidity <> TyparRigidity.Rigid) then
+            match fallbackRange with
+            | Some r when tp.Range = Range.range0 -> tp.SetIdent (FSharp.Compiler.Syntax.Ident(tp.typar_id.idText, r))
+            | _ -> ()
             cenv.unsolved <- tp :: cenv.unsolved) 
 
 let accTypeInst cenv env tyargs =
-    tyargs |> List.iter (accTy cenv env)
+    tyargs |> List.iter (accTy cenv env None)
 
 /// Walk expressions, collecting type variables
 let rec accExpr (cenv: cenv) (env: env) expr =
@@ -52,17 +56,17 @@ let rec accExpr (cenv: cenv) (env: env) expr =
         accBind cenv env bind  
         accExpr cenv env body
 
-    | Expr.Const (_, _, ty) -> 
-        accTy cenv env ty 
+    | Expr.Const (_, r, ty) -> 
+        accTy cenv env (Some r) ty 
 
     | Expr.Val (_v, _vFlags, _m) -> ()
 
-    | Expr.Quote (ast, _, _, _m, ty) -> 
+    | Expr.Quote (ast, _, _, m, ty) -> 
         accExpr cenv env ast
-        accTy cenv env ty
+        accTy cenv env (Some m) ty
 
-    | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, _m) -> 
-        accTy cenv env ty
+    | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, m) -> 
+        accTy cenv env (Some m) ty
         accExpr cenv env basecall
         accMethods cenv env basev overrides 
         accIntfImpls cenv env basev iimpls
@@ -77,8 +81,8 @@ let rec accExpr (cenv: cenv) (env: env) expr =
     | Expr.Op (c, tyargs, args, m) ->
         accOp cenv env (c, tyargs, args, m) 
 
-    | Expr.App (f, fty, tyargs, argsl, _m) ->
-        accTy cenv env fty
+    | Expr.App (f, fty, tyargs, argsl, m) ->
+        accTy cenv env (Some m) fty
         accTypeInst cenv env tyargs
         accExpr cenv env f
         accExprs cenv env argsl
@@ -88,33 +92,33 @@ let rec accExpr (cenv: cenv) (env: env) expr =
         let ty = mkMultiLambdaTy cenv.g m argvs bodyTy 
         accLambdas cenv env valReprInfo expr ty
 
-    | Expr.TyLambda (_, tps, _body, _m, bodyTy)  -> 
+    | Expr.TyLambda (_, tps, _body, m, bodyTy)  -> 
         let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal) 
-        accTy cenv env bodyTy
+        accTy cenv env (Some m) bodyTy
         let ty = mkForallTyIfNeeded tps bodyTy 
         accLambdas cenv env valReprInfo expr ty
 
     | Expr.TyChoose (_tps, e1, _m)  -> 
         accExpr cenv env e1 
 
     | Expr.Match (_, _exprm, dtree, targets, m, ty) -> 
-        accTy cenv env ty
+        accTy cenv env (Some m) ty
         accDTree cenv env dtree
         accTargets cenv env m ty targets
 
     | Expr.LetRec (binds, e, _m, _) ->  
         accBinds cenv env binds
         accExpr cenv env e
 
-    | Expr.StaticOptimization (constraints, e2, e3, _m) -> 
+    | Expr.StaticOptimization (constraints, e2, e3, m) -> 
         accExpr cenv env e2
         accExpr cenv env e3
         constraints |> List.iter (function 
             | TTyconEqualsTycon(ty1, ty2) -> 
-                accTy cenv env ty1
-                accTy cenv env ty2
+                accTy cenv env (Some m) ty1
+                accTy cenv env (Some m) ty2
             | TTyconIsStruct(ty1) -> 
-                accTy cenv env ty1)
+                accTy cenv env (Some m) ty1)
 
     | Expr.WitnessArg (traitInfo, _m) ->
         accTraitInfo cenv env traitInfo
@@ -136,7 +140,7 @@ and accIntfImpls cenv env baseValOpt l =
     List.iter (accIntfImpl cenv env baseValOpt) l
 
 and accIntfImpl cenv env baseValOpt (ty, overrides) = 
-    accTy cenv env ty
+    accTy cenv env None ty
     accMethods cenv env baseValOpt overrides 
 
 and accOp cenv env (op, tyargs, args, _m) =
@@ -158,16 +162,16 @@ and accOp cenv env (op, tyargs, args, _m) =
 
 and accTraitInfo cenv env (TTrait(tys, _nm, _, argTys, retTy, _sln)) =
     argTys |> accTypeInst cenv env 
-    retTy |> Option.iter (accTy cenv env)
-    tys |> List.iter (accTy cenv env)
+    retTy |> Option.iter (accTy cenv env None)
+    tys |> List.iter (accTy cenv env None)
 
 and accLambdas cenv env valReprInfo expr exprTy =
     match stripDebugPoints expr with
     | Expr.TyChoose (_tps, bodyExpr, _m)  -> accLambdas cenv env valReprInfo bodyExpr exprTy      
-    | Expr.Lambda _
-    | Expr.TyLambda _ ->
+    | Expr.Lambda (range = range)
+    | Expr.TyLambda (range = range) ->
         let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo cenv.g cenv.amap valReprInfo (expr, exprTy) 
-        accTy cenv env bodyTy
+        accTy cenv env (Some range) bodyTy
         vsl |> List.iterSquared (accVal cenv env)
         baseValOpt |> Option.iter (accVal cenv env)
         ctorThisValOpt |> Option.iter (accVal cenv env)
@@ -198,23 +202,23 @@ and accSwitch cenv env (e, cases, dflt, _m) =
 and accDiscrim cenv env d =
     match d with 
     | DecisionTreeTest.UnionCase(_ucref, tinst) -> accTypeInst cenv env tinst 
-    | DecisionTreeTest.ArrayLength(_, ty) -> accTy cenv env ty
+    | DecisionTreeTest.ArrayLength(_, ty) -> accTy cenv env None ty
     | DecisionTreeTest.Const _
     | DecisionTreeTest.IsNull -> ()
-    | DecisionTreeTest.IsInst (srcTy, tgtTy) -> accTy cenv env srcTy; accTy cenv env tgtTy
+    | DecisionTreeTest.IsInst (srcTy, tgtTy) -> accTy cenv env None srcTy; accTy cenv env None tgtTy
     | DecisionTreeTest.ActivePatternCase (exp, tys, _, _, _, _) -> 
         accExpr cenv env exp
         accTypeInst cenv env tys
     | DecisionTreeTest.Error _ -> ()
 
-and accAttrib cenv env (Attrib(_, _k, args, props, _, _, _m)) = 
+and accAttrib cenv env (Attrib(_, _k, args, props, _, _, m)) = 
     args |> List.iter (fun (AttribExpr(expr1, expr2)) -> 
         accExpr cenv env expr1
         accExpr cenv env expr2)
     props |> List.iter (fun (AttribNamedArg(_nm, ty, _flg, AttribExpr(expr, expr2))) -> 
         accExpr cenv env expr
         accExpr cenv env expr2
-        accTy cenv env ty)
+        accTy cenv env (Some m) ty)
 
 and accAttribs cenv env attribs = 
     List.iter (accAttrib cenv env) attribs
@@ -229,7 +233,7 @@ and accArgReprInfo cenv env (argInfo: ArgReprInfo) =
 and accVal cenv env v =
     v.Attribs |> accAttribs cenv env
     v.ValReprInfo |> Option.iter (accValReprInfo cenv env)
-    v.Type |> accTy cenv env 
+    v.Type |> accTy cenv env None 
 
 and accBind cenv env (bind: Binding) =
     accVal cenv env bind.Var    

src/Compiler/Checking/NameResolution.fs

@@ -541,8 +541,9 @@ let private GetCSharpStyleIndexedExtensionMembersForTyconRef (amap: Import.Impor
 
         let csharpStyleExtensionMembers = 
             if IsTyconRefUsedForCSharpStyleExtensionMembers g m tcrefOfStaticClass || tcrefOfStaticClass.IsLocalRef then
-                GetImmediateIntrinsicMethInfosOfType (None, AccessorDomain.AccessibleFromSomeFSharpCode) g amap m ty
-                |> List.filter (IsMethInfoPlainCSharpStyleExtensionMember g m true)
+                protectAssemblyExploration [] (fun () ->
+                    GetImmediateIntrinsicMethInfosOfType (None, AccessorDomain.AccessibleFromSomeFSharpCode) g amap m ty
+                    |> List.filter (IsMethInfoPlainCSharpStyleExtensionMember g m true))
             else
                 []
 
@@ -2137,14 +2138,16 @@ type TcResultsSinkImpl(tcGlobals, ?sourceText: ISourceText) =
             if allowedRange m then
                 if replace then
                     remove m
-                elif not (isAlreadyDone endPos item m) then
+
+                if not (isAlreadyDone endPos item m) then
                     capturedNameResolutions.Add(CapturedNameResolution(item, tpinst, occurenceType, nenv, ad, m))
 
         member sink.NotifyMethodGroupNameResolution(endPos, item, itemMethodGroup, tpinst, occurenceType, nenv, ad, m, replace) =
             if allowedRange m then
                 if replace then
                     remove m
-                elif not (isAlreadyDone endPos item m) then
+
+                if not (isAlreadyDone endPos item m) then
                     capturedNameResolutions.Add(CapturedNameResolution(item, tpinst, occurenceType, nenv, ad, m))
                     capturedMethodGroupResolutions.Add(CapturedNameResolution(itemMethodGroup, [], occurenceType, nenv, ad, m))
 
@@ -2724,6 +2727,36 @@ let rec ResolveLongIdentInTypePrim (ncenv: NameResolver) nenv lookupKind (resInf
 
         let errorTextF s =
             match tryTcrefOfAppTy g ty with
+            | ValueSome tcref when tcref.IsRecordTycon ->
+                let alternative = nenv.eFieldLabels |> Map.tryFind nm
+                match alternative with
+                | Some fieldLabels ->
+                    let fieldsOfResolvedType = tcref.AllFieldsArray  |> Array.map (fun f -> f.LogicalName) |> Set.ofArray
+                    let fieldsOfAlternatives =
+                        fieldLabels
+                        |> Seq.collect (fun l -> l.Tycon.AllFieldsArray |> Array.map (fun f -> f.LogicalName))
+                        |> Set.ofSeq
+                    let intersect = Set.intersect fieldsOfAlternatives fieldsOfResolvedType
+
+                    if not intersect.IsEmpty then
+                        let resolvedTypeName = NicePrint.fqnOfEntityRef g tcref
+                        let namesOfAlternatives =
+                            fieldLabels
+                            |> List.map (fun l -> $"    %s{NicePrint.fqnOfEntityRef g l.TyconRef}")
+                            |> fun names -> $"    %s{resolvedTypeName}" :: names
+                        let candidates = System.String.Join("\n", namesOfAlternatives)
+                        let overlappingNames =
+                            intersect
+                            |> Set.toArray
+                            |> Array.sort
+                            |> Array.map (fun s -> $"    %s{s}")
+                            |> fun a -> System.String.Join("\n", a)
+                        if g.langVersion.SupportsFeature(LanguageFeature.WarningWhenMultipleRecdTypeChoice) then
+                            warning(Error(FSComp.SR.tcMultipleRecdTypeChoice(candidates, resolvedTypeName, overlappingNames), m))
+                        else
+                            informationalWarning(Error(FSComp.SR.tcMultipleRecdTypeChoice(candidates, resolvedTypeName, overlappingNames), m))
+                | _ -> ()
+                FSComp.SR.undefinedNameFieldConstructorOrMemberWhenTypeIsKnown(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars, s)
             | ValueSome tcref ->
                 FSComp.SR.undefinedNameFieldConstructorOrMemberWhenTypeIsKnown(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars, s)
             | _ ->

src/Compiler/Checking/NicePrint.fs

@@ -2615,6 +2615,8 @@ let stringOfFSAttrib denv x = x |> PrintTypes.layoutAttrib denv |> squareAngleL
 
 let stringOfILAttrib denv x = x |> PrintTypes.layoutILAttrib denv |> squareAngleL |> showL
 
+let fqnOfEntityRef g x = x |> layoutTyconRefImpl false (DisplayEnv.Empty g) |> showL
+
 let layoutImpliedSignatureOfModuleOrNamespace showHeader denv infoReader ad m contents =
     InferredSigPrinting.layoutImpliedSignatureOfModuleOrNamespace showHeader denv infoReader ad m contents 
 

src/Compiler/Checking/NicePrint.fsi

@@ -135,6 +135,8 @@ val stringOfFSAttrib: denv: DisplayEnv -> x: Attrib -> string
 
 val stringOfILAttrib: denv: DisplayEnv -> ILType * ILAttribElem list -> string
 
+val fqnOfEntityRef: g: TcGlobals -> x: EntityRef -> string
+
 val layoutImpliedSignatureOfModuleOrNamespace:
     showHeader: bool ->
     denv: DisplayEnv ->