Merge branch 'main' into fix-test-startup-code

.git-blame-ignore-revs

@@ -1,5 +1,9 @@
+# Because this repository uses squash/rebase merges, commits added to a branch
+# referencing earlier commits in the same branch and squash/rebased merged as part of a PR
+# will need to be rewritten in a subsequent PR to the corresponding squashed/rebased commit SHAs.
+
 # Format src/Compiler/Checking/CheckComputationExpressions.fs, https://github.com/dotnet/fsharp/pull/16512
-603a310cdfd9902ec1d29b399377dcc9ac56235b
+0318afd91f38533879cc89d598e0431c312ad57e
 
 # Spelling, https://github.com/dotnet/fsharp/pull/16212
-823d5e99fdd13f696ea8fe572d502e5fa68f6fd1
+23e91e1322363a7e9c34baaeabbf0391c4b7eafd

src/Compiler/Checking/CheckDeclarations.fs

@@ -2856,12 +2856,16 @@ module EstablishTypeDefinitionCores =
         let hasStructAttr = HasFSharpAttribute g g.attrib_StructAttribute attrs
         let hasCLIMutable = HasFSharpAttribute g g.attrib_CLIMutableAttribute attrs
         let hasAllowNullLiteralAttr = HasFSharpAttribute g g.attrib_AllowNullLiteralAttribute attrs
+        let hasSealedAttr = HasFSharpAttribute g g.attrib_SealedAttribute attrs
+        let structLayoutAttr = HasFSharpAttribute g g.attrib_StructLayoutAttribute attrs
 
         // We want to keep these special attributes treatment and avoid having two errors for the same attribute.
         let reportAttributeTargetsErrors =
             g.langVersion.SupportsFeature(LanguageFeature.EnforceAttributeTargets)
             && not hasCLIMutable // CLIMutableAttribute has a special treatment(specific error FS3132)
             && not hasAllowNullLiteralAttr // AllowNullLiteralAttribute has a special treatment(specific errors FS0934, FS093)
+            && not hasSealedAttr // SealedAttribute has a special treatment(specific error FS942)
+            && not structLayoutAttr // StructLayoutAttribute has a special treatment(specific error FS0937)
 
         let noCLIMutableAttributeCheck() =
             if hasCLIMutable then errorR (Error(FSComp.SR.tcThisTypeMayNotHaveACLIMutableAttribute(), m))

src/Compiler/Driver/CompilerDiagnostics.fs

@@ -2044,14 +2044,16 @@ type FormattedDiagnosticDetailedInfo =
         Location: FormattedDiagnosticLocation option
         Canonical: FormattedDiagnosticCanonicalInformation
         Message: string
+        Context: string option
+        DiagnosticStyle: DiagnosticStyle
     }
 
 [<RequireQualifiedAccess>]
 type FormattedDiagnostic =
     | Short of FSharpDiagnosticSeverity * string
     | Long of FSharpDiagnosticSeverity * FormattedDiagnosticDetailedInfo
 
-let FormatDiagnosticLocation (tcConfig: TcConfig) m : FormattedDiagnosticLocation =
+let FormatDiagnosticLocation (tcConfig: TcConfig) (m: Range) : FormattedDiagnosticLocation =
     if equals m rangeStartup || equals m rangeCmdArgs then
         {
             Range = m
@@ -2114,6 +2116,10 @@ let FormatDiagnosticLocation (tcConfig: TcConfig) m : FormattedDiagnosticLocatio
                     sprintf "%s(%d,%d,%d,%d): " file m.StartLine m.StartColumn m.EndLine m.EndColumn, m, file
                 else
                     "", m, file
+            | DiagnosticStyle.Rich ->
+                let file = file.Replace('/', Path.DirectorySeparatorChar)
+                let m = withStart (mkPos m.StartLine (m.StartColumn + 1)) m
+                (sprintf "\n  --> %s (%d,%d)" file m.StartLine m.StartColumn), m, file
 
         {
             Range = m
@@ -2154,8 +2160,12 @@ let CollectFormattedDiagnostics (tcConfig: TcConfig, severity: FSharpDiagnosticS
             let text =
                 match tcConfig.diagnosticStyle with
                 // Show the subcategory for --vserrors so that we can fish it out in Visual Studio and use it to determine error stickiness.
+                | DiagnosticStyle.Emacs
+                | DiagnosticStyle.Gcc
+                | DiagnosticStyle.Default
+                | DiagnosticStyle.Test -> sprintf "%s FS%04d: " message errorNumber
                 | DiagnosticStyle.VisualStudio -> sprintf "%s %s FS%04d: " subcategory message errorNumber
-                | _ -> sprintf "%s FS%04d: " message errorNumber
+                | DiagnosticStyle.Rich -> sprintf "%s FS%04d: " message errorNumber
 
             let canonical: FormattedDiagnosticCanonicalInformation =
                 {
@@ -2164,13 +2174,51 @@ let CollectFormattedDiagnostics (tcConfig: TcConfig, severity: FSharpDiagnosticS
                     TextRepresentation = text
                 }
 
-            let message = diagnostic.FormatCore(tcConfig.flatErrors, suggestNames)
+            let message =
+                match tcConfig.diagnosticStyle with
+                | DiagnosticStyle.Emacs
+                | DiagnosticStyle.Gcc
+                | DiagnosticStyle.Default
+                | DiagnosticStyle.Test
+                | DiagnosticStyle.Rich
+                | DiagnosticStyle.VisualStudio -> diagnostic.FormatCore(tcConfig.flatErrors, suggestNames)
+
+            let context =
+                match tcConfig.diagnosticStyle with
+                | DiagnosticStyle.Emacs
+                | DiagnosticStyle.Gcc
+                | DiagnosticStyle.Default
+                | DiagnosticStyle.Test
+                | DiagnosticStyle.VisualStudio -> None
+                | DiagnosticStyle.Rich ->
+                    match diagnostic.Range with
+                    | Some m ->
+                        let content =
+                            m.FileName
+                            |> FileSystem.GetFullFilePathInDirectoryShim tcConfig.implicitIncludeDir
+                            |> System.IO.File.ReadAllLines
+
+                        if m.StartLine = m.EndLine then
+                            $"\n  {m.StartLine} | {content[m.StartLine - 1]}\n"
+                            + $"""{String.make (m.StartColumn + 6) ' '}{String.make (m.EndColumn - m.StartColumn) '^'}"""
+                            |> Some
+                        else
+                            content
+                            |> fun lines -> Array.sub lines (m.StartLine - 1) (m.EndLine - m.StartLine - 1)
+                            |> Array.fold
+                                (fun (context, lineNumber) line -> (context + $"\n{lineNumber} | {line}", lineNumber + 1))
+                                ("", (m.StartLine))
+                            |> fst
+                            |> Some
+                    | None -> None
 
             let entry: FormattedDiagnosticDetailedInfo =
                 {
                     Location = where
+                    Context = context
                     Canonical = canonical
                     Message = message
+                    DiagnosticStyle = tcConfig.diagnosticStyle
                 }
 
             errors.Add(FormattedDiagnostic.Long(severity, entry))
@@ -2198,12 +2246,33 @@ type PhasedDiagnostic with
             match e with
             | FormattedDiagnostic.Short(_, txt) -> buf.AppendString txt
             | FormattedDiagnostic.Long(_, details) ->
-                match details.Location with
-                | Some l when not l.IsEmpty -> buf.AppendString l.TextRepresentation
-                | _ -> ()
-
-                buf.AppendString details.Canonical.TextRepresentation
-                buf.AppendString details.Message
+                match details.DiagnosticStyle with
+                | DiagnosticStyle.Emacs
+                | DiagnosticStyle.Gcc
+                | DiagnosticStyle.Test
+                | DiagnosticStyle.VisualStudio
+                | DiagnosticStyle.Default ->
+                    match details.Location with
+                    | Some l when not l.IsEmpty ->
+                        buf.AppendString l.TextRepresentation
+
+                        if details.Context.IsSome then
+                            buf.AppendString details.Context.Value
+                    | _ -> ()
+
+                    buf.AppendString details.Canonical.TextRepresentation
+                    buf.AppendString details.Message
+                | DiagnosticStyle.Rich ->
+                    buf.AppendString details.Canonical.TextRepresentation
+                    buf.AppendString details.Message
+
+                    match details.Location with
+                    | Some l when not l.IsEmpty ->
+                        buf.AppendString l.TextRepresentation
+
+                        if details.Context.IsSome then
+                            buf.AppendString details.Context.Value
+                    | _ -> ()
 
     member diagnostic.OutputContext(buf, prefix, fileLineFunction) =
         match diagnostic.Range with

src/Compiler/Driver/CompilerDiagnostics.fsi

@@ -113,7 +113,9 @@ type FormattedDiagnosticCanonicalInformation =
 type FormattedDiagnosticDetailedInfo =
     { Location: FormattedDiagnosticLocation option
       Canonical: FormattedDiagnosticCanonicalInformation
-      Message: string }
+      Message: string
+      Context: string option
+      DiagnosticStyle: DiagnosticStyle }
 
 /// Used internally and in LegacyHostedCompilerForTesting
 [<RequireQualifiedAccess>]

src/Compiler/Driver/CompilerOptions.fs

@@ -1395,6 +1395,7 @@ let testFlag tcConfigB =
 let editorSpecificFlags (tcConfigB: TcConfigBuilder) =
     [
         CompilerOption("vserrors", tagNone, OptionUnit(fun () -> tcConfigB.diagnosticStyle <- DiagnosticStyle.VisualStudio), None, None)
+        CompilerOption("richerrors", tagNone, OptionUnit(fun () -> tcConfigB.diagnosticStyle <- DiagnosticStyle.Rich), None, None)
         CompilerOption("validate-type-providers", tagNone, OptionUnit id, None, None) // preserved for compatibility's sake, no longer has any effect
         CompilerOption("LCID", tagInt, OptionInt ignore, None, None)
         CompilerOption("flaterrors", tagNone, OptionUnit(fun () -> tcConfigB.flatErrors <- true), None, None)

src/Compiler/Facilities/DiagnosticsLogger.fs

@@ -18,13 +18,14 @@ open Internal.Utilities.Library.Extras
 open System.Threading.Tasks
 
 /// Represents the style being used to format errors
-[<RequireQualifiedAccess>]
+[<RequireQualifiedAccess; NoComparison; NoEquality>]
 type DiagnosticStyle =
     | Default
     | Emacs
     | Test
     | VisualStudio
     | Gcc
+    | Rich
 
 /// Thrown when we want to add some range information to a .NET exception
 exception WrappedError of exn * range with

src/Compiler/Facilities/DiagnosticsLogger.fsi

@@ -10,13 +10,14 @@ open System.Runtime.CompilerServices
 open System.Runtime.InteropServices
 
 /// Represents the style being used to format errors
-[<RequireQualifiedAccess>]
+[<RequireQualifiedAccess; NoComparison; NoEquality>]
 type DiagnosticStyle =
     | Default
     | Emacs
     | Test
     | VisualStudio
     | Gcc
+    | Rich
 
 /// Thrown when we want to add some range information to a .NET exception
 exception WrappedError of exn * range

tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/CustomAttributes/AttributeUsage/AttributeUsage.fs

@@ -846,4 +846,60 @@ type InterruptibleLazy<'T> private (valueFactory: unit -> 'T) =
         compilation
         |> withLangVersionPreview
         |> verifyCompile
-        |> shouldSucceed
+        |> shouldSucceed
+
+    // SOURCE= E_SealedAttribute01.fs	# E_SealedAttribute01.fs
+    [<Theory; Directory(__SOURCE_DIRECTORY__, Includes=[|"E_SealedAttribute01.fs"|])>]
+    let ``E_SealedAttribute01 9.0`` compilation =
+        compilation
+        |> withLangVersion90
+        |> verifyCompile
+        |> shouldFail
+        |> withDiagnostics [
+            (Error 942, Line 2, Col 6, Line 2, Col 31, "Struct types are always sealed")
+            (Error 948, Line 8, Col 6, Line 8, Col 24, "Interface types cannot be sealed")
+            (Error 942, Line 14, Col 6, Line 14, Col 33, "Delegate types are always sealed")
+        ]
+
+    // SOURCE=E_SealedAttribute01.fs	# E_SealedAttribute01.fs
+    [<Theory; Directory(__SOURCE_DIRECTORY__, Includes=[|"E_SealedAttribute01.fs"|])>]
+    let ``E_SealedAttribute01 preview`` compilation =
+        compilation
+        |> withLangVersionPreview
+        |> verifyCompile
+        |> shouldFail
+        |> withDiagnostics [
+            (Error 942, Line 2, Col 6, Line 2, Col 31, "Struct types are always sealed")
+            (Error 948, Line 8, Col 6, Line 8, Col 24, "Interface types cannot be sealed")
+            (Error 942, Line 14, Col 6, Line 14, Col 33, "Delegate types are always sealed")
+        ]
+
+    // SOURCE= E_StructLayout01.fs	# E_StructLayout01.fs
+    [<Theory; Directory(__SOURCE_DIRECTORY__, Includes=[|"E_StructLayout01.fs"|])>]
+    let ``E_StructLayout01 9.0`` compilation =
+        compilation
+        |> withLangVersion90
+        |> verifyCompile
+        |> shouldFail
+        |> withDiagnostics [
+            (Error 937, Line 2, Col 6, Line 2, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+            (Error 937, Line 7, Col 6, Line 7, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+            (Error 937, Line 11, Col 6, Line 11, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+            (Error 937, Line 14, Col 6, Line 14, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+            (Error 937, Line 17, Col 6, Line 17, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+        ]
+
+    // SOURCE=E_StructLayout01.fs	# E_StructLayout01.fs
+    [<Theory; Directory(__SOURCE_DIRECTORY__, Includes=[|"E_StructLayout01.fs"|])>]
+    let ``E_StructLayout01 preview`` compilation =
+        compilation
+        |> withLangVersionPreview
+        |> verifyCompile
+        |> shouldFail
+        |> withDiagnostics [
+            (Error 937, Line 2, Col 6, Line 2, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+            (Error 937, Line 7, Col 6, Line 7, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+            (Error 937, Line 11, Col 6, Line 11, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+            (Error 937, Line 14, Col 6, Line 14, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+            (Error 937, Line 17, Col 6, Line 17, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
+        ]

tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/CustomAttributes/AttributeUsage/E_SealedAttribute01.fs

@@ -0,0 +1,14 @@
+[<Sealed>]
+type UnnecessarilySealedStruct = 
+    struct
+        member x.P = 1
+    end
+
+[<Sealed>]
+type BadSealedInterface = 
+    interface
+        abstract P : int
+    end
+
+[<Sealed>]
+type UnnecessarilySealedDelegate = delegate of int -> int

tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/CustomAttributes/AttributeUsage/E_StructLayout01.fs

@@ -0,0 +1,17 @@
+[<System.Runtime.InteropServices.StructLayout(System.Runtime.InteropServices.LayoutKind.Sequential)>]
+type X1 = 
+    abstract M : unit -> 'a
+
+[<System.Runtime.InteropServices.StructLayout(System.Runtime.InteropServices.LayoutKind.Sequential)>]
+[<AbstractClass>]
+type X2() = 
+    abstract M : unit -> 'a
+
+[<System.Runtime.InteropServices.StructLayout(System.Runtime.InteropServices.LayoutKind.Sequential)>]
+type X4 =  R1 | R2
+
+[<System.Runtime.InteropServices.StructLayout(System.Runtime.InteropServices.LayoutKind.Sequential)>]
+type X5 =  R1 = 1 | R2 = 2
+
+[<System.Runtime.InteropServices.StructLayout(System.Runtime.InteropServices.LayoutKind.Sequential)>]
+type X6 =  delegate of int -> int 

tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/CustomAttributes/Basic/Basic.fs

@@ -159,8 +159,7 @@ module CustomAttributes_Basic =
         |> withLangVersionPreview
         |> verifyCompile
         |> shouldFail
-        |> withDiagnostics[
-            (Error 842, Line 8, Col 7, Line 8, Col 104, "This attribute is not valid for use on this language element")
+        |> withDiagnostics [
             (Error 937, Line 9, Col 10, Line 9, Col 12, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
         ]
 
@@ -172,7 +171,6 @@ module CustomAttributes_Basic =
         |> verifyCompile
         |> shouldFail
         |> withDiagnostics [
-            (Error 842, Line 8, Col 7, Line 8, Col 104, "This attribute is not valid for use on this language element")
             (Error 937, Line 9, Col 10, Line 9, Col 12, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
         ]
 
@@ -184,7 +182,6 @@ module CustomAttributes_Basic =
         |> verifyCompile
         |> shouldFail
         |> withDiagnostics [
-            (Error 842, Line 7, Col 7, Line 7, Col 104, "This attribute is not valid for use on this language element")
             (Error 937, Line 8, Col 10, Line 8, Col 12, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
         ]
 

tests/fsharp/typecheck/sigs/neg06.bsl

@@ -2,18 +2,12 @@
 neg06.fs(3,40,3,45): typecheck error FS0039: The type 'Encoding' does not define the field, constructor or member 'Ascii'. Maybe you want one of the following:
    ASCII
 
-neg06.fs(11,3,11,9): typecheck error FS0842: This attribute is not valid for use on this language element
-
 neg06.fs(12,6,12,31): typecheck error FS0942: Struct types are always sealed
 
-neg06.fs(17,3,17,9): typecheck error FS0842: This attribute is not valid for use on this language element
-
 neg06.fs(18,6,18,24): typecheck error FS0948: Interface types cannot be sealed
 
 neg06.fs(24,6,24,30): typecheck error FS0944: Abbreviated types cannot be given the 'Sealed' attribute
 
-neg06.fs(26,3,26,9): typecheck error FS0842: This attribute is not valid for use on this language element
-
 neg06.fs(27,6,27,33): typecheck error FS0942: Delegate types are always sealed
 
 neg06.fs(31,9,31,29): typecheck error FS0945: Cannot inherit a sealed type
@@ -94,20 +88,14 @@ neg06.fs(223,13,223,21): typecheck error FS0800: Invalid use of a type name
 
 neg06.fs(300,10,300,12): typecheck error FS0009: Uses of this construct may result in the generation of unverifiable .NET IL code. This warning can be disabled using '--nowarn:9' or '#nowarn "9"'.
 
-neg06.fs(303,7,303,104): typecheck error FS0842: This attribute is not valid for use on this language element
-
 neg06.fs(304,10,304,12): typecheck error FS0937: Only structs and classes without primary constructors may be given the 'StructLayout' attribute
 
 neg06.fs(310,10,310,12): typecheck error FS0937: Only structs and classes without primary constructors may be given the 'StructLayout' attribute
 
 neg06.fs(314,10,314,12): typecheck error FS0937: Only structs and classes without primary constructors may be given the 'StructLayout' attribute
 
-neg06.fs(316,7,316,104): typecheck error FS0842: This attribute is not valid for use on this language element
-
 neg06.fs(317,10,317,12): typecheck error FS0937: Only structs and classes without primary constructors may be given the 'StructLayout' attribute
 
-neg06.fs(319,7,319,104): typecheck error FS0842: This attribute is not valid for use on this language element
-
 neg06.fs(320,10,320,12): typecheck error FS0937: Only structs and classes without primary constructors may be given the 'StructLayout' attribute
 
 neg06.fs(326,10,326,18): typecheck error FS0954: This type definition involves an immediate cyclic reference through a struct field or inheritance relation