Merge pull request #14373 from dotnet/merges/main-to-release/dev17.5

src/Compiler/Checking/CheckBasics.fs

@@ -4,6 +4,7 @@ module internal FSharp.Compiler.CheckBasics
 
 open System.Collections.Generic
 
+open FSharp.Compiler.Diagnostics
 open Internal.Utilities.Library
 open Internal.Utilities.Library.Extras
 open FSharp.Compiler
@@ -310,6 +311,8 @@ type TcFileState =
 
       isInternalTestSpanStackReferring: bool
 
+      diagnosticOptions: FSharpDiagnosticOptions
+
       // forward call
       TcPat: WarnOnUpperFlag -> TcFileState -> TcEnv -> PrelimValReprInfo option -> TcPatValFlags -> TcPatLinearEnv -> TType -> SynPat -> (TcPatPhase2Input -> Pattern) * TcPatLinearEnv
 
@@ -328,7 +331,7 @@ type TcFileState =
 
     /// Create a new compilation environment
     static member Create
-         (g, isScript, amap, thisCcu, isSig, haveSig, conditionalDefines, tcSink, tcVal, isInternalTestSpanStackReferring,
+         (g, isScript, amap, thisCcu, isSig, haveSig, conditionalDefines, tcSink, tcVal, isInternalTestSpanStackReferring, diagnosticOptions,
           tcPat,
           tcSimplePats,
           tcSequenceExpressionEntry,
@@ -358,6 +361,7 @@ type TcFileState =
           compilingCanonicalFslibModuleType = (isSig || not haveSig) && g.compilingFSharpCore
           conditionalDefines = conditionalDefines
           isInternalTestSpanStackReferring = isInternalTestSpanStackReferring
+          diagnosticOptions = diagnosticOptions
           TcPat = tcPat
           TcSimplePats = tcSimplePats
           TcSequenceExpressionEntry = tcSequenceExpressionEntry

src/Compiler/Checking/CheckBasics.fsi

@@ -3,6 +3,7 @@
 module internal FSharp.Compiler.CheckBasics
 
 open System.Collections.Generic
+open FSharp.Compiler.Diagnostics
 open Internal.Utilities.Library
 open FSharp.Compiler.AccessibilityLogic
 open FSharp.Compiler.CompilerGlobalState
@@ -260,6 +261,8 @@ type TcFileState =
 
         isInternalTestSpanStackReferring: bool
 
+        diagnosticOptions: FSharpDiagnosticOptions
+
         // forward call
         TcPat: WarnOnUpperFlag
             -> TcFileState
@@ -319,6 +322,7 @@ type TcFileState =
         tcSink: TcResultsSink *
         tcVal: TcValF *
         isInternalTestSpanStackReferring: bool *
+        diagnosticOptions: FSharpDiagnosticOptions *
         tcPat: (WarnOnUpperFlag -> TcFileState -> TcEnv -> PrelimValReprInfo option -> TcPatValFlags -> TcPatLinearEnv -> TType -> SynPat -> (TcPatPhase2Input -> Pattern) * TcPatLinearEnv) *
         tcSimplePats: (TcFileState -> bool -> CheckConstraints -> TType -> TcEnv -> TcPatLinearEnv -> SynSimplePats -> string list * TcPatLinearEnv) *
         tcSequenceExpressionEntry: (TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv) *

src/Compiler/Checking/CheckDeclarations.fs

@@ -456,14 +456,17 @@ module TcRecdUnionAndEnumDeclarations =
     let TcAnonFieldDecl cenv env parent tpenv nm (SynField(Attributes attribs, isStatic, idOpt, ty, isMutable, xmldoc, vis, m, _)) =
         let mName = m.MakeSynthetic()
         let id = match idOpt with None -> mkSynId mName nm | Some id -> id
-        let xmlDoc = xmldoc.ToXmlDoc(true, Some [])
+
+        let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+        let xmlDoc = xmldoc.ToXmlDoc(checkXmlDocs, Some [])
         TcFieldDecl cenv env parent false tpenv (isStatic, attribs, id, idOpt.IsNone, ty, isMutable, xmlDoc, vis, m)
 
     let TcNamedFieldDecl cenv env parent isIncrClass tpenv (SynField(Attributes attribs, isStatic, id, ty, isMutable, xmldoc, vis, m, _)) =
         match id with 
         | None -> error (Error(FSComp.SR.tcFieldRequiresName(), m))
         | Some id ->
-            let xmlDoc = xmldoc.ToXmlDoc(true, Some [])
+            let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+            let xmlDoc = xmldoc.ToXmlDoc(checkXmlDocs, Some [])
             TcFieldDecl cenv env parent isIncrClass tpenv (isStatic, attribs, id, false, ty, isMutable, xmlDoc, vis, m) 
 
     let TcNamedFieldDecls cenv env parent isIncrClass tpenv fields =
@@ -552,7 +555,8 @@ module TcRecdUnionAndEnumDeclarations =
                     |> Seq.map (fun f -> f.DisplayNameCore)
                     |> Seq.toList
 
-        let xmlDoc = xmldoc.ToXmlDoc(true, Some names)
+        let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+        let xmlDoc = xmldoc.ToXmlDoc(checkXmlDocs, Some names)
         Construct.NewUnionCase id rfields recordTy attrs xmlDoc vis
 
     let TcUnionCaseDecls (cenv: cenv) env (parent: ParentRef) (thisTy: TType) (thisTyInst: TypeInst) hasRQAAttribute tpenv unionCases =
@@ -571,7 +575,8 @@ module TcRecdUnionAndEnumDeclarations =
             let vis, _ = ComputeAccessAndCompPath env None m None None parent
             let vis = CombineReprAccess parent vis
             if id.idText = "value__" then errorR(Error(FSComp.SR.tcNotValidEnumCaseName(), id.idRange))
-            let xmlDoc = xmldoc.ToXmlDoc(true, Some [])
+            let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+            let xmlDoc = xmldoc.ToXmlDoc(checkXmlDocs, Some [])
             Construct.NewRecdField true (Some v) id false thisTy false false [] attrs xmlDoc vis false
 
     let TcEnumDecls (cenv: cenv) env parent thisTy enumCases =
@@ -2197,7 +2202,9 @@ module TcExceptionDeclarations =
         CheckForDuplicateConcreteType env (id.idText + "Exception") id.idRange
         CheckForDuplicateConcreteType env id.idText id.idRange
         let repr = TExnFresh (Construct.MakeRecdFieldsTable [])
-        let xmlDoc = xmlDoc.ToXmlDoc(true, Some [])
+
+        let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+        let xmlDoc = xmlDoc.ToXmlDoc(checkXmlDocs, Some [])
         Construct.NewExn cpath id vis repr attrs xmlDoc
 
     let TcExnDefnCore_Phase1G_EstablishRepresentation (cenv: cenv) (env: TcEnv) parent (exnc: Entity) (SynExceptionDefnRepr(_, SynUnionCase(caseType=args), reprIdOpt, _, _, m)) =
@@ -2531,7 +2538,9 @@ module EstablishTypeDefinitionCores =
 
         let envForDecls, moduleTyAcc = MakeInnerEnv true envInitial id moduleKind    
         let moduleTy = Construct.NewEmptyModuleOrNamespaceType moduleKind
-        let xmlDoc = xml.ToXmlDoc(true, Some [])
+
+        let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+        let xmlDoc = xml.ToXmlDoc(checkXmlDocs, Some [])
         let moduleEntity = Construct.NewModuleOrNamespace (Some envInitial.eCompPath) vis id xmlDoc modAttrs (MaybeLazy.Strict moduleTy)
         let innerParent = Parent (mkLocalModuleRef moduleEntity)
         let innerTypeNames = TypeNamesInMutRecDecls cenv envForDecls decls
@@ -2599,7 +2608,9 @@ module EstablishTypeDefinitionCores =
 
                 patNames
             | _ -> []
-        let xmlDoc = xmlDoc.ToXmlDoc(true, Some paramNames )
+
+        let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+        let xmlDoc = xmlDoc.ToXmlDoc(checkXmlDocs, Some paramNames )
         Construct.NewTycon
             (cpath, id.idText, id.idRange, vis, visOfRepr, TyparKind.Type, LazyWithContext.NotLazy checkedTypars,
              xmlDoc, preferPostfix, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, lmodTy)
@@ -4485,7 +4496,9 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE
                 let id = ident (modName, id.idRange)
 
                 let moduleTy = Construct.NewEmptyModuleOrNamespaceType moduleKind
-                let xmlDoc = xml.ToXmlDoc(true, Some [])
+
+                let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+                let xmlDoc = xml.ToXmlDoc(checkXmlDocs, Some [])
                 let moduleEntity = Construct.NewModuleOrNamespace (Some env.eCompPath) vis id xmlDoc attribs (MaybeLazy.Strict moduleTy) 
 
                 let! moduleTy, _ = TcModuleOrNamespaceSignatureElementsNonMutRec cenv (Parent (mkLocalModuleRef moduleEntity)) env (id, moduleKind, moduleDefs, m, xml)
@@ -4590,8 +4603,9 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE
 and TcSignatureElements cenv parent endm env xml mutRecNSInfo defs = 
     cancellable {
         // Ensure the .Deref call in UpdateAccModuleOrNamespaceType succeeds 
-        if cenv.compilingCanonicalFslibModuleType then 
-            let xmlDoc = xml.ToXmlDoc(true, Some [])
+        if cenv.compilingCanonicalFslibModuleType then
+            let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+            let xmlDoc = xml.ToXmlDoc(checkXmlDocs, Some [])
             ensureCcuHasModuleOrNamespaceAtPath cenv.thisCcu env.ePath env.eCompPath xmlDoc
 
         let typeNames = EstablishTypeDefinitionCores.TypeNamesInNonMutRecSigDecls defs
@@ -4817,7 +4831,9 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
               // Create the new module specification to hold the accumulated results of the type of the module 
               // Also record this in the environment as the accumulator 
               let moduleTy = Construct.NewEmptyModuleOrNamespaceType moduleKind
-              let xmlDoc = xml.ToXmlDoc(true, Some [])
+
+              let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+              let xmlDoc = xml.ToXmlDoc(checkXmlDocs, Some [])
               let moduleEntity = Construct.NewModuleOrNamespace (Some env.eCompPath) vis id xmlDoc modAttrs (MaybeLazy.Strict moduleTy)
 
               // Now typecheck. 
@@ -5062,8 +5078,9 @@ and TcMutRecDefsFinish cenv defs m =
 and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 synModuleDecls =
   cancellable {
     // Ensure the deref_nlpath call in UpdateAccModuleOrNamespaceType succeeds 
-    if cenv.compilingCanonicalFslibModuleType then 
-        let xmlDoc = xml.ToXmlDoc(true, Some [])
+    if cenv.compilingCanonicalFslibModuleType then
+        let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+        let xmlDoc = xml.ToXmlDoc(checkXmlDocs, Some [])
         ensureCcuHasModuleOrNamespaceAtPath cenv.thisCcu env.ePath env.eCompPath xmlDoc
 
     // Collect the type names so we can implicitly add the compilation suffix to module names
@@ -5289,8 +5306,9 @@ let CheckOneImplFile
         isInternalTestSpanStackReferring,
         env,
         rootSigOpt: ModuleOrNamespaceType option,
-        synImplFile) =
-
+        synImplFile,
+        diagnosticOptions) =
+
     let (ParsedImplFileInput (fileName, isScript, qualNameOfFile, scopedPragmas, _, implFileFrags, isLastCompiland, _)) = synImplFile
     let infoReader = InfoReader(g, amap)
 
@@ -5304,6 +5322,7 @@ let CheckOneImplFile
         let cenv = 
             cenv.Create (g, isScript, amap, thisCcu, false, Option.isSome rootSigOpt,
                 conditionalDefines, tcSink, (LightweightTcValForUsingInBuildMethodCall g), isInternalTestSpanStackReferring,
+                diagnosticOptions,
                 tcPat=TcPat,
                 tcSimplePats=TcSimplePats,
                 tcSequenceExpressionEntry=TcSequenceExpressionEntry,
@@ -5426,7 +5445,7 @@ let CheckOneImplFile
 
 
 /// Check an entire signature file
-let CheckOneSigFile (g, amap, thisCcu, checkForErrors, conditionalDefines, tcSink, isInternalTestSpanStackReferring) tcEnv (sigFile: ParsedSigFileInput) = 
+let CheckOneSigFile (g, amap, thisCcu, checkForErrors, conditionalDefines, tcSink, isInternalTestSpanStackReferring, diagnosticOptions) tcEnv (sigFile: ParsedSigFileInput) = 
  cancellable {     
     use _ =
         Activity.start "CheckDeclarations.CheckOneSigFile"
@@ -5438,6 +5457,7 @@ let CheckOneSigFile (g, amap, thisCcu, checkForErrors, conditionalDefines, tcSin
         cenv.Create 
             (g, false, amap, thisCcu, true, false, conditionalDefines, tcSink,
              (LightweightTcValForUsingInBuildMethodCall g), isInternalTestSpanStackReferring,
+             diagnosticOptions,
              tcPat=TcPat,
              tcSimplePats=TcSimplePats,
              tcSequenceExpressionEntry=TcSequenceExpressionEntry,

src/Compiler/Checking/CheckDeclarations.fsi

@@ -2,6 +2,7 @@
 
 module internal FSharp.Compiler.CheckDeclarations
 
+open FSharp.Compiler.Diagnostics
 open Internal.Utilities.Library
 open FSharp.Compiler.CheckBasics
 open FSharp.Compiler.CompilerGlobalState
@@ -58,11 +59,19 @@ val CheckOneImplFile:
     bool *
     TcEnv *
     ModuleOrNamespaceType option *
-    ParsedImplFileInput ->
+    ParsedImplFileInput *
+    FSharpDiagnosticOptions ->
         Cancellable<TopAttribs * CheckedImplFile * TcEnv * bool>
 
 val CheckOneSigFile:
-    TcGlobals * ImportMap * CcuThunk * (unit -> bool) * ConditionalDefines option * TcResultsSink * bool ->
+    TcGlobals *
+    ImportMap *
+    CcuThunk *
+    (unit -> bool) *
+    ConditionalDefines option *
+    TcResultsSink *
+    bool *
+    FSharpDiagnosticOptions ->
         TcEnv ->
         ParsedSigFileInput ->
             Cancellable<TcEnv * ModuleOrNamespaceType * bool>

src/Compiler/Checking/CheckExpressions.fs

@@ -2436,7 +2436,8 @@ module BindingNormalization =
             let (NormalizedBindingPat(pat, rhsExpr, valSynData, typars)) =
                 NormalizeBindingPattern cenv cenv.nameResolver isObjExprBinding env valSynData headPat (NormalizedBindingRhs ([], retInfo, rhsExpr))
             let paramNames = Some valSynData.SynValInfo.ArgNames
-            let xmlDoc = xmlDoc.ToXmlDoc(true, paramNames)
+            let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+            let xmlDoc = xmlDoc.ToXmlDoc(checkXmlDocs, paramNames)
             NormalizedBinding(vis, kind, isInline, isMutable, attrs, xmlDoc, typars, valSynData, pat, rhsExpr, mBinding, debugPoint)
 
 //-------------------------------------------------------------------------
@@ -12089,7 +12090,8 @@ let TcAndPublishValSpec (cenv: cenv, env, containerInfo: ContainerInfo, declKind
             | None -> None
             | Some valReprInfo -> Some valReprInfo.ArgNames
 
-        let xmlDoc = xmlDoc.ToXmlDoc(true, paramNames)
+        let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs 
+        let xmlDoc = xmlDoc.ToXmlDoc(checkXmlDocs, paramNames)
         let vspec = MakeAndPublishVal cenv env (altActualParent, true, declKind, ValNotInRecScope, valscheme, attrs, xmlDoc, literalValue, false)
 
         assert(vspec.InlineInfo = inlineFlag)

src/Compiler/Checking/CheckIncrementalClasses.fs

@@ -4,6 +4,7 @@ module internal FSharp.Compiler.CheckIncrementalClasses
 
 open System
 
+open FSharp.Compiler.Diagnostics
 open Internal.Utilities.Collections
 open Internal.Utilities.Library
 open Internal.Utilities.Library.Extras
@@ -135,7 +136,9 @@ let TcImplicitCtorLhs_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attr
         let varReprInfo = InferGenericArityFromTyScheme prelimTyschemeG prelimValReprInfo
         let ctorValScheme = ValScheme(id, prelimTyschemeG, Some varReprInfo, None, Some memberInfo, false, ValInline.Never, NormalVal, vis, false, true, false, false)
         let paramNames = varReprInfo.ArgNames
-        let xmlDoc = xmlDoc.ToXmlDoc(true, Some paramNames)
+
+        let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
+        let xmlDoc = xmlDoc.ToXmlDoc(checkXmlDocs, Some paramNames)
         let ctorVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValInRecScope isComplete, ctorValScheme, attribs, xmlDoc, None, false) 
         ctorValScheme, ctorVal
 

src/Compiler/Driver/ParseAndCheckInputs.fs

@@ -1212,7 +1212,8 @@ let CheckOneInputAux
                          checkForErrors,
                          conditionalDefines,
                          tcSink,
-                         tcConfig.internalTestSpanStackReferring)
+                         tcConfig.internalTestSpanStackReferring,
+                         tcConfig.diagnosticsOptions)
                         tcState.tcsTcSigEnv
                         file
 
@@ -1290,7 +1291,8 @@ let CheckOneInputAux
                             tcConfig.internalTestSpanStackReferring,
                             tcState.tcsTcImplEnv,
                             rootSigOpt,
-                            file
+                            file,
+                            tcConfig.diagnosticsOptions
                         )
 
                     let tcState =
@@ -1485,7 +1487,8 @@ let CheckMultipleInputsInParallel
                             tcConfig.internalTestSpanStackReferring,
                             tcStateForImplFile.tcsTcImplEnv,
                             Some rootSig,
-                            file
+                            file,
+                            tcConfig.diagnosticsOptions
                         )
                         |> Cancellable.runWithoutCancellation
 

src/Compiler/Facilities/DiagnosticOptions.fs

@@ -31,3 +31,6 @@ type FSharpDiagnosticOptions =
             WarnAsError = []
             WarnAsWarn = []
         }
+
+    member x.CheckXmlDocs =
+        List.contains 3390 x.WarnOn && not (List.contains 3390 x.WarnOff)

src/Compiler/Facilities/DiagnosticOptions.fsi

@@ -22,3 +22,5 @@ type FSharpDiagnosticOptions =
       WarnAsWarn: int list }
 
     static member Default: FSharpDiagnosticOptions
+
+    member CheckXmlDocs: bool

tests/FSharp.Compiler.ComponentTests/Language/XmlComments.fs

@@ -49,6 +49,17 @@ module M =
                    "This XML comment is invalid: unknown parameter 'b'");
                 ]
 
+    [<Fact>]
+    let ``diagnostic is not reported when disabled`` () =
+        Fsx"""
+    /// <summary> F </summary>
+    /// <param name="x"> the parameter </param>
+    let f a = a
+        """
+         |> compile
+         |> shouldSucceed
+         |> withDiagnostics []
+
     [<Fact>]
     let ``invalid parameter name is reported`` () =
         Fsx"""

tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected

@@ -2386,10 +2386,12 @@ FSharp.Compiler.Diagnostics.FSharpDiagnosticKind: Int32 Tag
 FSharp.Compiler.Diagnostics.FSharpDiagnosticKind: Int32 get_Tag()
 FSharp.Compiler.Diagnostics.FSharpDiagnosticKind: System.String ToString()
 FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions
+FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions: Boolean CheckXmlDocs
 FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions: Boolean Equals(FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions)
 FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions: Boolean Equals(System.Object)
 FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions: Boolean Equals(System.Object, System.Collections.IEqualityComparer)
 FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions: Boolean GlobalWarnAsError
+FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions: Boolean get_CheckXmlDocs()
 FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions: Boolean get_GlobalWarnAsError()
 FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions: FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions Default
 FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions: FSharp.Compiler.Diagnostics.FSharpDiagnosticOptions get_Default()