Allow ParsedHashDirectives to take non string arguments (#17206)

* Enable extended ParsedHashDirectiveArgument * no need for nowarn * time * String only directives * disable #r * comment +errors * feedback * null ref * tests * fantomas * fsharpqa * #help work with longidents and idents --------- Co-authored-by: Petr <[email protected]>
dotnet · Jun 17, 2024 · 836d4e0 · 836d4e0
1 parent e8015d1
commit 836d4e0
Show file tree

Hide file tree

Showing 52 changed files with 955 additions and 311 deletions.
diff --git a/docs/release-notes/.FSharp.Compiler.Service/8.0.400.md b/docs/release-notes/.FSharp.Compiler.Service/8.0.400.md
@@ -21,6 +21,8 @@
 ### Added
 
 * Generate new `Equals` overload to avoid boxing for structural comparison ([PR #16857](https://github.com/dotnet/fsharp/pull/16857))
+* Allow #nowarn to support the FS prefix on error codes to disable warnings ([Issue #17206](https://github.com/dotnet/fsharp/issues/16447), [PR #17209](https://github.com/dotnet/fsharp/pull/17209))
+* Allow ParsedHashDirectives to have argument types other than strings ([Issue #17240](https://github.com/dotnet/fsharp/issues/16447), [PR #17209](https://github.com/dotnet/fsharp/pull/17209))
 * Parser: better recovery for unfinished patterns ([PR #17231](https://github.com/dotnet/fsharp/pull/17231))
 * Parser: recover on empty match clause ([PR #17233](https://github.com/dotnet/fsharp/pull/17233))
 

diff --git a/docs/release-notes/.Language/preview.md b/docs/release-notes/.Language/preview.md
@@ -6,6 +6,8 @@
 * Bidirectional F#/C# interop for 'unmanaged' constraint. ([PR #12154](https://github.com/dotnet/fsharp/pull/12154))
 * Make `.Is*` discriminated union properties visible. ([Language suggestion #222](https://github.com/fsharp/fslang-suggestions/issues/222), [PR #16341](https://github.com/dotnet/fsharp/pull/16341))
 * Allow returning bool instead of unit option for partial active patterns. ([Language suggestion #1041](https://github.com/fsharp/fslang-suggestions/issues/1041), [PR #16473](https://github.com/dotnet/fsharp/pull/16473))
+* Allow #nowarn to support the FS prefix on error codes to disable warnings ([Issue #17206](https://github.com/dotnet/fsharp/issues/16447), [PR #17209](https://github.com/dotnet/fsharp/pull/17209))
+* Allow ParsedHashDirectives to have argument types other than strings ([Issue #17240](https://github.com/dotnet/fsharp/issues/16447), [PR #17209](https://github.com/dotnet/fsharp/pull/17209))
 
 ### Fixed
 

diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs
@@ -91,16 +91,19 @@ let ResolveFileUsingPaths (paths, m, fileName) =
         let searchMessage = String.concat "\n " paths
         raise (FileNameNotResolved(fileName, searchMessage, m))
 
-let GetWarningNumber (m, warningNumber: string) =
+let GetWarningNumber (m, warningNumber: string, prefixSupported) =
     try
-        // Okay so ...
-        //      #pragma strips FS of the #pragma "FS0004" and validates the warning number
-        //      therefore if we have warning id that starts with a numeric digit we convert it to Some (int32)
-        //      anything else is ignored None
+        let warningNumber =
+            if warningNumber.StartsWithOrdinal "FS" then
+                if prefixSupported then
+                    warningNumber.Substring 2
+                else
+                    raise (new ArgumentException())
+            else
+                warningNumber
+
         if Char.IsDigit(warningNumber[0]) then
             Some(int32 warningNumber)
-        elif warningNumber.StartsWithOrdinal "FS" then
-            raise (ArgumentException())
         else
             None
     with _ ->
@@ -918,7 +921,7 @@ type TcConfigBuilder =
     member tcConfigB.TurnWarningOff(m, s: string) =
         use _ = UseBuildPhase BuildPhase.Parameter
 
-        match GetWarningNumber(m, s) with
+        match GetWarningNumber(m, s, tcConfigB.langVersion.SupportsFeature(LanguageFeature.ParsedHashDirectiveArgumentNonQuotes)) with
         | None -> ()
         | Some n ->
             // nowarn:62 turns on mlCompatibility, e.g. shows ML compat items in intellisense menus
@@ -933,7 +936,7 @@ type TcConfigBuilder =
     member tcConfigB.TurnWarningOn(m, s: string) =
         use _ = UseBuildPhase BuildPhase.Parameter
 
-        match GetWarningNumber(m, s) with
+        match GetWarningNumber(m, s, tcConfigB.langVersion.SupportsFeature(LanguageFeature.ParsedHashDirectiveArgumentNonQuotes)) with
         | None -> ()
         | Some n ->
             // warnon 62 turns on mlCompatibility, e.g. shows ML compat items in intellisense menus

diff --git a/src/Compiler/Driver/CompilerConfig.fsi b/src/Compiler/Driver/CompilerConfig.fsi
@@ -916,7 +916,7 @@ val TryResolveFileUsingPaths: paths: string seq * m: range * fileName: string ->
 
 val ResolveFileUsingPaths: paths: string seq * m: range * fileName: string -> string
 
-val GetWarningNumber: m: range * warningNumber: string -> int option
+val GetWarningNumber: m: range * warningNumber: string * prefixSupported: bool -> int option
 
 /// Get the name used for FSharp.Core
 val GetFSharpCoreLibraryName: unit -> string

diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs
@@ -216,17 +216,26 @@ let PostParseModuleSpec (_i, defaultNamespace, isLastCompiland, fileName, intf)
 
         SynModuleOrNamespaceSig(lid, isRecursive, kind, decls, xmlDoc, attributes, None, range, trivia)
 
-let GetScopedPragmasForHashDirective hd =
+let GetScopedPragmasForHashDirective hd (langVersion: LanguageVersion) =
+    let supportsNonStringArguments =
+        langVersion.SupportsFeature(LanguageFeature.ParsedHashDirectiveArgumentNonQuotes)
+
     [
         match hd with
         | ParsedHashDirective("nowarn", numbers, m) ->
             for s in numbers do
-                match s with
-                | ParsedHashDirectiveArgument.SourceIdentifier _ -> ()
-                | ParsedHashDirectiveArgument.String(s, _, _) ->
-                    match GetWarningNumber(m, s) with
-                    | None -> ()
-                    | Some n -> ScopedPragma.WarningOff(m, n)
+                let warningNumber =
+                    match supportsNonStringArguments, s with
+                    | _, ParsedHashDirectiveArgument.SourceIdentifier _ -> None
+                    | true, ParsedHashDirectiveArgument.LongIdent _ -> None
+                    | true, ParsedHashDirectiveArgument.Int32(n, _) -> GetWarningNumber(m, string n, true)
+                    | true, ParsedHashDirectiveArgument.Ident(s, _) -> GetWarningNumber(m, s.idText, true)
+                    | _, ParsedHashDirectiveArgument.String(s, _, _) -> GetWarningNumber(m, s, true)
+                    | _ -> None
+
+                match warningNumber with
+                | None -> ()
+                | Some n -> ScopedPragma.WarningOff(m, n)
         | _ -> ()
     ]
 
@@ -272,10 +281,10 @@ let PostParseModuleImpls
             for SynModuleOrNamespace(decls = decls) in impls do
                 for d in decls do
                     match d with
-                    | SynModuleDecl.HashDirective(hd, _) -> yield! GetScopedPragmasForHashDirective hd
+                    | SynModuleDecl.HashDirective(hd, _) -> yield! GetScopedPragmasForHashDirective hd lexbuf.LanguageVersion
                     | _ -> ()
             for hd in hashDirectives do
-                yield! GetScopedPragmasForHashDirective hd
+                yield! GetScopedPragmasForHashDirective hd lexbuf.LanguageVersion
         ]
 
     let conditionalDirectives = LexbufIfdefStore.GetTrivia(lexbuf)
@@ -323,10 +332,10 @@ let PostParseModuleSpecs
             for SynModuleOrNamespaceSig(decls = decls) in specs do
                 for d in decls do
                     match d with
-                    | SynModuleSigDecl.HashDirective(hd, _) -> yield! GetScopedPragmasForHashDirective hd
+                    | SynModuleSigDecl.HashDirective(hd, _) -> yield! GetScopedPragmasForHashDirective hd lexbuf.LanguageVersion
                     | _ -> ()
             for hd in hashDirectives do
-                yield! GetScopedPragmasForHashDirective hd
+                yield! GetScopedPragmasForHashDirective hd lexbuf.LanguageVersion
         ]
 
     let conditionalDirectives = LexbufIfdefStore.GetTrivia(lexbuf)
@@ -888,55 +897,90 @@ let ProcessMetaCommandsFromInput
 
         try
             match hash with
-            | ParsedHashDirective("I", ParsedHashDirectiveArguments args, m) ->
+            | ParsedHashDirective("I", [ path ], m) ->
                 if not canHaveScriptMetaCommands then
                     errorR (HashIncludeNotAllowedInNonScript m)
+                else
+                    let arguments = parsedHashDirectiveStringArguments [ path ] tcConfig.langVersion
 
-                match args with
-                | [ path ] ->
-                    matchedm <- m
-                    tcConfig.AddIncludePath(m, path, pathOfMetaCommandSource)
-                    state
-                | _ ->
-                    errorR (Error(FSComp.SR.buildInvalidHashIDirective (), m))
-                    state
-            | ParsedHashDirective("nowarn", ParsedHashDirectiveArguments numbers, m) ->
-                List.fold (fun state d -> nowarnF state (m, d)) state numbers
+                    match arguments with
+                    | [ path ] ->
+                        matchedm <- m
+                        tcConfig.AddIncludePath(m, path, pathOfMetaCommandSource)
+                    | _ -> errorR (Error(FSComp.SR.buildInvalidHashIDirective (), m))
 
-            | ParsedHashDirective(("reference" | "r"), ParsedHashDirectiveArguments args, m) ->
-                matchedm <- m
-                ProcessDependencyManagerDirective Directive.Resolution args m state
+                state
 
-            | ParsedHashDirective("i", ParsedHashDirectiveArguments args, m) ->
-                matchedm <- m
-                ProcessDependencyManagerDirective Directive.Include args m state
+            | ParsedHashDirective("nowarn", hashArguments, m) ->
+                let arguments = parsedHashDirectiveArguments hashArguments tcConfig.langVersion
+                List.fold (fun state d -> nowarnF state (m, d)) state arguments
 
-            | ParsedHashDirective("load", ParsedHashDirectiveArguments args, m) ->
+            | ParsedHashDirective(("reference" | "r") as c, [], m) ->
                 if not canHaveScriptMetaCommands then
                     errorR (HashDirectiveNotAllowedInNonScript m)
+                else
+                    let arg = (parsedHashDirectiveArguments [] tcConfig.langVersion)
+                    warning (Error((FSComp.SR.fsiInvalidDirective (c, String.concat " " arg)), m))
+
+                state
+
+            | ParsedHashDirective(("reference" | "r"), [ reference ], m) ->
+                if not canHaveScriptMetaCommands then
+                    errorR (HashDirectiveNotAllowedInNonScript m)
+                    state
+                else
+                    let arguments =
+                        parsedHashDirectiveStringArguments [ reference ] tcConfig.langVersion
+
+                    match arguments with
+                    | [ reference ] ->
+                        matchedm <- m
+                        ProcessDependencyManagerDirective Directive.Resolution [ reference ] m state
+                    | _ -> state
 
-                match args with
-                | _ :: _ ->
+            | ParsedHashDirective("i", [ path ], m) ->
+                if not canHaveScriptMetaCommands then
+                    errorR (HashDirectiveNotAllowedInNonScript m)
+                    state
+                else
                     matchedm <- m
-                    args |> List.iter (fun path -> loadSourceF state (m, path))
-                | _ -> errorR (Error(FSComp.SR.buildInvalidHashloadDirective (), m))
+                    let arguments = parsedHashDirectiveStringArguments [ path ] tcConfig.langVersion
+
+                    match arguments with
+                    | [ path ] -> ProcessDependencyManagerDirective Directive.Include [ path ] m state
+                    | _ -> state
+
+            | ParsedHashDirective("load", paths, m) ->
+                if not canHaveScriptMetaCommands then
+                    errorR (HashDirectiveNotAllowedInNonScript m)
+                else
+                    let arguments = parsedHashDirectiveArguments paths tcConfig.langVersion
+
+                    match arguments with
+                    | _ :: _ ->
+                        matchedm <- m
+                        arguments |> List.iter (fun path -> loadSourceF state (m, path))
+                    | _ -> errorR (Error(FSComp.SR.buildInvalidHashloadDirective (), m))
 
                 state
-            | ParsedHashDirective("time", ParsedHashDirectiveArguments args, m) ->
+
+            | ParsedHashDirective("time", switch, m) ->
                 if not canHaveScriptMetaCommands then
                     errorR (HashDirectiveNotAllowedInNonScript m)
+                else
+                    let arguments = parsedHashDirectiveArguments switch tcConfig.langVersion
 
-                match args with
-                | [] -> ()
-                | [ "on" | "off" ] -> ()
-                | _ -> errorR (Error(FSComp.SR.buildInvalidHashtimeDirective (), m))
+                    match arguments with
+                    | [] -> matchedm <- m
+                    | [ "on" | "off" ] -> matchedm <- m
+                    | _ -> errorR (Error(FSComp.SR.buildInvalidHashtimeDirective (), m))
 
                 state
 
             | _ ->
-
                 (* warning(Error("This meta-command has been ignored", m)) *)
                 state
+
         with RecoverableException e ->
             errorRecovery e matchedm
             state

diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt
@@ -1752,3 +1752,6 @@ featureReuseSameFieldsInStructUnions,"Share underlying fields in a [<Struct>] di
 3868,tcActivePatternArgsCountNotMatchOnlyPat,"This active pattern expects exactly one pattern argument, e.g., '%s pat'."
 3868,tcActivePatternArgsCountNotMatchArgs,"This active pattern expects %d expression argument(s), e.g., '%s%s'."
 3868,tcActivePatternArgsCountNotMatchArgsAndPat,"This active pattern expects %d expression argument(s) and a pattern argument, e.g., '%s%s pat'."
+featureParsedHashDirectiveArgumentNonString,"# directives with non-quoted string arguments"
+3869,featureParsedHashDirectiveUnexpectedInteger,"Unexpected integer literal '%d'."
+3869,featureParsedHashDirectiveUnexpectedIdentifier,"Unexpected identifier '%s'."
diff --git a/src/Compiler/FSStrings.resx b/src/Compiler/FSStrings.resx
@@ -1051,7 +1051,7 @@
     <value>Override implementations should be given as part of the initial declaration of a type.</value>
   </data>
   <data name="IntfImplInIntrinsicAugmentation" xml:space="preserve">
-    <value>Interface implementations should normally be given on the initial declaration of a type. Interface implementations in augmentations may lead to accessing static bindings before they are initialized, though only if the interface implementation is invoked during initialization of the static data, and in turn access the static data. You may remove this warning using #nowarn "69" if you have checked this is not the case.</value>
+    <value>Interface implementations should normally be given on the initial declaration of a type. Interface implementations in augmentations may lead to accessing static bindings before they are initialized, though only if the interface implementation is invoked during initialization of the static data, and in turn access the static data. You may remove this warning using '#nowarn "69"' if you have checked this is not the case.</value>
   </data>
   <data name="IntfImplInExtrinsicAugmentation" xml:space="preserve">
     <value>Interface implementations should be given on the initial declaration of a type.</value>
@@ -1063,10 +1063,10 @@
     <value>The type referenced through '{0}' is defined in an assembly that is not referenced. You must add a reference to assembly '{1}'.</value>
   </data>
   <data name="HashIncludeNotAllowedInNonScript" xml:space="preserve">
-    <value>#I directives may only occur in F# script files (extensions .fsx or .fsscript). Either move this code to a script file, add a '-I' compiler option for this reference or delimit the directive with delimit it with '#if INTERACTIVE'/'#endif'.</value>
+    <value>#I directives may only be used in F# script files (extensions .fsx or .fsscript). Either move this code to a script file, add a '-I' compiler option for this reference or delimit the directive with delimit it with '#if INTERACTIVE'/'#endif'.</value>
   </data>
   <data name="HashReferenceNotAllowedInNonScript" xml:space="preserve">
-    <value>#r directives may only occur in F# script files (extensions .fsx or .fsscript). Either move this code to a script file or replace this reference with the '-r' compiler option. If this directive is being executed as user input, you may delimit it with '#if INTERACTIVE'/'#endif'.</value>
+    <value>#r directives may only be used in F# script files (extensions .fsx or .fsscript). Either move this code to a script file or replace this reference with the '-r' compiler option. If this directive is being executed as user input, you may delimit it with '#if INTERACTIVE'/'#endif'.</value>
   </data>
   <data name="HashDirectiveNotAllowedInNonScript" xml:space="preserve">
     <value>This directive may only be used in F# script files (extensions .fsx or .fsscript). Either remove the directive, move this code to a script file or delimit the directive with '#if INTERACTIVE'/'#endif'.</value>

diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs
@@ -832,24 +832,26 @@ let internal languageFeatureError (langVersion: LanguageVersion) (langFeature: L
     let suggestedVersionStr = LanguageVersion.GetFeatureVersionString langFeature
     Error(FSComp.SR.chkFeatureNotLanguageSupported (featureStr, currentVersionStr, suggestedVersionStr), m)
 
-let private tryLanguageFeatureErrorAux (langVersion: LanguageVersion) (langFeature: LanguageFeature) (m: range) =
+let internal tryLanguageFeatureErrorOption (langVersion: LanguageVersion) (langFeature: LanguageFeature) (m: range) =
     if not (langVersion.SupportsFeature langFeature) then
         Some(languageFeatureError langVersion langFeature m)
     else
         None
 
 let internal checkLanguageFeatureError langVersion langFeature m =
-    match tryLanguageFeatureErrorAux langVersion langFeature m with
+    match tryLanguageFeatureErrorOption langVersion langFeature m with
     | Some e -> error e
     | None -> ()
 
-let internal checkLanguageFeatureAndRecover langVersion langFeature m =
-    match tryLanguageFeatureErrorAux langVersion langFeature m with
-    | Some e -> errorR e
-    | None -> ()
+let internal tryCheckLanguageFeatureAndRecover langVersion langFeature m =
+    match tryLanguageFeatureErrorOption langVersion langFeature m with
+    | Some e ->
+        errorR e
+        false
+    | None -> true
 
-let internal tryLanguageFeatureErrorOption langVersion langFeature m =
-    tryLanguageFeatureErrorAux langVersion langFeature m
+let internal checkLanguageFeatureAndRecover langVersion langFeature m =
+    tryCheckLanguageFeatureAndRecover langVersion langFeature m |> ignore
 
 let internal languageFeatureNotSupportedInLibraryError (langFeature: LanguageFeature) (m: range) =
     let featureStr = LanguageVersion.GetFeatureString langFeature

diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fsi b/src/Compiler/Facilities/DiagnosticsLogger.fsi
@@ -438,6 +438,8 @@ val languageFeatureError: langVersion: LanguageVersion -> langFeature: LanguageF
 
 val checkLanguageFeatureError: langVersion: LanguageVersion -> langFeature: LanguageFeature -> m: range -> unit
 
+val tryCheckLanguageFeatureAndRecover: langVersion: LanguageVersion -> langFeature: LanguageFeature -> m: range -> bool
+
 val checkLanguageFeatureAndRecover: langVersion: LanguageVersion -> langFeature: LanguageFeature -> m: range -> unit
 
 val tryLanguageFeatureErrorOption:

diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs
@@ -89,6 +89,7 @@ type LanguageFeature =
     | LowerInterpolatedStringToConcat
     | LowerIntegralRangesToFastLoops
     | LowerSimpleMappingsInComprehensionsToDirectCallsToMap
+    | ParsedHashDirectiveArgumentNonQuotes
 
 /// LanguageVersion management
 type LanguageVersion(versionText) =
@@ -205,6 +206,7 @@ type LanguageVersion(versionText) =
                 LanguageFeature.LowerInterpolatedStringToConcat, previewVersion
                 LanguageFeature.LowerIntegralRangesToFastLoops, previewVersion
                 LanguageFeature.LowerSimpleMappingsInComprehensionsToDirectCallsToMap, previewVersion
+                LanguageFeature.ParsedHashDirectiveArgumentNonQuotes, previewVersion
             ]
 
     static let defaultLanguageVersion = LanguageVersion("default")
@@ -353,6 +355,7 @@ type LanguageVersion(versionText) =
         | LanguageFeature.LowerIntegralRangesToFastLoops -> FSComp.SR.featureLowerIntegralRangesToFastLoops ()
         | LanguageFeature.LowerSimpleMappingsInComprehensionsToDirectCallsToMap ->
             FSComp.SR.featureLowerSimpleMappingsInComprehensionsToDirectCallsToMap ()
+        | LanguageFeature.ParsedHashDirectiveArgumentNonQuotes -> FSComp.SR.featureParsedHashDirectiveArgumentNonString ()
 
     /// Get a version string associated with the given feature.
     static member GetFeatureVersionString feature =