From 20fdc501abedb4ee1d11ab4dc616d4aee9c84baa Mon Sep 17 00:00:00 2001 From: "dotnet-maestro[bot]" <42748379+dotnet-maestro[bot]@users.noreply.github.com> Date: Mon, 10 Aug 2026 10:58:47 +0200 Subject: [PATCH 01/55] Update dependencies from https://dev.azure.com/dnceng/internal/_git/dotnet-optimization build 20260807.1 (#20236) On relative base path root optimization.linux-arm64.MIBC.Runtime , optimization.linux-x64.MIBC.Runtime , optimization.windows_nt-arm64.MIBC.Runtime , optimization.windows_nt-x64.MIBC.Runtime , optimization.windows_nt-x86.MIBC.Runtime From Version 1.0.0-prerelease.26403.1 -> To Version 1.0.0-prerelease.26407.1 Co-authored-by: dotnet-maestro[bot] --- eng/Version.Details.props | 10 +++++----- eng/Version.Details.xml | 20 ++++++++++---------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/eng/Version.Details.props b/eng/Version.Details.props index a4a0f8ca4a3..bb9666a824b 100644 --- a/eng/Version.Details.props +++ b/eng/Version.Details.props @@ -13,11 +13,11 @@ This file should be imported by eng/Versions.props 18.10.0-preview-26357-08 18.10.0-preview-26357-08 - 1.0.0-prerelease.26403.1 - 1.0.0-prerelease.26403.1 - 1.0.0-prerelease.26403.1 - 1.0.0-prerelease.26403.1 - 1.0.0-prerelease.26403.1 + 1.0.0-prerelease.26407.1 + 1.0.0-prerelease.26407.1 + 1.0.0-prerelease.26407.1 + 1.0.0-prerelease.26407.1 + 1.0.0-prerelease.26407.1 5.10.0-1.26365.3 5.10.0-1.26365.3 diff --git a/eng/Version.Details.xml b/eng/Version.Details.xml index 579f03c52de..a65baa445cd 100644 --- a/eng/Version.Details.xml +++ b/eng/Version.Details.xml @@ -86,25 +86,25 @@ https://github.com/dotnet/arcade 09bc8c946f4c4ae5d031c8875b85a6b8f1876b93 - + https://dev.azure.com/dnceng/internal/_git/dotnet-optimization - 4e59839621546daec139a776ec6510f61775e1df + e960b77a63b94a4b7c1f077c2d325d003a461d2d - + https://dev.azure.com/dnceng/internal/_git/dotnet-optimization - 4e59839621546daec139a776ec6510f61775e1df + e960b77a63b94a4b7c1f077c2d325d003a461d2d - + https://dev.azure.com/dnceng/internal/_git/dotnet-optimization - 4e59839621546daec139a776ec6510f61775e1df + e960b77a63b94a4b7c1f077c2d325d003a461d2d - + https://dev.azure.com/dnceng/internal/_git/dotnet-optimization - 4e59839621546daec139a776ec6510f61775e1df + e960b77a63b94a4b7c1f077c2d325d003a461d2d - + https://dev.azure.com/dnceng/internal/_git/dotnet-optimization - 4e59839621546daec139a776ec6510f61775e1df + e960b77a63b94a4b7c1f077c2d325d003a461d2d From 4a929f3f8fcc710432ecd3581204cf0aecc3df67 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 10 Aug 2026 11:00:34 +0200 Subject: [PATCH 02/55] docs: update state-machine.md for changed workflow SHAs (#20234) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Incremental update: - Fix LPSS safe-output label count (10 → 11) - Update source-shas footer Co-authored-by: github-actions[bot] <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- .github/docs/state-machine.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/docs/state-machine.md b/.github/docs/state-machine.md index 47ff1843bf9..2885894bf26 100644 --- a/.github/docs/state-machine.md +++ b/.github/docs/state-machine.md @@ -334,7 +334,7 @@ gh-aw safe-output defaults (suppressed below): `target: "*"`, `noop.report-as-is | `labelops-pr-maintenance` | `add-comment` | 5 | hide-older-comments: true | | `labelops-pr-maintenance` | `add-labels` | 3 | allowed: AI-needs-CI-fix-input | | `labelops-pr-maintenance` | `dispatch-workflow` | 3 | workflows: labelops-flake-fix | -| `labelops-pr-security-scan` | `add-labels` | 50 | allowed: 10 labels (⚠️ Affects-* family + Scanned-Clean + Bypassed) | +| `labelops-pr-security-scan` | `add-labels` | 50 | allowed: 11 labels (⚠️ Affects-* family + Suspicious-Prompting + Scope-Review-Needed + Scanned-Clean + Bypassed) | | `labelops-pr-security-scan` | `add-comment` | 25 | hide-older-comments: true | | `msbuild-quality-review` | `create-issue` | 1 | title `[msbuild-quality] `, labels: automation+Area-ProjectsAndBuild | | `msbuild-quality-review` | `create-pull-request` | 1 | draft: true, title `[msbuild-quality] `, protected-files: fallback-to-issue | @@ -372,4 +372,4 @@ gh-aw safe-output defaults (suppressed below): `target: "*"`, `noop.report-as-is --- -> generator-version: f107bba1a1cd61dc · source-shas: 06e56c52,149f0bbe,1af951a0,36b2b857,3775b51d,49b2989b,5e54b0e6,5e9a1344,7dca5b8f,9285c8a0,98d92f32,a5296399,acf12bdf,b5c04ea8,ec5fa486,f107bba1, +> generator-version: f107bba1a1cd61dc · source-shas: 06e56c52,149f0bbe,1af951a0,36b2b857,3775b51d,420b9d6e,49b2989b,5e9a1344,7dca5b8f,9285c8a0,98d92f32,acf12bdf,b5c04ea8,d3e496db,ec5fa486,f107bba1, From fa85b35e6644ff0814c1667e597ea4d91eddc99e Mon Sep 17 00:00:00 2001 From: "dotnet-maestro[bot]" <42748379+dotnet-maestro[bot]@users.noreply.github.com> Date: Mon, 10 Aug 2026 11:01:22 +0200 Subject: [PATCH 03/55] [main] Source code updates from dotnet/dotnet (#20214) * Backflow from https://github.com/dotnet/dotnet / ae1c2e7 build 325824 Diff: https://github.com/dotnet/dotnet/compare/13a51a374931ee7021dd6b366d3f7256ddfa2871..ae1c2e796871b41b1ffc4357e4aec0dd8c1f4f90 From: https://github.com/dotnet/dotnet/commit/13a51a374931ee7021dd6b366d3f7256ddfa2871 To: https://github.com/dotnet/dotnet/commit/ae1c2e796871b41b1ffc4357e4aec0dd8c1f4f90 [[ commit created by automation ]] * Update dependencies from build 325824 No dependency updates to commit [[ commit created by automation ]] * Update dependencies from build 326034 No dependency updates to commit [[ commit created by automation ]] * Update dependencies from build 326269 No dependency updates to commit [[ commit created by automation ]] * Update dependencies from build 326319 No dependency updates to commit [[ commit created by automation ]] * Update dependencies from build 326361 No dependency updates to commit [[ commit created by automation ]] * Remove versioning for package references in FSharp.Build Removed specific version references for several package dependencies. * Remove version constraints for package references Removed specific version references for several package dependencies to avoid conflicts and potential vulnerabilities. * Update FSharp.Build.fsproj --------- Co-authored-by: dotnet-maestro[bot] Co-authored-by: Viktor Hofer <7412651+ViktorHofer@users.noreply.github.com> --- eng/Version.Details.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/eng/Version.Details.xml b/eng/Version.Details.xml index a65baa445cd..5cda2d7a661 100644 --- a/eng/Version.Details.xml +++ b/eng/Version.Details.xml @@ -1,6 +1,6 @@ - + https://github.com/dotnet/msbuild From ab2e0668aed13f67ad9be17562460ecd22cf6c7a Mon Sep 17 00:00:00 2001 From: dotnet bot Date: Mon, 10 Aug 2026 02:01:51 -0700 Subject: [PATCH 04/55] Localized file check-in by OneLocBuild Task: Build definition ID 499: Build ID 3039021 (#20108) * Localized file check-in by OneLocBuild Task: Build definition ID 499: Build ID 3036509 * Localized file check-in by OneLocBuild Task: Build definition ID 499: Build ID 3036509 * Localized file check-in by OneLocBuild Task: Build definition ID 499: Build ID 3038596 * Localized file check-in by OneLocBuild Task: Build definition ID 499: Build ID 3038596 * Localized file check-in by OneLocBuild Task: Build definition ID 499: Build ID 3038733 * Localized file check-in by OneLocBuild Task: Build definition ID 499: Build ID 3038733 --------- Co-authored-by: Copilot --- src/Compiler/xlf/FSComp.txt.cs.xlf | 2 +- src/Compiler/xlf/FSComp.txt.de.xlf | 2 +- src/Compiler/xlf/FSComp.txt.es.xlf | 2 +- src/Compiler/xlf/FSComp.txt.fr.xlf | 2 +- src/Compiler/xlf/FSComp.txt.it.xlf | 2 +- src/Compiler/xlf/FSComp.txt.ja.xlf | 2 +- src/Compiler/xlf/FSComp.txt.ko.xlf | 2 +- src/Compiler/xlf/FSComp.txt.pl.xlf | 2 +- src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 2 +- src/Compiler/xlf/FSComp.txt.ru.xlf | 2 +- src/Compiler/xlf/FSComp.txt.tr.xlf | 2 +- src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 2 +- src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 2 +- 13 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index afb00396c5d..e007c5655fa 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - Neočekávaná syntaxe nebo možné nesprávné odsazení: Tento token je mimo kontext spuštěný na pozici {0}. Zkuste toto odsazení ještě více odsadit.\nPokud chcete dál používat neodpovídající odsazení, předejte kompilátoru příznak '--strict-indentation-' nebo nastavte jazykovou verzi na F# 7. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index 222cab682fd..002c068e7fb 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - Unerwartete Syntax oder möglicherweise falscher Einzug: Dieses Token befindet sich außerhalb des Kontexts, der an Position {0}gestartet wurde. Versuchen Sie, dies weiter einzurücken.\nUm weiterhin eine nicht konforme Einrückung zu verwenden, übergeben Sie dem Compiler das Flag „--strict-indentation-“ oder setzen Sie die Sprachversion auf F# 7. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index d3cbfab11f1..865897420f3 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - Sintaxis inesperada o posible sangría incorrecta: este token está fuera del contexto iniciado en la posición {0}. Intente aplicar más sangría.\nPara seguir usando la sangría no conforme, pase la marca "--strict-indentation-" al compilador o establezca la versión del lenguaje en F# 7. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 59712f7a2f5..5bf1a9add86 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - Syntaxe inattendue ou mise en retrait incorrecte possible : ce jeton est hors du contexte démarré à la position {0}. Essayez de mettre cela en retrait.\nPour continuer à utiliser une mise en retrait non conforme, passez l’indicateur '--strict-indentation-' au compilateur ou définissez la version de langage sur F# 7. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 92de61c5737..7099e8b391b 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - Sintassi imprevista o possibile rientro non corretto: questo token è fuori dal contesto avviato nella posizione {0}. Provare a impostare ulteriormente il rientro.\nPer continuare a usare un rientro non conforme, passare il flag '--strict-indentation-' al compilatore, o impostare la versione del linguaggio su F# 7. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index b4f048784cb..b8e4d9b7503 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - 予期しない構文またはインデントが正しくない可能性: このトークンは位置 {0} から開始されるコンテキストのオフサイドになります。このトークンのインデントを増やしてみてください。\n非準拠のインデントを引き続き使用するには、'--strict-indent-' フラグをコンパイラに渡すか、言語バージョンを F# 7 に設定してください。 + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 9d12c1d82b0..04533426fc5 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - 예기치 않은 구문 또는 잘못된 들여쓰기: 이 토큰은 {0} 위치에서 시작된 컨텍스트의 오프 사이드입니다. 이를 더 들여쓰기해 보세요.\n규정을 준수하지 않는 들여쓰기를 계속 사용하려면 '--strict-indentation-' 플래그를 컴파일러에 전달하거나 언어 버전을 F# 7로 설정합니다. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index 4ecb28aa71f..abaf87acfbf 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - Nieoczekiwana składnia lub możliwe niepoprawne wcięcie: ten token jest poza kontekstem uruchomionym na pozycji {0}. Spróbuj jeszcze bardziej wciąć to ustawienie.\nAby kontynuować używanie niezgodnych wcięć, przekaż flagę „--strict-indentation-” do kompilatora lub ustaw wersję języka na F# 7. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 736ab22b139..963037d4a72 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - Sintaxe inesperada ou possível recuo incorreto: esse token está fora do contexto iniciado na posição {0}. Tente recuar isso ainda mais.\nPara continuar usando o recuo não compatível, passe o sinalizador '--strict-indentation-' para o compilador ou defina a versão da linguagem como F# 7. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index 170bcfc7385..53ea084423b 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - Неожиданный синтаксис или, возможно, неправильный отступ: этот токен находится вне контекста, начатого в позиции {0}. Попробуйте увеличить отступ.\nЧтобы продолжить использование несоответствующего отступа, передайте компилятору флаг '--strict-indentation-' или установите версию языка F# 7. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 5595108617e..4540639f47c 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - Beklenmeyen sözdizimi veya olası yanlış girinti: Bu belirteç, {0} konumunda başlayan bağlamın ofsaytıdır. Bunu daha fazla girintilemeyi deneyin.\nUygun olmayan girintiyi kullanmaya devam etmek için '--strict-indentation-' işaretini derleyiciye iletin veya dil sürümünü F# 7 olarak ayarlayın. + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index c020d652bf0..76969b500eb 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - 意外语法或可能错误的缩进: 此令牌对于 {0} 处开始的上下文来说越位。尝试进一步缩进此内容。\n若要继续使用不符合条件的索引，请将 "--strict-indentation-" 传递给编译器，或者将语言版本设置为 F# 7。 + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 8ed6744afb6..1c1ffb1b333 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -6724,7 +6724,7 @@ Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. - 未預期的語法或可能不正確的縮排: 此權杖與在位置 {0} 啟動的內容不同步。請嘗試進一步縮排。\n若要繼續使用不符合的縮排，請傳遞 '--strict-indentation-' 旗標給編譯器，或將語言版本設定為 F# 7。 + Unexpected syntax or possible incorrect indentation: this token is offside of context started at position {0}. Try indenting this further. From 80b7e4e87c03c73640fff5df247a4421795416b3 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Mon, 10 Aug 2026 11:13:58 +0200 Subject: [PATCH 05/55] Enable MSBuild node reuse defaults in eng/Build.ps1 and eng/build.sh (#20220) Both entry points hard-disabled MSBuild node reuse for every build, overriding Arcade's default (node reuse on locally, off on CI). The overrides were added together in March 2019 (7a6448eda0, f4bd2211d8) as a workaround for FSharp.Build.dll version conflicts when the proto compiler and the freshly built one are loaded into reused MSBuild nodes during F#'s self-bootstrap. This removes both overrides so Arcade's default applies, restoring node reuse for the inner loop and unblocking MSBuild Server. Whether the 2019 FSharp.Build.dll conflict still reproduces is validated by full CI, including the Windows EndToEndBuildTests job, which builds without -ci and therefore now exercises node reuse end to end. Fixes #20217 Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> --- eng/Build.ps1 | 2 -- eng/build.sh | 3 --- 2 files changed, 5 deletions(-) diff --git a/eng/Build.ps1 b/eng/Build.ps1 index 01ff6313626..ad397df6acb 100644 --- a/eng/Build.ps1 +++ b/eng/Build.ps1 @@ -165,8 +165,6 @@ function Process-Arguments() { $script:useGlobalNugetCache = $False } - $script:nodeReuse = $False; - if ($testAll) { $script:testDesktop = $True $script:testCoreClr = $True diff --git a/eng/build.sh b/eng/build.sh index 7e0d6dd2a87..540e9c14e5f 100755 --- a/eng/build.sh +++ b/eng/build.sh @@ -303,9 +303,6 @@ function BuildSolution { quiet_restore=true fi - # Node reuse fails because multiple different versions of FSharp.Build.dll get loaded into MSBuild nodes - node_reuse=false - # build bootstrap tools # source_build=In source build proto does no work, except cause sourcebuild in wrapper to build bootstrap_dir=$artifacts_dir/Bootstrap From 22a8a5dcc724ea58041b8bc0b95e51268d7b656d Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Mon, 10 Aug 2026 11:16:53 +0200 Subject: [PATCH 06/55] Set the default F# language version to 11.0 (#20219) * Set default F# language version to 11.0 --- src/Compiler/Facilities/LanguageFeatures.fs | 2 +- .../Signatures/SignatureEnforcedAttributes.fs | 2 ++ .../EmittedIL/DirectDelegates/DirectDelegates.fs | 2 ++ .../EmittedIL/Nullness/NullnessMetadata.fs | 1 + .../SerializableAttribute.fs | 1 + .../Miscellaneous/FsharpSuiteMigrated.fs | 1 + .../Miscellaneous/MigratedTypeCheckTests.fs | 4 +++- tests/FSharp.Test.Utilities/ScriptHelpers.fs | 2 ++ .../Compiler/CodeGen/EmittedIL/StaticMember.fs | 15 ++++++++++----- tests/fsharp/tests.fs | 7 +++++-- 10 files changed, 28 insertions(+), 9 deletions(-) diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index 87a27860478..da9b3f9ac33 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -127,7 +127,7 @@ type LanguageVersion(versionText, ?disabledFeaturesArray: LanguageFeature array) static let languageVersion100 = 10.0m static let languageVersion110 = 11.0m static let previewVersion = 9999m // Language version when preview specified - static let defaultVersion = languageVersion100 // Language version when default specified + static let defaultVersion = languageVersion110 // Language version when default specified static let latestVersion = defaultVersion // Language version when latest specified static let latestMajorVersion = defaultVersion // Language version when latestmajor specified diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/Signatures/SignatureEnforcedAttributes.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/Signatures/SignatureEnforcedAttributes.fs index e9a7639999a..eae5eca01a1 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/Signatures/SignatureEnforcedAttributes.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/Signatures/SignatureEnforcedAttributes.fs @@ -16,6 +16,7 @@ module SignatureEnforcedAttributes = |> FS |> withAdditionalSourceFile (fs implSrc) |> asLibrary + |> withLangVersion10 // FS3888 is a warning pre-11 and an error at 11.0 (ErrorOnMissingSignatureAttribute); pin to the warning behavior |> ignoreWarnings |> compile @@ -265,6 +266,7 @@ let inline f (x: int) = x + 1 |> FS |> withAdditionalSourceFile (fs implSrc) |> asLibrary + |> withLangVersion10 // #nowarn suppresses FS3888 only while it is a warning (pre-11); at 11.0 it is an error |> compile |> shouldSucceed diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/DirectDelegates/DirectDelegates.fs b/tests/FSharp.Compiler.ComponentTests/EmittedIL/DirectDelegates/DirectDelegates.fs index f247d1c2210..e2c93ccedcd 100644 --- a/tests/FSharp.Compiler.ComponentTests/EmittedIL/DirectDelegates/DirectDelegates.fs +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/DirectDelegates/DirectDelegates.fs @@ -17,6 +17,7 @@ let private coreOptions compilation = let verifyCompilation compilation = compilation |> coreOptions + |> withLangVersion10 // default baseline captures the pre-11 closure IL; DirectDelegateConstruction (11.0) is covered by the preview twin |> compile |> shouldSucceed |> verifyPEFileWithSystemDlls @@ -212,6 +213,7 @@ let main _ = if d.Method.Name <> "Invoke" then failwithf "expected closure Method.Name 'Invoke' but got '%s'" d.Method.Name 0 """ + |> withLangVersion10 // "without the feature": DirectDelegateConstruction is off pre-11, so the delegate goes through a closure |> compileExeAndRun |> shouldSucceed diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/Nullness/NullnessMetadata.fs b/tests/FSharp.Compiler.ComponentTests/EmittedIL/Nullness/NullnessMetadata.fs index e4d4243b300..e4dcfbcb43b 100644 --- a/tests/FSharp.Compiler.ComponentTests/EmittedIL/Nullness/NullnessMetadata.fs +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/Nullness/NullnessMetadata.fs @@ -70,6 +70,7 @@ module NullnessMetadata = let ``Nullable attr for exception types`` compilation = compilation |> getCompilation + |> withLangVersion10 // ExceptionFieldSerializationSupport (11.0) changes exception IL; pin to pre-11 (nullness stays on, gated at 9.0) |> verifyCompilation DoNotOptimize [] diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/SerializableAttribute/SerializableAttribute.fs b/tests/FSharp.Compiler.ComponentTests/EmittedIL/SerializableAttribute/SerializableAttribute.fs index 4ba73a4b8da..e44f160a974 100644 --- a/tests/FSharp.Compiler.ComponentTests/EmittedIL/SerializableAttribute/SerializableAttribute.fs +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/SerializableAttribute/SerializableAttribute.fs @@ -15,6 +15,7 @@ module SerializableAttribute = |> withEmbeddedPdb |> withEmbedAllSource |> ignoreWarnings + |> withLangVersion10 // baselines capture pre-11 serialization IL; ExceptionFieldSerializationSupport (11.0) is off here |> compile |> verifyILBaseline diff --git a/tests/FSharp.Compiler.ComponentTests/Miscellaneous/FsharpSuiteMigrated.fs b/tests/FSharp.Compiler.ComponentTests/Miscellaneous/FsharpSuiteMigrated.fs index e0cfdff2ffd..b976f60d438 100644 --- a/tests/FSharp.Compiler.ComponentTests/Miscellaneous/FsharpSuiteMigrated.fs +++ b/tests/FSharp.Compiler.ComponentTests/Miscellaneous/FsharpSuiteMigrated.fs @@ -86,6 +86,7 @@ module TestFrameworkAdapter = match version with | LangVersion.V80 -> "8.0",bonusArgs | LangVersion.V90 -> "9.0",bonusArgs + | LangVersion.V10 -> "10.0",bonusArgs | LangVersion.Preview -> "preview",bonusArgs | LangVersion.Latest -> "latest", bonusArgs diff --git a/tests/FSharp.Compiler.ComponentTests/Miscellaneous/MigratedTypeCheckTests.fs b/tests/FSharp.Compiler.ComponentTests/Miscellaneous/MigratedTypeCheckTests.fs index 208a60327b4..ba474291d04 100644 --- a/tests/FSharp.Compiler.ComponentTests/Miscellaneous/MigratedTypeCheckTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Miscellaneous/MigratedTypeCheckTests.fs @@ -46,7 +46,9 @@ let ``type check neg10_a`` () = singleNegTest ( "typecheck/sigs") "neg10_a" let ``type check neg11`` () = singleNegTest ( "typecheck/sigs") "neg11" [] -let ``type check neg12`` () = singleNegTest ( "typecheck/sigs") "neg12" +// Pinned to 10.0: at 11.0 AccessProtectedBaseFieldFromClosure lets the protected-member-from-closure +// cases compile, dropping baseline errors. 11.0 behavior is covered by dedicated conformance tests. +let ``type check neg12`` () = singleVersionedNegTest ("typecheck/sigs") LangVersion.V10 "neg12" [] let ``type check neg13`` () = singleNegTest ( "typecheck/sigs") "neg13" diff --git a/tests/FSharp.Test.Utilities/ScriptHelpers.fs b/tests/FSharp.Test.Utilities/ScriptHelpers.fs index cb2956ab8ac..1822187751c 100644 --- a/tests/FSharp.Test.Utilities/ScriptHelpers.fs +++ b/tests/FSharp.Test.Utilities/ScriptHelpers.fs @@ -16,6 +16,7 @@ open FSharp.Test type LangVersion = | V80 | V90 + | V10 | Preview | Latest @@ -40,6 +41,7 @@ type FSharpScript(?additionalArgs: string[], ?quiet: bool, ?langVersion: LangVer | LangVersion.Latest -> "--langversion:latest" | LangVersion.V80 -> "--langversion:8.0" | LangVersion.V90 -> "--langversion:9.0" + | LangVersion.V10 -> "--langversion:10.0" |] let argv = Array.append baseArgs additionalArgs diff --git a/tests/fsharp/Compiler/CodeGen/EmittedIL/StaticMember.fs b/tests/fsharp/Compiler/CodeGen/EmittedIL/StaticMember.fs index 078cffd9e60..6a13f7f83ad 100644 --- a/tests/fsharp/Compiler/CodeGen/EmittedIL/StaticMember.fs +++ b/tests/fsharp/Compiler/CodeGen/EmittedIL/StaticMember.fs @@ -8,9 +8,13 @@ open Xunit module ``Static Member`` = + // The delegate-from-method cases below are pinned to --langversion:10.0: at F# 11.0 (now the default) + // DirectDelegateConstruction builds the delegate straight from the target method, dropping the closure + // class this IL expects. The 11.0 form is covered by EmittedIL/DirectDelegates. + [] let ``Action on Static Member``() = - CompilerAssert.CompileLibraryAndVerifyILRealSig( + CompilerAssert.CompileLibraryAndVerifyILWithOptions([| "--realsig+"; "--langversion:10.0" |], """ module StaticMember01 @@ -74,7 +78,7 @@ type C = [] let ``Action on Static Member with lambda``() = - CompilerAssert.CompileLibraryAndVerifyILRealSig( + CompilerAssert.CompileLibraryAndVerifyILWithOptions([| "--realsig+"; "--langversion:10.0" |], """ module StaticMember02 @@ -247,7 +251,7 @@ let main _ = [] let ``Func on Static Member``() = - CompilerAssert.CompileLibraryAndVerifyILRealSig( + CompilerAssert.CompileLibraryAndVerifyILWithOptions([| "--realsig+"; "--langversion:10.0" |], """ module StaticMember04 @@ -313,7 +317,7 @@ type C = [] let ``Func on Static Member with lambda``() = - CompilerAssert.CompileLibraryAndVerifyILRealSig( + CompilerAssert.CompileLibraryAndVerifyILWithOptions([| "--realsig+"; "--langversion:10.0" |], """ module StaticMember05 @@ -434,7 +438,8 @@ let main _ = #if !FX_NO_WINFORMS [] let ``EventHandler from Regression/83``() = - CompilerAssert.CompileLibraryAndVerifyILRealSig( + // Same pin as the cases above; WinForms-gated, so this one only runs on Windows CI. + CompilerAssert.CompileLibraryAndVerifyILWithOptions([| "--realsig+"; "--langversion:10.0" |], """ module StaticMember07 diff --git a/tests/fsharp/tests.fs b/tests/fsharp/tests.fs index 10a99ee04ab..95491e2e593 100644 --- a/tests/fsharp/tests.fs +++ b/tests/fsharp/tests.fs @@ -66,11 +66,14 @@ module CoreTests = exec cfg cfg.DotNetExe ($"msbuild {projectFile} /p:Configuration={cfg.BUILD_CONFIG} -property:FSharpRepositoryPath={FSharpRepositoryPath}") #if !NETCOREAPP + // Pinned to 10.0: at 11.0 ErrorOnMissingSignatureAttribute turns FS3888 (attribute on impl but + // not signature) from warning into error, which this test deliberately exercises. 11.0 behavior is + // covered by Conformance/Signatures/SignatureEnforcedAttributes. [] - let ``attributes-FSC_OPTIMIZED`` () = singleTestBuildAndRun "core/attributes" FSC_OPTIMIZED + let ``attributes-FSC_OPTIMIZED`` () = singleTestBuildAndRunVersion "core/attributes" FSC_OPTIMIZED "10.0" [] - let ``attributes-FSI`` () = singleTestBuildAndRun "core/attributes" FSI + let ``attributes-FSI`` () = singleTestBuildAndRunVersion "core/attributes" FSI "10.0" [] let span () = From 853c500401c58e394180a106322bd686c1e0f12b Mon Sep 17 00:00:00 2001 From: Kirtikumar Anandrao Ramchandani <33368817+KirtiRamchandani@users.noreply.github.com> Date: Tue, 11 Aug 2026 17:42:54 +0530 Subject: [PATCH 07/55] Fix spurious FS0410 for tuple patternInput bindings (#4161) (#19947) Skip accessibility checks on compiler-generated patternInput module bindings. These temps are module-init scaffolding whose visibility does not reflect the enclosing let-binding scope, which caused false FS0410 errors when tuple deconstruction referenced private types in the same module. Fixes #4161 --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + src/Compiler/Checking/PostInferenceChecks.fs | 13 +++++--- .../PatternMatching/Tuple/Tuple.fs | 32 +++++++++++++++++++ .../PatternMatching/Tuple/tuples02.fs | 15 +++++++++ .../PatternMatching/Tuple/tuples03.fs | 6 ++++ .../PatternMatching/Tuple/tuples04.fs | 6 ++++ 6 files changed, 68 insertions(+), 5 deletions(-) create mode 100644 tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples02.fs create mode 100644 tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples03.fs create mode 100644 tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples04.fs diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index ab65df29a6e..b6ba1cea739 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -23,6 +23,7 @@ * Preserve source range for type errors on empty-bodied computation expressions (e.g. `foo {}`) in pipelines, function arguments, and type-annotated contexts, instead of reporting `unknown(1,1)`. ([Issue #19550](https://github.com/dotnet/fsharp/issues/19550), [PR #19849](https://github.com/dotnet/fsharp/pull/19849)) * Fix multiline nested type arguments failing to parse when the closing `>` aligns with the opening type name's column. ([Issue #15171](https://github.com/dotnet/fsharp/issues/15171)) * Tooltip "Full name" now shows demangled companion module names (e.g. `MyType.func` instead of `MyTypeModule.func`). ([Issue #17335](https://github.com/dotnet/fsharp/issues/17335), [PR #19867](https://github.com/dotnet/fsharp/pull/19867)) +* Fix spurious FS0410 accessibility error when tuple-deconstructing bindings use private types in the same module scope. ([Issue #4161](https://github.com/dotnet/fsharp/issues/4161), [PR #19947](https://github.com/dotnet/fsharp/pull/19947)) * Fix internal error (FS0193) when calling an indexed property setter with a named argument that matches an indexer parameter. ([Issue #16034](https://github.com/dotnet/fsharp/issues/16034), [PR #19851](https://github.com/dotnet/fsharp/pull/19851)) * Fix missing FS1182 ("unused binding") warning for unused `let` function bindings inside class types. ([Issue #13849](https://github.com/dotnet/fsharp/issues/13849), [PR #19805](https://github.com/dotnet/fsharp/pull/19805)) * Fix internal compiler error FS1110 in `task { let! }` (and other computation expressions) when a generic IL extension method whose `this`-parameter is a method-level type variable is in scope (e.g. `open ReactiveUI`). Regression from PR #19536. ([Issue #19936](https://github.com/dotnet/fsharp/issues/19936)) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 09266946c43..9849d7ed875 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -525,7 +525,7 @@ let isLessAccessibleWithVisibility (cenv: cenv) itemAccess refAccess = let thisCompPath = compPathOfCcu cenv.viewCcu isLessAccessible (itemAccess |> AccessInternalsVisibleToAsInternal thisCompPath cenv.internalsVisibleToPaths) refAccess -let CheckTypeForAccess (cenv: cenv) env objName valAcc m ty = +let CheckTypeForAccess (cenv: cenv) env objName valAcc skipAccessibilityCheckForCompilerGeneratedVal m ty = if cenv.reportErrors then let visitType ty = @@ -534,7 +534,7 @@ let CheckTypeForAccess (cenv: cenv) env objName valAcc m ty = match tryTcrefOfAppTy cenv.g ty with | ValueNone -> () | ValueSome tcref -> - if isLessAccessibleWithVisibility cenv tcref.Accessibility valAcc then + if not skipAccessibilityCheckForCompilerGeneratedVal && isLessAccessibleWithVisibility cenv tcref.Accessibility valAcc then errorR(Error(FSComp.SR.chkTypeLessAccessibleThanType(tcref.DisplayName, objName()), m)) CheckTypeDeep cenv (visitType, None, None, None, None) cenv.g env NoInfo ty @@ -2135,7 +2135,10 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin // Check accessibility if (v.IsMemberOrModuleBinding || v.IsMember) && not v.IsIncrClassGeneratedMember then let access = AdjustAccess (IsHiddenVal env.sigToImplRemapInfo v) (fun () -> v.DeclaringEntity.CompilationPath) v.Accessibility - CheckTypeForAccess cenv env (fun () -> NicePrint.stringOfQualifiedValOrMember cenv.denv cenv.infoReader vref) access v.Range v.Type + // Compiler-generated patternInput temps are module-init scaffolding; their promoted + // accessibility does not reflect the enclosing binding scope (dotnet/fsharp#4161). + let skipAccessibilityCheck = v.IsCompilerGenerated && v.LogicalName.StartsWith("patternInput") + CheckTypeForAccess cenv env (fun () -> NicePrint.stringOfQualifiedValOrMember cenv.denv cenv.infoReader vref) access skipAccessibilityCheck v.Range v.Type CheckInlineValueIsSufficientlyAccessible cenv env v bindRhs @@ -2362,7 +2365,7 @@ let CheckRecdField isUnion cenv env (tycon: Tycon) (rfield: RecdField) = IsHiddenTyconRepr env.sigToImplRemapInfo tycon || (not isUnion && IsHiddenRecdField env.sigToImplRemapInfo (tcref.MakeNestedRecdFieldRef rfield)) let access = AdjustAccess isHidden (fun () -> tycon.CompilationPath) rfield.Accessibility - CheckTypeForAccess cenv env (fun () -> rfield.LogicalName) access m fieldTy + CheckTypeForAccess cenv env (fun () -> rfield.LogicalName) access false m fieldTy if isByrefLikeTyconRef g m tcref then // Permit Span fields in IsByRefLike types @@ -2642,7 +2645,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = // Access checks let access = AdjustAccess (IsHiddenTycon env.sigToImplRemapInfo tycon) (fun () -> tycon.CompilationPath) tycon.Accessibility - let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access tycon.Range ty + let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access false tycon.Range ty abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType) diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/Tuple.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/Tuple.fs index d7286f04e3b..10d286cd3e3 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/Tuple.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/Tuple.fs @@ -24,6 +24,38 @@ module Tuple = |> withOptions ["--test:ErrorRanges"] |> typecheck |> shouldSucceed + + [] + let ``Tuple - tuples02_fs - --test:ErrorRanges`` compilation = + compilation + |> asFs + |> withOptions ["--test:ErrorRanges"] + |> compileExeAndRun + |> shouldSucceed + + [] + let ``Tuple - tuples03_fs - --test:ErrorRanges`` compilation = + compilation + |> asFs + |> withOptions ["--test:ErrorRanges"] + |> typecheck + |> shouldFail + |> withDiagnostics [ + Error 410, Line 6, Col 12, Line 6, Col 14, "The type 'T' is less accessible than the value, member or type 'val t': T' it is used in." + Error 410, Line 6, Col 9, Line 6, Col 10, "The type 'T' is less accessible than the value, member or type 'val t: T' it is used in." + ] + + [] + let ``Tuple - tuples04_fs - --test:ErrorRanges`` compilation = + compilation + |> asFs + |> withOptions ["--test:ErrorRanges"] + |> typecheck + |> shouldFail + |> withDiagnostics [ + Error 410, Line 6, Col 12, Line 6, Col 14, "The type 'T' is less accessible than the value, member or type 'val internal t': T' it is used in." + Error 410, Line 6, Col 9, Line 6, Col 10, "The type 'T' is less accessible than the value, member or type 'val internal t: T' it is used in." + ] // This test was automatically generated (moved from FSharpQA suite - Conformance/PatternMatching/Tuple) [] diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples02.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples02.fs new file mode 100644 index 00000000000..b7cf08921a7 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples02.fs @@ -0,0 +1,15 @@ +module PM = + type PT = + abstract A : int + let a = { new PT with member __.A = 1 } + let b, c = + { new PT with member __.A = 1 } + , { new PT with member __.A = 1 } + +module private PM2 = + type PT = + abstract A : int + let a = { new PT with member __.A = 1 } + let b, c = + { new PT with member __.A = 1 } + , { new PT with member __.A = 1 } diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples03.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples03.fs new file mode 100644 index 00000000000..402101fbc18 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples03.fs @@ -0,0 +1,6 @@ +namespace N + +type internal T = T + +module public M = + let t, t' = T, T diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples04.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples04.fs new file mode 100644 index 00000000000..d01d6b98592 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Tuple/tuples04.fs @@ -0,0 +1,6 @@ +namespace N + +type private T = T + +module internal M = + let t, t' = T, T From 8111bff65fafaa4dc221a58ff66c466d68cbfdb6 Mon Sep 17 00:00:00 2001 From: Martin <29605222+Martin521@users.noreply.github.com> Date: Tue, 11 Aug 2026 14:14:42 +0200 Subject: [PATCH 08/55] Ignore lines starting with `#:` (RFC-1337) (#20212) --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + docs/release-notes/.Language/11.0.md | 1 + src/Compiler/FSComp.txt | 1 + src/Compiler/lex.fsl | 6 +++++ src/Compiler/xlf/FSComp.txt.cs.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.de.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.es.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.fr.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.it.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.ja.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.ko.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.pl.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.ru.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.tr.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 5 ++++ src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 5 ++++ .../CompilerDirectives/IgnoreColon.fs | 24 +++++++++++++++++++ .../FSharp.Compiler.ComponentTests.fsproj | 1 + 19 files changed, 99 insertions(+) create mode 100644 tests/FSharp.Compiler.ComponentTests/CompilerDirectives/IgnoreColon.fs diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index b6ba1cea739..1058b723552 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -170,6 +170,7 @@ * Lower string-typed interpolated strings to `System.String.Concat` rather than the reflection-based `printf` engine, making them trim- and NativeAOT-compatible. This generalizes and ungates the previous all-string `String.Concat` optimization, so it now applies to every string-typed interpolation. ([Language suggestion #1108](https://github.com/fsharp/fslang-suggestions/issues/1108), [PR #19971](https://github.com/dotnet/fsharp/pull/19971)) * Stabilized several `preview` language features into F# 11.0 (`--langversion:11.0`, enabled by default with a .NET 11 SDK): `MethodOverloadsCache`, `ErrorOnMissingSignatureAttribute`, `DirectDelegateConstruction`, `AccessProtectedBaseFieldFromClosure`, and `RecordSpreads`. `FromEndSlicing` intentionally remains in `preview`. ([PR #20199](https://github.com/dotnet/fsharp/pull/20199)) * Interpolated string holes (e.g. `$"{x}"`) are now formatted with invariant culture (via the `string` operator) instead of the current thread culture. ([PR #19971](https://github.com/dotnet/fsharp/pull/19971)) +* Lines starting with `#:` are now ignored ([Language suggestion 1440](https://github.com/fsharp/fslang-suggestions/issues/1440), [RFC FS-1337](https://github.com/fsharp/fslang-design/pull/830), [PR #20212](https://github.com/dotnet/fsharp/pull/20212)) ### Breaking Changes diff --git a/docs/release-notes/.Language/11.0.md b/docs/release-notes/.Language/11.0.md index 8c7f9ab94d6..07752bcd79f 100644 --- a/docs/release-notes/.Language/11.0.md +++ b/docs/release-notes/.Language/11.0.md @@ -14,6 +14,7 @@ ### Changed +* Lines starting with `#:` are now ignored ([Language suggestion 1440](https://github.com/fsharp/fslang-suggestions/issues/1440), [RFC FS-1337](https://github.com/fsharp/fslang-design/pull/830), [PR #20212](https://github.com/dotnet/fsharp/pull/20212)) * Direct delegate construction ([PR #19993](https://github.com/dotnet/fsharp/pull/19993)) * A delegate built from a method or function now points straight at that method instead of an intermediate closure, so `delegate.Method` is the real target and no closure class is generated. * Two delegates built from the same method and target now compare equal, where the previous closure form produced distinct instances; this also makes `Delegate.Remove` (and `-=` on events) match and remove such a delegate that it previously left in place. diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 04c6b1a7d33..48af3e625f7 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1845,3 +1845,4 @@ featureImprovedImpliedArgumentNamesPartTwo,"Improved implied argument names with featureRecordSpreads,"record type and expression spreads" 3908,xmlDocIncludeError,"XML documentation include error: %s" 3908,xmlDocIncludeError2,"XML documentation include error: Unable to include XML fragment '%s' of file '%s' -- %s" +3909,lexColonDirectiveMustBeFirst,"#: directives must start at the beginning of a line" diff --git a/src/Compiler/lex.fsl b/src/Compiler/lex.fsl index 32d1a39acde..ac73fd06961 100644 --- a/src/Compiler/lex.fsl +++ b/src/Compiler/lex.fsl @@ -754,6 +754,12 @@ rule token (args: LexArgs) (skip: bool) = parse { errorR(Error(FSComp.SR.lexInvalidIdentifier(), lexbuf.LexemeRange)) Keywords.IdentifierToken args lexbuf "" } + | "#:" anystring + { let m = lexbuf.LexemeRange + shouldStartLine args lexbuf m (FSComp.SR.lexColonDirectiveMustBeFirst()) + if not skip then WHITESPACE (LexCont.Token(args.ifdefStack, args.stringNest)) + else endline LexerEndlineContinuation.Token args skip lexbuf } + | ('#' anywhite* | "#line" anywhite+ ) digit+ anywhite* ('@'? "\"" [^'\n''\r''"']+ '"')? anywhite* newline { let pos = lexbuf.EndPos if skip then diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index e007c5655fa..6968bc66100 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -867,6 +867,11 @@ Bajtový řetězec se nedá interpolovat. + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. Rozšířená interpolace řetězců není v této verzi jazyka F# podporována. diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index 002c068e7fb..928dceb4a15 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -867,6 +867,11 @@ Eine Bytezeichenfolge darf nicht interpoliert werden. + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. Die erweiterte Zeichenfolgeninterpolation wird in dieser Version von F# nicht unterstützt. diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 865897420f3..bb71775e90a 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -867,6 +867,11 @@ no se puede interpolar una cadena de bytes + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. No se admite la interpolación de cadenas extendida en esta versión de F#. diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 5bf1a9add86..a25bf43f909 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -867,6 +867,11 @@ une chaîne d'octets ne peut pas être interpolée + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. L'interpolation de chaîne étendue n'est pas prise en charge dans cette version de F#. diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 7099e8b391b..57c10a40a76 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -867,6 +867,11 @@ non è possibile interpolare una stringa di byte + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. L'interpolazione di stringa estesa non è supportata in questa versione di F#. diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index b8e4d9b7503..0ea2e3a57f6 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -867,6 +867,11 @@ バイト文字列は補間されていない可能性があります + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. 拡張文字列補間は、このバージョンの F# ではサポートされていません。 diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 04533426fc5..fdb7398647a 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -867,6 +867,11 @@ 바이트 문자열을 보간하지 못할 수 있습니다. + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. 확장 문자열 보간은 이 버전의 F#에서 지원되지 않습니다. diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index abaf87acfbf..04c219d24ac 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -867,6 +867,11 @@ ciąg bajtowy nie może być interpolowany + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. Rozszerzona interpolacja ciągów nie jest obsługiwana w tej wersji języka F#. diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 963037d4a72..c41341a9fda 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -867,6 +867,11 @@ uma cadeia de caracteres de byte não pode ser interpolada + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. Não há suporte para interpolação de cadeia de caracteres estendida nesta versão do F#. diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index 53ea084423b..b24f781f1cf 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -867,6 +867,11 @@ невозможно выполнить интерполяцию для строки байтов + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. Расширенная интерполяция строк не поддерживается в этой версии F#. diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 4540639f47c..edfc62090d4 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -867,6 +867,11 @@ bir bayt dizesi, düz metin arasına kod eklenerek kullanılamaz + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. Genişletilmiş dize ilişkilendirmesi bu F# sürümünde desteklenmiyor. diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 76969b500eb..06ed554577c 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -867,6 +867,11 @@ 不能内插字节字符串 + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. 此版本的 F# 不支持扩展字符串内插。 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 1c1ffb1b333..076bf17ac73 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -867,6 +867,11 @@ 位元組字串不能是插補字串 + + #: directives must start at the beginning of a line + #: directives must start at the beginning of a line + + Extended string interpolation is not supported in this version of F#. 此 F# 版本不支援擴充字串插補。 diff --git a/tests/FSharp.Compiler.ComponentTests/CompilerDirectives/IgnoreColon.fs b/tests/FSharp.Compiler.ComponentTests/CompilerDirectives/IgnoreColon.fs new file mode 100644 index 00000000000..dbfac03f200 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/CompilerDirectives/IgnoreColon.fs @@ -0,0 +1,24 @@ +namespace CompilerDirectives + +open Xunit +open FSharp.Test.Compiler + +module IgnoreColon = + + let source = """ +module test +#:r test.dll +[] +let main _ = + #:source test.fs + 0 +#:ignore also at eof""" + + [] + let ignoreColonDirective () = + + FSharp source + |> compile + |> withDiagnostics [ + Error 3909, Line 6, Col 5, Line 6, Col 21, "#: directives must start at the beginning of a line" + ] \ No newline at end of file diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 8057ebb1da8..d6f7886d85e 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -33,6 +33,7 @@ + From 4890294f262a6c4ef4cd384e28dca53cb1522716 Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Tue, 11 Aug 2026 15:31:19 +0100 Subject: [PATCH 09/55] feat(Async+Task+ValueTask): consistent helper modules (#19844) --- docs/release-notes/.FSharp.Core/11.0.100.md | 2 + src/FSharp.Core/async.fs | 42 ++ src/FSharp.Core/async.fsi | 130 +++- src/FSharp.Core/tasks.fs | 151 +++++ src/FSharp.Core/tasks.fsi | 285 ++++++++ ...p.Core.SurfaceArea.netstandard20.debug.bsl | 20 +- ...Core.SurfaceArea.netstandard20.release.bsl | 20 +- ...p.Core.SurfaceArea.netstandard21.debug.bsl | 30 +- ...Core.SurfaceArea.netstandard21.release.bsl | 28 +- .../FSharp.Core.UnitTests.fsproj | 2 + .../AsyncModuleFunctions.fs | 262 ++++++++ .../TaskModuleFunctions.fs | 620 ++++++++++++++++++ 12 files changed, 1584 insertions(+), 8 deletions(-) create mode 100644 tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModuleFunctions.fs create mode 100644 tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs diff --git a/docs/release-notes/.FSharp.Core/11.0.100.md b/docs/release-notes/.FSharp.Core/11.0.100.md index 97c667e0eb3..6904710cc82 100644 --- a/docs/release-notes/.FSharp.Core/11.0.100.md +++ b/docs/release-notes/.FSharp.Core/11.0.100.md @@ -8,3 +8,5 @@ ### Added * `Async.RunSynchronouslyImmediate`: runs work on the calling thread until the first asynchronous suspension (as opposed to `RunSynchronously`, which immediately offloads if not on a background and/or threadpool thread). ([Issue #1042](https://github.com/fsharp/fslang-suggestions/issues/1042), [PR #19804](https://github.com/dotnet/fsharp/pull/19804)) +* Added modules for `Async`, `Task` and `ValueTask` with consistent `result`, `map`, `bind`, `ignore`, `catchWith`, `catch`, and `empty` functions ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) +* Added conversion functions `Task.ofValueTask` and `ValueTask.ofTask`. ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) diff --git a/src/FSharp.Core/async.fs b/src/FSharp.Core/async.fs index 02994a3a886..73c004b4260 100644 --- a/src/FSharp.Core/async.fs +++ b/src/FSharp.Core/async.fs @@ -2354,3 +2354,45 @@ module WebExtensions = start = (fun userToken -> this.DownloadFileAsync(address, fileName, userToken)), result = (fun _ -> ()) ) + +[] +module Async = + + [] + let inline result (value: 'T) : Async<'T> = + async.Return value + + [] + let inline map ([] mapping: 'T -> 'U) (computation: Async<'T>) : Async<'U> = + async.Bind(computation, mapping >> async.Return) + + [] + let inline bind ([] binder: 'T -> Async<'U>) (computation: Async<'T>) : Async<'U> = + async.Bind(computation, binder) + + [] + [] + let inline ignore<'T> (computation: Async<'T>) : Async = + Async.Ignore computation + + [] + let catchWith (handler: exn -> 'T) (computation: Async<'T>) : Async<'T> = + async { + try + return! computation + with e -> + return handler e + } + + [] + let catch (computation: Async<'T>) : Async> = + async { + try + let! v = computation + return Result.Ok v + with e -> + return Result.Error e + } + + [] + let empty: Async = async.Zero() diff --git a/src/FSharp.Core/async.fsi b/src/FSharp.Core/async.fsi index a629ab50fc5..1af0fab84db 100644 --- a/src/FSharp.Core/async.fsi +++ b/src/FSharp.Core/async.fsi @@ -1006,7 +1006,7 @@ namespace Microsoft.FSharp.Control /// use file = System.IO.File.OpenRead(filename) /// printfn "Reading from file %s." filename /// // Throw away the data being read. - /// do! file.AsyncRead(numBytes) |> Async.Ignore + /// do! file.AsyncRead(numBytes) |> Async.ignore<byte[]> /// } /// readFile "example.txt" 42 |> Async.Start /// @@ -1584,3 +1584,131 @@ namespace Microsoft.FSharp.Control module internal AsyncBuilderImpl = val async : AsyncBuilder + /// Contains camelCase module-level functions for computations. + /// + /// Async Programming + [] + module Async = + + /// Creates an asynchronous computation that returns the given value. + /// + /// The value to return. + /// + /// An asynchronous computation that returns value when executed. + /// + /// + /// + /// let computation = Async.result 42 + /// computation |> Async.RunSynchronouslyImmediate // evaluates to 42 + /// + /// + [] + val inline result: value: 'T -> Async<'T> + + /// Creates an asynchronous computation that applies the mapping function to the result of the given computation. + /// + /// The function to apply to the result. + /// The input computation. + /// + /// An asynchronous computation that applies mapping to the result of computation. + /// + /// + /// + /// let computation = Async.result 21 |> Async.map (fun x -> x * 2) + /// computation |> Async.RunSynchronouslyImmediate // evaluates to 42 + /// + /// + [] + val inline map: mapping: ('T -> 'U) -> computation: Async<'T> -> Async<'U> + + /// Creates an asynchronous computation that passes the result of the given computation to the binder function. + /// + /// A function that takes the result of the computation and returns a new asynchronous computation. + /// The input computation. + /// + /// An asynchronous computation that performs a monadic bind on the result of computation. + /// + /// + /// + /// let computation = Async.result 21 |> Async.bind (fun x -> Async.result (x * 2)) + /// computation |> Async.RunSynchronouslyImmediate // evaluates to 42 + /// + /// + [] + val inline bind: binder: ('T -> Async<'U>) -> computation: Async<'T> -> Async<'U> + + /// Creates an asynchronous computation that runs the given computation and ignores its result. + /// + /// The input computation. + /// + /// A computation that is equivalent to the input computation, but disregards the result. + /// + /// + /// + /// let readFile filename numBytes: Async<unit> = + /// async { + /// use file = System.IO.File.OpenRead(filename) + /// do! file.AsyncRead(numBytes) |> Async.ignore<byte[]> + /// } + /// + /// + /// + /// + /// let computation : Async<unit> = Async.result 42 |> Async.ignore<int> + /// computation |> Async.RunSynchronously // evaluates to () + /// + /// + [] + [] + val inline ignore<'T> : computation: Async<'T> -> Async + + /// Creates an asynchronous computation that yields the original result on success, or the result of + /// handler exn for non-cancellation exceptions. + /// OperationCanceledException and derived types such as TaskCanceledException propagate unchanged, + /// and therefore are never passed to handler. + /// + /// A function to handle (non-cancellation) exceptions, yielding a recovery value based on the exception. + /// Any exception thrown by handler will propagate. + /// The input computation. + /// An asynchronous computation that yields the result of computation on success, + /// or handler exn on failure. + /// Propagates the underlying cancellation exception where cancellation occurs. + /// + /// + /// let safeDiv x y = + /// async { return x / y } + /// |> Async.catchWith (fun _ -> 0) + /// safeDiv 10 0 |> Async.RunSynchronouslyImmediate // evaluates to 0 + /// + /// + [] + val catchWith: handler: (exn -> 'T) -> computation: Async<'T> -> Async<'T> + + /// Creates an asynchronous computation that reifies the outcome of the given computation as a Result: + /// Ok on success, Error on failure, so exceptions become values. Cancellation still propagates. + /// OperationCanceledException and derived types such as TaskCanceledException propagate unchanged. + /// The input computation. + /// An asynchronous computation that yields a Result: Ok with the outcome on success, + /// or Error with the exception on failure. + /// Propagates the underlying cancellation exception when cancellation occurs. + /// + /// + /// let safeDiv x y = + /// async { return x / y } |> Async.catch + /// safeDiv 10 2 |> Async.RunSynchronouslyImmediate // evaluates to Ok 5 + /// safeDiv 10 0 |> Async.RunSynchronouslyImmediate // evaluates to Error (DivideByZeroException ...) + /// + /// + [] + val catch: computation: Async<'T> -> Async> + + /// An asynchronous computation that returns unit. This is equivalent to async.Zero(). + /// + /// + /// + /// Async.empty |> Async.RunSynchronouslyImmediate // evaluates to () + /// + /// + [] + val empty: Async + diff --git a/src/FSharp.Core/tasks.fs b/src/FSharp.Core/tasks.fs index eec12a86c63..eda1d005c83 100644 --- a/src/FSharp.Core/tasks.fs +++ b/src/FSharp.Core/tasks.fs @@ -716,3 +716,154 @@ module LowPlusPriority = this.Bind(computation, fun (result2: ^TResult2) -> this.Return struct (result1, result2)) ) ) + +namespace Microsoft.FSharp.Control + +open System.Threading.Tasks +open Microsoft.FSharp.Core +open TaskBuilder +open Microsoft.FSharp.Control.TaskBuilderExtensions +open Microsoft.FSharp.Control.TaskBuilderExtensions.LowPriority +open Microsoft.FSharp.Control.TaskBuilderExtensions.HighPriority + +[] +[] +module Task = + + [] + let inline result (value: 'T) : Task<'T> = + Task.FromResult value + + [] + let empty: Task = result () + + [] + let inline bind ([] binder: 'T -> Task<'U>) (task: Task<'T>) : Task<'U> = + if task.Status = TaskStatus.RanToCompletion then + try + binder task.Result + with e -> + Task.FromException<'U>(e) + else + TaskBuilder.task { + let! v = task + return! binder v + } + + [] + let inline map ([] mapping: 'T -> 'U) (task: Task<'T>) : Task<'U> = + if task.Status = TaskStatus.RanToCompletion then + try + mapping task.Result |> result + with e -> + Task.FromException<'U>(e) + else + TaskBuilder.task { + let! v = task + return mapping v + } + + [] + [] + let inline ignore<'T> (task: Task<'T>) : Task = + if task.Status = TaskStatus.RanToCompletion then + empty + else + map ignore task + + [] + let inline catchWith ([] handler: exn -> 'T) (task: Task<'T>) : Task<'T> = + if task.Status = TaskStatus.RanToCompletion then + task + else + TaskBuilder.task { + try + return! task + with + | :? System.OperationCanceledException as e -> return! raise e + | e -> return handler e + } + + [] + let catch (task: Task<'T>) : Task> = + task |> map Ok |> catchWith Error + +#if NETSTANDARD2_1 + [] + let inline ofValueTask (valueTask: ValueTask<'T>) : Task<'T> = + valueTask.AsTask() +#endif + +#if NETSTANDARD2_1 +[] +[] +module ValueTask = + + [] + let inline result (value: 'T) : ValueTask<'T> = + ValueTask<'T>(value) + + [] + let empty: ValueTask = result () + + [] + let inline ofTask (task: Task<'T>) : ValueTask<'T> = + ValueTask<'T>(task) + + [] + let inline bind ([] binder: 'T -> ValueTask<'U>) (task: ValueTask<'T>) : ValueTask<'U> = + if task.IsCompletedSuccessfully then + try + binder task.Result + with e -> + Task.FromException<'U>(e) |> ofTask + else + let t: Task<'U> = + TaskBuilder.task { + let! v = task + return! binder v + } + + ValueTask<'U>(t) + + [] + let inline map ([] mapping: 'T -> 'U) (task: ValueTask<'T>) : ValueTask<'U> = + if task.IsCompletedSuccessfully then + try + mapping task.Result |> result + with e -> + Task.FromException<'U>(e) |> ofTask + else + let t: Task<'U> = + TaskBuilder.task { + let! v = task + return mapping v + } + + ValueTask<'U>(t) + + [] + [] + let inline ignore<'T> (task: ValueTask<'T>) : ValueTask = + map ignore task + + [] + let inline catchWith ([] handler: exn -> 'T) (task: ValueTask<'T>) : ValueTask<'T> = + if task.IsCompletedSuccessfully then + task + else + let t: Task<'T> = + TaskBuilder.task { + try + return! task + with + | :? System.OperationCanceledException as e -> return! raise e + | e -> return handler e + } + + ValueTask<'T>(t) + + [] + let catch (task: ValueTask<'T>) : ValueTask> = + task |> map Ok |> catchWith Error +#endif diff --git a/src/FSharp.Core/tasks.fsi b/src/FSharp.Core/tasks.fsi index 76d84bcfd28..a4e6806d824 100644 --- a/src/FSharp.Core/tasks.fsi +++ b/src/FSharp.Core/tasks.fsi @@ -457,3 +457,288 @@ module HighPriority = /// member inline MergeSources< ^TResult1, ^TResult2> : task1: Task< ^TResult1 > * task2: Task< ^TResult2 > -> Task + +namespace Microsoft.FSharp.Control + +open System.Threading.Tasks +open Microsoft.FSharp.Core + +/// Contains camelCase module-level functions for computations. +/// +/// Async Programming +[] +[] +module Task = + + /// Creates a task that returns the given value. + /// + /// The value to return. + /// + /// A completed task that returns value. + /// + /// + /// + /// let t = Task.result 42 + /// t.Result // evaluates to 42 + /// + /// + [] + val inline result: value: 'T -> Task<'T> + + /// Creates a task that applies the mapping function to the result of the given task. + /// + /// The function to apply to the result. + /// The input task. + /// + /// A task that applies mapping to the result of task. + /// + /// + /// + /// let t = Task.result 21 |> Task.map (fun x -> x * 2) + /// t.Result // evaluates to 42 + /// + /// + [] + val inline map: mapping: ('T -> 'U) -> task: Task<'T> -> Task<'U> + + /// Creates a task that passes the result of the given task to the binder function. + /// + /// A function that takes the result of the task and returns a new task. + /// The input task. + /// + /// A task that performs a monadic bind on the result of task. + /// + /// + /// + /// let t = Task.result 21 |> Task.bind (fun x -> Task.result (x * 2)) + /// t.Result // evaluates to 42 + /// + /// + [] + val inline bind: binder: ('T -> Task<'U>) -> task: Task<'T> -> Task<'U> + + /// Creates a task that runs the given task and ignores its result. + /// + /// The input task. + /// + /// A task that is equivalent to the input task, but disregards the result. + /// + /// + /// + /// let t : Task<unit> = Task.result 42 |> Task.ignore<int> + /// t.Result // evaluates to () + /// + /// + [] + [] + val inline ignore<'T> : task: Task<'T> -> Task + + /// Creates a Task that yields the original result on success, or the result of + /// handler exn for non-cancellation exceptions. + /// OperationCanceledException and derived types such as TaskCanceledException propagate unchanged + /// (and the task remains Canceled) in order to maintain cancellation semantics, and therefore are never passed to handler. + /// + /// A function to handle (non-cancellation) exceptions, yielding a recovery value based on the exception. + /// Any exception thrown by handler will propagate. + /// The input Task. + /// A Task that yields the result of task on success, or handler exn on failure. + /// Propagates the underlying cancellation exception when task is canceled. + /// + /// + /// let safeDiv x y = + /// task { return x / y } + /// |> Task.catchWith (fun _ -> 0) + /// (safeDiv 10 0).Result // evaluates to 0 + /// + /// + [] + val inline catchWith: handler: (exn -> 'T) -> task: Task<'T> -> Task<'T> + + /// Creates a Task that reifies the outcome of the given Task as a Result: + /// Ok on success, Error on failure, so faults become values. Cancellation still propagates. + /// OperationCanceledException and derived types such as TaskCanceledException propagate unchanged + /// (and the task remains Canceled) in order to maintain cancellation semantics. + /// The input Task. + /// A Task that yields a Result: Ok with the outcome on success, + /// or Error with the exception on failure. + /// Propagates the underlying cancellation exception when task is canceled. + /// + /// + /// let safeDiv x y = task { return x / y } |> Task.catch + /// (safeDiv 10 2).Result // evaluates to Ok 5 + /// (safeDiv 10 0).Result // evaluates to Error (DivideByZeroException ...) + /// + /// + [] + val catch: task: Task<'T> -> Task> + + /// A completed task that returns unit. This is a Task<unit> (not the non-generic Task.CompletedTask). + /// + /// + /// + /// Task.empty.Result // evaluates to () + /// + /// + [] + val empty: Task + +#if NETSTANDARD2_1 + /// Converts a to a . + /// + /// The input value task. + /// + /// A task equivalent to the given value task. + /// + /// + /// + /// let vt = ValueTask<int>(42) + /// let t = Task.ofValueTask vt + /// t.Result // evaluates to 42 + /// + /// + [] + val inline ofValueTask: valueTask: ValueTask<'T> -> Task<'T> +#endif + +#if NETSTANDARD2_1 +/// Contains camelCase module-level functions for computations. +/// +/// Async Programming +[] +[] +module ValueTask = + + /// Creates a value task that returns the given value. + /// + /// The value to return. + /// + /// A completed value task that returns value. + /// + /// + /// + /// let vt = ValueTask.result 42 + /// vt.Result // evaluates to 42 + /// + /// + [] + val inline result: value: 'T -> ValueTask<'T> + + /// Creates a value task that applies the mapping function to the result of the given value task. + /// + /// The function to apply to the result. + /// The input value task. + /// + /// A value task that applies mapping to the result of task. + /// + /// + /// + /// let vt = ValueTask.result 21 |> ValueTask.map (fun x -> x * 2) + /// vt.Result // evaluates to 42 + /// + /// + [] + val inline map: mapping: ('T -> 'U) -> task: ValueTask<'T> -> ValueTask<'U> + + /// Creates a value task that passes the result of the given value task to the binder function. + /// + /// A function that takes the result of the value task and returns a new value task. + /// The input value task. + /// + /// A value task that performs a monadic bind on the result of task. + /// + /// + /// + /// let vt = ValueTask.result 21 |> ValueTask.bind (fun x -> ValueTask.result (x * 2)) + /// vt.Result // evaluates to 42 + /// + /// + [] + val inline bind: binder: ('T -> ValueTask<'U>) -> task: ValueTask<'T> -> ValueTask<'U> + + /// Creates a value task that runs the given value task and ignores its result. + /// + /// When the value task is already synchronously complete, this avoids allocating a Task. + /// + /// The input value task. + /// + /// A value task that is equivalent to the input value task, but disregards the result. + /// + /// + /// + /// let vt : ValueTask<unit> = ValueTask.result 42 |> ValueTask.ignore<int> + /// vt.Result // evaluates to () + /// + /// + [] + [] + val inline ignore<'T> : task: ValueTask<'T> -> ValueTask + + /// Creates a ValueTask that yields the original result on success, or the result of + /// handler exn for non-cancellation exceptions. + /// OperationCanceledException and derived types such as TaskCanceledException propagate unchanged + /// (and the task remains Canceled) in order to maintain cancellation semantics, + /// and therefore are never passed to handler. + /// + /// A function to handle (non-cancellation) exceptions, yielding a recovery value based on the exception. + /// Any exception thrown by handler will propagate. + /// The input ValueTask. + /// A ValueTask that yields the result of task on success, + /// or handler exn on failure. + /// Propagates the underlying cancellation exception when task is canceled. + /// + /// + /// + /// let safeDiv x y = + /// task { return x / y } + /// |> ValueTask.ofTask + /// |> ValueTask.catchWith (fun _ -> 0) + /// (safeDiv 10 0).Result // evaluates to 0 + /// + /// + [] + val inline catchWith: handler: (exn -> 'T) -> task: ValueTask<'T> -> ValueTask<'T> + + /// Creates a ValueTask that reifies the outcome of the given ValueTask as a Result: + /// Ok on success, Error on failure, so faults become values. Cancellation still propagates. + /// OperationCanceledException and derived types such as TaskCanceledException propagate unchanged + /// (and the task remains Canceled) in order to maintain cancellation semantics. + /// The input ValueTask. + /// A ValueTask that yields a Result: Ok with the outcome on success, + /// or Error with the exception on failure. + /// Propagates the underlying cancellation exception when task is canceled. + /// + /// + /// let safeDiv x y = task { return x / y } |> ValueTask.ofTask |> ValueTask.catch + /// (safeDiv 10 2).Result // evaluates to Ok 5 + /// (safeDiv 10 0).Result // evaluates to Error (DivideByZeroException ...) + /// + /// + [] + val catch: task: ValueTask<'T> -> ValueTask> + + /// A completed value task that returns unit. + /// + /// + /// + /// ValueTask.empty.Result // evaluates to () + /// + /// + [] + val empty: ValueTask + + /// Converts a to a . + /// + /// The input task. + /// + /// A value task equivalent to the given task. + /// + /// + /// + /// let t = Task.FromResult 42 + /// let vt = ValueTask.ofTask t + /// vt.Result // evaluates to 42 + /// + /// + [] + val inline ofTask: task: Task<'T> -> ValueTask<'T> +#endif diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl index 89fb1bb6146..175102ee368 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl @@ -603,8 +603,8 @@ Microsoft.FSharp.Collections.SetModule: Microsoft.FSharp.Collections.FSharpSet`1 Microsoft.FSharp.Collections.SetModule: Microsoft.FSharp.Collections.FSharpSet`1[T] UnionMany[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Collections.FSharpSet`1[T]]) Microsoft.FSharp.Collections.SetModule: Microsoft.FSharp.Collections.FSharpSet`1[T] Union[T](Microsoft.FSharp.Collections.FSharpSet`1[T], Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: System.Collections.Generic.IEnumerable`1[T] ToSeq[T](Microsoft.FSharp.Collections.FSharpSet`1[T]) -Microsoft.FSharp.Collections.SetModule: System.Tuple`2[Microsoft.FSharp.Collections.FSharpSet`1[T],Microsoft.FSharp.Collections.FSharpSet`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: System.Tuple`2[Microsoft.FSharp.Collections.FSharpSet`1[T1],Microsoft.FSharp.Collections.FSharpSet`1[T2]] PartitionWith[T,T1,T2](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpChoice`2[T1,T2]], Microsoft.FSharp.Collections.FSharpSet`1[T]) +Microsoft.FSharp.Collections.SetModule: System.Tuple`2[Microsoft.FSharp.Collections.FSharpSet`1[T],Microsoft.FSharp.Collections.FSharpSet`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: T MaxElement[T](Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: T MinElement[T](Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: TState FoldBack[T,TState](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpFunc`2[TState,TState]], Microsoft.FSharp.Collections.FSharpSet`1[T], TState) @@ -617,6 +617,14 @@ Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncRet Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncReturn OnSuccess(T) Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncReturn Success(Microsoft.FSharp.Control.AsyncActivation`1[T], T) Microsoft.FSharp.Control.AsyncActivation`1[T]: Void OnExceptionRaised() +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Control.FSharpAsync`1[TResult]], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] Result[T](T) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Bind[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[TResult], Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn CallThenInvoke[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], TResult, Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Invoke[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Control.AsyncActivation`1[T]) @@ -801,6 +809,14 @@ Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.BackgroundT Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.TaskBuilder get_task() Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.TaskBuilder task Microsoft.FSharp.Control.TaskStateMachineData`1[T]: System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1[T] MethodBuilder +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] Ignore[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Threading.Tasks.Task`1[TResult]], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] Result[T](T) Microsoft.FSharp.Control.TaskStateMachineData`1[T]: T Result Microsoft.FSharp.Control.WebExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncDownloadFile(System.Net.WebClient, System.Uri, System.String) Microsoft.FSharp.Control.WebExtensions: Microsoft.FSharp.Control.FSharpAsync`1[System.Byte[]] AsyncDownloadData(System.Net.WebClient, System.Uri) @@ -2668,4 +2684,4 @@ Microsoft.FSharp.Reflection.UnionCaseInfo: System.String Name Microsoft.FSharp.Reflection.UnionCaseInfo: System.String ToString() Microsoft.FSharp.Reflection.UnionCaseInfo: System.String get_Name() Microsoft.FSharp.Reflection.UnionCaseInfo: System.Type DeclaringType -Microsoft.FSharp.Reflection.UnionCaseInfo: System.Type get_DeclaringType() \ No newline at end of file +Microsoft.FSharp.Reflection.UnionCaseInfo: System.Type get_DeclaringType() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl index 6d29205d290..cdf68c2d1ef 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl @@ -603,8 +603,8 @@ Microsoft.FSharp.Collections.SetModule: Microsoft.FSharp.Collections.FSharpSet`1 Microsoft.FSharp.Collections.SetModule: Microsoft.FSharp.Collections.FSharpSet`1[T] UnionMany[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Collections.FSharpSet`1[T]]) Microsoft.FSharp.Collections.SetModule: Microsoft.FSharp.Collections.FSharpSet`1[T] Union[T](Microsoft.FSharp.Collections.FSharpSet`1[T], Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: System.Collections.Generic.IEnumerable`1[T] ToSeq[T](Microsoft.FSharp.Collections.FSharpSet`1[T]) -Microsoft.FSharp.Collections.SetModule: System.Tuple`2[Microsoft.FSharp.Collections.FSharpSet`1[T],Microsoft.FSharp.Collections.FSharpSet`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: System.Tuple`2[Microsoft.FSharp.Collections.FSharpSet`1[T1],Microsoft.FSharp.Collections.FSharpSet`1[T2]] PartitionWith[T,T1,T2](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpChoice`2[T1,T2]], Microsoft.FSharp.Collections.FSharpSet`1[T]) +Microsoft.FSharp.Collections.SetModule: System.Tuple`2[Microsoft.FSharp.Collections.FSharpSet`1[T],Microsoft.FSharp.Collections.FSharpSet`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: T MaxElement[T](Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: T MinElement[T](Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: TState FoldBack[T,TState](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpFunc`2[TState,TState]], Microsoft.FSharp.Collections.FSharpSet`1[T], TState) @@ -617,6 +617,14 @@ Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncRet Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncReturn OnSuccess(T) Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncReturn Success(Microsoft.FSharp.Control.AsyncActivation`1[T], T) Microsoft.FSharp.Control.AsyncActivation`1[T]: Void OnExceptionRaised() +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Control.FSharpAsync`1[TResult]], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] Result[T](T) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Bind[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[TResult], Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn CallThenInvoke[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], TResult, Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Invoke[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Control.AsyncActivation`1[T]) @@ -800,6 +808,14 @@ Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.BackgroundT Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.BackgroundTaskBuilder get_backgroundTask() Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.TaskBuilder get_task() Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.TaskBuilder task +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] Ignore[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Threading.Tasks.Task`1[TResult]], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] Result[T](T) Microsoft.FSharp.Control.TaskStateMachineData`1[T]: System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1[T] MethodBuilder Microsoft.FSharp.Control.TaskStateMachineData`1[T]: T Result Microsoft.FSharp.Control.WebExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncDownloadFile(System.Net.WebClient, System.Uri, System.String) @@ -2667,4 +2683,4 @@ Microsoft.FSharp.Reflection.UnionCaseInfo: System.String Name Microsoft.FSharp.Reflection.UnionCaseInfo: System.String ToString() Microsoft.FSharp.Reflection.UnionCaseInfo: System.String get_Name() Microsoft.FSharp.Reflection.UnionCaseInfo: System.Type DeclaringType -Microsoft.FSharp.Reflection.UnionCaseInfo: System.Type get_DeclaringType() \ No newline at end of file +Microsoft.FSharp.Reflection.UnionCaseInfo: System.Type get_DeclaringType() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl index d8d7ff44b21..cac5fe9d0ef 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl @@ -605,8 +605,8 @@ Microsoft.FSharp.Collections.SetModule: Microsoft.FSharp.Collections.FSharpSet`1 Microsoft.FSharp.Collections.SetModule: Microsoft.FSharp.Collections.FSharpSet`1[T] UnionMany[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Collections.FSharpSet`1[T]]) Microsoft.FSharp.Collections.SetModule: Microsoft.FSharp.Collections.FSharpSet`1[T] Union[T](Microsoft.FSharp.Collections.FSharpSet`1[T], Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: System.Collections.Generic.IEnumerable`1[T] ToSeq[T](Microsoft.FSharp.Collections.FSharpSet`1[T]) -Microsoft.FSharp.Collections.SetModule: System.Tuple`2[Microsoft.FSharp.Collections.FSharpSet`1[T],Microsoft.FSharp.Collections.FSharpSet`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: System.Tuple`2[Microsoft.FSharp.Collections.FSharpSet`1[T1],Microsoft.FSharp.Collections.FSharpSet`1[T2]] PartitionWith[T,T1,T2](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpChoice`2[T1,T2]], Microsoft.FSharp.Collections.FSharpSet`1[T]) +Microsoft.FSharp.Collections.SetModule: System.Tuple`2[Microsoft.FSharp.Collections.FSharpSet`1[T],Microsoft.FSharp.Collections.FSharpSet`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: T MaxElement[T](Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: T MinElement[T](Microsoft.FSharp.Collections.FSharpSet`1[T]) Microsoft.FSharp.Collections.SetModule: TState FoldBack[T,TState](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpFunc`2[TState,TState]], Microsoft.FSharp.Collections.FSharpSet`1[T], TState) @@ -619,6 +619,14 @@ Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncRet Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncReturn OnSuccess(T) Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncReturn Success(Microsoft.FSharp.Control.AsyncActivation`1[T], T) Microsoft.FSharp.Control.AsyncActivation`1[T]: Void OnExceptionRaised() +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Control.FSharpAsync`1[TResult]], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] Result[T](T) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Bind[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[TResult], Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn CallThenInvoke[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], TResult, Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Invoke[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Control.AsyncActivation`1[T]) @@ -673,8 +681,8 @@ Microsoft.FSharp.Control.FSharpAsync: System.Threading.CancellationToken get_Def Microsoft.FSharp.Control.FSharpAsync: System.Threading.Tasks.Task`1[T] StartAsTask[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.Tasks.TaskCreationOptions], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: System.Threading.Tasks.Task`1[T] StartImmediateAsTask[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: System.Tuple`3[Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`3[TArg,System.AsyncCallback,System.Object],System.IAsyncResult],Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T],Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,Microsoft.FSharp.Core.Unit]] AsBeginEnd[TArg,T](Microsoft.FSharp.Core.FSharpFunc`2[TArg,Microsoft.FSharp.Control.FSharpAsync`1[T]]) -Microsoft.FSharp.Control.FSharpAsync: T RunSynchronously[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: T RunSynchronouslyImmediate[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) +Microsoft.FSharp.Control.FSharpAsync: T RunSynchronously[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: Void CancelDefaultToken() Microsoft.FSharp.Control.FSharpAsync: Void Start(Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: Void StartImmediate(Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) @@ -803,8 +811,26 @@ Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.BackgroundT Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.BackgroundTaskBuilder get_backgroundTask() Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.TaskBuilder get_task() Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.TaskBuilder task +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] Ignore[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Threading.Tasks.Task`1[TResult]], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] OfValueTask[T](System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] Result[T](T) Microsoft.FSharp.Control.TaskStateMachineData`1[T]: System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1[T] MethodBuilder Microsoft.FSharp.Control.TaskStateMachineData`1[T]: T Result +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[Microsoft.FSharp.Core.Unit] Ignore[T](System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Threading.Tasks.ValueTask`1[TResult]], System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[T] OfTask[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[T] Result[T](T) Microsoft.FSharp.Control.WebExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncDownloadFile(System.Net.WebClient, System.Uri, System.String) Microsoft.FSharp.Control.WebExtensions: Microsoft.FSharp.Control.FSharpAsync`1[System.Byte[]] AsyncDownloadData(System.Net.WebClient, System.Uri) Microsoft.FSharp.Control.WebExtensions: Microsoft.FSharp.Control.FSharpAsync`1[System.Net.WebResponse] AsyncGetResponse(System.Net.WebRequest) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl index db9f41d97a8..537095d9e10 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl @@ -619,6 +619,14 @@ Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncRet Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncReturn OnSuccess(T) Microsoft.FSharp.Control.AsyncActivation`1[T]: Microsoft.FSharp.Control.AsyncReturn Success(Microsoft.FSharp.Control.AsyncActivation`1[T], T) Microsoft.FSharp.Control.AsyncActivation`1[T]: Void OnExceptionRaised() +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Control.FSharpAsync`1[TResult]], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] Result[T](T) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Bind[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[TResult], Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn CallThenInvoke[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], TResult, Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Invoke[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Control.AsyncActivation`1[T]) @@ -673,8 +681,8 @@ Microsoft.FSharp.Control.FSharpAsync: System.Threading.CancellationToken get_Def Microsoft.FSharp.Control.FSharpAsync: System.Threading.Tasks.Task`1[T] StartAsTask[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.Tasks.TaskCreationOptions], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: System.Threading.Tasks.Task`1[T] StartImmediateAsTask[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: System.Tuple`3[Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`3[TArg,System.AsyncCallback,System.Object],System.IAsyncResult],Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T],Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,Microsoft.FSharp.Core.Unit]] AsBeginEnd[TArg,T](Microsoft.FSharp.Core.FSharpFunc`2[TArg,Microsoft.FSharp.Control.FSharpAsync`1[T]]) -Microsoft.FSharp.Control.FSharpAsync: T RunSynchronously[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: T RunSynchronouslyImmediate[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) +Microsoft.FSharp.Control.FSharpAsync: T RunSynchronously[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: Void CancelDefaultToken() Microsoft.FSharp.Control.FSharpAsync: Void Start(Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) Microsoft.FSharp.Control.FSharpAsync: Void StartImmediate(Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit], Microsoft.FSharp.Core.FSharpOption`1[System.Threading.CancellationToken]) @@ -803,8 +811,26 @@ Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.BackgroundT Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.BackgroundTaskBuilder get_backgroundTask() Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.TaskBuilder get_task() Microsoft.FSharp.Control.TaskBuilderModule: Microsoft.FSharp.Control.TaskBuilder task +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] Ignore[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Threading.Tasks.Task`1[TResult]], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] OfValueTask[T](System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.TaskModule: System.Threading.Tasks.Task`1[T] Result[T](T) Microsoft.FSharp.Control.TaskStateMachineData`1[T]: System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1[T] MethodBuilder Microsoft.FSharp.Control.TaskStateMachineData`1[T]: T Result +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[Microsoft.FSharp.Core.Unit] Empty +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[Microsoft.FSharp.Core.Unit] Ignore[T](System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[Microsoft.FSharp.Core.Unit] get_Empty() +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Threading.Tasks.ValueTask`1[TResult]], System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], System.Threading.Tasks.ValueTask`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[T] OfTask[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.ValueTaskModule: System.Threading.Tasks.ValueTask`1[T] Result[T](T) Microsoft.FSharp.Control.WebExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncDownloadFile(System.Net.WebClient, System.Uri, System.String) Microsoft.FSharp.Control.WebExtensions: Microsoft.FSharp.Control.FSharpAsync`1[System.Byte[]] AsyncDownloadData(System.Net.WebClient, System.Uri) Microsoft.FSharp.Control.WebExtensions: Microsoft.FSharp.Control.FSharpAsync`1[System.Net.WebResponse] AsyncGetResponse(System.Net.WebRequest) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj b/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj index 1694e8eb4ca..faf41f04322 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj @@ -83,6 +83,8 @@ + + diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModuleFunctions.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModuleFunctions.fs new file mode 100644 index 00000000000..3335e6910ac --- /dev/null +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModuleFunctions.fs @@ -0,0 +1,262 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +// Tests for camelCase functions in module Async +module FSharp.Core.UnitTests.Controa.AsyncModuleFunctionsTestsl + +open System +open System.Threading +open System.Threading.Tasks +open Xunit + +#if NETFRAMEWORK // Polyfill for netstandard2.0 +let cancelWithToken (tcs: TaskCompletionSource<'T>) = + tcs.SetCanceled() // No CT overload available + CancellationToken.None // so exception won't reference one +#else +let cancelWithToken (tcs: TaskCompletionSource<'T>) = + let ct = CancellationToken true + tcs.SetCanceled ct + ct +#endif + +let asyncWait (a: Async<'T>): 'T = Async.RunSynchronouslyImmediate a +let asyncWaitWithCt (ct: CancellationToken) (a: Async<'T>): 'T = Async.RunSynchronously(a, cancellationToken = ct) + +[] +let ``Async.result wraps value`` () = + let actual = Async.result 42 |> asyncWait + Assert.Equal(42, actual) + + +[] +let ``Async.map transforms value`` () = + let actual = Async.result 21 |> Async.map (fun x -> x * 2) |> asyncWait + Assert.Equal(42, actual) + +[] +let ``Async.map propagates incoming exception`` () = + let a = async { return failwith "boom" : int } |> Async.map (fun x -> x * 2) + let e = Assert.Throws(fun () -> a |> asyncWait |> ignore) + Assert.Equal("boom", e.Message) + +[] +let ``Async.map propagates mapper exception as Fault`` () = + let a = Async.result () |> Async.map (fun () -> failwith "boom") + let e = Assert.Throws(fun () -> a |> asyncWait |> ignore) + Assert.Equal("boom", e.Message) + +[] +let ``Async.map propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let a = Async.result 2 |> Async.map (fun x -> x * 2) + let e = Assert.Throws(fun () -> a |> asyncWaitWithCt ct |> ignore) + Assert.Equal(ct, e.CancellationToken) + +[] +let ``Async.map propagates Cancellation (async)`` () = + let mutable mapperWasCalled = false + let cts = new CancellationTokenSource() + let a = + async { do! Async.Sleep 5000 } + |> Async.map (fun () -> async { mapperWasCalled <- true }) + let t = Async.StartAsTask(a, cancellationToken = cts.Token) + cts.Cancel() + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.NotEqual(cts.Token, e.CancellationToken) + Assert.False mapperWasCalled + + +[] +let ``Async.bind threads value`` () = + let actual = + Async.result 21 + |> Async.bind (fun x -> Async.result (x * 2)) + |> asyncWait + Assert.Equal(42, actual) + +[] +let ``Async.bind propagates incoming exception (sync)`` () = + let a = async { return failwith "boom" } |> Async.bind Async.result + let e = Assert.Throws(fun () -> a |> asyncWait |> ignore) + Assert.Equal("boom", e.Message) + +[] +let ``Async.bind propagates binder exception as Fault (async)`` () = + let a = Async.result 5 |> Async.bind (fun x -> async { failwith $"boom {x}"}) + let e = Assert.Throws(fun () -> asyncWait a) + Assert.Equal("boom 5", e.Message) + +[] +let ``Async.bind propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let a = Async.result 2 |> Async.bind Async.result + let e = Assert.Throws(fun () -> a |> asyncWaitWithCt ct |> ignore) + Assert.Equal(ct, e.CancellationToken) + +[] +let ``Async.bind propagates Cancellation (async)`` () = + let cts = new CancellationTokenSource() + let mutable binderWasCalled = false + let a = + async { do! Async.Sleep 5000 } + |> Async.bind (fun () -> async { binderWasCalled <- true }) + let t = Async.StartAsTask(a, cancellationToken = cts.Token) + cts.Cancel() + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.NotEqual(cts.Token, e.CancellationToken) + Assert.False binderWasCalled + + +[] +let ``Async.ignore discards result (sync)`` () = + let actual = Async.result 42 |> Async.ignore |> asyncWait + Assert.Equal((), actual) + +[] +let ``Async.ignore discards result (async)`` () = + let tcs = TaskCompletionSource() + let t = async { return! tcs.Task |> Async.AwaitTask } |> Async.ignore |> Async.StartAsTask + tcs.SetResult 42 + Assert.Equal((), t.Result) + +[] +let ``Async.ignore propagates incoming exception (sync)`` () = + let a = async { return failwith "boom" : int } |> Async.ignore + let e = Assert.Throws(fun () -> a |> asyncWait) + Assert.Equal("boom", e.Message) + +[] +let ``Async.ignore propagates incoming exception (async)`` () = + let tcs = TaskCompletionSource() + let t = async { return! tcs.Task |> Async.AwaitTask } |> Async.ignore |> Async.StartAsTask + tcs.SetException(Exception "boom") + let e = Assert.ThrowsAsync(fun () -> t).Result.InnerException + Assert.Equal("boom", e.Message) + +[] +let ``Async.ignore propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let a = Async.result 2 |> Async.ignore + let e = Assert.Throws(fun () -> a |> asyncWaitWithCt ct) + Assert.Equal(ct, e.CancellationToken) + +[] +let ``Async.ignore propagates Cancellation (async)`` () = + let mutable cancellationFailed = false + let cts = new CancellationTokenSource() + let a = + async { do! Async.Sleep 5000 + cancellationFailed <- true + return 42 } + |> Async.ignore + let t = Async.StartAsTask(a, cancellationToken = cts.Token) + cts.Cancel() + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.NotEqual(cts.Token, e.CancellationToken) + Assert.False cancellationFailed + + +[] +let ``Async.catchWith passes through success (sync)`` () = + let source = Async.result 42 + let a = source |> Async.catchWith (fun _ -> -1) + Assert.Equal(42, asyncWait a) + +[] +let ``Async.catchWith passes through success (async)`` () = async { + let tcs = TaskCompletionSource() + let! a = async { return! tcs.Task |> Async.AwaitTask } |> Async.catchWith (fun _ -> -1) |> Async.StartChild + tcs.SetResult 42 + let! res = a + Assert.Equal(42, res) } + +[] +let ``Async.catchWith recovers from exception (sync)`` () = async { + let! actual = + async { return failwith "boom" : int } + |> Async.catchWith (fun e -> Assert.Equal("boom", e.Message); -1) + Assert.Equal(-1, actual) } + +[] +let ``Async.catchWith recovers from exception (async)`` () = async { + let tcs = TaskCompletionSource() + let! a = async { return! tcs.Task |> Async.AwaitTask } |> Async.catchWith (fun _ -> -1) |> Async.StartChild + tcs.SetException(Exception "boom") + let! result = a + Assert.Equal(-1, result) } + +[] +let ``Async.catchWith propagates Cancellation (sync)`` () = + let mutable cancellationFailed = false + let ct = CancellationToken true + let a = async { do! Async.Sleep 5000 + cancellationFailed <- true + return 42 } + |> Async.catchWith (fun _ -> -1) + let e = Assert.Throws(fun () -> a |> asyncWaitWithCt ct |> ignore) + Assert.Equal(ct, e.CancellationToken) + Assert.False cancellationFailed + +[] +let ``Async.catchWith propagates Cancellation (async)`` () = + let mutable cancellationFailed = false + let cts = new CancellationTokenSource() + let a = + async { do! Async.Sleep 5000 + cancellationFailed <- true + return 42 } + |> Async.catchWith (fun _ -> -1) + let t = Async.StartAsTask(a, cancellationToken = cts.Token) + cts.Cancel() + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.NotEqual(cts.Token, e.CancellationToken) + + +[] +let ``Async.catch returns Ok on success (sync)`` () = + let actual = Async.result 42 |> Async.catch |> asyncWait + Assert.Equal(Ok 42, actual) + +[] +let ``Async.catch returns Ok on success (async)`` () : unit = + let tcs = TaskCompletionSource() + let t = async { return! tcs.Task |> Async.AwaitTask } |> Async.catch |> Async.StartAsTask + tcs.SetResult 42 + Assert.Equal(Ok 42, t.Result) + +[] +let ``Async.catch returns Error on exception`` () = + let a = async { return failwith "boom" : int } |> Async.catch + match a |> asyncWait with + | Error ex -> Assert.Equal("boom", ex.Message) + | Ok _ -> failwith "unexpected success" + +[] +let ``Async.catch returns Error on exception (async)`` () : unit = + let a = async { do! Async.Sleep 1 + return failwith "boom" } |> Async.catch + match a |> asyncWait with + | Error ex -> Assert.Equal("boom", ex.Message) + | Ok _ -> failwith "unexpected success" + +[] +let ``Async.catch propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let a = async { do! Async.Sleep 5000 } |> Async.catch + let e = Assert.Throws(fun () -> a |> asyncWaitWithCt ct |> ignore) + Assert.Equal(ct, e.CancellationToken) + +[] +let ``Async.catch propagates Cancellation (async)`` () = + let cts = new CancellationTokenSource() + let a = async { do! Async.Sleep 5000 } |> Async.catch + let t = Async.StartAsTask(a, cancellationToken = cts.Token) + cts.Cancel() + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.NotEqual(cts.Token, e.CancellationToken) + + +[] +let ``Async.empty returns unit`` () = + let actual = Async.empty |> asyncWait + Assert.Equal((), actual) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs new file mode 100644 index 00000000000..b3b40724a81 --- /dev/null +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs @@ -0,0 +1,620 @@ + +// Tests for camelCase functions in module Task and module ValueTask + +namespace FSharp.Core.UnitTests.Control + +open System +open System.Threading +open System.Threading.Tasks +open Xunit + +module TaskModuleFunctionsTests = + +#if NETFRAMEWORK // Polyfill for netstandard2.0 + type Task<'T> with member x.IsCompletedSuccessfully = x.Status = TaskStatus.RanToCompletion + let cancelWithToken (tcs: TaskCompletionSource<'T>) = + tcs.SetCanceled() // No CT overload available + CancellationToken.None // so exception won't reference one +#else + let cancelWithToken (tcs: TaskCompletionSource<'T>) = + let ct = CancellationToken true + tcs.SetCanceled ct + ct +#endif + + [] + let ``Task.result wraps value`` () = + let t = Task.result 42 + Assert.Equal(42, t.Result) + + + [] + let ``Task.map transforms value (sync)`` () = + let t = Task.result 21 |> Task.map (fun x -> x * 2) + Assert.True t.IsCompleted + Assert.Equal(42, t.Result) + + [] + let ``Task.map transforms value (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.map (fun x -> x * 2) + Assert.False t.IsCompleted + tcs.SetResult 21 + Assert.Equal(42, t.Result) + + [] + let ``Task.map propagates incoming exception (sync)`` () = + let t = Task.FromException(Exception "boom") |> Task.map (fun x -> x * 2) + let! e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.map propagates incoming exception (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.map (fun x -> x * 2) + tcs.SetException(Exception "boom") + let! e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.map propagates mapper exception as Fault (sync)`` () = + let t = Task.result () |> Task.map (fun () -> failwith "boom") + let! e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.map propagates mapper exception as Fault (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.map (fun () -> failwith "boom") + tcs.SetResult () + let! e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.map propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> Task.map (fun x -> x * 2) + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``Task.map propagates Cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.map (fun x -> x * 2) + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + + [] + let ``Task.bind threads value (sync)`` () = + let t = Task.result 21 |> Task.bind (fun x -> Task.result (x * 2)) + Assert.True t.IsCompleted + Assert.Equal(42, t.Result) + + [] + let ``Task.bind threads value (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.bind (fun x -> Task.result (x * 2)) + Assert.False t.IsCompleted + tcs.SetResult 21 + Assert.Equal(42, t.Result) + + [] + let ``Task.bind propagates incoming exception (sync)`` () = + let t = Task.FromException(Exception "boom") |> Task.bind (fun x -> Task.result (x * 2)) + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.bind propagates incoming exception (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.bind (fun x -> Task.result (x * 2)) + tcs.SetException(Exception "boom") + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.bind propagates binder exception as Fault (sync)`` () = + let t = Task.result () |> Task.bind (fun () -> failwith "boom") + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.bind propagates binder exception as Fault (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.bind (fun () -> failwith "boom") + tcs.SetResult () + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.bind propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> Task.bind (fun x -> Task.result (x * 2)) + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``Task.bind propagates Cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.bind (fun x -> Task.result (x * 2)) + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + + [] + let ``Task.ignore discards result (sync)`` () : unit = + let t = Task.result 42 |> Task.ignore + Assert.True t.IsCompletedSuccessfully + t.Result : unit + + [] + let ``Task.ignore discards result (async)`` () : unit = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.ignore + Assert.False t.IsCompleted + tcs.SetResult 42 + Assert.True t.IsCompletedSuccessfully + t.Result : unit + + [] + let ``Task.ignore propagates incoming exception (sync)`` () = + let t = Task.FromException(Exception "boom") |> Task.ignore + Assert.True t.IsCompleted + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.ignore propagates incoming exception (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.ignore + Assert.False t.IsCompleted + tcs.SetException(Exception "boom") + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + + [] + let ``Task.ignore propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> Task.ignore + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``Task.ignore propagates Cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.ignore + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + + [] + let ``Task.catchWith recovers from exception (sync)`` () = + let source = Task.FromException(Exception "boom") + let t = source |> Task.catchWith (fun _ -> -1) + Assert.Equal(-1, t.Result) + + [] + let ``Task.catchWith recovers from exception (async)`` () : Task = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.catchWith (fun _ -> -1) + tcs.SetException(Exception "boom") + task { + let! result = t + Assert.Equal(-1, result) + } + + [] + let ``Task.catchWith passes through success (sync)`` () = + let source = Task.result 42 + let t = source |> Task.catchWith (fun _ -> -1) + Assert.Equal(42, t.Result) + + [] + let ``Task.catchWith passes through success (async)`` () : Task = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.catchWith (fun _ -> -1) + Assert.False t.IsCompleted + tcs.SetResult 42 + task { + let! result = t + Assert.Equal(42, result) + } + + [] + let ``Task.catchWith propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> Task.catchWith (fun _ -> -1) + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``Task.catchWith propagates Cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.catchWith (fun _ -> -1) + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + + [] + let ``Task.catch returns Ok on success (sync)`` () : unit= + let t = Task.result 42 |> Task.catch + Assert.Equal(Ok 42, t.Result) + + [] + let ``Task.catch returns Ok on success (async)`` () : unit = + let tcs = TaskCompletionSource() + let t = Task.catch tcs.Task + tcs.SetResult 42 + Assert.Equal(Ok 42, t.Result) + + [] + let ``Task.catch returns Error on exception (sync)`` () = + let t = Task.FromException(Exception "boom") |> Task.catch + match t.Result with + | Error ex -> Assert.Equal("boom", ex.Message) + | Ok _ -> failwith "unexpected success" + + [] + let ``Task.catch returns Error on exception (async)`` () : unit = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.catch + tcs.SetException(Exception "boom") + match t.Result with + | Error ex -> Assert.Equal("boom", ex.Message) + | Ok _ -> failwith "unexpected success" + + [] + let ``Task.catch propagates cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> Task.catch + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``Task.catch propagates cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> Task.catch + let ct = CancellationToken true + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + + [] + let ``Task.empty returns completed unit task`` () = + let t = Task.empty + Assert.True t.IsCompletedSuccessfully + Assert.Equal((), t.Result) + + +#if NETSTANDARD2_1 + [] + let ``Task.ofValueTask converts ValueTask`` () = + let vt = ValueTask(42) + let t = Task.ofValueTask vt + Assert.Equal(42, t.Result) + + let ``Task.ofValueTask converts faulted ValueTask`` () = + let vt = ValueTask(Task.FromException(Exception "boom")) + let t = Task.ofValueTask vt + let e = Assert.ThrowsAsync(fun () -> t).Result + Assert.Equal("boom", e.Message) + +module ValueTaskModuleFunctionsTests = + + let cancelWithToken (tcs: TaskCompletionSource<'T>) = + let ct = CancellationToken true + tcs.SetCanceled ct + ct + + [] + let ``ValueTask.result wraps value`` () = + let vt = ValueTask.result 42 + Assert.Equal(42, vt.Result) + + [] + let ``ValueTask.map transforms value (sync)`` () = + let t = ValueTask.result 21 |> ValueTask.map (fun x -> x * 2) + Assert.True t.IsCompleted + Assert.Equal(42, t.Result) + + [] + let ``ValueTask.map transforms value (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.map (fun x -> x * 2) + Assert.False t.IsCompleted + tcs.SetResult 21 + Assert.Equal(42, t.Result) + + [] + let ``ValueTask.map propagates incoming exception (sync)`` () = + let t = ValueTask.FromException(Exception "boom") |> ValueTask.map (fun x -> x * 2) + task { + let! e = Assert.ThrowsAnyAsync(fun () -> t.AsTask()) + Assert.Equal("boom", e.Message) + } + + [] + let ``ValueTask.map propagates incoming exception (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.map (fun x -> x * 2) + tcs.SetException(Exception "boom") + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal("boom", e.Message) + + [] + let ``ValueTask.map propagates mapper exception as Fault (sync)`` () = + let t = ValueTask.result () |> ValueTask.map (fun () -> failwith "boom") + task { + let! e = Assert.ThrowsAnyAsync(fun () -> t.AsTask()) + Assert.Equal("boom", e.Message) + } + + [] + let ``ValueTask.map propagates mapper exception as Fault (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.map (fun () -> failwith "boom") + tcs.SetResult () + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal("boom", e.Message) + + [] + let ``ValueTask.map propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> ValueTask.ofTask |> ValueTask.map (fun x -> x * 2) + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``ValueTask.map propagates Cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.map (fun x -> x * 2) + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + + [] + let ``ValueTask.bind threads value (sync)`` () = + let t = ValueTask.result 21 |> ValueTask.bind (fun x -> ValueTask.result (x * 2)) + Assert.True t.IsCompleted + Assert.Equal(42, t.Result) + + [] + let ``ValueTask.bind threads value (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.bind (fun x -> ValueTask.result (x * 2)) + Assert.False t.IsCompleted + tcs.SetResult 21 + Assert.Equal(42, t.Result) + + [] + let ``ValueTask.bind propagates incoming exception (sync)`` () = + let t = Task.FromException(Exception "boom") |> ValueTask.ofTask |> ValueTask.bind (fun x -> ValueTask.result (x * 2)) + task { + let! e = Assert.ThrowsAnyAsync(fun () -> t.AsTask()) + Assert.Equal("boom", e.Message) + } + + [] + let ``ValueTask.bind propagates incoming exception (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.bind (fun x -> ValueTask.result (x * 2)) + tcs.SetException(Exception "boom") + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal("boom", e.Message) + + [] + let ``ValueTask.bind propagates binder exception as Fault (sync)`` () = + let t = ValueTask.result () |> ValueTask.bind (fun () -> failwith "boom") + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal("boom", e.Message) + + [] + let ``ValueTask.bind propagates binder exception as Fault (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.bind (fun () -> failwith "boom") + tcs.SetResult () + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal("boom", e.Message) + + [] + let ``ValueTask.bind propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> ValueTask.ofTask |> ValueTask.bind (fun x -> ValueTask.result (x * 2)) + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``ValueTask.bind propagates Cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.bind (fun x -> ValueTask.result (x * 2)) + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + + [] + let ``ValueTask.ignore discards result (sync)`` () : unit = + let t = ValueTask.result 42 |> ValueTask.ignore + Assert.True t.IsCompletedSuccessfully + t.Result : unit + + [] + let ``ValueTask.ignore discards result (async)`` () : unit = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.ignore + Assert.False t.IsCompleted + tcs.SetResult 42 + Assert.True t.IsCompletedSuccessfully + t.Result : unit + + [] + let ``ValueTask.ignore propagates incoming exception (sync)`` () = + let t = Task.FromException(Exception "boom") |> ValueTask.ofTask |> ValueTask.ignore + Assert.True t.IsCompleted + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal("boom", e.Message) + + [] + let ``ValueTask.ignore propagates incoming exception (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.ignore + Assert.False t.IsCompleted + tcs.SetException(Exception "boom") + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal("boom", e.Message) + + [] + let ``ValueTask.ignore propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> ValueTask.ofTask |> ValueTask.ignore + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``ValueTask.ignore propagates Cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.ignore + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + + [] + let ``ValueTask.catchWith recovers from exception (sync)`` () = + let source = Task.FromException(Exception "boom") + let t = source |> ValueTask.ofTask |> ValueTask.catchWith (fun _ -> -1) + Assert.Equal(-1, t.Result) + + [] + let ``ValueTask.catchWith recovers from exception (async)`` () : Task = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.catchWith (fun _ -> -1) + tcs.SetException(Exception "boom") + task { + let! result = t + Assert.Equal(-1, result) + } + + [] + let ``ValueTask.catchWith passes through success (sync)`` () = + let source = ValueTask.result 42 + let t = source |> ValueTask.catchWith (fun _ -> -1) + Assert.Equal(42, t.Result) + + [] + let ``ValueTask.catchWith passes through success (async)`` () : Task = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.catchWith (fun _ -> -1) + Assert.False t.IsCompleted + tcs.SetResult 42 + task { + let! result = t + Assert.Equal(42, result) + } + + [] + let ``ValueTask.catchWith propagates Cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> ValueTask.ofTask |> ValueTask.catchWith (fun _ -> -1) + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``ValueTask.catchWith propagates Cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.catchWith (fun _ -> -1) + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``ValueTask.catch returns Ok on success (sync)`` () : unit= + let t = ValueTask.result 42 |> ValueTask.catch + Assert.Equal(Ok 42, t.Result) + + [] + let ``ValueTask.catch returns Ok on success (async)`` () : unit = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.catch + tcs.SetResult 42 + Assert.Equal(Ok 42, t.Result) + + [] + let ``ValueTask.catch returns Error on exception (sync)`` () = + let t = ValueTask.FromException(Exception "boom") |> ValueTask.catch + match t.Result with + | Error ex -> Assert.Equal("boom", ex.Message) + | Ok _ -> failwith "unexpected success" + + [] + let ``ValueTask.catch returns Error on exception (async)`` () : unit = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.catch + tcs.SetException(Exception "boom") + match t.Result with + | Error ex -> Assert.Equal("boom", ex.Message) + | Ok _ -> failwith "unexpected success" + + [] + let ``ValueTask.catch propagates cancellation (sync)`` () = + let ct = CancellationToken true + let t = Task.FromCanceled(ct) |> ValueTask.ofTask |> ValueTask.catch + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + [] + let ``ValueTask.catch propagates cancellation (async)`` () = + let tcs = TaskCompletionSource() + let t = tcs.Task |> ValueTask.ofTask |> ValueTask.catch + let ct = CancellationToken true + let ct = cancelWithToken tcs + let e = Assert.ThrowsAsync(fun () -> t.AsTask()).Result + Assert.Equal(ct, e.CancellationToken) + Assert.True t.IsCanceled + + + [] + let ``ValueTask.empty returns completed unit value task`` () : unit = + let vt = ValueTask.empty + Assert.True vt.IsCompletedSuccessfully + vt.Result + + [] + let ``ValueTask.ofTask wraps Task`` () = + let t = Task.FromResult 42 + let vt = ValueTask.ofTask t + Assert.Equal(42, vt.Result) + + let ``ValueTask.ofTask converts faulted Task`` () = + let t = Task.FromException(Exception "boom") + let vt = ValueTask.ofTask t + let e = Assert.ThrowsAsync(fun () -> vt.AsTask()).Result + Assert.Equal("boom", e.Message) + +#endif From 51dd37eda8b357da25e731f50684a87887533d76 Mon Sep 17 00:00:00 2001 From: Nat Elkins Date: Tue, 11 Aug 2026 11:28:49 -0700 Subject: [PATCH 10/55] Add hot reload baseline reading and recorded EnC state (#20026) * Add Roslyn-format EnC CustomDebugInformation codec and portable PDB method CDI emission Adds an internal AbstractIL module implementing, byte for byte, the three Portable PDB CustomDebugInformation blob formats Roslyn persists per method for Edit and Continue (EnC Local Slot Map, EnC Lambda and Closure Map, EnC State Machine State Map), with serializers, deserializers, a portable PDB read-back helper, and an occurrence-key packing helper for deterministic syntax-offset slots. Plumbs an optional methodCustomDebugInfoRows side channel through the IL binary writer options into the portable PDB generator so a compilation can attach CDI rows to named methods. Names that do not identify exactly one method row are dropped. All existing writer call sites pass an empty map, so emitted PDBs are byte-identical to before. No in-tree caller populates the map yet; the consumer is the F# hot reload work in dotnet/fsharp#19941, following the same pattern as #20017 (land isolated, test-covered infrastructure first, wire the feature later). Tests: blob round-trips, Roslyn golden-byte encodings, cross-validation against CDI blobs emitted by a real Roslyn compilation, fail-closed occurrence-key packing (including an int32-overflow regression where a wrapped negative key previously escaped the bound check), and end-to-end synthetic PDB emission proving correct MethodDef parenting, zero rows for an empty map, and no rows for absent or ambiguous names. --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + .../AbstractIL/EncMethodDebugInformation.fs | 169 ++- .../AbstractIL/EncMethodDebugInformation.fsi | 21 + src/Compiler/AbstractIL/ilwrite.fs | 15 +- src/Compiler/AbstractIL/ilwrite.fsi | 3 + src/Compiler/AbstractIL/ilwritepdb.fs | 25 +- src/Compiler/AbstractIL/ilwritepdb.fsi | 6 + src/Compiler/CodeGen/HotReloadBaseline.fs | 456 ++++++++ src/Compiler/CodeGen/ILBaselineReader.fs | 1015 +++++++++++++++++ src/Compiler/Driver/fsc.fs | 2 + src/Compiler/FSharp.Compiler.Service.fsproj | 6 +- src/Compiler/Interactive/fsi.fs | 1 + .../EncMethodDebugInformationTests.fs | 392 ++++++- .../DeltaMetadata/MetadataDeltaTestHelpers.fs | 1 + 14 files changed, 2078 insertions(+), 35 deletions(-) create mode 100644 src/Compiler/CodeGen/HotReloadBaseline.fs create mode 100644 src/Compiler/CodeGen/ILBaselineReader.fs diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index 1058b723552..8aaeed797c4 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -153,6 +153,7 @@ * Add internal `ResetCompilerGeneratedNameState` to `CompilerGlobalState` name generators so warm-checker re-compilation can produce fresh-process-identical generated names. ([PR #20017](https://github.com/dotnet/fsharp/pull/20017)) * Add internal ECMA-335 Edit-and-Continue metadata delta writer to AbstractIL. ([PR #20019](https://github.com/dotnet/fsharp/pull/20019)) * Add Roslyn-format EnC CustomDebugInformation codec and portable PDB method CDI emission support to AbstractIL. ([PR #20018](https://github.com/dotnet/fsharp/pull/20018)) +* Add internal hot reload baseline reading for recorded EnC state and synthesized-name snapshot PDB data. ([PR #20026](https://github.com/dotnet/fsharp/pull/20026)) * Support for the `` XML documentation tag: at compile time, documentation is copied from an external XML file selected by an XPath query and emitted into the generated documentation file. `` remains unsupported. ([Issue #19175](https://github.com/dotnet/fsharp/issues/19175), [PR #19186](https://github.com/dotnet/fsharp/pull/19186)) * Expand `` at tooling time. In IDE tooltips, completion, and signature help, documentation is inherited from base classes, interfaces, overridden members, and constructors (matched by parameter signature). The FCS Symbols API (`FSharpSymbol.XmlDoc`) additionally resolves explicit `cref` targets, but does not expand constructor inheritance. The compiler emits the tag verbatim into generated XML documentation files, matching C#; `` is not implemented. ([Issue #19175](https://github.com/dotnet/fsharp/issues/19175), [PR #19188](https://github.com/dotnet/fsharp/pull/19188)) diff --git a/src/Compiler/AbstractIL/EncMethodDebugInformation.fs b/src/Compiler/AbstractIL/EncMethodDebugInformation.fs index e605b2208a4..36160e5c981 100644 --- a/src/Compiler/AbstractIL/EncMethodDebugInformation.fs +++ b/src/Compiler/AbstractIL/EncMethodDebugInformation.fs @@ -31,8 +31,11 @@ open System.IO open System.Reflection.Metadata open System.Reflection.Metadata.Ecma335 open System.Runtime.InteropServices +open System.Text open Microsoft.FSharp.NativeInterop +open FSharp.Compiler.AbstractIL.ILPdbWriter + /// Portable-PDB CustomDebugInformation kind GUIDs for the EnC blobs, copied verbatim /// from roslyn/src/Dependencies/CodeAnalysis.Debugging/PortableCustomDebugInfoKinds.cs. [] @@ -47,6 +50,10 @@ module PortableCustomDebugInfoKinds = /// EnC State Machine State Map CDI kind. let encStateMachineStateMap = Guid("8B78CD68-2EDE-420B-980B-E15884B8AAA3") + /// F#-owned hot reload synthesized-name snapshot CDI kind. The blob records + /// FSharpSynthesizedTypeMaps.Snapshot bucket arrays in allocation-slot order. + let fsharpSynthesizedNameSnapshot = Guid("49DDB47E-9C74-46EC-8626-0350676571EB") + /// Closure ordinal of a lambda that is lowered to a static (non-capturing) method. /// Mirrors Roslyn's LambdaDebugInfo.StaticClosureOrdinal. [] @@ -167,7 +174,7 @@ let private MaxOccurrenceKey = 0x1FFFFFFD /// 16-bit segments, least-significant segment = the innermost ordinal; an enclosing /// ordinal p is stored as (p + 1) shifted left 16 so that depth-1 keys (< 0x10000) and /// depth-2 keys (>= 0x10000) never collide. Fails closed (None) past the limits: chains -/// deeper than 2, ordinals > 0xFFFF, or keys exceeding the compressed-integer budget — +/// deeper than 2, ordinals > 0xFFFF, or keys exceeding the compressed-integer budget, /// callers must then treat the chain as unmappable, never truncate. let tryEncodeOccurrenceKey (ordinalChain: int list) : int option = match ordinalChain with @@ -209,6 +216,134 @@ let private invalidData (blobName: string) (offset: int) = // nullness model, so guard with box (FS3261-safe) rather than dropping the check. let private isEmpty (blob: byte[]) = isNull (box blob) || blob.Length = 0 +// --------------------------------------------------------------------------- +// F# hot reload module CDI: synthesized-name allocation snapshot +// Format: +// compressed(version = 1), compressed(bucket count), +// then buckets sorted by key for deterministic PDB bytes: +// string key, compressed(name count), string name in allocation-slot order. +// Strings are compressed(byte length) followed by UTF-8 bytes. +// --------------------------------------------------------------------------- + +[] +let private SynthesizedNameSnapshotBlobVersion = 1 + +let private writeUtf8String (builder: BlobBuilder) (value: string) = + if isNull (box value) then + invalidArg (nameof value) "snapshot strings must be non-null" + + let bytes = Encoding.UTF8.GetBytes value + builder.WriteCompressedInteger bytes.Length + builder.WriteBytes bytes + +let private readUtf8String (blobName: string) (reader: byref) = + let length = reader.ReadCompressedInteger() + + if length < 0 || length > reader.RemainingBytes then + invalidData blobName reader.Offset + + let bytes = reader.ReadBytes length + Encoding.UTF8.GetString(bytes, 0, bytes.Length) + +let private materializeSynthesizedNameSnapshot (snapshot: seq) = + snapshot + |> Seq.map (fun struct (key, names) -> + if isNull (box key) then + invalidArg (nameof snapshot) "snapshot keys must be non-null" + + if isNull (box names) then + invalidArg (nameof snapshot) $"snapshot bucket '{key}' must be non-null" + + key, Array.copy names) + |> Seq.sortBy fst + |> Seq.toArray + +/// Serializes an allocation-ordered synthesized-name snapshot into the F#-owned module +/// CDI blob. An empty snapshot returns an empty blob so no CDI row needs to be emitted. +let serializeSynthesizedNameSnapshot (snapshot: seq) : byte[] = + let buckets = materializeSynthesizedNameSnapshot snapshot + + if buckets.Length = 0 then + Array.empty + else + let builder = BlobBuilder() + builder.WriteCompressedInteger SynthesizedNameSnapshotBlobVersion + builder.WriteCompressedInteger buckets.Length + + for key, names in buckets do + writeUtf8String builder key + builder.WriteCompressedInteger names.Length + + for name in names do + writeUtf8String builder name + + builder.ToArray() + +/// Deserializes the F#-owned synthesized-name snapshot CDI blob. Bucket order in the +/// blob is deterministic only; each bucket array is returned exactly in recorded slot order. +let deserializeSynthesizedNameSnapshot (blob: byte[]) : Map = + if isEmpty blob then + Map.empty + else + let handle = GCHandle.Alloc(blob, GCHandleType.Pinned) + + try + let mutable reader = + BlobReader(NativePtr.ofNativeInt (handle.AddrOfPinnedObject()), blob.Length) + + try + let version = reader.ReadCompressedInteger() + + if version <> SynthesizedNameSnapshotBlobVersion then + invalidData "synthesized name snapshot" reader.Offset + + let bucketCount = reader.ReadCompressedInteger() + + if bucketCount <= 0 || bucketCount > reader.RemainingBytes / 2 then + invalidData "synthesized name snapshot" reader.Offset + + let buckets = ResizeArray() + + for _ in 1..bucketCount do + let key = readUtf8String "synthesized name snapshot" &reader + let nameCount = reader.ReadCompressedInteger() + + // Every serialized name consumes at least one byte for its UTF-8 + // length, so this check bounds allocation before Array.zeroCreate. + if nameCount < 0 || nameCount > reader.RemainingBytes then + invalidData "synthesized name snapshot" reader.Offset + + let names = Array.zeroCreate nameCount + + for i in 0 .. nameCount - 1 do + names[i] <- readUtf8String "synthesized name snapshot" &reader + + buckets.Add(key, names) + + if reader.RemainingBytes <> 0 then + invalidData "synthesized name snapshot" reader.Offset + + buckets |> Seq.map id |> Map.ofSeq + with :? BadImageFormatException -> + invalidData "synthesized name snapshot" reader.Offset + finally + handle.Free() + +/// Creates the module-level CustomDebugInformation row for the allocation-ordered +/// synthesized-name snapshot. Empty snapshots emit no row. +let computeSynthesizedNameSnapshotCustomDebugInfoRows (snapshot: seq) : PdbModuleCustomDebugInfo list = + let blob = serializeSynthesizedNameSnapshot snapshot + + if blob.Length = 0 then + [] + else + [ + { + KindGuid = PortableCustomDebugInfoKinds.fsharpSynthesizedNameSnapshot + Blob = blob + } + ] + // --------------------------------------------------------------------------- // EnC Local Slot Map // Format (EditAndContinueMethodDebugInformation.cs, SerializeLocalSlots lines 145-191, @@ -555,3 +690,35 @@ let readEncMethodDebugInfoFromPortablePdb (pdbBytes: byte[]) : Map option = + if isEmpty pdbBytes then + None + else + try + use provider = + MetadataReaderProvider.FromPortablePdbImage(ImmutableArray.CreateRange pdbBytes) + + let reader = provider.GetMetadataReader() + + let blobs = + [ + for cdiHandle in reader.CustomDebugInformation do + let cdi = reader.GetCustomDebugInformation cdiHandle + + if cdi.Parent.Kind = HandleKind.ModuleDefinition then + let kind = reader.GetGuid cdi.Kind + + if kind = PortableCustomDebugInfoKinds.fsharpSynthesizedNameSnapshot then + reader.GetBlobBytes cdi.Value + ] + + match blobs with + | [ blob ] -> Some(deserializeSynthesizedNameSnapshot blob) + | _ -> None + with + | :? BadImageFormatException + | :? InvalidDataException -> None diff --git a/src/Compiler/AbstractIL/EncMethodDebugInformation.fsi b/src/Compiler/AbstractIL/EncMethodDebugInformation.fsi index 1e2ba76e7c8..6d83c3a42b6 100644 --- a/src/Compiler/AbstractIL/EncMethodDebugInformation.fsi +++ b/src/Compiler/AbstractIL/EncMethodDebugInformation.fsi @@ -36,6 +36,9 @@ module PortableCustomDebugInfoKinds = /// EnC State Machine State Map CDI kind. val encStateMachineStateMap: System.Guid + /// F#-owned hot reload synthesized-name snapshot CDI kind. + val fsharpSynthesizedNameSnapshot: System.Guid + /// Closure ordinal of a lambda that is lowered to a static (non-capturing) method. /// Mirrors Roslyn's LambdaDebugInfo.StaticClosureOrdinal. [] @@ -135,6 +138,19 @@ val tryEncodeOccurrenceKey: ordinalChain: int list -> int option /// root-first ordinal chain. val decodeOccurrenceKey: key: int -> int list +/// Serializes an allocation-ordered synthesized-name snapshot into the F#-owned module +/// CDI blob. An empty snapshot returns an empty blob so no CDI row needs to be emitted. +val serializeSynthesizedNameSnapshot: snapshot: seq -> byte[] + +/// Deserializes the F#-owned synthesized-name snapshot CDI blob. Bucket order in the +/// blob is deterministic only; each bucket array is returned exactly in recorded slot order. +val deserializeSynthesizedNameSnapshot: blob: byte[] -> Map + +/// Creates the module-level CustomDebugInformation row for the allocation-ordered +/// synthesized-name snapshot. Empty snapshots emit no row. +val computeSynthesizedNameSnapshotCustomDebugInfoRows: + snapshot: seq -> FSharp.Compiler.AbstractIL.ILPdbWriter.PdbModuleCustomDebugInfo list + /// Serializes the EnC Local Slot Map blob for 'info', byte-for-byte as Roslyn's /// SerializeLocalSlots. Returns the empty array when there are no slots (no CDI row /// should be emitted then). @@ -176,3 +192,8 @@ val deserialize: /// Fail safe: a null/empty or non-PDB image yields the empty map, and a method whose /// blobs do not decode is omitted rather than guessed. val readEncMethodDebugInfoFromPortablePdb: pdbBytes: byte[] -> Map + +/// Reads the F#-owned allocation-ordered synthesized-name snapshot from a portable PDB. +/// None means either the record is absent or invalid; callers must fall back to IL +/// reconstruction rather than trusting a partial layout. +val readSynthesizedNameSnapshotFromPortablePdb: pdbBytes: byte[] -> Map option diff --git a/src/Compiler/AbstractIL/ilwrite.fs b/src/Compiler/AbstractIL/ilwrite.fs index bf6277bf485..5c387dc7e41 100644 --- a/src/Compiler/AbstractIL/ilwrite.fs +++ b/src/Compiler/AbstractIL/ilwrite.fs @@ -3863,8 +3863,11 @@ type options = referenceAssemblyAttribOpt: ILAttribute option referenceAssemblySignatureHash : int option pathMap: PathMap + /// Hot reload baseline side channel: module-level CustomDebugInformation rows for + /// F#-owned records in the portable PDB. Empty for ordinary compiles. + moduleCustomDebugInfoRows: PdbModuleCustomDebugInfo list /// Per-method EnC CustomDebugInformation rows for the portable PDB writer, keyed by - /// IL method name. Empty for ordinary compiles, so flag-off output stays byte-identical. + /// IL method name. Empty for ordinary compiles. methodCustomDebugInfoRows: Map } let writeBinaryAux (stream: Stream, options: options, modul, normalizeAssemblyRefs) = @@ -4028,7 +4031,15 @@ let writeBinaryAux (stream: Stream, options: options, modul, normalizeAssemblyRe match options.pdbfile, options.portablePDB with | Some _, true -> let pdbInfo = - generatePortablePdb options.embedAllSource options.embedSourceList options.sourceLink options.checksumAlgorithm pdbData options.pathMap options.methodCustomDebugInfoRows + generatePortablePdb + options.embedAllSource + options.embedSourceList + options.sourceLink + options.checksumAlgorithm + pdbData + options.pathMap + options.moduleCustomDebugInfoRows + options.methodCustomDebugInfoRows if options.embeddedPDB then let uncompressedLength, contentId, stream, algorithmName, checkSum = pdbInfo diff --git a/src/Compiler/AbstractIL/ilwrite.fsi b/src/Compiler/AbstractIL/ilwrite.fsi index edb46b98a31..40ea015db12 100644 --- a/src/Compiler/AbstractIL/ilwrite.fsi +++ b/src/Compiler/AbstractIL/ilwrite.fsi @@ -28,6 +28,9 @@ type options = referenceAssemblyAttribOpt: ILAttribute option referenceAssemblySignatureHash: int option pathMap: PathMap + /// Hot reload baseline side channel: module-level CustomDebugInformation rows for + /// F#-owned records in the portable PDB. Empty for ordinary compiles. + moduleCustomDebugInfoRows: PdbModuleCustomDebugInfo list /// Per-method EnC CustomDebugInformation rows for the portable PDB writer, keyed by /// IL method name. Empty for ordinary compiles, so flag-off output stays byte-identical. methodCustomDebugInfoRows: Map diff --git a/src/Compiler/AbstractIL/ilwritepdb.fs b/src/Compiler/AbstractIL/ilwritepdb.fs index 70f88b471d7..bfa9cafef99 100644 --- a/src/Compiler/AbstractIL/ilwritepdb.fs +++ b/src/Compiler/AbstractIL/ilwritepdb.fs @@ -122,6 +122,10 @@ type PdbMethodData = /// definition row in the portable PDB. type PdbMethodCustomDebugInfo = { KindGuid: Guid; Blob: byte[] } +/// A pre-serialized CustomDebugInformation row (kind GUID + blob) to attach to the +/// module definition row in the portable PDB. +type PdbModuleCustomDebugInfo = { KindGuid: Guid; Blob: byte[] } + module SequencePoint = let orderBySource sp1 sp2 = let c1 = compare sp1.Document sp2.Document @@ -348,6 +352,7 @@ type PortablePdbGenerator checksumAlgorithm, info: PdbData, pathMap: PathMap, + moduleCustomDebugInfoRows: PdbModuleCustomDebugInfo list, methodCustomDebugInfoRows: Map ) = @@ -484,6 +489,14 @@ type PortablePdbGenerator ) |> ignore + for cdiRow in moduleCustomDebugInfoRows |> List.sortBy (fun row -> row.KindGuid) do + metadata.AddCustomDebugInformation( + ModuleDefinitionHandle.op_Implicit EntityHandle.ModuleDefinition, + metadata.GetOrAddGuid cdiRow.KindGuid, + metadata.GetOrAddBlob cdiRow.Blob + ) + |> ignore + index let mutable lastLocalVariableHandle = Unchecked.defaultof @@ -881,10 +894,20 @@ let generatePortablePdb checksumAlgorithm (info: PdbData) (pathMap: PathMap) + (moduleCustomDebugInfoRows: PdbModuleCustomDebugInfo list) (methodCustomDebugInfoRows: Map) = let generator = - PortablePdbGenerator(embedAllSource, embedSourceList, sourceLink, checksumAlgorithm, info, pathMap, methodCustomDebugInfoRows) + PortablePdbGenerator( + embedAllSource, + embedSourceList, + sourceLink, + checksumAlgorithm, + info, + pathMap, + moduleCustomDebugInfoRows, + methodCustomDebugInfoRows + ) generator.Emit() diff --git a/src/Compiler/AbstractIL/ilwritepdb.fsi b/src/Compiler/AbstractIL/ilwritepdb.fsi index 09d380e44cc..3aa0679178a 100644 --- a/src/Compiler/AbstractIL/ilwritepdb.fsi +++ b/src/Compiler/AbstractIL/ilwritepdb.fsi @@ -73,6 +73,11 @@ type PdbMethodData = /// one method row (fail closed on ambiguity). type PdbMethodCustomDebugInfo = { KindGuid: System.Guid; Blob: byte[] } +/// A pre-serialized CustomDebugInformation row to attach to the module definition row +/// in the portable PDB (kind GUID + blob). Supplied by hot reload for F#-owned +/// deterministic baseline records. +type PdbModuleCustomDebugInfo = { KindGuid: System.Guid; Blob: byte[] } + [] type PdbData = { @@ -115,6 +120,7 @@ val generatePortablePdb: checksumAlgorithm: HashAlgorithm -> info: PdbData -> pathMap: PathMap -> + moduleCustomDebugInfoRows: PdbModuleCustomDebugInfo list -> methodCustomDebugInfoRows: Map -> int64 * BlobContentId * MemoryStream * string * byte[] diff --git a/src/Compiler/CodeGen/HotReloadBaseline.fs b/src/Compiler/CodeGen/HotReloadBaseline.fs new file mode 100644 index 00000000000..f68e3b10419 --- /dev/null +++ b/src/Compiler/CodeGen/HotReloadBaseline.fs @@ -0,0 +1,456 @@ +module internal FSharp.Compiler.HotReloadBaseline + +open System +open System.Collections.Generic +open System.Collections.Immutable + +open FSharp.Compiler.AbstractIL.EncMethodDebugInformation +open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.CodeGen +open FSharp.Compiler.CompilerGeneratedNameMapState +open FSharp.Compiler.GeneratedNames +open FSharp.Compiler.Syntax.PrettyNaming + +[] +type SynthesizedNameSnapshotSource = + | Recorded + | Reconstructed + +type PortablePdbSnapshot = + { + Bytes: byte[] + TableRowCounts: ImmutableArray + EntryPointToken: int option + } + +type TypeDefinitionKey = + { + RowId: int + Namespace: string + Name: string + } + +type MethodDefinitionKey = + { + DeclaringType: TypeDefinitionKey + Name: string + Signature: byte list + } + +type FieldDefinitionKey = + { + DeclaringType: TypeDefinitionKey + Name: string + Signature: byte list + } + +type PropertyDefinitionKey = + { + DeclaringType: TypeDefinitionKey + Name: string + Signature: byte list + } + +type EventDefinitionKey = + { + DeclaringType: TypeDefinitionKey + Name: string + EventType: int + } + +type BaselineTokenMaps = + { + TypeTokens: Map + MethodTokens: Map + FieldTokens: Map + PropertyTokens: Map + EventTokens: Map + } + +type FSharpEmitBaseline = + { + ModuleId: Guid + Metadata: ILBaselineReader.MetadataSnapshot + PortablePdb: PortablePdbSnapshot option + TokenMaps: BaselineTokenMaps + SynthesizedNameSnapshot: Map + SynthesizedNameSnapshotSource: SynthesizedNameSnapshotSource + EncMethodDebugInfos: Map + EncClosureNames: Map> + } + +let private typeDefToken rowId = (0x02 <<< 24) ||| rowId +let private fieldToken rowId = (0x04 <<< 24) ||| rowId +let private methodDefToken rowId = (0x06 <<< 24) ||| rowId +let private eventToken rowId = (0x14 <<< 24) ||| rowId +let private propertyToken rowId = (0x17 <<< 24) ||| rowId + +let private typeFullName (key: TypeDefinitionKey) = + if String.IsNullOrEmpty key.Namespace then + key.Name + else + key.Namespace + "." + key.Name + +let private signatureList (bytes: byte[]) = bytes |> Array.toList + +let private buildTypeKeys (reader: ILBaselineReader.BaselineMetadataReader) = + [ + for rowId in 1 .. reader.TypeDefCount do + match reader.GetTypeDef rowId with + | Some row -> + yield + rowId, + { + RowId = rowId + Namespace = reader.GetString row.NamespaceOffset + Name = reader.GetString row.NameOffset + } + | None -> () + ] + |> Map.ofList + +let private emptyTokenMaps = + { + TypeTokens = Map.empty + MethodTokens = Map.empty + FieldTokens = Map.empty + PropertyTokens = Map.empty + EventTokens = Map.empty + } + +let private buildTokenMaps (reader: ILBaselineReader.BaselineMetadataReader) = + let typeKeys = buildTypeKeys reader + + let typeTokens: Map = + typeKeys + |> Map.toSeq + |> Seq.map (fun (rowId, key) -> key, typeDefToken rowId) + |> Map.ofSeq + + let methodTokens: Map = + seq { + for KeyValue(typeRowId, typeKey) in typeKeys do + match reader.GetTypeMethodRange typeRowId with + | None -> () + | Some(firstMethod, lastMethod) -> + for methodRowId in firstMethod..lastMethod do + match reader.GetMethodDef methodRowId with + | None -> () + | Some methodDef -> + let key: MethodDefinitionKey = + { + DeclaringType = typeKey + Name = reader.GetString methodDef.NameOffset + Signature = reader.GetBlob methodDef.SignatureOffset |> signatureList + } + + yield key, methodDefToken methodRowId + } + |> Map.ofSeq + + let fieldTokens: Map = + seq { + for KeyValue(typeRowId, typeKey) in typeKeys do + match reader.GetTypeFieldRange typeRowId with + | None -> () + | Some(firstField, lastField) -> + for fieldRowId in firstField..lastField do + match reader.GetField fieldRowId with + | None -> () + | Some fieldDef -> + let key: FieldDefinitionKey = + { + DeclaringType = typeKey + Name = reader.GetString fieldDef.NameOffset + Signature = reader.GetBlob fieldDef.SignatureOffset |> signatureList + } + + yield key, fieldToken fieldRowId + } + |> Map.ofSeq + + let propertyTokens: Map = + seq { + for propertyMapRowId in 1 .. reader.PropertyMapCount do + match reader.GetPropertyMapRange propertyMapRowId with + | Some(parentTypeRowId, firstProperty, lastProperty) -> + match Map.tryFind parentTypeRowId typeKeys with + | None -> () + | Some typeKey -> + for propertyRowId in firstProperty..lastProperty do + match reader.GetProperty propertyRowId with + | None -> () + | Some propertyDef -> + let key: PropertyDefinitionKey = + { + DeclaringType = typeKey + Name = reader.GetString propertyDef.NameOffset + Signature = reader.GetBlob propertyDef.SignatureOffset |> signatureList + } + + yield key, propertyToken propertyRowId + | None -> () + } + |> Map.ofSeq + + let eventTokens: Map = + seq { + for eventMapRowId in 1 .. reader.EventMapCount do + match reader.GetEventMapRange eventMapRowId with + | Some(parentTypeRowId, firstEvent, lastEvent) -> + match Map.tryFind parentTypeRowId typeKeys with + | None -> () + | Some typeKey -> + for eventRowId in firstEvent..lastEvent do + match reader.GetEvent eventRowId with + | None -> () + | Some eventDef -> + let key: EventDefinitionKey = + { + DeclaringType = typeKey + Name = reader.GetString eventDef.NameOffset + EventType = eventDef.EventType + } + + yield key, eventToken eventRowId + | None -> () + } + |> Map.ofSeq + + { + TypeTokens = typeTokens + MethodTokens = methodTokens + FieldTokens = fieldTokens + PropertyTokens = propertyTokens + EventTokens = eventTokens + } + +let private addSynthesizedName (buckets: Dictionary>) (name: string) = + if not (String.IsNullOrWhiteSpace name) && IsCompilerGeneratedName name then + let basicName = GetBasicNameOfPossibleCompilerGeneratedName name + let mapKey = SynthesizedNameMapKey basicName + + if not (String.IsNullOrWhiteSpace mapKey) then + let bucket = + match buckets.TryGetValue mapKey with + | true, existing -> existing + | _ -> + let created = ResizeArray() + buckets[mapKey] <- created + created + + if not (bucket.Contains name) then + bucket.Add name + +let private snapshotFromBuckets (buckets: Dictionary>) = + buckets + |> Seq.map (fun (KeyValue(key, bucket)) -> key, bucket.ToArray()) + |> Map.ofSeq + +let internal collectSynthesizedNameSnapshot (ilModule: ILModuleDef) = + let buckets = Dictionary>(StringComparer.Ordinal) + + let rec collectTypeDef (typeDef: ILTypeDef) = + addSynthesizedName buckets typeDef.Name + + typeDef.Fields.AsList() + |> List.iter (fun fieldDef -> addSynthesizedName buckets fieldDef.Name) + + typeDef.Methods.AsList() + |> List.iter (fun methodDef -> addSynthesizedName buckets methodDef.Name) + + typeDef.Properties.AsList() + |> List.iter (fun propertyDef -> addSynthesizedName buckets propertyDef.Name) + + typeDef.Events.AsList() + |> List.iter (fun eventDef -> addSynthesizedName buckets eventDef.Name) + + typeDef.NestedTypes.AsList() |> List.iter collectTypeDef + + ilModule.TypeDefs.AsList() |> List.iter collectTypeDef + snapshotFromBuckets buckets + +let internal collectRecordedSynthesizedNameSnapshot (_compilerGlobalState: obj) (map: ICompilerGeneratedNameMap) = map.Snapshot + +let private collectSynthesizedNameSnapshotFromTokens (tokenMaps: BaselineTokenMaps) = + let buckets = Dictionary>(StringComparer.Ordinal) + + for KeyValue(typeKey, _) in tokenMaps.TypeTokens do + addSynthesizedName buckets typeKey.Name + + for KeyValue(methodKey, _) in tokenMaps.MethodTokens do + addSynthesizedName buckets methodKey.Name + + for KeyValue(fieldKey, _) in tokenMaps.FieldTokens do + addSynthesizedName buckets fieldKey.Name + + for KeyValue(propertyKey, _) in tokenMaps.PropertyTokens do + addSynthesizedName buckets propertyKey.Name + + for KeyValue(eventKey, _) in tokenMaps.EventTokens do + addSynthesizedName buckets eventKey.Name + + snapshotFromBuckets buckets + +let private formatOccurrenceChainKey (ordinalChain: int list) = + ordinalChain |> List.map string |> String.concat "_" + +let private formatGenerationSuffixedClosureName baseName generation ordinalChain = + CompilerGeneratedNameSuffix baseName $"hotreload#g{generation}_o{formatOccurrenceChainKey ordinalChain}" + +let private cleanUpGeneratedTypeName (name: string) = + if name.IndexOfAny IllegalCharactersInTypeAndNamespaceNames = -1 then + name + else + (name, IllegalCharactersInTypeAndNamespaceNames) + ||> Array.fold (fun acc c -> acc.Replace(string c, "-")) + +let private typeDefSimpleNames (tokenMaps: BaselineTokenMaps) = + tokenMaps.TypeTokens + |> Map.toSeq + |> Seq.map (fun (key, _) -> key.Name) + |> Set.ofSeq + +let private methodNamesByToken (methodTokens: Map) = + methodTokens + |> Map.toSeq + |> Seq.map (fun (key, token) -> token, key.Name) + |> Map.ofSeq + +let deriveEncClosureNamesFromEncDebugInfos + (encMethodDebugInfos: Map) + (methodNamesByToken: Map) + (typeDefSimpleNames: Set) + : Map> = + + if Map.isEmpty encMethodDebugInfos then + Map.empty + else + let hasMidSessionClosureNames = + typeDefSimpleNames + |> Set.exists (fun name -> + match TryGetHotReloadNameGeneration name with + | Some generation -> generation >= 1 + | None -> false) + + if hasMidSessionClosureNames then + Map.empty + else + let hasReplayNamedTypeDef nameBase = + let prefix = nameBase + "@hotreload" + + typeDefSimpleNames + |> Set.exists (fun name -> + name.StartsWith(prefix, StringComparison.Ordinal) + && not (IsHotReloadGenerationSuffixedName name)) + + let derivedRows = + encMethodDebugInfos + |> Map.toList + |> List.choose (fun (methodToken, info) -> + match info.Closures, Map.tryFind methodToken methodNamesByToken with + | [], _ + | _, None -> None + | closures, Some methodName -> + let nameBase = cleanUpGeneratedTypeName methodName + + let rows = + closures + |> List.choose (fun closure -> + let chain = decodeOccurrenceKey closure.SyntaxOffset + let name = formatGenerationSuffixedClosureName nameBase 0 chain + + if Set.contains name typeDefSimpleNames then + Some(chain, name) + else + None) + + Some(methodToken, nameBase, rows)) + + let hasReplayOnlyCdiMethod = + derivedRows + |> List.exists (fun (_, nameBase, rows) -> List.isEmpty rows && hasReplayNamedTypeDef nameBase) + + if hasReplayOnlyCdiMethod then + Map.empty + else + derivedRows + |> List.choose (fun (methodToken, _, rows) -> + match rows with + | [] -> None + | _ -> Some(methodToken, Map.ofList rows)) + |> Map.ofList + +let private toPortablePdbSnapshot (expectedContentId: byte[]) (pdbBytes: byte[]) = + ILBaselineReader.readPortablePdbMetadata pdbBytes + |> Option.filter (fun metadata -> metadata.ContentId.AsSpan().SequenceEqual(expectedContentId)) + |> Option.map (fun metadata -> + { + Bytes = Array.copy pdbBytes + TableRowCounts = ImmutableArray.CreateRange metadata.TableRowCounts + EntryPointToken = metadata.EntryPointToken + }) + +let private createCore moduleId metadata portablePdb tokenMaps = + let reconstructedSynthesizedNames = + collectSynthesizedNameSnapshotFromTokens tokenMaps + + let synthesizedNames, synthesizedNameSnapshotSource = + match + portablePdb + |> Option.bind (fun snapshot -> readSynthesizedNameSnapshotFromPortablePdb snapshot.Bytes) + with + | Some recordedSnapshot -> recordedSnapshot, SynthesizedNameSnapshotSource.Recorded + | None -> reconstructedSynthesizedNames, SynthesizedNameSnapshotSource.Reconstructed + + let encMethodDebugInfos = + portablePdb + |> Option.map (fun snapshot -> readEncMethodDebugInfoFromPortablePdb snapshot.Bytes) + |> Option.defaultValue Map.empty + + { + ModuleId = moduleId + Metadata = metadata + PortablePdb = portablePdb + TokenMaps = tokenMaps + SynthesizedNameSnapshot = synthesizedNames + SynthesizedNameSnapshotSource = synthesizedNameSnapshotSource + EncMethodDebugInfos = encMethodDebugInfos + EncClosureNames = + deriveEncClosureNamesFromEncDebugInfos + encMethodDebugInfos + (methodNamesByToken tokenMaps.MethodTokens) + (typeDefSimpleNames tokenMaps) + } + +let tryReadFromAssemblyAndPdbBytes (assemblyBytes: byte[]) (portablePdbBytes: byte[] option) = + try + match + ILBaselineReader.metadataSnapshotFromBytes assemblyBytes, + ILBaselineReader.BaselineMetadataReader.Create assemblyBytes, + ILBaselineReader.readModuleMvidFromBytes assemblyBytes + with + | Some metadata, Some reader, Some moduleId when moduleId <> Guid.Empty -> + let portablePdb = + match ILBaselineReader.readCodeViewContentIdFromBytes assemblyBytes with + | Some expectedContentId -> portablePdbBytes |> Option.bind (toPortablePdbSnapshot expectedContentId) + | None -> None + + Some(createCore moduleId metadata portablePdb (buildTokenMaps reader)) + | _ -> None + with + | :? BadImageFormatException + | :? IO.IOException + | :? ArgumentException + | :? IndexOutOfRangeException + | :? InvalidOperationException + | :? OverflowException -> None + +let readFromAssemblyAndPdbBytes (assemblyBytes: byte[]) (portablePdbBytes: byte[] option) = + match tryReadFromAssemblyAndPdbBytes assemblyBytes portablePdbBytes with + | Some baseline -> baseline + | None -> invalidArg (nameof assemblyBytes) "assembly bytes do not contain readable CLI metadata" + +let metadataSnapshotFromBytes = ILBaselineReader.metadataSnapshotFromBytes + +let readModuleMvid = ILBaselineReader.readModuleMvidFromBytes diff --git a/src/Compiler/CodeGen/ILBaselineReader.fs b/src/Compiler/CodeGen/ILBaselineReader.fs new file mode 100644 index 00000000000..e41faadd39e --- /dev/null +++ b/src/Compiler/CodeGen/ILBaselineReader.fs @@ -0,0 +1,1015 @@ +/// Minimal binary reader for baseline PE and portable PDB metadata. +module internal FSharp.Compiler.CodeGen.ILBaselineReader + +open System +open System.Collections.Immutable +open System.IO +open System.Reflection.PortableExecutable +open System.Text + +type MetadataHeapSizes = + { + StringHeapSize: int + UserStringHeapSize: int + BlobHeapSize: int + GuidHeapSize: int + } + +type MetadataSnapshot = + { + HeapSizes: MetadataHeapSizes + TableRowCounts: int[] + GuidHeapStart: int + } + +type PortablePdbMetadata = + { + ContentId: byte[] + TableRowCounts: int[] + EntryPointToken: int option + } + +let private readUInt16 (bytes: byte[]) (offset: int) = + uint16 bytes[offset] ||| (uint16 bytes[offset + 1] <<< 8) + +let private readInt32 (bytes: byte[]) (offset: int) = + int bytes[offset] + ||| (int bytes[offset + 1] <<< 8) + ||| (int bytes[offset + 2] <<< 16) + ||| (int bytes[offset + 3] <<< 24) + +/// Reads an unsigned 64-bit little-endian value without sign-extending either half. +let internal readUInt64 (bytes: byte[]) (offset: int) = + uint64 (uint32 (readInt32 bytes offset)) + ||| (uint64 (uint32 (readInt32 bytes (offset + 4))) <<< 32) + +[] +let private tableCount = 64 + +module private TableIndices = + let Module = 0 + let TypeRef = 1 + let TypeDef = 2 + let FieldPtr = 3 + let Field = 4 + let MethodPtr = 5 + let MethodDef = 6 + let ParamPtr = 7 + let Param = 8 + let InterfaceImpl = 9 + let MemberRef = 10 + let Constant = 11 + let FieldMarshal = 13 + let DeclSecurity = 14 + let ClassLayout = 15 + let FieldLayout = 16 + let StandAloneSig = 17 + let EventMap = 18 + let EventPtr = 19 + let Event = 20 + let PropertyMap = 21 + let PropertyPtr = 22 + let Property = 23 + let MethodSemantics = 24 + let MethodImpl = 25 + let ModuleRef = 26 + let TypeSpec = 27 + let ImplMap = 28 + let FieldRVA = 29 + let Assembly = 32 + let AssemblyRef = 35 + let File = 38 + let ExportedType = 39 + let ManifestResource = 40 + let NestedClass = 41 + let GenericParam = 42 + let MethodSpec = 43 + let GenericParamConstraint = 44 + +type private StreamHeader = + { Offset: int; Size: int; Name: string } + +let private tryRvaToOffset (bytes: byte[]) (coffHeader: int) (optionalHeader: int) (sizeOfOptionalHeader: int) (rva: int) = + let numberOfSections = int (readUInt16 bytes (coffHeader + 2)) + let sectionHeadersStart = optionalHeader + sizeOfOptionalHeader + + let rec loop sectionIndex = + if sectionIndex >= numberOfSections then + None + else + let sectionOffset = sectionHeadersStart + sectionIndex * 40 + + if sectionOffset + 40 > bytes.Length then + None + else + let virtualSize = readInt32 bytes (sectionOffset + 8) + let virtualAddress = readInt32 bytes (sectionOffset + 12) + let rawSize = readInt32 bytes (sectionOffset + 16) + let pointerToRawData = readInt32 bytes (sectionOffset + 20) + let span = max virtualSize rawSize + + if rva >= virtualAddress && rva < virtualAddress + span then + Some(rva - virtualAddress + pointerToRawData) + else + loop (sectionIndex + 1) + + loop 0 + +let private findMetadataRoot (bytes: byte[]) : int option = + try + if bytes.Length < 64 || bytes[0] <> 0x4Duy || bytes[1] <> 0x5Auy then + None + else + let peOffset = readInt32 bytes 0x3C + + if peOffset < 0 || peOffset + 24 > bytes.Length then + None + elif + bytes[peOffset] <> 0x50uy + || bytes[peOffset + 1] <> 0x45uy + || bytes[peOffset + 2] <> 0uy + || bytes[peOffset + 3] <> 0uy + then + None + else + let coffHeader = peOffset + 4 + let sizeOfOptionalHeader = int (readUInt16 bytes (coffHeader + 16)) + let optionalHeader = coffHeader + 20 + let magic = readUInt16 bytes optionalHeader + + let dataDirectoryStart = + if magic = 0x20Bus then + optionalHeader + 112 + else + optionalHeader + 96 + + let cliDirectory = dataDirectoryStart + 14 * 8 + + if cliDirectory + 8 > bytes.Length then + None + else + let cliHeaderRva = readInt32 bytes cliDirectory + + if cliHeaderRva = 0 then + None + else + match tryRvaToOffset bytes coffHeader optionalHeader sizeOfOptionalHeader cliHeaderRva with + | None -> None + | Some cliHeaderOffset when cliHeaderOffset + 12 > bytes.Length -> None + | Some cliHeaderOffset -> + let metadataRva = readInt32 bytes (cliHeaderOffset + 8) + tryRvaToOffset bytes coffHeader optionalHeader sizeOfOptionalHeader metadataRva + with + | :? IndexOutOfRangeException + | :? ArgumentOutOfRangeException -> None + +let private parseStreamHeaders (bytes: byte[]) (metadataRoot: int) : StreamHeader list = + let signature = readInt32 bytes metadataRoot + + if signature <> 0x424A5342 then + [] + else + let versionLength = readInt32 bytes (metadataRoot + 12) + let paddedVersionLength = (versionLength + 3) &&& ~~~3 + let streamsOffset = metadataRoot + 16 + paddedVersionLength + let numberOfStreams = int (readUInt16 bytes (streamsOffset + 2)) + let mutable currentOffset = streamsOffset + 4 + let headers = ResizeArray() + + for _ in 1..numberOfStreams do + let offset = readInt32 bytes currentOffset + let size = readInt32 bytes (currentOffset + 4) + let mutable nameEnd = currentOffset + 8 + + while nameEnd < bytes.Length && bytes[nameEnd] <> 0uy do + nameEnd <- nameEnd + 1 + + if nameEnd >= bytes.Length then + invalidArg (nameof bytes) "invalid metadata stream header" + + let name = + Encoding.ASCII.GetString(bytes, currentOffset + 8, nameEnd - currentOffset - 8) + + let paddedNameLength = ((nameEnd - currentOffset - 8 + 1) + 3) &&& ~~~3 + + headers.Add( + { + Offset = metadataRoot + offset + Size = size + Name = name + } + ) + + currentOffset <- currentOffset + 8 + paddedNameLength + + headers |> Seq.toList + +let private findStream (headers: StreamHeader list) (name: string) = + headers |> List.tryFind (fun header -> header.Name = name) + +let private parseTablesStream (bytes: byte[]) (tablesStream: StreamHeader) = + let offset = tablesStream.Offset + let heapSizes = bytes[offset + 6] + let valid = readUInt64 bytes (offset + 8) + let rowCounts = Array.zeroCreate tableCount + let mutable rowCountOffset = offset + 24 + + for i in 0..63 do + if (valid &&& (1UL <<< i)) <> 0UL then + let rowCount = readInt32 bytes rowCountOffset + + if rowCount < 0 then + invalidArg (nameof bytes) "metadata table row counts must be non-negative" + + rowCounts[i] <- rowCount + rowCountOffset <- rowCountOffset + 4 + + heapSizes, rowCounts, offset, valid + +/// Computes the first table-row offset from the table header's valid-table mask. +let internal tableDataStart tablesOffset (valid: uint64) = + let mutable remaining = valid + let mutable presentTableCount = 0 + + while remaining <> 0UL do + presentTableCount <- presentTableCount + 1 + remaining <- remaining &&& (remaining - 1UL) + + tablesOffset + 24 + (presentTableCount * 4) + +let metadataSnapshotFromBytes (bytes: byte[]) : MetadataSnapshot option = + try + match findMetadataRoot bytes with + | None -> None + | Some metadataRoot -> + let streamHeaders = parseStreamHeaders bytes metadataRoot + let stringsStream = findStream streamHeaders "#Strings" + let userStringsStream = findStream streamHeaders "#US" + let blobStream = findStream streamHeaders "#Blob" + let guidStream = findStream streamHeaders "#GUID" + + let tablesStream = + findStream streamHeaders "#~" |> Option.orElse (findStream streamHeaders "#-") + + match tablesStream with + | None -> None + | Some tables -> + let _, rowCounts, _, _ = parseTablesStream bytes tables + + let trimmedStringHeapSize = + match stringsStream with + | None -> 0 + | Some stream -> + if stream.Size = 0 then + 0 + else + let last = stream.Offset + stream.Size - 1 + let mutable i = last + + while i >= stream.Offset && bytes[i] = 0uy do + i <- i - 1 + + if i = last then stream.Size else i - stream.Offset + 2 + + let heapSizes = + { + StringHeapSize = trimmedStringHeapSize + UserStringHeapSize = + userStringsStream + |> Option.map (fun stream -> stream.Size) + |> Option.defaultValue 0 + BlobHeapSize = blobStream |> Option.map (fun stream -> stream.Size) |> Option.defaultValue 0 + GuidHeapSize = guidStream |> Option.map (fun stream -> stream.Size) |> Option.defaultValue 0 + } + + Some + { + HeapSizes = heapSizes + TableRowCounts = rowCounts + GuidHeapStart = heapSizes.GuidHeapSize + } + with + | :? IndexOutOfRangeException + | :? ArgumentOutOfRangeException -> None + +let private readGuidFromBytes (bytes: byte[]) (guidIndex: int) = + if guidIndex <= 0 then + None + else + match findMetadataRoot bytes with + | None -> None + | Some metadataRoot -> + let streamHeaders = parseStreamHeaders bytes metadataRoot + + match findStream streamHeaders "#GUID" with + | None -> None + | Some guidStream -> + let offset = guidStream.Offset + (guidIndex - 1) * 16 + let streamEnd = int64 guidStream.Offset + int64 guidStream.Size + let guidEnd = int64 offset + 16L + + if + guidStream.Offset < 0 + || guidStream.Size < 0 + || streamEnd > int64 bytes.Length + || offset < guidStream.Offset + || guidEnd > streamEnd + then + None + else + Some(Guid(bytes[offset .. offset + 15])) + +/// Reads the portable CodeView content ID embedded in a PE debug directory. +let readCodeViewContentIdFromBytes (bytes: byte[]) : byte[] option = + try + use peReader = new PEReader(ImmutableArray.CreateRange bytes) + + peReader.ReadDebugDirectory() + |> Seq.tryFind (fun entry -> entry.IsPortableCodeView) + |> Option.map (fun entry -> + let data = peReader.ReadCodeViewDebugDirectoryData entry + let contentId = Array.zeroCreate 20 + data.Guid.ToByteArray().CopyTo(contentId, 0) + BitConverter.GetBytes(entry.Stamp).CopyTo(contentId, 16) + contentId) + with + | :? BadImageFormatException + | :? IOException + | :? InvalidOperationException -> None + +/// Parsed metadata context for reading table rows. +/// Internal (not private): tiny reader members can get cross-module inlined in Release +/// builds, and inlined code referencing a module-private type fails CLR visibility +/// checks at runtime. +type internal MetadataContext = + { + Bytes: byte[] + HeapSizes: byte + RowCounts: int[] + TablesStart: int + StringIndexSize: int + GuidIndexSize: int + BlobIndexSize: int + StringsStreamOffset: int + StringsStreamSize: int + BlobStreamOffset: int + } + +let private tableIndexSize (rowCounts: int[]) tableIndex = + if rowCounts[tableIndex] <= 65535 then 2 else 4 + +let private codedIndexSize (rowCounts: int[]) (tableIndices: int[]) tagBits = + let maxRows = + tableIndices + |> Array.map (fun tableIndex -> if tableIndex < tableCount then rowCounts[tableIndex] else 0) + |> Array.max + + let maxValue = (maxRows <<< tagBits) ||| ((1 <<< tagBits) - 1) + if maxValue <= 65535 then 2 else 4 + +let private resolutionScopeSize rowCounts = + codedIndexSize + rowCounts + [| + TableIndices.Module + TableIndices.ModuleRef + TableIndices.AssemblyRef + TableIndices.TypeRef + |] + 2 + +let private typeDefOrRefSize rowCounts = + codedIndexSize rowCounts [| TableIndices.TypeDef; TableIndices.TypeRef; TableIndices.TypeSpec |] 2 + +let private hasConstantSize rowCounts = + codedIndexSize rowCounts [| TableIndices.Field; TableIndices.Param; TableIndices.Property |] 2 + +let private hasCustomAttributeSize rowCounts = + codedIndexSize + rowCounts + [| + TableIndices.MethodDef + TableIndices.Field + TableIndices.TypeRef + TableIndices.TypeDef + TableIndices.Param + TableIndices.InterfaceImpl + TableIndices.MemberRef + TableIndices.Module + TableIndices.DeclSecurity + TableIndices.Property + TableIndices.Event + TableIndices.StandAloneSig + TableIndices.ModuleRef + TableIndices.TypeSpec + TableIndices.Assembly + TableIndices.AssemblyRef + TableIndices.File + TableIndices.ExportedType + TableIndices.ManifestResource + TableIndices.GenericParam + TableIndices.GenericParamConstraint + TableIndices.MethodSpec + |] + 5 + +let private hasFieldMarshalSize rowCounts = + codedIndexSize rowCounts [| TableIndices.Field; TableIndices.Param |] 1 + +let private hasDeclSecuritySize rowCounts = + codedIndexSize rowCounts [| TableIndices.TypeDef; TableIndices.MethodDef; TableIndices.Assembly |] 2 + +let private memberRefParentSize rowCounts = + codedIndexSize + rowCounts + [| + TableIndices.TypeDef + TableIndices.TypeRef + TableIndices.ModuleRef + TableIndices.MethodDef + TableIndices.TypeSpec + |] + 3 + +let private hasSemanticsSize rowCounts = + codedIndexSize rowCounts [| TableIndices.Event; TableIndices.Property |] 1 + +let private methodDefOrRefSize rowCounts = + codedIndexSize rowCounts [| TableIndices.MethodDef; TableIndices.MemberRef |] 1 + +let private memberForwardedSize rowCounts = + codedIndexSize rowCounts [| TableIndices.Field; TableIndices.MethodDef |] 1 + +let private implementationSize rowCounts = + codedIndexSize rowCounts [| TableIndices.File; TableIndices.AssemblyRef; TableIndices.ExportedType |] 2 + +let private customAttributeTypeSize rowCounts = + codedIndexSize rowCounts [| 0; 0; TableIndices.MethodDef; TableIndices.MemberRef; 0 |] 3 + +let private typeOrMethodDefSize rowCounts = + codedIndexSize rowCounts [| TableIndices.TypeDef; TableIndices.MethodDef |] 1 + +let private calculateTableRowSizes (ctx: MetadataContext) = + let rowCounts = ctx.RowCounts + let strIdx = ctx.StringIndexSize + let guidIdx = ctx.GuidIndexSize + let blobIdx = ctx.BlobIndexSize + let sizes = Array.zeroCreate tableCount + + sizes[0] <- 2 + strIdx + guidIdx + guidIdx + guidIdx + sizes[1] <- resolutionScopeSize rowCounts + strIdx + strIdx + + sizes[2] <- + 4 + + strIdx + + strIdx + + typeDefOrRefSize rowCounts + + tableIndexSize rowCounts TableIndices.Field + + tableIndexSize rowCounts TableIndices.MethodDef + + sizes[4] <- 2 + strIdx + blobIdx + sizes[6] <- 4 + 2 + 2 + strIdx + blobIdx + tableIndexSize rowCounts TableIndices.Param + sizes[8] <- 2 + 2 + strIdx + sizes[9] <- tableIndexSize rowCounts TableIndices.TypeDef + typeDefOrRefSize rowCounts + sizes[10] <- memberRefParentSize rowCounts + strIdx + blobIdx + sizes[11] <- 2 + hasConstantSize rowCounts + blobIdx + sizes[12] <- hasCustomAttributeSize rowCounts + customAttributeTypeSize rowCounts + blobIdx + sizes[13] <- hasFieldMarshalSize rowCounts + blobIdx + sizes[14] <- 2 + hasDeclSecuritySize rowCounts + blobIdx + sizes[15] <- 2 + 4 + tableIndexSize rowCounts TableIndices.TypeDef + sizes[16] <- 4 + tableIndexSize rowCounts TableIndices.Field + sizes[17] <- blobIdx + + sizes[18] <- + tableIndexSize rowCounts TableIndices.TypeDef + + tableIndexSize rowCounts TableIndices.Event + + sizes[20] <- 2 + strIdx + typeDefOrRefSize rowCounts + + sizes[21] <- + tableIndexSize rowCounts TableIndices.TypeDef + + tableIndexSize rowCounts TableIndices.Property + + sizes[23] <- 2 + strIdx + blobIdx + sizes[24] <- 2 + tableIndexSize rowCounts TableIndices.MethodDef + hasSemanticsSize rowCounts + + sizes[25] <- + tableIndexSize rowCounts TableIndices.TypeDef + + methodDefOrRefSize rowCounts + + methodDefOrRefSize rowCounts + + sizes[26] <- strIdx + sizes[27] <- blobIdx + + sizes[28] <- + 2 + + memberForwardedSize rowCounts + + strIdx + + tableIndexSize rowCounts TableIndices.ModuleRef + + sizes[29] <- 4 + tableIndexSize rowCounts TableIndices.Field + sizes[32] <- 4 + 2 + 2 + 2 + 2 + 4 + blobIdx + strIdx + strIdx + sizes[35] <- 2 + 2 + 2 + 2 + 4 + blobIdx + strIdx + strIdx + blobIdx + sizes[38] <- 4 + strIdx + blobIdx + sizes[39] <- 4 + 4 + strIdx + strIdx + implementationSize rowCounts + sizes[40] <- 4 + 4 + strIdx + implementationSize rowCounts + + sizes[41] <- + tableIndexSize rowCounts TableIndices.TypeDef + + tableIndexSize rowCounts TableIndices.TypeDef + + sizes[42] <- 2 + 2 + typeOrMethodDefSize rowCounts + strIdx + sizes[43] <- methodDefOrRefSize rowCounts + blobIdx + sizes[44] <- tableIndexSize rowCounts TableIndices.GenericParam + typeDefOrRefSize rowCounts + sizes + +let private calculateTableOffsets (ctx: MetadataContext) (rowSizes: int[]) = + let offsets = Array.zeroCreate tableCount + let mutable currentOffset = ctx.TablesStart + + for i in 0 .. tableCount - 1 do + offsets[i] <- currentOffset + currentOffset <- currentOffset + rowSizes[i] * ctx.RowCounts[i] + + offsets + +let private readHeapIndex (bytes: byte[]) offset indexSize = + if indexSize = 2 then + int (readUInt16 bytes offset) + else + readInt32 bytes offset + +let private createMetadataContext (bytes: byte[]) = + match findMetadataRoot bytes with + | None -> None + | Some metadataRoot -> + let streamHeaders = parseStreamHeaders bytes metadataRoot + + let tablesStream = + findStream streamHeaders "#~" |> Option.orElse (findStream streamHeaders "#-") + + match tablesStream with + | None -> None + | Some stream -> + let heapSizes, rowCounts, tablesOffset, valid = parseTablesStream bytes stream + + let pointerTables = + [| + TableIndices.FieldPtr + TableIndices.MethodPtr + TableIndices.ParamPtr + TableIndices.EventPtr + TableIndices.PropertyPtr + |] + + // The #- stream permits pointer-table indirection. This reader consumes the + // definition tables directly, so accepting a non-empty pointer table would + // associate members with the wrong declaring type. + if + stream.Name = "#-" + && pointerTables |> Array.exists (fun table -> rowCounts[table] <> 0) + then + None + else + let stringsBig = (heapSizes &&& 0x01uy) <> 0uy + let guidsBig = (heapSizes &&& 0x02uy) <> 0uy + let blobsBig = (heapSizes &&& 0x04uy) <> 0uy + + let stringsStream = + streamHeaders |> List.tryFind (fun header -> header.Name = "#Strings") + + Some + { + Bytes = bytes + HeapSizes = heapSizes + RowCounts = rowCounts + TablesStart = tableDataStart tablesOffset valid + StringIndexSize = if stringsBig then 4 else 2 + GuidIndexSize = if guidsBig then 4 else 2 + BlobIndexSize = if blobsBig then 4 else 2 + StringsStreamOffset = + stringsStream + |> Option.map (fun header -> header.Offset) + |> Option.defaultValue 0 + StringsStreamSize = stringsStream |> Option.map (fun header -> header.Size) |> Option.defaultValue 0 + BlobStreamOffset = + streamHeaders + |> List.tryFind (fun h -> h.Name = "#Blob") + |> Option.map (fun h -> h.Offset) + |> Option.defaultValue 0 + } + +let private readStringFromHeap (ctx: MetadataContext) offset = + if offset = 0 then + "" + else + let streamStart = int64 ctx.StringsStreamOffset + let streamSize = int64 ctx.StringsStreamSize + let streamEnd = streamStart + streamSize + let stringStart = streamStart + int64 offset + + // Metadata indices are scoped to #Strings, not to the containing PE image. + // Failing before decoding prevents malformed offsets from reading an adjacent heap. + if + offset < 0 + || streamStart < 0L + || streamSize < 0L + || streamEnd > int64 ctx.Bytes.Length + || stringStart < streamStart + || stringStart >= streamEnd + then + raise (BadImageFormatException("String heap index is outside the #Strings stream.")) + + let start = int stringStart + let streamEnd = int streamEnd + let mutable endPos = start + + while endPos < streamEnd && ctx.Bytes[endPos] <> 0uy do + endPos <- endPos + 1 + + if endPos = streamEnd then + raise (BadImageFormatException("String heap value is not terminated inside the #Strings stream.")) + + Encoding.UTF8.GetString(ctx.Bytes, start, endPos - start) + +let private readBlobFromHeap (ctx: MetadataContext) offset = + if offset <= 0 then + Array.empty + else + let start = ctx.BlobStreamOffset + offset + let b0 = int ctx.Bytes[start] + + let length, headerSize = + if b0 &&& 0x80 = 0 then + b0, 1 + elif b0 &&& 0xC0 = 0x80 then + ((b0 &&& 0x3F) <<< 8) ||| int ctx.Bytes[start + 1], 2 + else + (((b0 &&& 0x1F) <<< 24) + ||| (int ctx.Bytes[start + 1] <<< 16) + ||| (int ctx.Bytes[start + 2] <<< 8) + ||| int ctx.Bytes[start + 3]), + 4 + + if length = 0 then + Array.empty + else + ctx.Bytes[start + headerSize .. start + headerSize + length - 1] + +type TypeDefRowData = + { + Flags: int + NameOffset: int + NamespaceOffset: int + Extends: int + FieldList: int + MethodList: int + } + +type FieldRowData = + { + Flags: int + NameOffset: int + SignatureOffset: int + } + +type MethodDefRowData = + { + RVA: int + ImplFlags: int + Flags: int + NameOffset: int + SignatureOffset: int + ParamList: int + } + +type PropertyMapRowData = { Parent: int; PropertyList: int } + +type PropertyRowData = + { + Flags: int + NameOffset: int + SignatureOffset: int + } + +type EventMapRowData = { Parent: int; EventList: int } + +type EventRowData = + { + Flags: int + NameOffset: int + EventType: int + } + +type ModuleRowData = + { + Generation: int + NameOffset: int + MvidIndex: int + EncIdIndex: int + EncBaseIdIndex: int + } + +let private rowOffset (ctx: MetadataContext) (rowSizes: int[]) (tableOffsets: int[]) tableIndex rowId = + if rowId < 1 || rowId > ctx.RowCounts[tableIndex] then + None + else + Some(tableOffsets[tableIndex] + (rowId - 1) * rowSizes[tableIndex]) + +let private readTypeDefRow ctx rowSizes tableOffsets rowId = + rowOffset ctx rowSizes tableOffsets TableIndices.TypeDef rowId + |> Option.map (fun offset -> + let extendsOffset = offset + 4 + ctx.StringIndexSize + ctx.StringIndexSize + + { + Flags = readInt32 ctx.Bytes offset + NameOffset = readHeapIndex ctx.Bytes (offset + 4) ctx.StringIndexSize + NamespaceOffset = readHeapIndex ctx.Bytes (offset + 4 + ctx.StringIndexSize) ctx.StringIndexSize + Extends = readHeapIndex ctx.Bytes extendsOffset (typeDefOrRefSize ctx.RowCounts) + FieldList = + readHeapIndex ctx.Bytes (extendsOffset + typeDefOrRefSize ctx.RowCounts) (tableIndexSize ctx.RowCounts TableIndices.Field) + MethodList = + readHeapIndex + ctx.Bytes + (extendsOffset + + typeDefOrRefSize ctx.RowCounts + + tableIndexSize ctx.RowCounts TableIndices.Field) + (tableIndexSize ctx.RowCounts TableIndices.MethodDef) + }) + +let private readFieldRow ctx rowSizes tableOffsets rowId = + rowOffset ctx rowSizes tableOffsets TableIndices.Field rowId + |> Option.map (fun offset -> + { + Flags = int (readUInt16 ctx.Bytes offset) + NameOffset = readHeapIndex ctx.Bytes (offset + 2) ctx.StringIndexSize + SignatureOffset = readHeapIndex ctx.Bytes (offset + 2 + ctx.StringIndexSize) ctx.BlobIndexSize + }) + +let private readMethodDefRow ctx rowSizes tableOffsets rowId = + rowOffset ctx rowSizes tableOffsets TableIndices.MethodDef rowId + |> Option.map (fun offset -> + { + RVA = readInt32 ctx.Bytes offset + ImplFlags = int (readUInt16 ctx.Bytes (offset + 4)) + Flags = int (readUInt16 ctx.Bytes (offset + 6)) + NameOffset = readHeapIndex ctx.Bytes (offset + 8) ctx.StringIndexSize + SignatureOffset = readHeapIndex ctx.Bytes (offset + 8 + ctx.StringIndexSize) ctx.BlobIndexSize + ParamList = + readHeapIndex + ctx.Bytes + (offset + 8 + ctx.StringIndexSize + ctx.BlobIndexSize) + (tableIndexSize ctx.RowCounts TableIndices.Param) + }) + +let private readPropertyMapRow ctx rowSizes tableOffsets rowId = + rowOffset ctx rowSizes tableOffsets TableIndices.PropertyMap rowId + |> Option.map (fun offset -> + { + Parent = readHeapIndex ctx.Bytes offset (tableIndexSize ctx.RowCounts TableIndices.TypeDef) + PropertyList = + readHeapIndex + ctx.Bytes + (offset + tableIndexSize ctx.RowCounts TableIndices.TypeDef) + (tableIndexSize ctx.RowCounts TableIndices.Property) + }) + +let private readPropertyRow ctx rowSizes tableOffsets rowId = + rowOffset ctx rowSizes tableOffsets TableIndices.Property rowId + |> Option.map (fun offset -> + { + Flags = int (readUInt16 ctx.Bytes offset) + NameOffset = readHeapIndex ctx.Bytes (offset + 2) ctx.StringIndexSize + SignatureOffset = readHeapIndex ctx.Bytes (offset + 2 + ctx.StringIndexSize) ctx.BlobIndexSize + }) + +let private readEventMapRow ctx rowSizes tableOffsets rowId = + rowOffset ctx rowSizes tableOffsets TableIndices.EventMap rowId + |> Option.map (fun offset -> + { + Parent = readHeapIndex ctx.Bytes offset (tableIndexSize ctx.RowCounts TableIndices.TypeDef) + EventList = + readHeapIndex + ctx.Bytes + (offset + tableIndexSize ctx.RowCounts TableIndices.TypeDef) + (tableIndexSize ctx.RowCounts TableIndices.Event) + }) + +let private readEventRow ctx rowSizes tableOffsets rowId = + rowOffset ctx rowSizes tableOffsets TableIndices.Event rowId + |> Option.map (fun offset -> + { + Flags = int (readUInt16 ctx.Bytes offset) + NameOffset = readHeapIndex ctx.Bytes (offset + 2) ctx.StringIndexSize + EventType = readHeapIndex ctx.Bytes (offset + 2 + ctx.StringIndexSize) (typeDefOrRefSize ctx.RowCounts) + }) + +let private readModuleRow (ctx: MetadataContext) (tableOffsets: int[]) = + if ctx.RowCounts[TableIndices.Module] < 1 then + None + else + let offset = tableOffsets[TableIndices.Module] + + Some + { + Generation = int (readUInt16 ctx.Bytes offset) + NameOffset = readHeapIndex ctx.Bytes (offset + 2) ctx.StringIndexSize + MvidIndex = readHeapIndex ctx.Bytes (offset + 2 + ctx.StringIndexSize) ctx.GuidIndexSize + EncIdIndex = readHeapIndex ctx.Bytes (offset + 2 + ctx.StringIndexSize + ctx.GuidIndexSize) ctx.GuidIndexSize + EncBaseIdIndex = + readHeapIndex ctx.Bytes (offset + 2 + ctx.StringIndexSize + ctx.GuidIndexSize + ctx.GuidIndexSize) ctx.GuidIndexSize + } + +type BaselineMetadataReader private (ctx: MetadataContext, rowSizes: int[], tableOffsets: int[]) = + + static member Create(bytes: byte[]) = + try + match createMetadataContext bytes with + | None -> None + | Some ctx -> + let rowSizes = calculateTableRowSizes ctx + let tableOffsets = calculateTableOffsets ctx rowSizes + Some(BaselineMetadataReader(ctx, rowSizes, tableOffsets)) + with + | :? IndexOutOfRangeException + | :? ArgumentOutOfRangeException -> None + + member _.RowCounts = ctx.RowCounts + + member _.TypeDefCount = ctx.RowCounts[TableIndices.TypeDef] + + member _.FieldCount = ctx.RowCounts[TableIndices.Field] + + member _.MethodDefCount = ctx.RowCounts[TableIndices.MethodDef] + + member _.PropertyMapCount = ctx.RowCounts[TableIndices.PropertyMap] + + member _.PropertyCount = ctx.RowCounts[TableIndices.Property] + + member _.EventMapCount = ctx.RowCounts[TableIndices.EventMap] + + member _.EventCount = ctx.RowCounts[TableIndices.Event] + + member _.GetModule() = readModuleRow ctx tableOffsets + + member _.GetTypeDef(rowId: int) = + readTypeDefRow ctx rowSizes tableOffsets rowId + + member _.GetField(rowId: int) = + readFieldRow ctx rowSizes tableOffsets rowId + + member _.GetMethodDef(rowId: int) = + readMethodDefRow ctx rowSizes tableOffsets rowId + + member _.GetPropertyMap(rowId: int) = + readPropertyMapRow ctx rowSizes tableOffsets rowId + + member _.GetProperty(rowId: int) = + readPropertyRow ctx rowSizes tableOffsets rowId + + member _.GetEventMap(rowId: int) = + readEventMapRow ctx rowSizes tableOffsets rowId + + member _.GetEvent(rowId: int) = + readEventRow ctx rowSizes tableOffsets rowId + + member _.GetString(offset: int) = readStringFromHeap ctx offset + + member _.GetBlob(offset: int) = readBlobFromHeap ctx offset + + member this.GetTypeFieldRange(typeRowId: int) = + match this.GetTypeDef typeRowId with + | None -> None + | Some typeDef -> + let firstField = typeDef.FieldList + + let lastField = + if typeRowId < ctx.RowCounts[TableIndices.TypeDef] then + match this.GetTypeDef(typeRowId + 1) with + | Some next -> next.FieldList - 1 + | None -> ctx.RowCounts[TableIndices.Field] + else + ctx.RowCounts[TableIndices.Field] + + if firstField <= 0 || firstField > lastField then + None + else + Some(firstField, lastField) + + member this.GetTypeMethodRange(typeRowId: int) = + match this.GetTypeDef typeRowId with + | None -> None + | Some typeDef -> + let firstMethod = typeDef.MethodList + + let lastMethod = + if typeRowId < ctx.RowCounts[TableIndices.TypeDef] then + match this.GetTypeDef(typeRowId + 1) with + | Some next -> next.MethodList - 1 + | None -> ctx.RowCounts[TableIndices.MethodDef] + else + ctx.RowCounts[TableIndices.MethodDef] + + if firstMethod <= 0 || firstMethod > lastMethod then + None + else + Some(firstMethod, lastMethod) + + member this.GetPropertyMapRange(propertyMapRowId: int) = + match this.GetPropertyMap propertyMapRowId with + | None -> None + | Some map -> + let firstProperty = map.PropertyList + + let lastProperty = + if propertyMapRowId < ctx.RowCounts[TableIndices.PropertyMap] then + match this.GetPropertyMap(propertyMapRowId + 1) with + | Some next -> next.PropertyList - 1 + | None -> ctx.RowCounts[TableIndices.Property] + else + ctx.RowCounts[TableIndices.Property] + + if firstProperty <= 0 || firstProperty > lastProperty then + None + else + Some(map.Parent, firstProperty, lastProperty) + + member this.GetEventMapRange(eventMapRowId: int) = + match this.GetEventMap eventMapRowId with + | None -> None + | Some map -> + let firstEvent = map.EventList + + let lastEvent = + if eventMapRowId < ctx.RowCounts[TableIndices.EventMap] then + match this.GetEventMap(eventMapRowId + 1) with + | Some next -> next.EventList - 1 + | None -> ctx.RowCounts[TableIndices.Event] + else + ctx.RowCounts[TableIndices.Event] + + if firstEvent <= 0 || firstEvent > lastEvent then + None + else + Some(map.Parent, firstEvent, lastEvent) + +let readModuleMvidFromBytes (bytes: byte[]) : Guid option = + try + match BaselineMetadataReader.Create bytes with + | None -> None + | Some reader -> reader.GetModule() |> Option.bind (fun m -> readGuidFromBytes bytes m.MvidIndex) + with + | :? IndexOutOfRangeException + | :? ArgumentOutOfRangeException -> None + +let private parsePdbStream (bytes: byte[]) (pdbStream: StreamHeader) = + if pdbStream.Size < 24 then + None + else + let entryPointToken = readInt32 bytes (pdbStream.Offset + 20) + if entryPointToken = 0 then None else Some entryPointToken + +let private parsePdbTablesStream (bytes: byte[]) (tablesStream: StreamHeader) = + let offset = tablesStream.Offset + let valid = readUInt64 bytes (offset + 8) + let pdbRowCounts = Array.zeroCreate 8 + let mutable rowCountOffset = offset + 24 + + for i in 0..63 do + if (valid &&& (1UL <<< i)) <> 0UL then + let count = readInt32 bytes rowCountOffset + + if i >= 0x30 && i <= 0x37 then + pdbRowCounts[i - 0x30] <- count + + rowCountOffset <- rowCountOffset + 4 + + pdbRowCounts + +let readPortablePdbMetadata (pdbBytes: byte[]) = + if pdbBytes.Length < 4 then + None + else + try + if readInt32 pdbBytes 0 <> 0x424A5342 then + None + else + let streamHeaders = parseStreamHeaders pdbBytes 0 + + let tablesStream = + findStream streamHeaders "#~" |> Option.orElse (findStream streamHeaders "#-") + + let pdbStream = findStream streamHeaders "#Pdb" + + Option.map2 + (fun stream pdb -> + { + ContentId = pdbBytes[pdb.Offset .. pdb.Offset + 19] + TableRowCounts = parsePdbTablesStream pdbBytes stream + EntryPointToken = parsePdbStream pdbBytes pdb + }) + tablesStream + (pdbStream |> Option.filter (fun stream -> stream.Size >= 24)) + with + | :? IndexOutOfRangeException + | :? ArgumentOutOfRangeException -> None diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index 4674c71421b..0690d97786a 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -1149,6 +1149,7 @@ let main6 referenceAssemblyAttribOpt = referenceAssemblyAttribOpt referenceAssemblySignatureHash = refAssemblySignatureHash pathMap = tcConfig.pathMap + moduleCustomDebugInfoRows = [] methodCustomDebugInfoRows = Map.empty }, ilxMainModule, @@ -1181,6 +1182,7 @@ let main6 referenceAssemblyAttribOpt = None referenceAssemblySignatureHash = None pathMap = tcConfig.pathMap + moduleCustomDebugInfoRows = [] methodCustomDebugInfoRows = Map.empty }, ilxMainModule, diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 520eac77c32..46f2ae1acc6 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -236,10 +236,10 @@ - - + + - - $(ProtoOutputPath)\fsc\FSharp.Build.dll - - - + + + $(ProtoOutputPath)\fsc\FSharp.Build.dll + $(ArtifactsDir)bin\FSharp.Build\$(Configuration)\netstandard2.0\FSharp.Build.dll + + + + + + + ` XML documentation tag: at compile time, documentation is copied from an external XML file selected by an XPath query and emitted into the generated documentation file. `` remains unsupported. ([Issue #19175](https://github.com/dotnet/fsharp/issues/19175), [PR #19186](https://github.com/dotnet/fsharp/pull/19186)) * Expand `` at tooling time. In IDE tooltips, completion, and signature help, documentation is inherited from base classes, interfaces, overridden members, and constructors (matched by parameter signature). The FCS Symbols API (`FSharpSymbol.XmlDoc`) additionally resolves explicit `cref` targets, but does not expand constructor inheritance. The compiler emits the tag verbatim into generated XML documentation files, matching C#; `` is not implemented. ([Issue #19175](https://github.com/dotnet/fsharp/issues/19175), [PR #19188](https://github.com/dotnet/fsharp/pull/19188)) +* Add symbol and type highlighting to F# diagnostics ([PR #20097](https://github.com/dotnet/fsharp/pull/20097)) ### Improved diff --git a/proto.proj b/proto.proj index 313cf2efdca..248c30fcbf1 100644 --- a/proto.proj +++ b/proto.proj @@ -5,6 +5,7 @@ + diff --git a/src/Compiler/AbstractIL/ilreflect.fs b/src/Compiler/AbstractIL/ilreflect.fs index eab257c1573..9aa9d6403a0 100644 --- a/src/Compiler/AbstractIL/ilreflect.fs +++ b/src/Compiler/AbstractIL/ilreflect.fs @@ -14,12 +14,18 @@ open Internal.Utilities.Library open FSharp.Compiler.AbstractIL.Diagnostics open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.DiagnosticsLogger +open FSharp.Compiler.Text open FSharp.Compiler.IO open FSharp.Compiler.Text.Range open FSharp.Core.Printf let codeLabelOrder = ComparisonIdentity.Structural +let richTextOfILTypeRef (tref: ILTypeRef) = + tref.Enclosing @ [ tref.Name ] + |> List.map RichText.ofQualifiedTypeName + |> RichText.concatWith (RichText.mkPunctuation "+") + // Convert the output of convCustomAttr let wrapCustomAttr setCustomAttr (cinfo, bytes) = setCustomAttr (cinfo, bytes) @@ -473,7 +479,7 @@ type cenv = override x.ToString() = "" -let convResolveAssemblyRef (cenv: cenv) (asmref: ILAssemblyRef) qualifiedName = +let convResolveAssemblyRef (cenv: cenv) (asmref: ILAssemblyRef) (tref: ILTypeRef) = let assembly = match cenv.resolveAssemblyRef asmref with | Some(Choice1Of2 path) -> @@ -486,10 +492,20 @@ let convResolveAssemblyRef (cenv: cenv) (asmref: ILAssemblyRef) qualifiedName = let asmName = convAssemblyRef asmref FileSystem.AssemblyLoader.AssemblyLoad asmName - let typT = assembly.GetType qualifiedName + let typT = assembly.GetType tref.BasicQualifiedName match typT with - | null -> error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, asmref.QualifiedName), range0)) + | null -> + error ( + Error( + FSComp.SR.itemNotFoundDuringDynamicCodeGen ( + RichText.mkText "type", + richTextOfILTypeRef tref, + RichText.mkText asmref.QualifiedName + ), + range0 + ) + ) | res -> res /// Convert an Abstract IL type reference to Reflection.Emit System.Type value. @@ -500,19 +516,26 @@ let convResolveAssemblyRef (cenv: cenv) (asmref: ILAssemblyRef) qualifiedName = // [ns] , name -> ns+name // [ns;typeA;typeB], name -> ns+typeA+typeB+name let convTypeRefAux (cenv: cenv) (tref: ILTypeRef) = - let qualifiedName = - (String.concat "+" (tref.Enclosing @ [ tref.Name ])).Replace(",", @"\,") - match tref.Scope with - | ILScopeRef.Assembly asmref -> convResolveAssemblyRef cenv asmref qualifiedName + | ILScopeRef.Assembly asmref -> convResolveAssemblyRef cenv asmref tref | ILScopeRef.Module _ | ILScopeRef.Local -> - let typT = Type.GetType qualifiedName + let typT = Type.GetType tref.BasicQualifiedName match typT with - | null -> error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, ""), range0)) + | null -> + error ( + Error( + FSComp.SR.itemNotFoundDuringDynamicCodeGen ( + RichText.mkText "type", + richTextOfILTypeRef tref, + RichText.mkText "" + ), + range0 + ) + ) | res -> res - | ILScopeRef.PrimaryAssembly -> convResolveAssemblyRef cenv cenv.ilg.primaryAssemblyRef qualifiedName + | ILScopeRef.PrimaryAssembly -> convResolveAssemblyRef cenv cenv.ilg.primaryAssemblyRef tref /// The (local) emitter env (state). Some of these fields are effectively global accumulators /// and could be placed as hash tables in the global environment. @@ -705,7 +728,16 @@ let rec convTypeSpec cenv emEnv preferCreated (tspec: ILTypeSpec) = match res with | Null -> - error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", tspec.TypeRef.QualifiedName, tspec.Scope.QualifiedName), range0)) + error ( + Error( + FSComp.SR.itemNotFoundDuringDynamicCodeGen ( + RichText.mkText "type", + richTextOfILTypeRef tspec.TypeRef, + RichText.mkText tspec.Scope.QualifiedName + ), + range0 + ) + ) | NonNull res -> res and convTypeAux cenv emEnv preferCreated ty = @@ -837,10 +869,10 @@ let queryableTypeGetField _emEnv (parentT: Type) (fref: ILFieldRef) = error ( Error( FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ( - "field", - fref.Name, - fref.DeclaringTypeRef.FullName, - fref.DeclaringTypeRef.Scope.QualifiedName + RichText.mkText "field", + RichText.mkMember fref.Name, + RichText.ofQualifiedTypeName fref.DeclaringTypeRef.FullName, + RichText.mkText fref.DeclaringTypeRef.Scope.QualifiedName ), range0 ) @@ -1046,10 +1078,10 @@ let convMethodRef cenv emEnv (parentTI: Type) (mref: ILMethodRef) = error ( Error( FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ( - "method", - mref.Name, - parentTI.FullName |> string, - parentTI.Assembly.FullName |> string + RichText.mkText "method", + RichText.mkMember mref.Name, + RichText.ofQualifiedTypeName (parentTI.FullName |> string), + RichText.mkText (parentTI.Assembly.FullName |> string) ), range0 ) @@ -1092,10 +1124,10 @@ let queryableTypeGetConstructor cenv emEnv (parentT: Type) (mref: ILMethodRef) = error ( Error( FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ( - "constructor", - mref.Name, - parentT.FullName |> string, - parentT.Assembly.FullName |> string + RichText.mkText "constructor", + RichText.mkMember mref.Name, + RichText.ofQualifiedTypeName (parentT.FullName |> string), + RichText.mkText (parentT.Assembly.FullName |> string) ), range0 ) @@ -1132,10 +1164,10 @@ let convConstructorSpec cenv emEnv (mspec: ILMethodSpec) = error ( Error( FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ( - "constructor", - "", - parentTI.FullName |> string, - parentTI.Assembly.FullName |> string + RichText.mkText "constructor", + RichText.mkMember "", + RichText.ofQualifiedTypeName (parentTI.FullName |> string), + RichText.mkText (parentTI.Assembly.FullName |> string) ), range0 ) diff --git a/src/Compiler/AbstractIL/ilreflect.fsi b/src/Compiler/AbstractIL/ilreflect.fsi index 79fb6f8535c..bfd0e559b26 100644 --- a/src/Compiler/AbstractIL/ilreflect.fsi +++ b/src/Compiler/AbstractIL/ilreflect.fsi @@ -7,6 +7,11 @@ open System.Reflection open System.Reflection.Emit open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.Text + +/// A type reference's name as reflection spells it, classifying the namespace, the enclosing types and +/// the name itself separately. Only a reference is at hand, so what kind of type it is is not known. +val richTextOfILTypeRef: tref: ILTypeRef -> RichText val mkDynamicAssemblyAndModule: assemblyName: string * optimize: bool * collectible: bool -> AssemblyBuilder * ModuleBuilder diff --git a/src/Compiler/AbstractIL/ilsign.fs b/src/Compiler/AbstractIL/ilsign.fs index 36d5b2d3563..40fccefbf47 100644 --- a/src/Compiler/AbstractIL/ilsign.fs +++ b/src/Compiler/AbstractIL/ilsign.fs @@ -11,6 +11,7 @@ open System.Reflection.PortableExecutable open System.Security.Cryptography open System.Runtime.InteropServices +open FSharp.Compiler.Text open Internal.Utilities.Library type KeyType = @@ -33,7 +34,7 @@ let BLOBHEADER_LENGTH = int 20 let RSA_PUB_MAGIC = int 0x31415352 let RSA_PRIV_MAGIC = int 0x32415352 -let getResourceString (_, str) = str +let getResourceString (_, message: RichText) = message.Text [] type ByteArrayUnion = @@ -351,7 +352,7 @@ let signerSignatureSize (pk: pubkey) : int = signatureSize pk let signerSignStreamWithKeyPair stream keyBlob = signStream stream keyBlob let failWithContainerSigningUnsupportedOnThisPlatform () = - failwith (FSComp.SR.containerSigningUnsupportedOnThisPlatform () |> snd) + failwith (FSComp.SR.containerSigningUnsupportedOnThisPlatform () |> getResourceString) //--------------------------------------------------------------------- // Strong name signing diff --git a/src/Compiler/AbstractIL/ilwrite.fs b/src/Compiler/AbstractIL/ilwrite.fs index 5c387dc7e41..f626e1e56ef 100644 --- a/src/Compiler/AbstractIL/ilwrite.fs +++ b/src/Compiler/AbstractIL/ilwrite.fs @@ -7,6 +7,7 @@ open System.Collections.Generic open System.IO open Internal.Utilities +open FSharp.Compiler.Text open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.Diagnostics open FSharp.Compiler.AbstractIL.BinaryConstants @@ -694,7 +695,7 @@ let rec GenTypeDefPass1 enc cenv (tdef: ILTypeDef) = // Verify that the typedef contains fewer than maximumMethodsPerDotNetType let count = tdef.Methods.AsArray().Length if count > maximumMethodsPerDotNetType then - errorR(Error(FSComp.SR.tooManyMethodsInDotNetTypeWritingAssembly (tdef.Name, count, maximumMethodsPerDotNetType), rangeStartup)) + errorR(Error(FSComp.SR.tooManyMethodsInDotNetTypeWritingAssembly (RichText.ofQualifiedTypeName tdef.Name, count, maximumMethodsPerDotNetType), rangeStartup)) GenTypeDefsPass1 (enc@[tdef.Name]) cenv (tdef.NestedTypes.AsList()) diff --git a/src/Compiler/Checking/AccessibilityLogic.fs b/src/Compiler/Checking/AccessibilityLogic.fs index 6dd833cac8c..ddae64243ad 100644 --- a/src/Compiler/Checking/AccessibilityLogic.fs +++ b/src/Compiler/Checking/AccessibilityLogic.fs @@ -6,6 +6,7 @@ module internal FSharp.Compiler.AccessibilityLogic open Internal.Utilities.Library open FSharp.Compiler open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.Text open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.Import open FSharp.Compiler.Infos @@ -179,7 +180,7 @@ let IsEntityAccessible amap m ad (tcref:TyconRef) = let CheckTyconAccessible amap m ad tcref = let res = IsEntityAccessible amap m ad tcref if not res then - errorR(Error(FSComp.SR.typeIsNotAccessible tcref.DisplayName, m)) + errorR(Error(FSComp.SR.typeIsNotAccessible (richTextOfEntityRef tcref), m)) res /// Indicates if a type definition and its representation contents are accessible @@ -192,7 +193,7 @@ let CheckTyconReprAccessible amap m ad tcref = CheckTyconAccessible amap m ad tcref && (let res = IsAccessible ad tcref.TypeReprAccessibility if not res then - errorR (Error (FSComp.SR.unionCasesAreNotAccessible tcref.DisplayName, m)) + errorR (Error(FSComp.SR.unionCasesAreNotAccessible (richTextOfEntityRef tcref), m)) res) /// Indicates if a type is accessible (both definition and instantiation) @@ -338,9 +339,9 @@ let IsILPropInfoAccessible g amap m ad pinfo = let IsValAccessible ad (vref:ValRef) = vref.Accessibility |> IsAccessible ad -let CheckValAccessible m ad (vref:ValRef) = +let CheckValAccessible g m ad (vref:ValRef) = if not (IsValAccessible ad vref) then - errorR (Error (FSComp.SR.valueIsNotAccessible vref.DisplayName, m)) + errorR (Error(FSComp.SR.valueIsNotAccessible (richTextOfValName g vref.Deref), m)) let IsUnionCaseAccessible amap m ad (ucref:UnionCaseRef) = IsTyconReprAccessible amap m ad ucref.TyconRef && @@ -350,7 +351,7 @@ let CheckUnionCaseAccessible amap m ad (ucref:UnionCaseRef) = CheckTyconReprAccessible amap m ad ucref.TyconRef && (let res = IsAccessible ad ucref.UnionCase.Accessibility if not res then - errorR (Error (FSComp.SR.unionCaseIsNotAccessible ucref.CaseName, m)) + errorR (Error(FSComp.SR.unionCaseIsNotAccessible (RichText.mkUnionCase ucref.CaseName), m)) res) let IsRecdFieldAccessible amap m ad (rfref:RecdFieldRef) = @@ -361,7 +362,7 @@ let CheckRecdFieldAccessible amap m ad (rfref:RecdFieldRef) = CheckTyconReprAccessible amap m ad rfref.TyconRef && (let res = IsAccessible ad rfref.RecdField.Accessibility if not res then - errorR (Error (FSComp.SR.fieldIsNotAccessible rfref.FieldName, m)) + errorR (Error(FSComp.SR.fieldIsNotAccessible (RichText.mkRecordField rfref.FieldName), m)) res) let CheckRecdFieldInfoAccessible amap m ad (rfinfo:RecdFieldInfo) = @@ -369,7 +370,7 @@ let CheckRecdFieldInfoAccessible amap m ad (rfinfo:RecdFieldInfo) = let CheckILFieldInfoAccessible g amap m ad finfo = if not (IsILFieldInfoAccessible g amap m ad finfo) then - errorR (Error (FSComp.SR.structOrClassFieldIsNotAccessible finfo.FieldName, m)) + errorR (Error(FSComp.SR.structOrClassFieldIsNotAccessible (RichText.mkField finfo.FieldName), m)) /// Uses a separate accessibility domains for containing type and method itself /// This makes sense cases like diff --git a/src/Compiler/Checking/AccessibilityLogic.fsi b/src/Compiler/Checking/AccessibilityLogic.fsi index 3f05f0d1417..2f8bfc4eb41 100644 --- a/src/Compiler/Checking/AccessibilityLogic.fsi +++ b/src/Compiler/Checking/AccessibilityLogic.fsi @@ -86,7 +86,7 @@ val IsILPropInfoAccessible: val IsValAccessible: ad: AccessorDomain -> vref: ValRef -> bool -val CheckValAccessible: m: range -> ad: AccessorDomain -> vref: ValRef -> unit +val CheckValAccessible: g: TcGlobals -> m: range -> ad: AccessorDomain -> vref: ValRef -> unit val IsUnionCaseAccessible: amap: ImportMap -> m: range -> ad: AccessorDomain -> ucref: TypedTree.UnionCaseRef -> bool diff --git a/src/Compiler/Checking/AttributeChecking.fs b/src/Compiler/Checking/AttributeChecking.fs index 3b32bd29f3b..8e7b32caea8 100755 --- a/src/Compiler/Checking/AttributeChecking.fs +++ b/src/Compiler/Checking/AttributeChecking.fs @@ -263,7 +263,7 @@ let MethInfoHasWellKnownAttributeSpec (g: TcGlobals) (m: range) (spec: WellKnown let private reportObsoleteDiagnostic m diagnostic = match diagnostic with | Some(ObsoleteDiagnosticInfo(isError, id, msg, urlFormat)) -> - let obsoleteDiagnostic = ObsoleteDiagnostic(isError, id, msg, urlFormat, m) + let obsoleteDiagnostic = ObsoleteDiagnostic(isError, id, msg |> Option.map RichText.mkText, urlFormat, m) if isError then ErrorD(obsoleteDiagnostic) else @@ -396,7 +396,7 @@ let private CheckCompilerMessageAttribute g attribs m = trackErrors { match attribs with | EntityAttrib g WellKnownEntityAttributes.CompilerMessageAttribute (Attrib(unnamedArgs= [ AttribStringArg s ; AttribInt32Arg n ]; propVal= namedArgs)) -> - let msg = UserCompilerMessage(s, n, m) + let msg = UserCompilerMessage(RichText.mkText s, n, m) let isError = match namedArgs with | ExtractAttribNamedArg "IsError" (AttribBoolArg v) -> v @@ -614,7 +614,7 @@ let CheckMethInfoAttributes g m tyargsOpt (minfo: MethInfo) = trackErrors { do! CheckFSharpAttributes g fsAttribs m if Option.isNone tyargsOpt && (attribsHaveValFlag g WellKnownValAttributes.RequiresExplicitTypeArgumentsAttribute fsAttribs) then - do! ErrorD(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(minfo.LogicalName), m)) + do! ErrorD(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(RichText.mkMethod minfo.LogicalName), m)) } Some res) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index b6fdfadb062..9d48a88a95f 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -407,7 +407,7 @@ let CheckDuplicates (idf: _ -> Ident) k elems = let private CheckDuplicatesArgNames (synVal: SynValSig) m = let argNames = synVal.SynInfo.ArgNames |> List.duplicates for name in argNames do - errorR(Error((FSComp.SR.chkDuplicatedMethodParameter(name), m))) + errorR(Error(FSComp.SR.chkDuplicatedMethodParameter(RichText.mkParameter name), m)) let private CheckDuplicatesAbstractMethodParamsSig (typeSpecs: SynTypeDefnSig list) = for SynTypeDefnSig(typeRepr= trepr) in typeSpecs do @@ -511,7 +511,7 @@ module TcRecdUnionAndEnumDeclarations = let g = cenv.g let name = id.idText if name = "Tags" then - errorR(Error(FSComp.SR.tcUnionCaseNameConflictsWithGeneratedType(name, "Tags"), id.idRange)) + errorR(Error(FSComp.SR.tcUnionCaseNameConflictsWithGeneratedType(RichText.mkUnionCase name, RichText.mkClass "Tags"), id.idRange)) CheckNamespaceModuleOrTypeName g id @@ -527,7 +527,7 @@ module TcRecdUnionAndEnumDeclarations = elems |> List.iteri (fun i (uc1: Ident) -> elems |> List.iteri (fun j (uc2: Ident) -> if j > i && uc1.idText = uc2.idText then - errorR(Error(FSComp.SR.tcFieldNameIsUsedModeThanOnce(uc1.idText), uc1.idRange)))) + errorR(Error(FSComp.SR.tcFieldNameIsUsedModeThanOnce(RichText.mkRecordField uc1.idText), uc1.idRange)))) let ValidateFieldNames (synFields: SynField list, tastFields: RecdField list) = let fields = synFields |> List.choose (function SynField(idOpt = Some ident) -> Some ident | _ -> None) @@ -541,7 +541,7 @@ module TcRecdUnionAndEnumDeclarations = match sf, synField with | SynField(idOpt = Some id), SynField(idOpt = None) | SynField(idOpt = None), SynField(idOpt = Some id) -> - errorR(Error(FSComp.SR.tcFieldNameConflictsWithGeneratedNameForAnonymousField(id.idText), id.idRange)) + errorR(Error(FSComp.SR.tcFieldNameConflictsWithGeneratedNameForAnonymousField(RichText.mkRecordField id.idText), id.idRange)) | _ -> () | _ -> seen.Add(f.LogicalName, sf)) @@ -687,7 +687,7 @@ let PublishInterface (cenv: cenv) denv (tcref: TyconRef) m isCompGen interfaceTy let g = cenv.g if not (isInterfaceTy g interfaceTy) then - errorR(Error(FSComp.SR.tcTypeIsNotInterfaceType1(NicePrint.minimalStringOfType denv interfaceTy), m)) + errorR(Error(FSComp.SR.tcTypeIsNotInterfaceType1(NicePrint.minimalRichTextOfType denv interfaceTy), m)) if tcref.HasInterface g interfaceTy then errorR(Error(FSComp.SR.tcDuplicateSpecOfInterface(), m)) @@ -767,13 +767,13 @@ let TcOpenModuleOrNamespaceDecl tcSink g amap scopem env (longId, m) = modrefs |> List.iter (fun (_, modref, _) -> if modref.IsModule && EntityHasWellKnownAttribute g WellKnownEntityAttributes.RequireQualifiedAccessAttribute modref.Deref then - errorR(Error(FSComp.SR.tcModuleRequiresQualifiedAccess(fullDisplayTextOfModRef modref), m))) + errorR(Error(FSComp.SR.tcModuleRequiresQualifiedAccess(richTextOfQualifiedModRef modref), m))) // Bug FSharp 1.0 3133: 'open Lexing'. Skip this warning if we successfully resolved to at least a module name if not (modrefs |> List.exists (fun (_, modref, _) -> modref.IsModule && not (EntityHasWellKnownAttribute g WellKnownEntityAttributes.RequireQualifiedAccessAttribute modref.Deref))) then modrefs |> List.iter (fun (_, modref, _) -> if IsPartiallyQualifiedNamespace modref then - errorR(Error(FSComp.SR.tcOpenUsedWithPartiallyQualifiedPath(fullDisplayTextOfModRef modref), m))) + errorR(Error(FSComp.SR.tcOpenUsedWithPartiallyQualifiedPath(richTextOfQualifiedModRef modref), m))) let modrefs = List.map p23 modrefs modrefs |> List.iter (fun modref -> CheckEntityAttributes g modref m |> CommitOperationResult) @@ -788,7 +788,7 @@ let TcOpenTypeDecl (cenv: cenv) scopem env (synType: SynType, m) = let ty, _tpenv = TcType cenv NoNewTypars CheckCxs ItemOccurrence.Open WarnOnIWSAM.Yes env emptyUnscopedTyparEnv synType if not (isAppTy g ty) then - errorR(Error(FSComp.SR.tcNamedTypeRequired("open type"), m)) + errorR(Error(FSComp.SR.tcNamedTypeRequired(RichText.mkKeyword "open type"), m)) if isByrefTy g ty then errorR(Error(FSComp.SR.tcIllegalByrefsInOpenTypeDeclaration(), m)) @@ -839,12 +839,12 @@ module AddAugmentationDeclarations = let hasExplicitIStructuralComparable = tycon.HasInterface g g.mk_IStructuralComparable_ty if hasExplicitIComparable then - errorR(Error(FSComp.SR.tcImplementsIComparableExplicitly(tycon.DisplayName), m)) + errorR(Error(FSComp.SR.tcImplementsIComparableExplicitly(richTextOfEntity tycon), m)) elif hasExplicitGenericIComparable then - errorR(Error(FSComp.SR.tcImplementsGenericIComparableExplicitly(tycon.DisplayName), m)) + errorR(Error(FSComp.SR.tcImplementsGenericIComparableExplicitly(richTextOfEntity tycon), m)) elif hasExplicitIStructuralComparable then - errorR(Error(FSComp.SR.tcImplementsIStructuralComparableExplicitly(tycon.DisplayName), m)) + errorR(Error(FSComp.SR.tcImplementsIStructuralComparableExplicitly(richTextOfEntity tycon), m)) else let hasExplicitGenericIComparable = tycon.HasInterface g genericIComparableTy let cvspec1, cvspec2 = AugmentTypeDefinitions.MakeValsForCompareAugmentation g tcref @@ -870,7 +870,7 @@ module AddAugmentationDeclarations = let hasExplicitIStructuralEquatable = tycon.HasInterface g g.mk_IStructuralEquatable_ty if hasExplicitIStructuralEquatable then - errorR(Error(FSComp.SR.tcImplementsIStructuralEquatableExplicitly(tycon.DisplayName), m)) + errorR(Error(FSComp.SR.tcImplementsIStructuralEquatableExplicitly(richTextOfEntity tycon), m)) else let augmentation = AugmentTypeDefinitions.MakeValsForEqualityWithComparerAugmentation g tcref PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralEquatable_ty @@ -925,7 +925,7 @@ module AddAugmentationDeclarations = let hasExplicitGenericIEquatable = tcaugHasNominalInterface g tcaug g.system_GenericIEquatable_tcref if hasExplicitGenericIEquatable then - errorR(Error(FSComp.SR.tcImplementsIEquatableExplicitly(tycon.DisplayName), m)) + errorR(Error(FSComp.SR.tcImplementsIEquatableExplicitly(richTextOfEntity tycon), m)) // Note: only provide the equals method if Equals is not implemented explicitly, and // we're actually generating Hash/Equals for this type @@ -1163,7 +1163,7 @@ module MutRecBindingChecking = let allDo = letBinds |> List.forall (function SynBinding(kind=SynBindingKind.Do) -> true | _ -> false) // Code for potential future design change to allow functions-compiled-as-members in structs if allDo then - errorR(Deprecated(FSComp.SR.tcStructsMayNotContainDoBindings(), (trimRangeToLine m))) + errorR(Deprecated(RichText.mkText (FSComp.SR.tcStructsMayNotContainDoBindings()), (trimRangeToLine m))) else // Code for potential future design change to allow functions-compiled-as-members in structs errorR(Error(FSComp.SR.tcStructsMayNotContainLetBindings(), (trimRangeToLine m))) @@ -1464,7 +1464,7 @@ module MutRecBindingChecking = match TryFindIntrinsicMethInfo cenv.infoReader bind.Var.Range ad nm ty, TryFindIntrinsicPropInfo cenv.infoReader bind.Var.Range ad nm ty with | [], [] -> () - | _ -> errorR (Error(FSComp.SR.tcMemberAndLocalClassBindingHaveSameName nm, bind.Var.Range)) + | _ -> errorR (Error(FSComp.SR.tcMemberAndLocalClassBindingHaveSameName (RichText.mkMember nm), bind.Var.Range)) // Also add static entries to the envInstance if necessary let envInstance = (if isStatic then (binds, envInstance) ||> List.foldBack (fun b e -> AddLocalVal g cenv.tcSink scopem b.Var e) else env) @@ -1601,7 +1601,7 @@ module MutRecBindingChecking = collectedBinds.Add pgbrind yield pgbrind ]) - CheckRecursiveInlineGroup (List.ofSeq collectedBinds) + CheckRecursiveInlineGroup g (List.ofSeq collectedBinds) result @@ -1785,7 +1785,7 @@ module MutRecBindingChecking = let modrefs = mvvs |> List.map p23 if not (isNil modrefs) && modrefs |> List.forall (fun modref -> modref.IsNamespace) then - errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head modrefs)), m)) + errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(richTextOfQualifiedModRef (List.head modrefs)), m)) let modrefs = modrefs |> List.filter (fun mvv -> not mvv.IsNamespace) @@ -1937,7 +1937,7 @@ module MutRecBindingChecking = for extraTypar in allExtraGeneralizableTypars do if Zset.memberOf freeInInitialEnv extraTypar then let ty = mkTyparTy extraTypar - errorR(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty), extraTypar.Range)) + errorR(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyRichTextOfTy denv ty), extraTypar.Range)) // Solve any type variables in any part of the overall type signature of the class whose // constraints involve generalized type variables. @@ -2265,9 +2265,9 @@ module TyconConstraintInference = failwith "unreachable" | Some (ty, _) -> if isTyparTy g ty then - errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied1(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty), tycon.Range)) + errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied1(richTextOfEntity tycon, NicePrint.prettyRichTextOfTy denv ty), tycon.Range)) else - errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied2(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty), tycon.Range)) + errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied2(richTextOfEntity tycon, NicePrint.prettyRichTextOfTy denv ty), tycon.Range)) else match structuralTypes |> List.tryFind (fst >> checkIfFieldTypeSupportsComparison tycon >> not) with | None -> @@ -2278,9 +2278,9 @@ module TyconConstraintInference = // PERF: this call to prettyStringOfTy is always being executed, even when the warning // is not being reported (the normal case). if isTyparTy g ty then - warning(Error(FSComp.SR.tcNoComparisonNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty, tycon.DisplayName), tycon.Range)) + warning(Error(FSComp.SR.tcNoComparisonNeeded1(richTextOfEntity tycon, NicePrint.prettyRichTextOfTy denv ty, richTextOfEntity tycon), tycon.Range)) else - warning(Error(FSComp.SR.tcNoComparisonNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty, tycon.DisplayName), tycon.Range)) + warning(Error(FSComp.SR.tcNoComparisonNeeded2(richTextOfEntity tycon, NicePrint.prettyRichTextOfTy denv ty, richTextOfEntity tycon), tycon.Range)) res) @@ -2388,9 +2388,9 @@ module TyconConstraintInference = failwith "unreachable" | Some (ty, _) -> if isTyparTy g ty then - errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied1(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty), tycon.Range)) + errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied1(richTextOfEntity tycon, NicePrint.prettyRichTextOfTy denv ty), tycon.Range)) else - errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied2(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty), tycon.Range)) + errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied2(richTextOfEntity tycon, NicePrint.prettyRichTextOfTy denv ty), tycon.Range)) else if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then match structuralTypes |> List.tryFind (fst >> checkIfFieldTypeSupportsEquality tycon >> not) with @@ -2399,9 +2399,9 @@ module TyconConstraintInference = failwith "unreachable" | Some (ty, _) -> if isTyparTy g ty then - warning(Error(FSComp.SR.tcNoEqualityNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty, tycon.DisplayName), tycon.Range)) + warning(Error(FSComp.SR.tcNoEqualityNeeded1(richTextOfEntity tycon, NicePrint.prettyRichTextOfTy denv ty, richTextOfEntity tycon), tycon.Range)) else - warning(Error(FSComp.SR.tcNoEqualityNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty, tycon.DisplayName), tycon.Range)) + warning(Error(FSComp.SR.tcNoEqualityNeeded2(richTextOfEntity tycon, NicePrint.prettyRichTextOfTy denv ty, richTextOfEntity tycon), tycon.Range)) res) @@ -3171,7 +3171,7 @@ module EstablishTypeDefinitionCores = if not isRootGenerated then let desig = theRootTypeWithRemapping.TypeProviderDesignation let nm = theRootTypeWithRemapping.PUntaint((fun st -> string st.FullName), m) - error(Error(FSComp.SR.etErasedTypeUsedInGeneration(desig, nm), m)) + error(Error(FSComp.SR.etErasedTypeUsedInGeneration(RichText.mkText desig, RichText.ofQualifiedTypeName nm), m)) cenv.createsGeneratedProvidedTypes <- true @@ -3212,7 +3212,7 @@ module EstablishTypeDefinitionCores = if not isGenerated then let desig = st.TypeProviderDesignation let nm = st.PUntaint((fun st -> string st.FullName), m) - error(Error(FSComp.SR.etErasedTypeUsedInGeneration(desig, nm), m)) + error(Error(FSComp.SR.etErasedTypeUsedInGeneration(RichText.mkText desig, RichText.ofQualifiedTypeName nm), m)) // Embed the type into the module we're compiling let cpath = eref.CompilationPath.NestedCompPath eref.LogicalName ModuleOrNamespaceKind.ModuleOrType @@ -3354,7 +3354,7 @@ module EstablishTypeDefinitionCores = | CompiledTypeRepr.ILAsmOpen _ -> () | CompiledTypeRepr.ILAsmNamed _ -> if tcref.CompiledRepresentationForNamedType.FullName = fullName then - warning(Error(FSComp.SR.chkAttributeAliased(fullName), tycon.Id.idRange)) + warning(Error(FSComp.SR.chkAttributeAliased(richTextOfEntityRefName tcref fullName), tycon.Id.idRange)) | _ -> () // Check for attributes in unit-of-measure declarations @@ -3371,7 +3371,7 @@ module EstablishTypeDefinitionCores = let ftyvs = freeInTypeLeftToRight g false ty let typars = tycon.Typars if ftyvs.Length <> typars.Length then - errorR(Deprecated(FSComp.SR.tcTypeAbbreviationHasTypeParametersMissingOnType(), tycon.Range)) + errorR(Deprecated(RichText.mkText (FSComp.SR.tcTypeAbbreviationHasTypeParametersMissingOnType()), tycon.Range)) if firstPass then tycon.SetTypeAbbrev (Some ty) @@ -4590,7 +4590,7 @@ module TcDeclarations = | Exception exn -> if inSig && List.isSingleton longPath then - errorR(Deprecated(FSComp.SR.tcReservedSyntaxForAugmentation(), m)) + errorR(Deprecated(RichText.mkText (FSComp.SR.tcReservedSyntaxForAugmentation()), m)) ForceRaise (Exception exn) tcref @@ -4638,18 +4638,18 @@ module TcDeclarations = elif isInSameModuleOrNamespace && not isInterfaceOrDelegateOrEnum then // For historical reasons we only give a warning for incorrect type parameters on intrinsic extensions if nReqTypars <> synTypars.Length then - errorR(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) + errorR(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(richTextOfEntityRefName tcref tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) if not (checkTyparsForExtension()) then - warning(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) + warning(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(richTextOfEntityRefName tcref tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) // Note we return 'reqTypars' for intrinsic extensions since we may only have given warnings IntrinsicExtensionBinding, tcref, reqTypars else if isInSameModuleOrNamespace && isDelegateOrEnum then errorR(Error(FSComp.SR.tcMembersThatExtendInterfaceMustBePlacedInSeparateModule(), tcref.Range)) if nReqTypars <> synTypars.Length then - error(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) + error(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(richTextOfEntityRefName tcref tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) if not (checkTyparsForExtension()) then - errorR(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) + errorR(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(richTextOfEntityRefName tcref tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) ExtrinsicExtensionBinding, tcref, declaredTypars @@ -5317,7 +5317,7 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE let modrefs = unfilteredModrefs |> List.filter (fun modref -> not modref.IsNamespace) if not (List.isEmpty unfilteredModrefs) && List.isEmpty modrefs then - errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head unfilteredModrefs)), m)) + errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(richTextOfQualifiedModRef (List.head unfilteredModrefs)), m)) if List.isEmpty modrefs then return env else modrefs |> List.iter (fun modref -> CheckEntityAttributes g modref m |> CommitOperationResult) @@ -5500,7 +5500,7 @@ let TcMutRecDefnsEscapeCheck (binds: MutRecShapes<_, _, _>) env = let checkTycon (tycon: Tycon) = if not tycon.IsTypeAbbrev && Zset.contains tycon freeInEnv then let nm = tycon.DisplayName - errorR(Error(FSComp.SR.tcTypeUsedInInvalidWay(nm, nm, nm), tycon.Range)) + errorR(Error(FSComp.SR.tcTypeUsedInInvalidWay(richTextOfEntityName tycon nm, richTextOfEntityName tycon nm, richTextOfEntityName tycon nm), tycon.Range)) binds |> MutRecShapes.iterTycons (fst >> Option.iter checkTycon) @@ -5509,7 +5509,7 @@ let TcMutRecDefnsEscapeCheck (binds: MutRecShapes<_, _, _>) env = for bind in binds do if Zset.contains bind.Var freeInEnv then let nm = bind.Var.DisplayName - errorR(Error(FSComp.SR.tcMemberUsedInInvalidWay(nm, nm, nm), bind.Var.Range)) + errorR(Error(FSComp.SR.tcMemberUsedInInvalidWay(RichText.mkMember nm, RichText.mkMember nm, RichText.mkMember nm), bind.Var.Range)) binds |> MutRecShapes.iterTyconsAndLets (snd >> checkBinds) checkBinds @@ -5940,7 +5940,7 @@ and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 let ApplyAssemblyLevelAutoOpenAttributeToTcEnv g amap (ccu: CcuThunk) scopem env (p, root) = let warn() = - warning(Error(FSComp.SR.tcAttributeAutoOpenWasIgnored(p, ccu.AssemblyName), scopem)) + warning(Error(FSComp.SR.tcAttributeAutoOpenWasIgnored(RichText.mkModule p, RichText.mkText ccu.AssemblyName), scopem)) [], env let p = splitNamespace p match List.tryFrontAndBack p with @@ -6272,7 +6272,7 @@ let CheckOneImplFile match attrName with | "System.Reflection.AssemblyFileVersionAttribute" //TODO compile error like c# compiler? | "System.Reflection.AssemblyVersionAttribute" when not (isValid()) -> - warning(Error(FSComp.SR.fscBadAssemblyVersion(attrName, version), range)) + warning(Error(FSComp.SR.fscBadAssemblyVersion(RichText.mkClass attrName, RichText.mkText version), range)) | _ -> () | _ -> ()) diff --git a/src/Compiler/Checking/CheckFormatStrings.fs b/src/Compiler/Checking/CheckFormatStrings.fs index 19c91858df6..1c60eac9db6 100644 --- a/src/Compiler/Checking/CheckFormatStrings.fs +++ b/src/Compiler/Checking/CheckFormatStrings.fs @@ -460,8 +460,7 @@ let parseFormatStringInternal // residue of hole "...{n}..." in interpolated strings become %P(...) | 'P' when isInterpolated -> - let code, message = FSComp.SR.alwaysUseTypedStringInterpolation() - warning(DiagnosticWithText(code, message, m)) + warning(Error(FSComp.SR.alwaysUseTypedStringInterpolation(), m)) checkOtherFlags ch let i = requireAndSkipInterpolationHoleFormat (i+1) // Note, the fragCol doesn't advance at all as these are magically inserted. @@ -499,7 +498,7 @@ let parseFormatStringInternal | '%' -> // This allows for things like `printf "%-4.2%"` to compile and print just a `%` // For now we are adding a warning, but keeping this behavior. - warning(DiagnosticWithText(3376, FSComp.SR.forBadFormatSpecifierGeneral("%"), m)) + warning(Error((3376, RichText.mkText (FSComp.SR.forBadFormatSpecifierGeneral("%"))), m)) collectSpecifierLocation fragLine fragCol 0 appendToDotnetFormatString "%" parseLoop acc (i+1, fragLine, fragCol+1) fragments diff --git a/src/Compiler/Checking/CheckIncrementalClasses.fs b/src/Compiler/Checking/CheckIncrementalClasses.fs index 3bc3af174d1..a6513de2856 100644 --- a/src/Compiler/Checking/CheckIncrementalClasses.fs +++ b/src/Compiler/Checking/CheckIncrementalClasses.fs @@ -335,7 +335,7 @@ type IncrClassReprInfo = let reportIfUnused() = if not v.HasBeenReferenced && not (v.DisplayName.StartsWithOrdinal("_")) && not v.IsCompilerGenerated then - warning (Error(FSComp.SR.chkUnusedValue(v.DisplayName), v.Range)) + warning (Error(FSComp.SR.chkUnusedValue(richTextOfValName cenv.g v), v.Range)) let repr = match InferValReprInfoOfBinding g AllowTypeDirectedDetupling.Yes v bind.Expr with diff --git a/src/Compiler/Checking/CheckPatterns.fs b/src/Compiler/Checking/CheckPatterns.fs index d7b1ffd4e3e..7ea6500dcfb 100644 --- a/src/Compiler/Checking/CheckPatterns.fs +++ b/src/Compiler/Checking/CheckPatterns.fs @@ -22,6 +22,7 @@ open FSharp.Compiler.Syntax open FSharp.Compiler.Syntax.PrettyNaming open FSharp.Compiler.SyntaxTreeOps open FSharp.Compiler.TcGlobals +open FSharp.Compiler.Text open FSharp.Compiler.Text.Range open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics @@ -245,10 +246,10 @@ and TcPatBindingName cenv env id ty isMemberThis vis1 valReprInfo (vFlags: TcPat if not (String.IsNullOrEmpty name) && not (String.isLeadingIdentifierCharacterUpperCase name) then match env.eNameResEnv.ePatItems.TryGetValue name with | true, Item.Value vref when vref.LiteralValue.IsSome -> - warning(Error(FSComp.SR.checkLowercaseLiteralBindingInPattern name, id.idRange)) + warning(Error(FSComp.SR.checkLowercaseLiteralBindingInPattern (RichText.mkLocal name), id.idRange)) | _ -> () value - | _ -> error(Error(FSComp.SR.tcNameNotBoundInPattern name, id.idRange)) + | _ -> error(Error(FSComp.SR.tcNameNotBoundInPattern (RichText.mkUnresolvedName name), id.idRange)) // isLeftMost indicates we are processing the left-most path through a disjunctive or pattern. // For those binding locations, CallNameResolutionSink is called in MakeAndPublishValue, like all other bindings @@ -598,7 +599,7 @@ and TcPatLongIdent warnOnUpper cenv env ad valReprInfo vFlags (patEnv: TcPatLine match args with | SynArgPats.Pats _ -> () - | _ -> errorR (Error (FSComp.SR.tcNamedActivePattern apinfo.ActiveTags[idx], m)) + | _ -> errorR (Error(FSComp.SR.tcNamedActivePattern (RichText.mkActivePatternCase apinfo.ActiveTags[idx]), m)) let args = GetSynArgPatterns args @@ -654,7 +655,7 @@ and ApplyUnionCaseOrExn m (cenv: cenv) env overallTy item = | Item.UnionCase(ucinfo, showDeprecated) -> if showDeprecated then - let diagnostic = Deprecated(FSComp.SR.nrUnionTypeNeedsQualifiedAccess(ucinfo.DisplayName, ucinfo.Tycon.DisplayName) |> snd, m) + let diagnostic = Deprecated(FSComp.SR.nrUnionTypeNeedsQualifiedAccess(RichText.mkUnionCase ucinfo.DisplayName, richTextOfEntity ucinfo.Tycon) |> snd, m) if g.langVersion.SupportsFeature(LanguageFeature.ErrorOnDeprecatedRequireQualifiedAccess) then errorR(diagnostic) else @@ -723,11 +724,11 @@ and TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags patEnv ty (m extraPatterns.Add pat match item with | Item.UnionCase(uci, _) -> - errorR (Error (FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName (uci.DisplayName, id.idText), id.idRange)) + errorR (Error(FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName (RichText.mkUnionCase uci.DisplayName, RichText.mkUnresolvedName id.idText), id.idRange)) | Item.ExnCase tcref -> - errorR (Error (FSComp.SR.tcExceptionConstructorDoesNotHaveFieldWithGivenName (tcref.DisplayName, id.idText), id.idRange)) + errorR (Error(FSComp.SR.tcExceptionConstructorDoesNotHaveFieldWithGivenName (richTextOfEntityRef tcref, RichText.mkUnresolvedName id.idText), id.idRange)) | _ -> - errorR (Error (FSComp.SR.tcConstructorDoesNotHaveFieldWithGivenName id.idText, id.idRange)) + errorR (Error(FSComp.SR.tcConstructorDoesNotHaveFieldWithGivenName (RichText.mkUnresolvedName id.idText), id.idRange)) | Some idx -> let argItem = @@ -742,7 +743,7 @@ and TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags patEnv ty (m | null -> result[idx] <- pat | _ -> extraPatterns.Add pat - errorR (Error (FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce id.idText, id.idRange)) + errorR (Error(FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce (RichText.mkField id.idText), id.idRange)) for i = 0 to numArgTys - 1 do if isNull (box result[i]) then @@ -784,12 +785,17 @@ and TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags patEnv ty (m elif numArgs < numArgTys then if numArgTys > 1 then // Expects tuple without enough args - let printTy = NicePrint.minimalStringOfType env.DisplayEnv let missingArgs = argNames.[numArgs..numArgTys - 1] - |> List.map (fun id -> (if id.rfield_name_generated then "" else id.DisplayName + ": ") + printTy id.FormalType) - |> String.concat (Environment.NewLine + "\t") - |> fun s -> Environment.NewLine + "\t" + s + |> List.map (fun id -> + RichText.concat + [ if not id.rfield_name_generated then + RichText.mkRecordField id.DisplayName + RichText.mkPunctuation ":" + RichText.mkText " " + NicePrint.minimalRichTextOfType env.DisplayEnv id.FormalType ]) + |> RichText.concatWith (RichText.mkText (Environment.NewLine + "\t")) + |> RichText.append (RichText.mkText (Environment.NewLine + "\t")) errorR (Error (FSComp.SR.tcUnionCaseExpectsTupledArguments(numArgTys, numArgs, missingArgs), m)) else @@ -813,7 +819,7 @@ and TcPatLongIdentILField warnOnUpper (cenv: cenv) env vFlags patEnv ty (mLongId CheckILFieldInfoAccessible g cenv.amap mLongId env.AccessRights finfo if not finfo.IsStatic then - errorR (Error (FSComp.SR.tcFieldIsNotStatic finfo.FieldName, mLongId)) + errorR (Error(FSComp.SR.tcFieldIsNotStatic (RichText.mkField finfo.FieldName), mLongId)) CheckILFieldAttributes g finfo m @@ -834,7 +840,7 @@ and TcPatLongIdentILField warnOnUpper (cenv: cenv) env vFlags patEnv ty (mLongId and TcPatLongIdentRecdField warnOnUpper cenv env vFlags patEnv ty (mLongId, rfinfo, args, m) = let g = cenv.g CheckRecdFieldInfoAccessible cenv.amap mLongId env.AccessRights rfinfo - if not rfinfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.DisplayName), mLongId)) + if not rfinfo.IsStatic then errorR (Error(FSComp.SR.tcFieldIsNotStatic(RichText.mkRecordField rfinfo.DisplayName), mLongId)) CheckRecdFieldInfoAttributes g rfinfo mLongId |> CommitOperationResult match rfinfo.LiteralValue with @@ -859,7 +865,7 @@ and TcPatLongIdentLiteral warnOnUpper (cenv: cenv) env vFlags patEnv ty (mLongId | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m)) | Some lit -> let _, _, _, vexpty, _, _ = TcVal cenv env tpenv vref None None mLongId - CheckValAccessible mLongId env.AccessRights vref + CheckValAccessible g mLongId env.AccessRights vref CheckFSharpAttributes g vref.Attribs mLongId |> CommitOperationResult CheckNoArgsForLiteral args m let _, acc = TcArgPats warnOnUpper cenv env vFlags patEnv args diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index fddbc8797b6..f8ece244530 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -247,11 +247,11 @@ exception ConstraintSolverNullnessWarningWithTypes of DisplayEnv * TType * TType exception ConstraintSolverNullnessWarningWithType of DisplayEnv * TType * NullnessInfo * range * range -exception ConstraintSolverNullnessWarning of string * range * range +exception ConstraintSolverNullnessWarning of RichText * range * range exception ConstraintSolverNullnessWarningOnDotAccess of DisplayEnv * objTy: TType * memberName: string * bindingName: string option * objExprRange: range * mMethod: range -exception ConstraintSolverError of string * range * range +exception ConstraintSolverError of RichText * range * range exception ErrorFromApplyingDefault of tcGlobals: TcGlobals * displayEnv: DisplayEnv * Typar * TType * error: exn * range: range @@ -698,7 +698,7 @@ let rec TransactStaticReq (csenv: ConstraintSolverEnv) (trace: OptionalTrace) (t // declared StaticReq. With feature InterfacesWithAbstractStaticMembers it is inferred // from the finalized constraints on the type variable. if not (g.langVersion.SupportsFeature LanguageFeature.InterfacesWithAbstractStaticMembers) && tpr.Rigidity.ErrorIfUnified && tpr.StaticReq <> req then - ErrorD(ConstraintSolverError(FSComp.SR.csTypeCannotBeResolvedAtCompileTime(tpr.Name), m, m)) + ErrorD(ConstraintSolverError(RichText.mkText (FSComp.SR.csTypeCannotBeResolvedAtCompileTime(tpr.Name)), m, m)) else let orig = tpr.StaticReq trace.Exec (fun () -> tpr.SetStaticReq req) (fun () -> tpr.SetStaticReq orig) @@ -1185,11 +1185,11 @@ and SolveTyparsEqualTypesAux (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optio and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: AnonRecdTypeInfo) (anonInfo2: AnonRecdTypeInfo) = if evalTupInfoIsStruct anonInfo1.TupInfo <> evalTupInfoIsStruct anonInfo2.TupInfo then - ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m,m2)) + ErrorD (ConstraintSolverError(RichText.mkText (FSComp.SR.tcTupleStructMismatch()), csenv.m,m2)) else trackErrors { if not (ccuEq anonInfo1.Assembly anonInfo2.Assembly) then - do! ErrorD (ConstraintSolverError(FSComp.SR.tcAnonRecdCcuMismatch(anonInfo1.Assembly.AssemblyName, anonInfo2.Assembly.AssemblyName), csenv.m,m2)) + do! ErrorD (ConstraintSolverError(RichText.mkText (FSComp.SR.tcAnonRecdCcuMismatch(anonInfo1.Assembly.AssemblyName, anonInfo2.Assembly.AssemblyName)), csenv.m,m2)) if anonInfo1.SortedNames <> anonInfo2.SortedNames then let (|Subset|Superset|Overlap|CompletelyDifferent|) (first, second) = @@ -1209,46 +1209,42 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon let second = Set.toList second CompletelyDifferent(first, second) + let quotedNames names = + names + |> List.map (fun name -> + RichText.concat + [ RichText.mkPunctuation "'" + RichText.mkRecordField name + RichText.mkPunctuation "'" ]) + |> RichText.concatWith (RichText.mkText ", ") + let message = match anonInfo1.SortedNames, anonInfo2.SortedNames with | Subset missingFields -> match missingFields with | [missingField] -> - FSComp.SR.tcAnonRecdSingleFieldNameSubset(string missingField) + FSComp.SR.tcAnonRecdSingleFieldNameSubset(RichText.mkRecordField missingField) | _ -> - let missingFields = missingFields |> List.map(sprintf "'%s'") - let missingFields = String.concat ", " missingFields - FSComp.SR.tcAnonRecdMultipleFieldsNameSubset(string missingFields) + FSComp.SR.tcAnonRecdMultipleFieldsNameSubset(quotedNames missingFields) | Superset extraFields -> match extraFields with | [extraField] -> - FSComp.SR.tcAnonRecdSingleFieldNameSuperset(string extraField) + FSComp.SR.tcAnonRecdSingleFieldNameSuperset(RichText.mkRecordField extraField) | _ -> - let extraFields = extraFields |> List.map(sprintf "'%s'") - let extraFields = String.concat ", " extraFields - FSComp.SR.tcAnonRecdMultipleFieldsNameSuperset(string extraFields) + FSComp.SR.tcAnonRecdMultipleFieldsNameSuperset(quotedNames extraFields) | Overlap (missingFields, extraFields) -> - FSComp.SR.tcAnonRecdFieldNameMismatch(string missingFields, string extraFields) + FSComp.SR.tcAnonRecdFieldNameMismatch(RichText.mkText (string missingFields), RichText.mkText (string extraFields)) | CompletelyDifferent missingFields -> let missingFields, usedFields = missingFields match missingFields, usedFields with | [ missingField ], [ usedField ] -> - FSComp.SR.tcAnonRecdSingleFieldNameSingleDifferent(missingField, usedField) + FSComp.SR.tcAnonRecdSingleFieldNameSingleDifferent(RichText.mkRecordField missingField, RichText.mkRecordField usedField) | [ missingField ], usedFields -> - let usedFields = usedFields |> List.map(sprintf "'%s'") - let usedFields = String.concat ", " usedFields - FSComp.SR.tcAnonRecdSingleFieldNameMultipleDifferent(missingField, usedFields) + FSComp.SR.tcAnonRecdSingleFieldNameMultipleDifferent(RichText.mkRecordField missingField, quotedNames usedFields) | missingFields, [ usedField ] -> - let missingFields = missingFields |> List.map(sprintf "'%s'") - let missingFields = String.concat ", " missingFields - FSComp.SR.tcAnonRecdMultipleFieldNameSingleDifferent(missingFields, usedField) - + FSComp.SR.tcAnonRecdMultipleFieldNameSingleDifferent(quotedNames missingFields, RichText.mkRecordField usedField) | missingFields, usedFields -> - let missingFields = missingFields |> List.map(sprintf "'%s'") - let missingFields = String.concat ", " missingFields - let usedFields = usedFields |> List.map(sprintf "'%s'") - let usedFields = String.concat ", " usedFields - FSComp.SR.tcAnonRecdMultipleFieldNameMultipleDifferent(missingFields, usedFields) + FSComp.SR.tcAnonRecdMultipleFieldNameMultipleDifferent(quotedNames missingFields, quotedNames usedFields) do! ErrorD (ConstraintSolverError(message, csenv.m,m2)) else @@ -1400,7 +1396,7 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> if evalTupInfoIsStruct tupInfo1 <> evalTupInfoIsStruct tupInfo2 then - ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m, m2)) + ErrorD (ConstraintSolverError(RichText.mkText (FSComp.SR.tcTupleStructMismatch()), csenv.m, m2)) else SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 @@ -1568,7 +1564,7 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> if evalTupInfoIsStruct tupInfo1 <> evalTupInfoIsStruct tupInfo2 then - ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m, m2)) + ErrorD (ConstraintSolverError(RichText.mkText (FSComp.SR.tcTupleStructMismatch()), csenv.m, m2)) else SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 (* nb. can unify since no variance *) | TType_fun (domainTy1, rangeTy1, nullness1), TType_fun (domainTy2, rangeTy2, nullness2) -> @@ -1741,7 +1737,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload if memFlags.IsInstance then match supportTys, traitObjAndArgTys with | [ty], h :: _ -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace h ty - | _ -> do! ErrorD (ConstraintSolverError(FSComp.SR.csExpectedArguments(), m, m2)) + | _ -> do! ErrorD (ConstraintSolverError(RichText.mkText (FSComp.SR.csExpectedArguments()), m, m2)) // Trait calls are only supported on pseudo type (variables) if not (g.langVersion.SupportsFeature LanguageFeature.InterfacesWithAbstractStaticMembers) then @@ -1876,7 +1872,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload when isArrayTy g ty -> if rankOfArrayTy g ty <> argTys.Length then - do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), argTys.Length), m, m2)) + do! ErrorD(ConstraintSolverError(RichText.mkText (FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), argTys.Length)), m, m2)) for argTy in argTys do do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argTy g.int_ty @@ -1889,7 +1885,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload when isArrayTy g ty -> if rankOfArrayTy g ty <> argTys.Length - 1 then - do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), (argTys.Length - 1)), m, m2)) + do! ErrorD(ConstraintSolverError(RichText.mkText (FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), (argTys.Length - 1))), m, m2)) let argTys, lastTy = List.frontAndBack argTys for argTy in argTys do @@ -2054,40 +2050,43 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload match minfos, recdPropSearch, anonRecdPropSearch with | [], None, None when MemberConstraintIsReadyForStrongResolution csenv traitInfo -> if supportTys |> List.exists (isFunTy g) then - return! ErrorD (ConstraintSolverError(FSComp.SR.csExpectTypeWithOperatorButGivenFunction(ConvertValLogicalNameToDisplayNameCore nm), m, m2)) + return! ErrorD (ConstraintSolverError(RichText.mkText (FSComp.SR.csExpectTypeWithOperatorButGivenFunction(ConvertValLogicalNameToDisplayNameCore nm)), m, m2)) elif supportTys |> List.exists (isAnyTupleTy g) then - return! ErrorD (ConstraintSolverError(FSComp.SR.csExpectTypeWithOperatorButGivenTuple(ConvertValLogicalNameToDisplayNameCore nm), m, m2)) + return! ErrorD (ConstraintSolverError(RichText.mkText (FSComp.SR.csExpectTypeWithOperatorButGivenTuple(ConvertValLogicalNameToDisplayNameCore nm)), m, m2)) else match nm, argTys with | "op_Explicit", [argTy] -> - let argTyString = NicePrint.prettyStringOfTy denv argTy - let rtyString = NicePrint.prettyStringOfTy denv retTy - return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportConversion(argTyString, rtyString), m, m2)) + let argTyText = NicePrint.prettyRichTextOfTy denv argTy + let retTyText = NicePrint.prettyRichTextOfTy denv retTy + return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportConversion(argTyText, retTyText), m, m2)) | _ -> let tyString = match supportTys with - | [ty] -> NicePrint.minimalStringOfType denv ty - | _ -> supportTys |> List.map (NicePrint.minimalStringOfType denv) |> String.concat ", " + | [ty] -> NicePrint.minimalRichTextOfType denv ty + | _ -> + supportTys + |> List.map (NicePrint.minimalRichTextOfType denv) + |> RichText.concatWith (RichText.mkText ", ") let opName = ConvertValLogicalNameToDisplayNameCore nm let err = match opName with | "?>=" | "?>" | "?<=" | "?<" | "?=" | "?<>" | ">=?" | ">?" | "<=?" | "?" | "?>=?" | "?>?" | "?<=?" | "??" -> - if List.isSingleton supportTys then FSComp.SR.csTypeDoesNotSupportOperatorNullable(tyString, opName) - else FSComp.SR.csTypesDoNotSupportOperatorNullable(tyString, opName) + if List.isSingleton supportTys then FSComp.SR.csTypeDoesNotSupportOperatorNullable(tyString, RichText.mkOperator opName) + else FSComp.SR.csTypesDoNotSupportOperatorNullable(tyString, RichText.mkOperator opName) | _ -> match supportTys, source.Value with | [_], Some s when s.StartsWith("Operators.") -> let opSource = s[10..] - if opSource = nm then FSComp.SR.csTypeDoesNotSupportOperator(tyString, opName) - else FSComp.SR.csTypeDoesNotSupportOperator(tyString, opSource) + if opSource = nm then FSComp.SR.csTypeDoesNotSupportOperator(tyString, RichText.mkOperator opName) + else FSComp.SR.csTypeDoesNotSupportOperator(tyString, RichText.mkOperator opSource) | [_], Some s -> - FSComp.SR.csFunctionDoesNotSupportType(s, tyString, nm) + FSComp.SR.csFunctionDoesNotSupportType(RichText.mkFunction s, tyString, RichText.mkFunction nm) | [_], _ - -> FSComp.SR.csTypeDoesNotSupportOperator(tyString, opName) + -> FSComp.SR.csTypeDoesNotSupportOperator(tyString, RichText.mkOperator opName) | _, _ - -> FSComp.SR.csTypesDoNotSupportOperator(tyString, opName) + -> FSComp.SR.csTypesDoNotSupportOperator(tyString, RichText.mkOperator opName) return! ErrorD(ConstraintSolverError(err, m, m2)) | _ -> @@ -2135,9 +2134,9 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload if isInstance <> memFlags.IsInstance then return! if isInstance then - ErrorD(ConstraintSolverError(FSComp.SR.csMethodFoundButIsNotStatic((NicePrint.minimalStringOfType denv minfo.ApparentEnclosingType), (ConvertValLogicalNameToDisplayNameCore nm), nm), m, m2 )) + ErrorD(ConstraintSolverError(FSComp.SR.csMethodFoundButIsNotStatic(NicePrint.minimalRichTextOfType denv minfo.ApparentEnclosingType, RichText.mkMethod (ConvertValLogicalNameToDisplayNameCore nm), RichText.mkMethod nm), m, m2 )) else - ErrorD(ConstraintSolverError(FSComp.SR.csMethodFoundButIsStatic((NicePrint.minimalStringOfType denv minfo.ApparentEnclosingType), (ConvertValLogicalNameToDisplayNameCore nm), nm), m, m2 )) + ErrorD(ConstraintSolverError(FSComp.SR.csMethodFoundButIsStatic(NicePrint.minimalRichTextOfType denv minfo.ApparentEnclosingType, RichText.mkMethod (ConvertValLogicalNameToDisplayNameCore nm), RichText.mkMethod nm), m, m2 )) else do! CheckMethInfoAttributes g m None minfo return TTraitSolved (minfo, calledMeth.CalledTyArgs, calledMeth.OptionalStaticType) @@ -2715,7 +2714,7 @@ and SolveTypeUseSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 trace ty = if TypeNullIsExtraValueNew g m ty then () elif isNullableTy g ty then - return! ErrorD (ConstraintSolverError(FSComp.SR.csNullableTypeDoesNotHaveNull(NicePrint.minimalStringOfType denv ty), m, m2)) + return! ErrorD (ConstraintSolverError(FSComp.SR.csNullableTypeDoesNotHaveNull(NicePrint.minimalRichTextOfType denv ty), m, m2)) else match tryDestTyparTy g ty with | ValueSome tp -> @@ -2737,7 +2736,7 @@ and SolveTypeUseSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 trace ty = // If checkNullness is off give the same errors as F# 4.5 if not g.checkNullness && not (TypeNullIsExtraValue g m ty) then - return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotHaveNull(NicePrint.minimalStringOfType denv ty), m, m2)) + return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotHaveNull(NicePrint.minimalRichTextOfType denv ty), m, m2)) else // Use legacy F# nullness rules when langFeatureNullness is disabled do! SolveLegacyTypeUseSupportsNullLiteral csenv ndeep m2 trace ty @@ -2752,13 +2751,13 @@ and SolveLegacyTypeUseSupportsNullLiteral (csenv: ConstraintSolverEnv) ndeep m2 if TypeNullIsExtraValue g m ty then () elif isNullableTy g ty then - return! ErrorD (ConstraintSolverError(FSComp.SR.csNullableTypeDoesNotHaveNull(NicePrint.minimalStringOfType denv ty), m, m2)) + return! ErrorD (ConstraintSolverError(FSComp.SR.csNullableTypeDoesNotHaveNull(NicePrint.minimalRichTextOfType denv ty), m, m2)) else match tryDestTyparTy g ty with | ValueSome tp -> do! AddConstraint csenv ndeep m2 trace tp (TyparConstraint.SupportsNull m) | ValueNone -> - return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotHaveNull(NicePrint.minimalStringOfType denv ty), m, m2)) + return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotHaveNull(NicePrint.minimalRichTextOfType denv ty), m, m2)) } and SolveNullnessSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) ty nullness = @@ -2786,7 +2785,7 @@ and SolveNullnessSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 (trace: Opti if (TypeNullIsExtraValue g m ty) then return! WarnD(ConstraintSolverNullnessWarningWithType(denv, ty, n1, getNullnessWarningRange csenv, m2)) else - return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotHaveNull(NicePrint.minimalStringOfType denv ty), m, m2)) + return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotHaveNull(NicePrint.minimalRichTextOfType denv ty), m, m2)) | Nullness.KnownFromConstructor -> () // Unreachable after Normalize() } @@ -2799,7 +2798,7 @@ and SolveTypeUseNotSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 trace ty = if TypeNullIsTrueValue g ty then // We can only give warnings here as F# 5.0 introduces these constraints into existing // code via Option.ofObj and Option.toObj - do! WarnD (ConstraintSolverNullnessWarning(FSComp.SR.csTypeHasNullAsTrueValue(NicePrint.minimalStringOfType denv ty), getNullnessWarningRange csenv, m2)) + do! WarnD (ConstraintSolverNullnessWarning(FSComp.SR.csTypeHasNullAsTrueValue(NicePrint.minimalRichTextOfType denv ty), getNullnessWarningRange csenv, m2)) elif TypeNullIsExtraValueNew g m ty then if g.checkNullness then // Constructor results are provably non-null even for AllowNullLiteral types @@ -2808,7 +2807,7 @@ and SolveTypeUseNotSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 trace ty = | TType_app(_, _, Nullness.KnownFromConstructor) -> true | _ -> false if not isFromConstructor then - do! WarnD (ConstraintSolverNullnessWarning(FSComp.SR.csTypeHasNullAsExtraValue(NicePrint.minimalStringOfTypeWithNullness denv ty), getNullnessWarningRange csenv, m2)) + do! WarnD (ConstraintSolverNullnessWarning(FSComp.SR.csTypeHasNullAsExtraValue(NicePrint.minimalRichTextOfTypeWithNullness denv ty), getNullnessWarningRange csenv, m2)) else match tryDestTyparTy g ty with | ValueSome tp -> @@ -2836,7 +2835,7 @@ and SolveNullnessNotSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 (trace: O | NullnessInfo.WithoutNull -> () | NullnessInfo.WithNull -> if g.checkNullness && TypeNullIsExtraValueNew g m ty then - return! WarnD(ConstraintSolverNullnessWarning(FSComp.SR.csTypeHasNullAsExtraValue(NicePrint.minimalStringOfTypeWithNullness denv ty), getNullnessWarningRange csenv, m2)) + return! WarnD(ConstraintSolverNullnessWarning(FSComp.SR.csTypeHasNullAsExtraValue(NicePrint.minimalRichTextOfTypeWithNullness denv ty), getNullnessWarningRange csenv, m2)) | Nullness.KnownFromConstructor -> () // Unreachable after Normalize() } @@ -2850,8 +2849,8 @@ and SolveTypeCanCarryNullness (csenv: ConstraintSolverEnv) ty nullness = if isTyparTy g strippedTy && not (IsReferenceTyparTy g strippedTy) then return! AddConstraint csenv 0 m NoTrace (destTyparTy g strippedTy) (TyparConstraint.IsReferenceType m) | None -> - let tyString = NicePrint.minimalStringOfType csenv.DisplayEnv strippedTy - return! ErrorD(Error(FSComp.SR.tcTypeDoesNotHaveAnyNull(tyString), m)) + let tyText = NicePrint.minimalRichTextOfType csenv.DisplayEnv strippedTy + return! ErrorD(Error(FSComp.SR.tcTypeDoesNotHaveAnyNull(tyText), m)) } and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = @@ -2866,7 +2865,7 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = // Check it isn't ruled out by the user match tryTcrefOfAppTy g ty with | ValueSome tcref when EntityHasWellKnownAttribute g WellKnownEntityAttributes.NoComparisonAttribute tcref.Deref -> - ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison1(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison1(NicePrint.minimalRichTextOfType denv ty), m, m2)) | _ -> match ty with | SpecialComparableHeadType g tinst -> @@ -2894,10 +2893,10 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tcref.Deref && Option.isNone tcref.GeneratedCompareToWithComparerValues) then - ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison3(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison3(NicePrint.minimalRichTextOfType denv ty), m, m2)) else - ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison2(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison2(NicePrint.minimalRichTextOfType denv ty), m, m2)) and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = let g = csenv.g @@ -2909,13 +2908,13 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = | _ -> match tryTcrefOfAppTy g ty with | ValueSome tcref when EntityHasWellKnownAttribute g WellKnownEntityAttributes.NoEqualityAttribute tcref.Deref -> - ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality1(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality1(NicePrint.minimalRichTextOfType denv ty), m, m2)) | _ -> match ty with | SpecialEquatableHeadType g tinst -> tinst |> IterateD (SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace) | SpecialNotEquatableHeadType g _ -> - ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality2(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality2(NicePrint.minimalRichTextOfType denv ty), m, m2)) | _ -> // The type is equatable because it has Object.Equals(...) match ty with @@ -2924,7 +2923,7 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tcref.Deref && Option.isNone tcref.GeneratedHashAndEqualsWithComparerValues then - ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality3(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality3(NicePrint.minimalRichTextOfType denv ty), m, m2)) else // Check the (possibly inferred) structural dependencies (tinst, tcref.Typars) ||> Iterate2D (fun ty tp -> @@ -2946,7 +2945,7 @@ and SolveTypeIsEnum (csenv: ConstraintSolverEnv) ndeep m2 trace ty underlying = if isEnumTy g ty then SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace underlying (underlyingTypeOfEnumTy g ty) else - ErrorD (ConstraintSolverError(FSComp.SR.csTypeIsNotEnumType(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csTypeIsNotEnumType(NicePrint.minimalRichTextOfType denv ty), m, m2)) and SolveTypeIsDelegate (csenv: ConstraintSolverEnv) ndeep m2 trace ty aty bty = let g = csenv.g @@ -2964,9 +2963,9 @@ and SolveTypeIsDelegate (csenv: ConstraintSolverEnv) ndeep m2 trace ty aty bty = do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace bty retTy } | None -> - ErrorD (ConstraintSolverError(FSComp.SR.csTypeHasNonStandardDelegateType(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csTypeHasNonStandardDelegateType(NicePrint.minimalRichTextOfType denv ty), m, m2)) else - ErrorD (ConstraintSolverError(FSComp.SR.csTypeIsNotDelegateType(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csTypeIsNotDelegateType(NicePrint.minimalRichTextOfType denv ty), m, m2)) and SolveTypeIsNonNullableValueType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = let g = csenv.g @@ -2979,11 +2978,11 @@ and SolveTypeIsNonNullableValueType (csenv: ConstraintSolverEnv) ndeep m2 trace let underlyingTy = stripTyEqnsAndMeasureEqns g ty if isStructTy g underlyingTy then if isNullableTy g underlyingTy then - ErrorD (ConstraintSolverError(FSComp.SR.csTypeParameterCannotBeNullable(), m, m)) + ErrorD (ConstraintSolverError(RichText.mkText (FSComp.SR.csTypeParameterCannotBeNullable()), m, m)) else CompleteD else - ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresStructType(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresStructType(NicePrint.minimalRichTextOfType denv ty), m, m2)) and SolveTypeIsUnmanaged (csenv: ConstraintSolverEnv) ndeep m2 trace ty = let g = csenv.g @@ -3008,7 +3007,7 @@ and SolveTypeIsUnmanaged (csenv: ConstraintSolverEnv) ndeep m2 trace ty = if isUnmanagedTy g ty then CompleteD else - ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresUnmanagedType(NicePrint.minimalStringOfType denv ty), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresUnmanagedType(NicePrint.minimalRichTextOfType denv ty), m, m2)) and SolveTypeChoice (csenv: ConstraintSolverEnv) ndeep m2 trace ty choiceTys = trackErrors { @@ -3024,9 +3023,9 @@ and SolveTypeChoice (csenv: ConstraintSolverEnv) ndeep m2 trace ty choiceTys = return! AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.SimpleChoice(choiceTys, m)) | _ -> if not (choiceTys |> List.exists (typeEquivAux Erasure.EraseMeasures g ty)) then - let tyString = NicePrint.minimalStringOfType denv ty - let tysString = choiceTys |> List.map (NicePrint.prettyStringOfTy denv) |> String.concat "," - return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeNotCompatibleBecauseOfPrintf(tyString, tysString), m, m2)) + let tyText = NicePrint.minimalRichTextOfType denv ty + let tysText = choiceTys |> List.map (LayoutRender.toRichText << NicePrint.prettyLayoutOfType denv) |> RichText.concatWith (RichText.mkText ",") + return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeNotCompatibleBecauseOfPrintf(tyText, tysText), m, m2)) } and SolveTypeIsReferenceType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = @@ -3040,7 +3039,7 @@ and SolveTypeIsReferenceType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = // Strip measure equations so we test the underlying erased representation — see dotnet/fsharp#19657. let underlyingTy = stripTyEqnsAndMeasureEqns g ty if isRefTy g underlyingTy then CompleteD - else ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresReferenceSemantics(NicePrint.minimalStringOfType denv ty), m, m)) + else ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresReferenceSemantics(NicePrint.minimalRichTextOfType denv ty), m, m)) and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 trace origTy = let g = csenv.g @@ -3062,14 +3061,14 @@ and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 tr elif TypeHasDefaultValue g m ty then CompleteD else - ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresPublicDefaultConstructor(NicePrint.minimalStringOfType denv origTy), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresPublicDefaultConstructor(NicePrint.minimalRichTextOfType denv origTy), m, m2)) else if GetIntrinsicConstructorInfosOfType csenv.InfoReader m ty |> List.exists (fun x -> x.IsNullary && IsMethInfoAccessible amap m AccessibleFromEverywhere x) then match tryTcrefOfAppTy g ty with | ValueSome tcref when EntityHasWellKnownAttribute g WellKnownEntityAttributes.AbstractClassAttribute tcref.Deref -> - ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresNonAbstract(NicePrint.minimalStringOfType denv origTy), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresNonAbstract(NicePrint.minimalRichTextOfType denv origTy), m, m2)) | _ -> CompleteD else @@ -3080,7 +3079,7 @@ and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 tr (tcref.IsRecordTycon && EntityHasWellKnownAttribute g WellKnownEntityAttributes.CLIMutableAttribute tcref.Deref) -> CompleteD | _ -> - ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresPublicDefaultConstructor(NicePrint.minimalStringOfType denv origTy), m, m2)) + ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresPublicDefaultConstructor(NicePrint.minimalRichTextOfType denv origTy), m, m2)) // Note, this constraint arises structurally when processing the element types of struct tuples and struct anonymous records. // @@ -3097,7 +3096,7 @@ and SolveTypeRequiresDefaultValue (csenv: ConstraintSolverEnv) ndeep m2 trace or elif IsReferenceTyparTy g ty then SolveTypeUseSupportsNull csenv ndeep m2 trace ty else - ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresStructOrReferenceConstraint(), m, m2)) + ErrorD (ConstraintSolverError(RichText.mkText (FSComp.SR.csGenericConstructRequiresStructOrReferenceConstraint()), m, m2)) else if isStructTy g ty then SolveTypeRequiresDefaultConstructor csenv ndeep m2 trace ty @@ -3151,9 +3150,9 @@ and CanMemberSigsMatchUpToCheck if calledObjArgTys.Length <> callerObjArgTys.Length then if calledObjArgTys.Length <> 0 then - ErrorD(Error (FSComp.SR.csMemberIsNotStatic(minfo.LogicalName), m)) + ErrorD(Error(FSComp.SR.csMemberIsNotStatic(RichText.mkMethod minfo.LogicalName), m)) else - ErrorD(Error (FSComp.SR.csMemberIsNotInstance(minfo.LogicalName), m)) + ErrorD(Error(FSComp.SR.csMemberIsNotInstance(RichText.mkMethod minfo.LogicalName), m)) else // The object types must be non-null let nonNullCalledObjArgTys = @@ -3401,21 +3400,21 @@ and ReportNoCandidatesError (csenv: ConstraintSolverEnv) (nUnnamedCallerArgs, nN // No version accessible | ([], others), _, _, _, _ -> if isNil others then - Error (FSComp.SR.csMemberIsNotAccessible(methodName, (ShowAccessDomain ad)), m) + Error(FSComp.SR.csMemberIsNotAccessible(RichText.mkMethod methodName, RichText.mkText (ShowAccessDomain ad)), m) else - Error (FSComp.SR.csMemberIsNotAccessible2(methodName, (ShowAccessDomain ad)), m) + Error(FSComp.SR.csMemberIsNotAccessible2(RichText.mkMethod methodName, RichText.mkText (ShowAccessDomain ad)), m) | _, ([], cmeth :: _), _, _, _ -> // Check all the argument types. if cmeth.CalledObjArgTys(m).Length <> 0 then - Error (FSComp.SR.csMethodIsNotAStaticMethod(methodName), m) + Error(FSComp.SR.csMethodIsNotAStaticMethod(RichText.mkMethod methodName), m) else - Error (FSComp.SR.csMethodIsNotAnInstanceMethod(methodName), m) + Error(FSComp.SR.csMethodIsNotAnInstanceMethod(RichText.mkMethod methodName), m) // One method, incorrect name/arg assignment | _, _, _, _, ([], [cmeth]) -> let minfo = cmeth.Method - let msgNum, msgText = FSComp.SR.csRequiredSignatureIs(NicePrint.stringOfMethInfo infoReader m denv minfo) + let msgNum, msgText = FSComp.SR.csRequiredSignatureIs(NicePrint.richTextOfMethInfo infoReader m denv minfo) match cmeth.UnassignedNamedArgs with | CallerNamedArg(id, _) :: _ -> if minfo.IsConstructor then @@ -3423,9 +3422,9 @@ and ReportNoCandidatesError (csenv: ConstraintSolverEnv) (nUnnamedCallerArgs, nN for p in minfo.DeclaringTyconRef.AllInstanceFieldsAsList do addToBuffer(p.LogicalName.Replace("@", "")) - ErrorWithSuggestions((msgNum, FSComp.SR.csCtorHasNoArgumentOrReturnProperty(methodName, id.idText, msgText)), id.idRange, id.idText, suggestFields) + ErrorWithSuggestions((msgNum, FSComp.SR.csCtorHasNoArgumentOrReturnProperty(RichText.mkMethod methodName, RichText.mkUnresolvedName id.idText, msgText)), id.idRange, id.idText, suggestFields) else - Error((msgNum, FSComp.SR.csMemberHasNoArgumentOrReturnProperty(methodName, id.idText, msgText)), id.idRange) + Error((msgNum, FSComp.SR.csMemberHasNoArgumentOrReturnProperty(RichText.mkMethod methodName, RichText.mkUnresolvedName id.idText, msgText)), id.idRange) | [] -> Error((msgNum, msgText), m) // One method, incorrect number of arguments provided by the user @@ -3433,11 +3432,11 @@ and ReportNoCandidatesError (csenv: ConstraintSolverEnv) (nUnnamedCallerArgs, nN let minfo = cmeth.Method let nReqd = cmeth.TotalNumUnnamedCalledArgs let nActual = cmeth.TotalNumUnnamedCallerArgs - let signature = NicePrint.stringOfMethInfo infoReader m denv minfo + let signature = NicePrint.richTextOfMethInfo infoReader m denv minfo if nActual = nReqd then let nreqdTyArgs = cmeth.NumCalledTyArgs let nactualTyArgs = cmeth.NumCallerTyArgs - Error (FSComp.SR.csMemberSignatureMismatchArityType(methodName, nreqdTyArgs, nactualTyArgs, signature), m) + Error (FSComp.SR.csMemberSignatureMismatchArityType(RichText.mkMethod methodName, nreqdTyArgs, nactualTyArgs, signature), m) else let nReqdNamed = cmeth.TotalNumAssignedNamedArgs @@ -3450,11 +3449,11 @@ and ReportNoCandidatesError (csenv: ConstraintSolverEnv) (nUnnamedCallerArgs, nN |> List.exists (fun c -> isSequential c.Expr)) if couldBeNameArgs then - Error (FSComp.SR.csCtorSignatureMismatchArityProp(methodName, nReqd, nActual, signature), m) + Error (FSComp.SR.csCtorSignatureMismatchArityProp(RichText.mkMethod methodName, nReqd, nActual, signature), m) else - Error (FSComp.SR.csCtorSignatureMismatchArity(methodName, nReqd, nActual, signature), m) + Error (FSComp.SR.csCtorSignatureMismatchArity(RichText.mkMethod methodName, nReqd, nActual, signature), m) else - Error (FSComp.SR.csMemberSignatureMismatchArity(methodName, nReqd, nActual, signature), m) + Error (FSComp.SR.csMemberSignatureMismatchArity(RichText.mkMethod methodName, nReqd, nActual, signature), m) else if nReqd > nActual then let diff = nReqd - nActual @@ -3462,40 +3461,40 @@ and ReportNoCandidatesError (csenv: ConstraintSolverEnv) (nUnnamedCallerArgs, nN match NamesOfCalledArgs missingArgs with | [] -> if nActual = 0 then - Error (FSComp.SR.csMemberSignatureMismatch(methodName, diff, signature), m) + Error (FSComp.SR.csMemberSignatureMismatch(RichText.mkMethod methodName, diff, signature), m) else - Error (FSComp.SR.csMemberSignatureMismatch2(methodName, diff, signature), m) + Error (FSComp.SR.csMemberSignatureMismatch2(RichText.mkMethod methodName, diff, signature), m) | names -> - let str = String.concat ";" (pathOfLid names) + let str = RichText.concatWith (RichText.mkText ";") (pathOfLid names |> List.map (RichText.mkParameter)) if nActual = 0 then - Error (FSComp.SR.csMemberSignatureMismatch3(methodName, diff, signature, str), m) + Error (FSComp.SR.csMemberSignatureMismatch3(RichText.mkMethod methodName, diff, signature, str), m) else - Error (FSComp.SR.csMemberSignatureMismatch4(methodName, diff, signature, str), m) + Error (FSComp.SR.csMemberSignatureMismatch4(RichText.mkMethod methodName, diff, signature, str), m) else - Error (FSComp.SR.csMemberSignatureMismatchArityNamed(methodName, (nReqd+nReqdNamed), nActual, nReqdNamed, signature), m) + Error (FSComp.SR.csMemberSignatureMismatchArityNamed(RichText.mkMethod methodName, (nReqd+nReqdNamed), nActual, nReqdNamed, signature), m) // One or more accessible, all the same arity, none correct | (cmeth :: cmeths2, _), _, _, _, _ when not cmeth.HasCorrectArity && cmeths2 |> List.forall (fun cmeth2 -> cmeth.TotalNumUnnamedCalledArgs = cmeth2.TotalNumUnnamedCalledArgs) -> - Error (FSComp.SR.csMemberNotAccessible(methodName, nUnnamedCallerArgs, methodName, cmeth.TotalNumUnnamedCalledArgs), m) + Error (FSComp.SR.csMemberNotAccessible(RichText.mkMethod methodName, nUnnamedCallerArgs, RichText.mkMethod methodName, cmeth.TotalNumUnnamedCalledArgs), m) // Many methods, all with incorrect number of generic arguments | _, _, _, ([], cmeth :: _), _ -> - let msg = FSComp.SR.csIncorrectGenericInstantiation((ShowAccessDomain ad), methodName, cmeth.NumCallerTyArgs) + let msg = FSComp.SR.csIncorrectGenericInstantiation(RichText.mkText (ShowAccessDomain ad), RichText.mkMethod methodName, cmeth.NumCallerTyArgs) Error (msg, m) // Many methods of different arities, all incorrect | _, _, ([], cmeth :: _), _, _ -> let minfo = cmeth.Method - Error (FSComp.SR.csMemberOverloadArityMismatch(methodName, cmeth.TotalNumUnnamedCallerArgs, (List.sum minfo.NumArgs)), m) + Error (FSComp.SR.csMemberOverloadArityMismatch(RichText.mkMethod methodName, cmeth.TotalNumUnnamedCallerArgs, (List.sum minfo.NumArgs)), m) | _ -> let msg = if nNamedCallerArgs = 0 then - FSComp.SR.csNoMemberTakesTheseArguments((ShowAccessDomain ad), methodName, nUnnamedCallerArgs) + FSComp.SR.csNoMemberTakesTheseArguments(RichText.mkText (ShowAccessDomain ad), RichText.mkMethod methodName, nUnnamedCallerArgs) else let s = calledMethGroup |> List.map (fun cmeth -> cmeth.UnassignedNamedArgs |> List.map (fun na -> na.Name)|> Set.ofList) |> Set.intersectMany if s.IsEmpty then - FSComp.SR.csNoMemberTakesTheseArguments2((ShowAccessDomain ad), methodName, nUnnamedCallerArgs, nNamedCallerArgs) + FSComp.SR.csNoMemberTakesTheseArguments2(RichText.mkText (ShowAccessDomain ad), RichText.mkMethod methodName, nUnnamedCallerArgs, nNamedCallerArgs) else let sample = s.MinimumElement - FSComp.SR.csNoMemberTakesTheseArguments3((ShowAccessDomain ad), methodName, nUnnamedCallerArgs, sample) + FSComp.SR.csNoMemberTakesTheseArguments3(RichText.mkText (ShowAccessDomain ad), RichText.mkMethod methodName, nUnnamedCallerArgs, RichText.mkParameter sample) Error (msg, m) |> ErrorD @@ -3704,13 +3703,13 @@ and ResolveOverloading let minfo = calledMeth.Method match minfo with | ILMeth(ilMethInfo= ilMethInfo) when not isStaticConstrainedCall && ilMethInfo.IsStatic && ilMethInfo.IsAbstract -> - None, ErrorD (Error (FSComp.SR.chkStaticAbstractInterfaceMembers(ilMethInfo.ILName), m)), NoTrace + None, ErrorD (Error(FSComp.SR.chkStaticAbstractInterfaceMembers(RichText.mkMethod ilMethInfo.ILName), m)), NoTrace | FSMeth(g, _, vref, _) when not isStaticConstrainedCall && not minfo.IsInstance && isInterfaceTy g minfo.ApparentEnclosingType && vref.IsDispatchSlotMember -> - None, ErrorD (Error (FSComp.SR.chkStaticAbstractInterfaceMembers(minfo.LogicalName), m)), NoTrace + None, ErrorD (Error(FSComp.SR.chkStaticAbstractInterfaceMembers(RichText.mkMethod minfo.LogicalName), m)), NoTrace | _ -> Some calledMeth, CompleteD, NoTrace | [], _ when not isOpConversion -> - None, ErrorD (Error (FSComp.SR.csMethodNotFound(methodName), m)), NoTrace + None, ErrorD (Error(FSComp.SR.csMethodNotFound(RichText.mkMethod methodName), m)), NoTrace | _, [] when not isOpConversion -> None, ReportNoCandidatesErrorExpr csenv callerArgs.CallerArgCounts methodName ad calledMethGroup, NoTrace @@ -3997,7 +3996,7 @@ let UnifyUniqueOverloading } | [], _ -> - ErrorD (Error (FSComp.SR.csMethodNotFound(methodName), m)) + ErrorD (Error(FSComp.SR.csMethodNotFound(RichText.mkMethod methodName), m)) | _, [] -> trackErrors { do! ReportNoCandidatesErrorSynExpr csenv callerArgCounts methodName ad calledMethGroup return false diff --git a/src/Compiler/Checking/ConstraintSolver.fsi b/src/Compiler/Checking/ConstraintSolver.fsi index 866330c5ce1..aa58ae10878 100644 --- a/src/Compiler/Checking/ConstraintSolver.fsi +++ b/src/Compiler/Checking/ConstraintSolver.fsi @@ -156,7 +156,7 @@ exception ConstraintSolverNullnessWarningWithTypes of exception ConstraintSolverNullnessWarningWithType of DisplayEnv * TType * NullnessInfo * range * range -exception ConstraintSolverNullnessWarning of string * range * range +exception ConstraintSolverNullnessWarning of RichText * range * range exception ConstraintSolverNullnessWarningOnDotAccess of DisplayEnv * @@ -166,7 +166,7 @@ exception ConstraintSolverNullnessWarningOnDotAccess of objExprRange: range * mMethod: range -exception ConstraintSolverError of string * range * range +exception ConstraintSolverError of RichText * range * range exception ErrorFromApplyingDefault of tcGlobals: TcGlobals * diff --git a/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs b/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs index 2f47d898fc1..c83a6a2e827 100644 --- a/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs @@ -297,16 +297,16 @@ let tryGetDataForCustomOperation (nm: Ident) ceenv = || (isLikeZip && isLikeGroupJoin) || (isLikeJoin && isLikeGroupJoin) then - errorR (Error(FSComp.SR.tcCustomOperationInvalid opName, nm.idRange)) + errorR (Error(FSComp.SR.tcCustomOperationInvalid (RichText.mkMethod opName), nm.idRange)) if not (ceenv.cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations) then match ceenv.customOperationMethodsIndexedByMethodName.TryGetValue methInfo.LogicalName with | true, [ _ ] -> () - | _ -> errorR (Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded nm.idText, nm.idRange)) + | _ -> errorR (Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded (RichText.mkMethod nm.idText), nm.idRange)) Some opDatas | true, opData :: _ -> - errorR (Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded nm.idText, nm.idRange)) + errorR (Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded (RichText.mkMethod nm.idText), nm.idRange)) Some [ opData ] | _ -> None @@ -317,7 +317,7 @@ let customOperationCheckValidity m f opDatas = let vs = List.map f opDatas let v0 = vs[0] - let (opName, + let (opName: string, _maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, @@ -329,7 +329,7 @@ let customOperationCheckValidity m f opDatas = opDatas[0] if not (List.allEqual vs) then - errorR (Error(FSComp.SR.tcCustomOperationInvalid opName, m)) + errorR (Error(FSComp.SR.tcCustomOperationInvalid (RichText.mkMethod opName), m)) v0 @@ -477,21 +477,21 @@ let customOpUsageText ceenv nm = if isLikeGroupJoin then Some( FSComp.SR.customOperationTextLikeGroupJoin ( - nm.idText, - customOperationJoinConditionWord ceenv nm, - customOperationJoinConditionWord ceenv nm + RichText.mkMethod nm.idText, + RichText.mkKeyword (customOperationJoinConditionWord ceenv nm), + RichText.mkKeyword (customOperationJoinConditionWord ceenv nm) ) ) elif isLikeJoin then Some( FSComp.SR.customOperationTextLikeJoin ( - nm.idText, - customOperationJoinConditionWord ceenv nm, - customOperationJoinConditionWord ceenv nm + RichText.mkMethod nm.idText, + RichText.mkKeyword (customOperationJoinConditionWord ceenv nm), + RichText.mkKeyword (customOperationJoinConditionWord ceenv nm) ) ) elif isLikeZip then - Some(FSComp.SR.customOperationTextLikeZip nm.idText) + Some(FSComp.SR.customOperationTextLikeZip (RichText.mkMethod nm.idText)) else None | _ -> None @@ -593,7 +593,7 @@ let isCustomOperationProjectionParameter ceenv i (nm: Ident) = let opDatas = (tryGetDataForCustomOperation nm ceenv).Value let opName, _, _, _, _, _, _, _j, _ = opDatas[0] - errorR (Error(FSComp.SR.tcCustomOperationInvalid opName, nm.idRange)) + errorR (Error(FSComp.SR.tcCustomOperationInvalid (RichText.mkMethod opName), nm.idRange)) false [] @@ -712,12 +712,22 @@ let JoinOrGroupJoinOp ceenv detector synExpr = Some(nm, innerSourcePat, mJoinCore, false) // join with bad pattern (gives error on "join" and continues) | SynExpr.App(_, _, CustomOpId (isCustomOperation ceenv) detector nm, _innerSourcePatExpr, mJoinCore) -> - errorR (Error(FSComp.SR.tcBinaryOperatorRequiresVariable (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + errorR ( + Error( + FSComp.SR.tcBinaryOperatorRequiresVariable (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), + nm.idRange + ) + ) Some(nm, arbPat mJoinCore, mJoinCore, true) // join (without anything after - gives error on "join" and continues) | CustomOpId (isCustomOperation ceenv) detector nm -> - errorR (Error(FSComp.SR.tcBinaryOperatorRequiresVariable (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + errorR ( + Error( + FSComp.SR.tcBinaryOperatorRequiresVariable (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), + nm.idRange + ) + ) Some(nm, arbPat synExpr.Range, synExpr.Range, true) | _ -> None @@ -742,7 +752,12 @@ let MatchIntoSuffixOrRecover ceenv alreadyGivenError (nm: Ident) synExpr = (x, intoPat, alreadyGivenError) | _ -> if not alreadyGivenError then - errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + errorR ( + Error( + FSComp.SR.tcOperatorIncorrectSyntax (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), + nm.idRange + ) + ) (synExpr, arbPat synExpr.Range, true) @@ -754,7 +769,12 @@ let MatchOnExprOrRecover ceenv alreadyGivenError nm (onExpr: SynExpr) = suppressErrorReporting (fun () -> TcExprOfUnknownType ceenv.cenv ceenv.env ceenv.tpenv onExpr) |> ignore - errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + errorR ( + Error( + FSComp.SR.tcOperatorIncorrectSyntax (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), + nm.idRange + ) + ) (arbExpr ("_innerSource", onExpr.Range), mkSynBifix onExpr.Range "=" (arbExpr ("_keySelectors", onExpr.Range)) (arbExpr ("_keySelector2", onExpr.Range))) @@ -768,7 +788,9 @@ let (|JoinExpr|_|) (ceenv: ComputationExpressionContext<'a>) synExpr = Some(nm, innerSourcePat, innerSource, keySelectors, mJoinCore) | JoinOp ceenv (nm, innerSourcePat, mJoinCore, alreadyGivenError) -> if alreadyGivenError then - errorR (Error(FSComp.SR.tcOperatorRequiresIn (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + errorR ( + Error(FSComp.SR.tcOperatorRequiresIn (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange) + ) Some(nm, innerSourcePat, arbExpr ("_innerSource", synExpr.Range), arbKeySelectors synExpr.Range, mJoinCore) | _ -> None @@ -785,7 +807,9 @@ let (|GroupJoinExpr|_|) ceenv synExpr = Some(nm, innerSourcePat, innerSource, keySelectors, intoPat, mGroupJoinCore) | GroupJoinOp ceenv (nm, innerSourcePat, mGroupJoinCore, alreadyGivenError) -> if alreadyGivenError then - errorR (Error(FSComp.SR.tcOperatorRequiresIn (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + errorR ( + Error(FSComp.SR.tcOperatorRequiresIn (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange) + ) Some( nm, @@ -815,13 +839,15 @@ let (|JoinOrGroupJoinOrZipClause|_|) (ceenv: ComputationExpressionContext<'a>) s // zip (without secondSource or in - gives error) | CustomOpId (isCustomOperation ceenv) (customOperationIsLikeZip ceenv) nm -> - errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + errorR ( + Error(FSComp.SR.tcOperatorIncorrectSyntax (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange) + ) Some(nm, arbPat synExpr.Range, arbExpr ("_secondSource", synExpr.Range), None, None, synExpr.Range) // zip secondSource (without in - gives error) | SynExpr.App(_, _, CustomOpId (isCustomOperation ceenv) (customOperationIsLikeZip ceenv) nm, ExprAsPat secondSourcePat, mZipCore) -> - errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText ceenv nm)), mZipCore)) + errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), mZipCore)) Some(nm, secondSourcePat, arbExpr ("_innerSource", synExpr.Range), None, None, mZipCore) @@ -843,7 +869,9 @@ let (|ForEachThenJoinOrGroupJoinOrZipClause|_|) (ceenv: ComputationExpressionCon Some(isFromSource, firstSourcePat, firstSource, nm, secondSourcePat, secondSource, keySelectorsOpt, pat3opt, mOpCore, innerComp) | JoinOrGroupJoinOrZipClause ceenv (nm, pat2, expr2, expr3, pat3opt, mOpCore) when strict -> - errorR (Error(FSComp.SR.tcBinaryOperatorRequiresBody (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + errorR ( + Error(FSComp.SR.tcBinaryOperatorRequiresBody (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange) + ) Some( true, @@ -1011,7 +1039,7 @@ let hasBuilderMethod ceenv m methodName = /// Checks if a builder method exists and reports an error if it doesn't let requireBuilderMethod methodName ceenv m1 m2 = if not (hasBuilderMethod ceenv m1 methodName) then - error (Error(FSComp.SR.tcRequireBuilderMethod methodName, m2)) + error (Error(FSComp.SR.tcRequireBuilderMethod (RichText.mkMethod methodName), m2)) /// One `let`/`use`/`let!`/`use!`/`do!` binding step, exposing whether it is a "bang" construct, its /// continuation body, and how to rebuild the step around a rewritten body. @@ -1223,14 +1251,14 @@ let rec TryTranslateComputationExpression SimplePatsOfPat cenv.synArgNameGenerator secondSourcePat if Option.isSome later1 then - errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern nm.idText, firstSourcePat.Range)) + errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern (RichText.mkMethod nm.idText), firstSourcePat.Range)) if Option.isSome later2 then - errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern nm.idText, secondSourcePat.Range)) + errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern (RichText.mkMethod nm.idText), secondSourcePat.Range)) // check 'join' or 'groupJoin' or 'zip' is permitted for this builder match tryGetDataForCustomOperation nm ceenv with - | None -> error (Error(FSComp.SR.tcMissingCustomOperation nm.idText, nm.idRange)) + | None -> error (Error(FSComp.SR.tcMissingCustomOperation (RichText.mkMethod nm.idText), nm.idRange)) | Some opDatas -> let opName, _, _, _, _, _, _, _, methInfo = opDatas[0] @@ -1310,7 +1338,7 @@ let rec TryTranslateComputationExpression SimplePatsOfPat cenv.synArgNameGenerator secondResultPat if Option.isSome later3 then - errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern nm.idText, secondResultPat.Range)) + errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern (RichText.mkMethod nm.idText), secondResultPat.Range)) match relExpr with | JoinRelation ceenv (keySelector1, keySelector2) -> @@ -1320,12 +1348,14 @@ let rec TryTranslateComputationExpression // When we cannot resolve NullableOps, recommend the relevant namespace to be added errorR ( Error( - FSComp.SR.cannotResolveNullableOperators (ConvertValLogicalNameToDisplayNameCore opId.idText), + FSComp.SR.cannotResolveNullableOperators ( + RichText.mkOperator (ConvertValLogicalNameToDisplayNameCore opId.idText) + ), relExpr.Range ) ) else - errorR (Error(FSComp.SR.tcInvalidRelationInJoin nm.idText, relExpr.Range)) + errorR (Error(FSComp.SR.tcInvalidRelationInJoin (RichText.mkMethod nm.idText), relExpr.Range)) let l = wrapInArbErrSequence l "_keySelector1" let r = wrapInArbErrSequence r "_keySelector2" @@ -1333,7 +1363,7 @@ let rec TryTranslateComputationExpression // we've already reported error now we can use operands of binary operation as join components mkJoinExpr l r secondResultSimplePats, varSpaceWithGroupJoinVars | _ -> - errorR (Error(FSComp.SR.tcInvalidRelationInJoin nm.idText, relExpr.Range)) + errorR (Error(FSComp.SR.tcInvalidRelationInJoin (RichText.mkMethod nm.idText), relExpr.Range)) // since the shape of relExpr doesn't match our expectations (JoinRelation) // then we assume that this is l.h.s. of the join relation // so typechecker will treat relExpr as body of outerKeySelector lambda parameter in GroupJoin method @@ -1349,19 +1379,21 @@ let rec TryTranslateComputationExpression // When we cannot resolve NullableOps, recommend the relevant namespace to be added errorR ( Error( - FSComp.SR.cannotResolveNullableOperators (ConvertValLogicalNameToDisplayNameCore opId.idText), + FSComp.SR.cannotResolveNullableOperators ( + RichText.mkOperator (ConvertValLogicalNameToDisplayNameCore opId.idText) + ), relExpr.Range ) ) else - errorR (Error(FSComp.SR.tcInvalidRelationInJoin nm.idText, relExpr.Range)) + errorR (Error(FSComp.SR.tcInvalidRelationInJoin (RichText.mkMethod nm.idText), relExpr.Range)) // this is not correct JoinRelation but it is still binary operation // we've already reported error now we can use operands of binary operation as join components let l = wrapInArbErrSequence l "_keySelector1" let r = wrapInArbErrSequence r "_keySelector2" mkJoinExpr l r secondSourceSimplePats, varSpaceWithGroupJoinVars | _ -> - errorR (Error(FSComp.SR.tcInvalidRelationInJoin nm.idText, relExpr.Range)) + errorR (Error(FSComp.SR.tcInvalidRelationInJoin (RichText.mkMethod nm.idText), relExpr.Range)) // since the shape of relExpr doesn't match our expectations (JoinRelation) // then we assume that this is l.h.s. of the join relation // so typechecker will treat relExpr as body of outerKeySelector lambda parameter in Join method @@ -1685,7 +1717,7 @@ let rec TryTranslateComputationExpression && equals mUnit range0 -> error (Error(FSComp.SR.tcEmptyBodyRequiresBuilderZeroMethod (), ceenv.mWhole)) - | _ -> error (Error(FSComp.SR.tcRequireBuilderMethod "Zero", m)) + | _ -> error (Error(FSComp.SR.tcRequireBuilderMethod (RichText.mkMethod "Zero"), m)) let mCall = if equals m range0 then ceenv.mWhole else m Some(translatedCtxt (mkSynCall "Zero" mCall [] ceenv.builderValName)) @@ -2228,7 +2260,7 @@ let rec TryTranslateComputationExpression loop 2 if maxMergeSources = 1 then - error (Error(FSComp.SR.tcRequireMergeSourcesOrBindN bindNName, mBind)) + error (Error(FSComp.SR.tcRequireMergeSourcesOrBindN (RichText.mkMethod bindNName), mBind)) let rec mergeSources (sourcesAndPats: (SynExpr * SynPat) list) = let numSourcesAndPats = sourcesAndPats.Length @@ -2500,7 +2532,12 @@ and ConsumeCustomOpClauses methInfo if isLikeZip || isLikeJoin || isLikeGroupJoin then - errorR (Error(FSComp.SR.tcBinaryOperatorRequiresBody (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + errorR ( + Error( + FSComp.SR.tcBinaryOperatorRequiresBody (RichText.mkMethod nm.idText, Option.get (customOpUsageText ceenv nm)), + nm.idRange + ) + ) match optionalCont with | None -> @@ -2547,7 +2584,10 @@ and ConsumeCustomOpClauses let expectedArgCount = defaultArg expectedArgCount 0 errorR ( - Error(FSComp.SR.tcCustomOperationHasIncorrectArgCount (nm.idText, expectedArgCount, args.Length), nm.idRange) + Error( + FSComp.SR.tcCustomOperationHasIncorrectArgCount (RichText.mkMethod nm.idText, expectedArgCount, args.Length), + nm.idRange + ) ) mkSynCall @@ -2575,7 +2615,7 @@ and ConsumeCustomOpClauses match optionalIntoPat with | Some intoPat -> if not (customOperationAllowsInto ceenv nm) then - error (Error(FSComp.SR.tcOperatorDoesntAcceptInto nm.idText, intoPat.Range)) + error (Error(FSComp.SR.tcOperatorDoesntAcceptInto (RichText.mkMethod nm.idText), intoPat.Range)) // Rebind using either for ... or let!.... let rebind = diff --git a/src/Compiler/Checking/Expressions/CheckComputationExpressionsCustomOps.fs b/src/Compiler/Checking/Expressions/CheckComputationExpressionsCustomOps.fs index 29cbdfcbb8e..b5ed0a75599 100644 --- a/src/Compiler/Checking/Expressions/CheckComputationExpressionsCustomOps.fs +++ b/src/Compiler/Checking/Expressions/CheckComputationExpressionsCustomOps.fs @@ -18,7 +18,7 @@ type DeferredCustomOpSink = { KeywordRange: range OpName: string - UsageText: unit -> string option + UsageText: unit -> RichText option SyntheticCallRange: range Fallback: MethInfo NameEnv: NameResolutionEnv diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index f09da4233e1..03ea69f01c2 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -139,7 +139,7 @@ exception OverrideInExtrinsicAugmentation of range exception NonUniqueInferredAbstractSlot of TcGlobals * DisplayEnv * string * MethInfo * MethInfo * range -exception StandardOperatorRedefinitionWarning of string * range +exception StandardOperatorRedefinitionWarning of RichText * range exception InvalidInternalsVisibleToAssemblyName of badName: string * fileName: string option @@ -478,7 +478,7 @@ let UnifyOverallType (cenv: cenv) (env: TcEnv) m overallTy actualTy = | TypeDirectedConversionUsed.No -> () if AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m reqdTy2 actualTy then - let reqdTyText, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes env.DisplayEnv reqdTy actualTy + let reqdTyText, actualTyText, _cxs = NicePrint.minimalRichTextsOfTwoTypes env.DisplayEnv reqdTy actualTy warning (Error(FSComp.SR.tcSubsumptionImplicitConversionUsed(actualTyText, reqdTyText), m)) else // report the error @@ -726,10 +726,10 @@ let UnifyUnitType (cenv: cenv) (env: TcEnv) m ty expr = | ContextInfo.SequenceExpression seqTy -> let liftedTy = mkSeqTy g ty if typeEquiv g seqTy liftedTy then - warning (Error (FSComp.SR.implicitlyDiscardedInSequenceExpression(NicePrint.prettyStringOfTy denv ty), m)) + warning (Error(FSComp.SR.implicitlyDiscardedInSequenceExpression(NicePrint.prettyRichTextOfTy denv ty), m)) else if isListTy g ty || isArrayTy g ty || typeEquiv g seqTy ty then - warning (Error (FSComp.SR.implicitlyDiscardedSequenceInSequenceExpression(NicePrint.prettyStringOfTy denv ty), m)) + warning (Error(FSComp.SR.implicitlyDiscardedSequenceInSequenceExpression(NicePrint.prettyRichTextOfTy denv ty), m)) else reportImplicitlyDiscardError() | _ -> @@ -1013,14 +1013,14 @@ let TcAddNullnessToType (warn: bool) (cenv: cenv) (env: TcEnv) nullness innerTyC let g = cenv.g if g.langFeatureNullness then if TypeNullNever g innerTyC then - let tyString = NicePrint.minimalStringOfType env.DisplayEnv innerTyC - errorR(Error(FSComp.SR.tcTypeDoesNotHaveAnyNull(tyString), m)) + let tyText = NicePrint.minimalRichTextOfType env.DisplayEnv innerTyC + errorR(Error(FSComp.SR.tcTypeDoesNotHaveAnyNull(tyText), m)) match tryAddNullnessToTy nullness innerTyC with | None -> - let tyString = NicePrint.minimalStringOfType env.DisplayEnv innerTyC - errorR(Error(FSComp.SR.tcTypeDoesNotHaveAnyNull(tyString), m)) + let tyText = NicePrint.minimalRichTextOfType env.DisplayEnv innerTyC + errorR(Error(FSComp.SR.tcTypeDoesNotHaveAnyNull(tyText), m)) innerTyC | Some innerTyCWithNull -> @@ -1115,12 +1115,12 @@ let MakeMemberDataAndMangledNameForMemberVal(g, tcref, isExtrinsic, attrs, implS let displayName = ConvertValLogicalNameToDisplayNameCore logicalName // Check symbolic members. Expect valSynData implied arity to be [[2]]. match SynInfo.AritiesOfArgs valSynData with - | [] | [0] -> warning(Error(FSComp.SR.memberOperatorDefinitionWithNoArguments displayName, m)) + | [] | [0] -> warning(Error(FSComp.SR.memberOperatorDefinitionWithNoArguments (RichText.mkMember displayName), m)) | n :: otherArgs -> let opTakesThreeArgs = IsLogicalTernaryOperator logicalName - if n<>2 && not opTakesThreeArgs then warning(Error(FSComp.SR.memberOperatorDefinitionWithNonPairArgument(displayName, n), m)) - if n<>3 && opTakesThreeArgs then warning(Error(FSComp.SR.memberOperatorDefinitionWithNonTripleArgument(displayName, n), m)) - if not (isNil otherArgs) then warning(Error(FSComp.SR.memberOperatorDefinitionWithCurriedArguments displayName, m)) + if n<>2 && not opTakesThreeArgs then warning(Error(FSComp.SR.memberOperatorDefinitionWithNonPairArgument(RichText.mkMember displayName, n), m)) + if n<>3 && opTakesThreeArgs then warning(Error(FSComp.SR.memberOperatorDefinitionWithNonTripleArgument(RichText.mkMember displayName, n), m)) + if not (isNil otherArgs) then warning(Error(FSComp.SR.memberOperatorDefinitionWithCurriedArguments (RichText.mkMember displayName), m)) if isExtrinsic && IsLogicalOpName id.idText then warning(Error(FSComp.SR.tcMemberOperatorDefinitionInExtrinsic(), id.idRange)) @@ -1251,32 +1251,32 @@ let CheckForAbnormalOperatorNames (cenv: cenv) (idRange: range) coreDisplayName match opName with | Relational -> if isMember then - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForRelationalOperator(opName, coreDisplayName), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForRelationalOperator(RichText.mkOperator opName, RichText.mkMember coreDisplayName), idRange)) else - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionRelational opName, idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionRelational(RichText.mkOperator opName), idRange)) | Equality -> if isMember then - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForEquality(opName, coreDisplayName), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForEquality(RichText.mkOperator opName, RichText.mkMember coreDisplayName), idRange)) else - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionEquality opName, idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionEquality(RichText.mkOperator opName), idRange)) | Control -> if isMember then - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberName(opName, coreDisplayName), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberName(RichText.mkOperator opName, RichText.mkMember coreDisplayName), idRange)) else - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinition opName, idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinition(RichText.mkOperator opName), idRange)) | Indexer -> if not isMember then - error(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidIndexOperatorDefinition opName, idRange)) + error(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidIndexOperatorDefinition(RichText.mkOperator opName), idRange)) | FixedTypes -> if isMember then - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberNameFixedTypes opName, idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberNameFixedTypes(RichText.mkOperator opName), idRange)) | Other -> () -let CheckInitProperties (g: TcGlobals) (minfo: MethInfo) methodName mItem = +let CheckInitProperties (g: TcGlobals) (minfo: MethInfo) (methodName: string) mItem = if g.langVersion.SupportsFeature(LanguageFeature.InitPropertiesSupport) then // Check, whether this method has external init, emit an error diagnostic in this case. if minfo.HasExternalInit then - errorR (Error (FSComp.SR.tcSetterForInitOnlyPropertyCannotBeCalled1 methodName, mItem)) + errorR (Error(FSComp.SR.tcSetterForInitOnlyPropertyCannotBeCalled1 (RichText.mkProperty methodName), mItem)) let CheckRequiredProperties (g:TcGlobals) (env: TcEnv) (cenv: TcFileState) (minfo: MethInfo) finalAssignedItemSetters mMethExpr = // Make sure, if apparent type has any required properties, they all are in the `finalAssignedItemSetters`. @@ -1310,7 +1310,7 @@ let CheckRequiredProperties (g:TcGlobals) (env: TcEnv) (cenv: TcFileState) (minf |> List.filter (fun pinfo -> not (Set.contains pinfo.PropertyName setterPropNames)) if missingProps.Length > 0 then let details = NicePrint.multiLineStringOfPropInfos g cenv.amap mMethExpr env.DisplayEnv missingProps - errorR(Error(FSComp.SR.tcMissingRequiredMembers details, mMethExpr)) + errorR(Error(FSComp.SR.tcMissingRequiredMembers (RichText.mkText details), mMethExpr)) let private HasMethodImplNoInliningAttribute g attrs = match attrs with @@ -1598,7 +1598,7 @@ let ChooseCanonicalDeclaredTyparsAfterInference g denv declaredTypars m = declaredTypars |> List.iter (fun tp -> let ty = mkTyparTy tp if not (isAnyParTy g ty) then - error(Error(FSComp.SR.tcLessGenericBecauseOfAnnotation(tp.Name, NicePrint.prettyStringOfTy denv ty), tp.Range))) + error(Error(FSComp.SR.tcLessGenericBecauseOfAnnotation(RichText.mkTypeParameter tp.Name, NicePrint.prettyRichTextOfTy denv ty), tp.Range))) let declaredTypars = NormalizeDeclaredTyparsForEquiRecursiveInference g declaredTypars @@ -1623,9 +1623,9 @@ let SetTyparRigid denv m (tp: Typar) = | None -> () | Some ty -> if tp.IsCompilerGenerated then - errorR(Error(FSComp.SR.tcGenericParameterHasBeenConstrained(NicePrint.prettyStringOfTy denv ty), m)) + errorR(Error(FSComp.SR.tcGenericParameterHasBeenConstrained(NicePrint.prettyRichTextOfTy denv ty), m)) else - errorR(Error(FSComp.SR.tcTypeParameterHasBeenConstrained(NicePrint.prettyStringOfTy denv ty), tp.Range)) + errorR(Error(FSComp.SR.tcTypeParameterHasBeenConstrained(NicePrint.prettyRichTextOfTy denv ty), tp.Range)) tp.SetRigidity TyparRigidity.Rigid let GeneralizeVal (cenv: cenv) denv enclosingDeclaredTypars generalizedTyparsForThisBinding prelimVal = @@ -1939,7 +1939,7 @@ let CheckRecdExprDuplicateFields (elems: Ident list) = elems |> List.iteri (fun i (uc1: Ident) -> elems |> List.iteri (fun j (uc2: Ident) -> if j > i && uc1.idText = uc2.idText then - errorR (Error(FSComp.SR.tcMultipleFieldsInRecord(uc1.idText), uc1.idRange)))) + errorR (Error(FSComp.SR.tcMultipleFieldsInRecord(RichText.mkRecordField uc1.idText), uc1.idRange)))) //------------------------------------------------------------------------- // Helpers to typecheck expressions and patterns @@ -2011,7 +2011,7 @@ let BuildFieldMap (cenv: cenv) env isPartial ty (flds: (Ident * ExplicitOrSpread CheckFSharpAttributes g fref2.PropertyAttribs ident.idRange |> CommitOperationResult if showDeprecated then - let diagnostic = Deprecated(FSComp.SR.nrRecordTypeNeedsQualifiedAccess(fref2.FieldName, fref2.Tycon.DisplayName) |> snd, m) + let diagnostic = Deprecated(FSComp.SR.nrRecordTypeNeedsQualifiedAccess(RichText.mkRecordField fref2.FieldName, richTextOfEntity fref2.Tycon) |> snd, m) if g.langVersion.SupportsFeature(LanguageFeature.ErrorOnDeprecatedRequireQualifiedAccess) then errorR(diagnostic) else @@ -2041,7 +2041,7 @@ let ApplyUnionCaseOrExn (makerForUnionCase, makerForExnTag) m mItemIdent (cenv: | Item.UnionCase(ucinfo, showDeprecated) -> if showDeprecated then - let diagnostic = Deprecated(FSComp.SR.nrUnionTypeNeedsQualifiedAccess(ucinfo.DisplayName, ucinfo.Tycon.DisplayName) |> snd, mItemIdent) + let diagnostic = Deprecated(FSComp.SR.nrUnionTypeNeedsQualifiedAccess(RichText.mkUnionCase ucinfo.DisplayName, richTextOfEntity ucinfo.Tycon) |> snd, mItemIdent) if g.langVersion.SupportsFeature(LanguageFeature.ErrorOnDeprecatedRequireQualifiedAccess) then errorR(diagnostic) else @@ -2306,7 +2306,7 @@ module GeneralizationHelpers = for tp in allDeclaredTypars do if Zset.memberOf freeInEnv tp then let ty = mkTyparTy tp - error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty), m)) + error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyRichTextOfTy denv ty), m)) let generalizedTypars = CondenseTypars(cenv, denv, generalizedTypars, tauTy, m) @@ -2580,7 +2580,7 @@ module BindingNormalization = NormalizedBindingPat(pat, rhsExpr, valSynData, typars) else if isObjExprBinding = ObjExprBinding then - errorR(Deprecated(FSComp.SR.tcObjectExpressionFormDeprecated(), m)) + errorR(Deprecated(RichText.mkText (FSComp.SR.tcObjectExpressionFormDeprecated()), m)) MakeNormalizedStaticOrValBinding cenv isObjExprBinding id vis typars args rhsExpr valSynData | _ -> error(Error(FSComp.SR.tcInvalidDeclaration(), m)) @@ -2776,7 +2776,7 @@ let TcValEarlyGeneralizationConsistencyCheck (cenv: cenv) (env: TcEnv) (v: Val, let vTauTy = instType (mkTyparInst vTypars tinst) vTauTy if not (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m tau vTauTy) then let txt = buildString (fun buf -> NicePrint.outputQualifiedValSpec env.DisplayEnv cenv.infoReader buf (mkLocalValRef v)) - error(Error(FSComp.SR.tcInferredGenericTypeGivesRiseToInconsistency(v.DisplayName, txt), m))) + error(Error(FSComp.SR.tcInferredGenericTypeGivesRiseToInconsistency(richTextOfValName g v, RichText.mkText txt), m))) | _ -> () @@ -2798,7 +2798,7 @@ let TcVal (cenv: cenv) env (tpenv: UnscopedTyparEnv) (vref: ValRef) instantiatio // Don't count compiler-generated refs (synthetic range) for FS1182 if not m.IsSynthetic then v.SetHasBeenReferenced() - CheckValAccessible m env.eAccessRights vref + CheckValAccessible g m env.eAccessRights vref CheckValAttributes g vref m |> CommitOperationResult @@ -2837,7 +2837,7 @@ let TcVal (cenv: cenv) env (tpenv: UnscopedTyparEnv) (vref: ValRef) instantiatio // No explicit instantiation (the normal case) | None -> if ValHasWellKnownAttribute g WellKnownValAttributes.RequiresExplicitTypeArgumentsAttribute v then - errorR(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(v.DisplayName), m)) + errorR(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(richTextOfValName g v), m)) match valRecInfo with | ValInRecScope false -> @@ -2853,7 +2853,7 @@ let TcVal (cenv: cenv) env (tpenv: UnscopedTyparEnv) (vref: ValRef) instantiatio | Some(vrefFlags, checkTys) -> let checkInst (tinst: TypeInst) = if not v.IsMember && not v.PermitsExplicitTypeInstantiation && not (List.isEmpty tinst) && not (List.isEmpty v.Typars) then - warning(Error(FSComp.SR.tcDoesNotAllowExplicitTypeArguments(v.DisplayName), m)) + warning(Error(FSComp.SR.tcDoesNotAllowExplicitTypeArguments(richTextOfValName g v), m)) match valRecInfo with | ValInRecScope false -> let vTypars, vTauTy = vref.GeneralizedType @@ -3028,24 +3028,24 @@ let TcRuntimeTypeTest isCast isOperator (cenv: cenv) denv m tgtTy srcTy = if isErasedType g tgtTy then if isCast then - warning(Error(FSComp.SR.tcTypeCastErased(NicePrint.minimalStringOfType denv tgtTy, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll g tgtTy)), m)) + warning(Error(FSComp.SR.tcTypeCastErased(NicePrint.minimalRichTextOfType denv tgtTy, NicePrint.minimalRichTextOfType denv (stripTyEqnsWrtErasure EraseAll g tgtTy)), m)) else - error(Error(FSComp.SR.tcTypeTestErased(NicePrint.minimalStringOfType denv tgtTy, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll g tgtTy)), m)) + error(Error(FSComp.SR.tcTypeTestErased(NicePrint.minimalRichTextOfType denv tgtTy, NicePrint.minimalRichTextOfType denv (stripTyEqnsWrtErasure EraseAll g tgtTy)), m)) else let checkTrgtNullness = match (srcTy,g),(tgtTy,g) with | (NullableRefType|NullTrueValue|NullableTypar), WithoutNullRefType when g.checkNullness && isCast -> - let srcNice = NicePrint.minimalStringOfTypeWithNullness denv srcTy - let tgtNice = NicePrint.minimalStringOfTypeWithNullness denv tgtTy - warning(Error(FSComp.SR.tcDowncastFromNullableToWithoutNull(srcNice,tgtNice,tgtNice), m)) + let srcNice = NicePrint.minimalRichTextOfTypeWithNullness denv srcTy + let tgtNice = NicePrint.minimalRichTextOfTypeWithNullness denv tgtTy + warning(Error(FSComp.SR.tcDowncastFromNullableToWithoutNull(srcNice, tgtNice, tgtNice), m)) false | (NullableRefType|NullTrueValue|NullableTypar), (NullableRefType|NullTrueValue|NullableTypar) -> not isCast //a type test (unlike type cast) will never return true for null in the source, therefore adding |null to target does not help => keep the erasure warning | _ -> true for ety in getErasedTypes g tgtTy checkTrgtNullness do if isMeasureTy g ety then - warning(Error(FSComp.SR.tcTypeTestLosesMeasures(NicePrint.minimalStringOfType denv ety), m)) + warning(Error(FSComp.SR.tcTypeTestLosesMeasures(NicePrint.minimalRichTextOfType denv ety), m)) else - warning(Error(FSComp.SR.tcTypeTestLossy(NicePrint.minimalStringOfTypeWithNullness denv ety, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll g ety)), m)) + warning(Error(FSComp.SR.tcTypeTestLossy(NicePrint.minimalRichTextOfTypeWithNullness denv ety, NicePrint.minimalRichTextOfType denv (stripTyEqnsWrtErasure EraseAll g ety)), m)) /// Checks, warnings and constraint assertions for upcasts let TcStaticUpcast (cenv: cenv) denv mSourceExpr mUpcastExpr tgtTy srcTy = @@ -3195,7 +3195,7 @@ let private CheckFieldLiteralArg (finfo: ILFieldInfo) argExpr m = match stripDebugPoints argExpr with | Expr.Const (v, _, _) -> let literalValue = string v - error (Error(FSComp.SR.tcLiteralFieldAssignmentWithArg literalValue, m)) + error (Error(FSComp.SR.tcLiteralFieldAssignmentWithArg (RichText.mkText literalValue), m)) | _ -> error (Error(FSComp.SR.tcLiteralFieldAssignmentNoArg(), m)) ) @@ -3358,7 +3358,7 @@ let AnalyzeArbitraryExprAsEnumerable (cenv: cenv) (env: TcEnv) localAlloc m expr let g = cenv.g let err k ty = - let txt = NicePrint.minimalStringOfType env.DisplayEnv ty + let txt = NicePrint.minimalRichTextOfType env.DisplayEnv ty let msg = if k then FSComp.SR.tcTypeCannotBeEnumerated txt else FSComp.SR.tcEnumTypeCannotBeEnumerated txt Exception(Error(msg, m)) @@ -4683,7 +4683,7 @@ and CheckIWSAM (cenv: cenv) (env: TcEnv) checkConstraints iwsam m tcref = if meths |> List.exists (fun meth -> not meth.IsInstance && meth.IsDispatchSlot && not meth.IsExtensionMember) then let tcref = tcrefOfAppTy g ty - warning(Error(FSComp.SR.tcUsingInterfaceWithStaticAbstractMethodAsType(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) + warning(Error(FSComp.SR.tcUsingInterfaceWithStaticAbstractMethodAsType(richTextOfEntityRefName tcref tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) and TcLongIdentType kindOpt (cenv: cenv) newOk checkConstraints occ iwsam env tpenv synLongId = let (SynLongIdent(tc, _, _)) = synLongId @@ -4778,7 +4778,7 @@ and CheckAnonRecdTypeDuplicateFields (elems: Ident array) = elems |> Array.iteri (fun i (uc1: Ident) -> elems |> Array.iteri (fun j (uc2: Ident) -> if j > i && uc1.idText = uc2.idText then - errorR(Error(FSComp.SR.tcAnonRecdTypeDuplicateFieldId(uc1.idText), uc1.idRange)))) + errorR(Error(FSComp.SR.tcAnonRecdTypeDuplicateFieldId(RichText.mkRecordField uc1.idText), uc1.idRange)))) and TcAnonRecdType (cenv: cenv) newOk checkConstraints occ env tpenv isStruct args m = let tupInfo = mkTupInfo isStruct @@ -4875,7 +4875,7 @@ and TcTypeStaticConstant kindOpt tpenv c m = and TcTypeMeasurePower kindOpt (cenv: cenv) newOk checkConstraints occ env tpenv ty exponent m = match kindOpt with | Some TyparKind.Type -> - errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression("^"), m)) + errorR(Error(FSComp.SR.tcUnexpectedSymbolInTypeExpression(RichText.mkOperator "^"), m)) NewErrorType (), tpenv | _ -> let ms, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv ty m @@ -4997,7 +4997,7 @@ and TcTyparConstraints (cenv: cenv) newOk checkConstraints occ env tpenv synCons #if !NO_TYPEPROVIDERS and TcStaticConstantParameter (cenv: cenv) (env: TcEnv) tpenv kind (StripParenTypes v) idOpt container = let g = cenv.g - let fail() = error(Error(FSComp.SR.etInvalidStaticArgument(NicePrint.minimalStringOfType env.DisplayEnv kind), v.Range)) + let fail() = error(Error(FSComp.SR.etInvalidStaticArgument(NicePrint.minimalRichTextOfType env.DisplayEnv kind), v.Range)) let record ttype = match idOpt with | Some id -> @@ -5084,16 +5084,16 @@ and CrackStaticConstantArgs (cenv: cenv) env tpenv (staticParameters: Tainted List.filter (fun (j, sp) -> j >= unnamedArgs.Length && n.idText = sp.PUntaint((fun sp -> sp.Name), m)) with | [] -> if staticParameters |> Array.exists (fun sp -> n.idText = sp.PUntaint((fun sp -> sp.Name), n.idRange)) then - error (Error(FSComp.SR.etStaticParameterAlreadyHasValue n.idText, n.idRange)) + error (Error(FSComp.SR.etStaticParameterAlreadyHasValue (RichText.mkParameter n.idText), n.idRange)) else let availableNames = staticParameters |> Array.map (fun sp -> sp.PUntaint((fun sp -> sp.Name), n.idRange)) |> formatAvailableNames - error (Error(FSComp.SR.etNoStaticParameterWithName (n.idText, availableNames), n.idRange)) + error (Error(FSComp.SR.etNoStaticParameterWithName(RichText.mkUnresolvedName n.idText, RichText.mkText availableNames), n.idRange)) | [_] -> () - | _ -> error (Error(FSComp.SR.etMultipleStaticParameterWithName n.idText, n.idRange)) + | _ -> error (Error(FSComp.SR.etMultipleStaticParameterWithName(RichText.mkParameter n.idText), n.idRange)) if staticParameters.Length < namedArgs.Length + unnamedArgs.Length then error (Error(FSComp.SR.etTooManyStaticParameters(staticParameters.Length, unnamedArgs.Length, namedArgs.Length), m)) @@ -5114,12 +5114,12 @@ and CrackStaticConstantArgs (cenv: cenv) env tpenv (staticParameters: Tainted if sp.PUntaint((fun sp -> sp.IsOptional), m) then match sp.PUntaint((fun sp -> sp.RawDefaultValue), m) with - | null -> error (Error(FSComp.SR.etStaticParameterRequiresAValue (spName, containerName, containerName, spName), m)) + | null -> error (Error(FSComp.SR.etStaticParameterRequiresAValue (RichText.mkParameter spName, RichText.ofQualifiedTypeName containerName, RichText.ofQualifiedTypeName containerName, RichText.mkParameter spName), m)) | v -> v else - error (Error(FSComp.SR.etStaticParameterRequiresAValue (spName, containerName, containerName, spName), m)) + error (Error(FSComp.SR.etStaticParameterRequiresAValue (RichText.mkParameter spName, RichText.ofQualifiedTypeName containerName, RichText.ofQualifiedTypeName containerName, RichText.mkParameter spName), m)) | ps -> - error (Error(FSComp.SR.etMultipleStaticParameterWithName spName, (fst (List.last ps)).idRange))) + error (Error(FSComp.SR.etMultipleStaticParameterWithName (RichText.mkParameter spName), (fst (List.last ps)).idRange))) argsInStaticParameterOrderIncludingDefaults @@ -5176,7 +5176,7 @@ and TcProvidedTypeApp (cenv: cenv) env tpenv tcref args m = //printfn "adding entity for provided type '%s', isDirectReferenceToGenerated = %b, isGenerated = %b" (st.PUntaint((fun st -> st.Name), m)) isDirectReferenceToGenerated isGenerated let isDirectReferenceToGenerated = isGenerated && IsGeneratedTypeDirectReference (providedTypeAfterStaticArguments, m) if isDirectReferenceToGenerated then - error(Error(FSComp.SR.etDirectReferenceToGeneratedTypeNotAllowed(tcref.DisplayName), m)) + error(Error(FSComp.SR.etDirectReferenceToGeneratedTypeNotAllowed(richTextOfEntityRef tcref), m)) // We put the type name check after the 'isDirectReferenceToGenerated' check because we need the 'isDirectReferenceToGenerated' error to be shown for generated types checkTypeName() @@ -5395,10 +5395,10 @@ and TcPatLongIdentActivePatternCase warnOnUpper (cenv: cenv) (env: TcEnv) vFlags let caseName = apinfo.ActiveTags[idx] let msg = match paramCount, returnCount with - | 0, 0 -> FSComp.SR.tcActivePatternArgsCountNotMatchNoArgsNoPat(caseName, caseName) - | 0, _ -> FSComp.SR.tcActivePatternArgsCountNotMatchOnlyPat(caseName) - | _, 0 -> FSComp.SR.tcActivePatternArgsCountNotMatchArgs(paramCount, caseName, fmtExprArgs paramCount) - | _, _ -> FSComp.SR.tcActivePatternArgsCountNotMatchArgsAndPat(paramCount, caseName, fmtExprArgs paramCount) + | 0, 0 -> FSComp.SR.tcActivePatternArgsCountNotMatchNoArgsNoPat(RichText.mkActivePatternCase caseName, RichText.mkActivePatternCase caseName) + | 0, _ -> FSComp.SR.tcActivePatternArgsCountNotMatchOnlyPat(RichText.mkActivePatternCase caseName) + | _, 0 -> FSComp.SR.tcActivePatternArgsCountNotMatchArgs(paramCount, RichText.mkActivePatternCase caseName, RichText.mkText (fmtExprArgs paramCount)) + | _, _ -> FSComp.SR.tcActivePatternArgsCountNotMatchArgsAndPat(paramCount, RichText.mkActivePatternCase caseName, RichText.mkText (fmtExprArgs paramCount)) error(Error(msg, m)) let isUnsolvedTyparTy g ty = tryDestTyparTy g ty |> ValueOption.exists (fun typar -> not typar.IsSolved) @@ -6556,7 +6556,7 @@ and TcExprTryFinally (cenv: cenv) overallTy env tpenv (synBodyExpr, synFinallyEx mkTryFinally g (bodyExpr, finallyExpr, mTryToLast, overallTy.Commit, spTry, spFinally), tpenv and TcExprJoinIn (cenv: cenv) overallTy env tpenv (synExpr1, mInToken, synExpr2, mAll) = - errorR(Error(FSComp.SR.parsUnfinishedExpression("in"), mInToken)) + errorR(Error(FSComp.SR.parsUnfinishedExpression(RichText.mkKeyword "in"), mInToken)) let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv synExpr1) let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv synExpr2) mkDefault(mAll, overallTy.Commit), tpenv @@ -6733,7 +6733,7 @@ and TcIteratedLambdas (cenv: cenv) isFirst (env: TcEnv) overallTy takenNames tpe // See bug 5758: Non-monotonicity in inference: need to ensure that parameters are never inferred to have byref type, instead it is always declared byrefs |> Map.iter (fun _ (orig, v) -> - if not orig && isByrefTy g v.Type then errorR(Error(FSComp.SR.tcParameterInferredByref v.DisplayName, v.Range))) + if not orig && isByrefTy g v.Type then errorR(Error(FSComp.SR.tcParameterInferredByref (RichText.mkParameter v.DisplayName), v.Range))) mkMultiLambda m vspecs (bodyExpr, resultTy), tpenv @@ -7042,7 +7042,7 @@ and TcNewExpr cenv env tpenv objTy mObjTyOpt superInit arg mWholeExprOrObjTy = mkCallCreateInstance g mWholeExprOrObjTy objTy, tpenv else - if not (isAppTy g objTy) && not (isAnyTupleTy g objTy) then error(Error(FSComp.SR.tcNamedTypeRequired(if superInit then "inherit" else "new"), mWholeExprOrObjTy)) + if not (isAppTy g objTy) && not (isAnyTupleTy g objTy) then error(Error(FSComp.SR.tcNamedTypeRequired(RichText.mkKeyword (if superInit then "inherit" else "new")), mWholeExprOrObjTy)) let item = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mWholeExprOrObjTy ad objTy) TcCtorCall false cenv env tpenv (MustEqual objTy) objTy mObjTyOpt item superInit [arg] mWholeExprOrObjTy [] None @@ -7092,7 +7092,7 @@ and TcCtorCall isNaked cenv env tpenv (overallTy: OverallTy) objTy mObjTyOpt ite TcNewDelegateThen cenv (MustEqual objTy) env tpenv mItem mWholeCall ty arg ExprAtomicFlag.NonAtomic delayed | _ -> - error(Error(FSComp.SR.tcSyntaxCanOnlyBeUsedToCreateObjectTypes(if superInit then "inherit" else "new"), mWholeCall)) + error(Error(FSComp.SR.tcSyntaxCanOnlyBeUsedToCreateObjectTypes(RichText.mkKeyword (if superInit then "inherit" else "new")), mWholeCall)) // Check a record construction expression and TcRecordConstruction (cenv: cenv) (overallTy: TType) isObjExpr env tpenv withExprInfoOpt (spreadSrcs : (Expr -> Expr) list) objTy fldsList m = @@ -7105,7 +7105,7 @@ and TcRecordConstruction (cenv: cenv) (overallTy: TType) isObjExpr env tpenv wit // Types with implicit constructors can't use record or object syntax: all constructions must go through the implicit constructor let supportsObjectExpressionWithoutOverrides = isObjExpr && g.langVersion.SupportsFeature(LanguageFeature.AllowObjectExpressionWithoutOverrides) if not supportsObjectExpressionWithoutOverrides && tycon.MembersOfFSharpTyconByName |> NameMultiMap.existsInRange (fun v -> v.IsIncrClassConstructor) then - errorR(Error(FSComp.SR.tcConstructorRequiresCall(tycon.DisplayName), m)) + errorR(Error(FSComp.SR.tcConstructorRequiresCall(richTextOfEntity tycon), m)) let fspecs = tycon.TrueInstanceFieldsAsList @@ -7126,7 +7126,15 @@ and TcRecordConstruction (cenv: cenv) (overallTy: TType) isObjExpr env tpenv wit let fieldExpr, tpenv = TcExprFlex cenv flex false fty env tpenv fexpr (fname, fieldExpr) :: checkedFields, tpenv) |> Option.defaultWith (fun () -> - error (Error(FSComp.SR.tcUndefinedField(fname, NicePrint.minimalStringOfType env.DisplayEnv objTy), m))) + error ( + Error( + FSComp.SR.tcUndefinedField( + RichText.mkUnresolvedName fname, + NicePrint.minimalRichTextOfType env.DisplayEnv objTy + ), + m + ) + )) tcFields checkedFields tpenv fields @@ -7170,7 +7178,7 @@ and TcRecordConstruction (cenv: cenv) (overallTy: TType) isObjExpr env tpenv wit // Check all fields are bound fspecs |> List.iter (fun fspec -> if not (fldsList |> List.exists (fun (fname, _) -> fname = fspec.LogicalName)) then - error(Error(FSComp.SR.tcFieldRequiresAssignment(fspec.rfield_id.idText, fullDisplayTextOfTyconRef tcref), m))) + error(Error(FSComp.SR.tcFieldRequiresAssignment(RichText.mkRecordField fspec.rfield_id.idText, richTextOfQualifiedTyconRef tcref), m))) // Other checks (overlap with above check now clear) let ns1 = NameSet.ofList (List.map fst fldsList) @@ -7185,7 +7193,7 @@ and TcRecordConstruction (cenv: cenv) (overallTy: TType) isObjExpr env tpenv wit // Don't emit the warning for nested field updates, because it does not really make sense. if oldFldsList.IsEmpty && not m.IsSynthetic then let enabledByLangFeature = g.langVersion.SupportsFeature LanguageFeature.WarningWhenCopyAndUpdateRecordChangesAllFields - warning(ErrorEnabledWithLanguageFeature(FSComp.SR.tcCopyAndUpdateRecordChangesAllFields(fullDisplayTextOfTyconRef tcref), m, enabledByLangFeature)) + warning(ErrorEnabledWithLanguageFeature(FSComp.SR.tcCopyAndUpdateRecordChangesAllFields(richTextOfQualifiedTyconRef tcref), m, enabledByLangFeature)) if not (Zset.subset ns1 ns2) then error (Error(FSComp.SR.tcExtraneousFieldsGivenValues(), m)) @@ -7290,15 +7298,15 @@ and FreshenObjExprAbstractSlot (cenv: cenv) (env: TcEnv) (implTy: TType) virtNam addToBuffer x if containsNonAbstractMemberWithSameName then - errorR(ErrorWithSuggestions(FSComp.SR.tcMemberFoundIsNotAbstractOrVirtual(tcref.DisplayName, bindName), mBinding, bindName, suggestVirtualMembers)) + errorR(ErrorWithSuggestions(FSComp.SR.tcMemberFoundIsNotAbstractOrVirtual(richTextOfEntityRef tcref, RichText.mkMember bindName), mBinding, bindName, suggestVirtualMembers)) else - errorR(ErrorWithSuggestions(FSComp.SR.tcNoAbstractOrVirtualMemberFound bindName, mBinding, bindName, suggestVirtualMembers)) + errorR(ErrorWithSuggestions(FSComp.SR.tcNoAbstractOrVirtualMemberFound (RichText.mkMember bindName), mBinding, bindName, suggestVirtualMembers)) | [ (_, absSlot: MethInfo) ] -> - errorR(Error(FSComp.SR.tcArgumentArityMismatch(bindName, List.sum absSlot.NumArgs, arity, getSignature absSlot, getDetails absSlot), mBinding)) + errorR(Error(FSComp.SR.tcArgumentArityMismatch(RichText.mkMember bindName, List.sum absSlot.NumArgs, arity, RichText.mkText (getSignature absSlot), RichText.mkText (getDetails absSlot)), mBinding)) | (_, absSlot) :: _ -> - errorR(Error(FSComp.SR.tcArgumentArityMismatchOneOverload(bindName, List.sum absSlot.NumArgs, arity, getSignature absSlot, getDetails absSlot), mBinding)) + errorR(Error(FSComp.SR.tcArgumentArityMismatchOneOverload(RichText.mkMember bindName, List.sum absSlot.NumArgs, arity, RichText.mkText (getSignature absSlot), RichText.mkText (getDetails absSlot)), mBinding)) None @@ -7677,7 +7685,7 @@ and TcFormatStringExpr cenv (overallTy: OverallTy) env m tpenv (fmtString: strin let _argTys, atyRequired, etyRequired, _percentATys, specifierLocations, _dotnetFormatString = try CheckFormatStrings.ParseFormatString m [m] g false false formatStringCheckContext normalizedString bty cty dty - with Failure errString -> error (Error(FSComp.SR.tcUnableToParseFormatString errString, m)) + with Failure errString -> error (Error(FSComp.SR.tcUnableToParseFormatString (RichText.mkText errString), m)) match cenv.tcSink.CurrentSink with | None -> () @@ -7913,7 +7921,7 @@ and TcInterpolatedStringExpr cenv (overallTy: OverallTy) env m tpenv (parts: Syn try CheckFormatStrings.ParseFormatString m stringFragmentRanges g true isFormattableString None printfFormatString printerArgTy printerResidueTy printerResultTy with Failure errString -> - error (Error(FSComp.SR.tcUnableToParseInterpolatedString errString, m)) + error (Error(FSComp.SR.tcUnableToParseInterpolatedString (RichText.mkText errString), m)) // Check the expressions filling the holes if argTys.Length <> synFillExprs.Length then @@ -8011,7 +8019,7 @@ and TcConstExpr cenv (overallTy: OverallTy) env m tpenv c = let ad = env.eAccessRights match ResolveLongIdentAsModuleOrNamespace cenv.tcSink cenv.amap m true OpenQualified env.eNameResEnv ad (ident (modName, m)) [] false ShouldNotifySink.Yes with | Result [] - | Exception _ -> error(Error(FSComp.SR.tcNumericLiteralRequiresModule modName, m)) + | Exception _ -> error(Error(FSComp.SR.tcNumericLiteralRequiresModule (RichText.mkModule modName), m)) | Result ((_, mref, _) :: _) -> let expr = try @@ -8217,7 +8225,7 @@ and TcAnonRecdExpr cenv (overallTy: TType) env tpenv (isStruct, optOrigSynExpr, | SynExprAnonRecordFieldOrSpread.Spread _ -> (* Spreads are allowed to shadow fields. *) None) |> List.countBy textOfLid |> List.iter (fun (label, count) -> - if count > 1 then error (Error (FSComp.SR.tcAnonRecdDuplicateFieldId(label), mWholeExpr))) + if count > 1 then error (Error(FSComp.SR.tcAnonRecdDuplicateFieldId(RichText.mkRecordField label), mWholeExpr))) TcCopyAndUpdateAnonRecdExpr cenv overallTy env tpenv (isStruct, orig, unsortedFieldIdsAndSynExprsGiven, mWholeExpr) @@ -8746,13 +8754,13 @@ and Propagate (cenv: cenv) (overallTy: OverallTy) (env: TcEnv) tpenv (expr: Appl error (NotAFunctionButIndexer(denv, overallTy.Commit, vName, mExpr, mArg, false)) match vName with | Some nm -> - error(Error(FSComp.SR.tcNotAFunctionButIndexerNamedIndexingNotYetEnabled(nm, nm), mExprAndArg)) + error(Error(FSComp.SR.tcNotAFunctionButIndexerNamedIndexingNotYetEnabled(RichText.mkMember nm, RichText.mkMember nm), mExprAndArg)) | _ -> error(Error(FSComp.SR.tcNotAFunctionButIndexerIndexingNotYetEnabled(), mExprAndArg)) else match vName with | Some nm -> - error(Error(FSComp.SR.tcNotAnIndexerNamedIndexingNotYetEnabled(nm), mExprAndArg)) + error(Error(FSComp.SR.tcNotAnIndexerNamedIndexingNotYetEnabled(RichText.mkMember nm), mExprAndArg)) | _ -> error(Error(FSComp.SR.tcNotAnIndexerIndexingNotYetEnabled(), mExprAndArg)) else @@ -9183,8 +9191,8 @@ and TcItemThen (cenv: cenv) (overallTy: OverallTy) env tpenv (tinstEnclosing, it // 'delayed' is about to be dropped on the floor, first do rudimentary checking to get name resolutions in its body RecordNameAndTypeResolutionsDelayed cenv env tpenv delayed match usageTextOpt() with - | None -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly nm, mItemIdent)) - | Some usageText -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly2(nm, usageText), mItemIdent)) + | None -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly (RichText.mkMethod nm), mItemIdent)) + | Some usageText -> error(Error(FSComp.SR.tcCustomOperationNotUsedCorrectly2(RichText.mkMethod nm, usageText), mItemIdent)) // These items are not expected here - they are only used for reporting symbols from name resolution to language service | Item.ActivePatternCase _ @@ -9284,7 +9292,7 @@ and TcUnionCaseOrExnCaseOrActivePatternResultItemThen (cenv: cenv) overallTy env | Item.ExnCase tref -> Item.RecdField (RecdFieldInfo ([], RecdFieldRef (tref, id.idText))) | _ -> failwithf "Expecting union case or exception item, got: %O" item CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, argItem, emptyTyparInst, ItemOccurrence.Use, ad) - else error(Error(FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce(id.idText), id.idRange)) + else error(Error(FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce(RichText.mkRecordField id.idText), id.idRange)) currentIndex <- SEEN_NAMED_ARGUMENT | None -> // ambiguity may appear only when if argument is boolean\generic. @@ -9308,13 +9316,13 @@ and TcUnionCaseOrExnCaseOrActivePatternResultItemThen (cenv: cenv) overallTy env else match item with | Item.UnionCase(uci, _) -> - error(Error(FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName(uci.DisplayName, id.idText), id.idRange)) + error(Error(FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName(RichText.mkUnionCase uci.DisplayName, RichText.mkUnresolvedName id.idText), id.idRange)) | Item.ExnCase tcref -> - error(Error(FSComp.SR.tcExceptionConstructorDoesNotHaveFieldWithGivenName(tcref.DisplayName, id.idText), id.idRange)) + error(Error(FSComp.SR.tcExceptionConstructorDoesNotHaveFieldWithGivenName(richTextOfEntityRef tcref, RichText.mkUnresolvedName id.idText), id.idRange)) | Item.ActivePatternResult _ -> error(Error(FSComp.SR.tcActivePatternsDoNotHaveFields(), id.idRange)) | _ -> - error(Error(FSComp.SR.tcConstructorDoesNotHaveFieldWithGivenName(id.idText), id.idRange)) + error(Error(FSComp.SR.tcConstructorDoesNotHaveFieldWithGivenName(RichText.mkUnresolvedName id.idText), id.idRange)) assert (Seq.forall (box >> ((<>) null) ) fittedArgs) List.ofArray fittedArgs @@ -9507,12 +9515,12 @@ and TcTraitItemThen (cenv: cenv) overallTy env objOpt traitInfo tpenv mItem dela match traitInfo.SupportTypes with | tys when tys.Length > 1 -> - error(Error (FSComp.SR.tcTraitHasMultipleSupportTypes(traitInfo.MemberDisplayNameCore), mItem)) + error(Error(FSComp.SR.tcTraitHasMultipleSupportTypes(RichText.mkMember traitInfo.MemberDisplayNameCore), mItem)) | _ -> () match objOpt, traitInfo.MemberFlags.IsInstance with - | Some _, false -> error (Error (FSComp.SR.tcTraitIsStatic traitInfo.MemberDisplayNameCore, mItem)) - | None, true -> error (Error (FSComp.SR.tcTraitIsNotStatic traitInfo.MemberDisplayNameCore, mItem)) + | Some _, false -> error (Error(FSComp.SR.tcTraitIsStatic (RichText.mkMember traitInfo.MemberDisplayNameCore), mItem)) + | None, true -> error (Error(FSComp.SR.tcTraitIsNotStatic (RichText.mkMember traitInfo.MemberDisplayNameCore), mItem)) | _ -> () // If this is an instance trait the object must be evaluated, just in case this is a first-class use of the trait, e.g. @@ -9715,7 +9723,7 @@ and TcValueItemThen cenv overallTy env vref tpenv mItem mItemIdent afterResoluti if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty vref.Deref.SetHasBeenReferenced() - CheckValAccessible mItemIdent env.AccessRights vref + CheckValAccessible g mItemIdent env.AccessRights vref CheckValAttributes g vref mItemIdent |> CommitOperationResult let vTy = vref.Type let vty2 = @@ -9823,7 +9831,7 @@ and TcPropertyItemThen cenv overallTy env nm pinfos tpenv mItem mItemIdent after ExprAtomicFlag.Atomic, None, [mkSynUnit mItem], delayed, tpenv if not pinfo.IsStatic then - error (Error (FSComp.SR.tcPropertyIsNotStatic nm, mItemIdent)) + error (Error(FSComp.SR.tcPropertyIsNotStatic (RichText.mkProperty nm), mItemIdent)) match delayed with | DelayedSet(expr2, mStmt) :: otherDelayed -> @@ -9839,21 +9847,21 @@ and TcPropertyItemThen cenv overallTy env nm pinfos tpenv mItem mItemIdent after let isByrefMethReturnSetter = meths |> List.exists (function _,Some pinfo -> isByrefTy g (pinfo.GetPropertyType(cenv.amap,mItem)) | _ -> false) if not isByrefMethReturnSetter then - errorR (Error (FSComp.SR.tcPropertyCannotBeSet1 nm, mItemIdent)) + errorR (Error(FSComp.SR.tcPropertyCannotBeSet1 (RichText.mkProperty nm), mItemIdent)) // x.P <- ... byref setter - if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable nm, mItemIdent)) + if isNil meths then error (Error(FSComp.SR.tcPropertyIsNotReadable (RichText.mkProperty nm), mItemIdent)) TcMethodApplicationThen cenv env overallTy None tpenv tyArgsOpt [] mItem mItemIdent nm ad NeverMutates true meths afterResolution NormalValUse args ExprAtomicFlag.Atomic staticTyOpt delayed else let args = if pinfo.IsIndexer then args else [] if isNil meths then - errorR (Error (FSComp.SR.tcPropertyCannotBeSet1 nm, mItemIdent)) + errorR (Error(FSComp.SR.tcPropertyCannotBeSet1 (RichText.mkProperty nm), mItemIdent)) // Note: static calls never mutate a struct object argument TcMethodApplicationThen cenv env overallTy None tpenv tyArgsOpt [] mStmt mItemIdent nm ad NeverMutates true meths afterResolution NormalValUse (args@[expr2]) ExprAtomicFlag.NonAtomic staticTyOpt otherDelayed | _ -> // Static Property Get (possibly indexer) let meths = pinfos |> GettersOfPropInfos - if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable nm, mItemIdent)) + if isNil meths then error (Error(FSComp.SR.tcPropertyIsNotReadable (RichText.mkProperty nm), mItemIdent)) // Note: static calls never mutate a struct object argument TcMethodApplicationThen cenv env overallTy None tpenv tyArgsOpt [] mItem mItemIdent nm ad NeverMutates true meths afterResolution NormalValUse args ExprAtomicFlag.Atomic staticTyOpt delayed @@ -9909,7 +9917,7 @@ and TcRecdFieldItemThen cenv overallTy env rfinfo tpenv mItem mItemIdent delayed let g = cenv.g let ad = env.eAccessRights CheckRecdFieldInfoAccessible cenv.amap mItemIdent ad rfinfo - if not rfinfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.DisplayName), mItemIdent)) + if not rfinfo.IsStatic then error (Error(FSComp.SR.tcFieldIsNotStatic(RichText.mkRecordField rfinfo.DisplayName), mItemIdent)) CheckRecdFieldInfoAttributes g rfinfo mItemIdent |> CommitOperationResult let fref = rfinfo.RecdFieldRef let fieldTy = rfinfo.FieldType @@ -10031,7 +10039,7 @@ and TcLookupItemThen cenv overallTy env tpenv mObjExpr objExpr objExprTy delayed if pinfo.IsIndexer then GetMemberApplicationArgs delayed cenv env tpenv else ExprAtomicFlag.Atomic, None, [mkSynUnit mItem], delayed, tpenv - if pinfo.IsStatic then error (Error (FSComp.SR.tcPropertyIsStatic nm, mItemIdent)) + if pinfo.IsStatic then error (Error(FSComp.SR.tcPropertyIsStatic (RichText.mkProperty nm), mItemIdent)) match delayed with @@ -10044,14 +10052,14 @@ and TcLookupItemThen cenv overallTy env tpenv mObjExpr objExpr objExprTy delayed let meths = pinfos |> GettersOfPropInfos let isByrefMethReturnSetter = meths |> List.exists (function _,Some pinfo -> isByrefTy g (pinfo.GetPropertyType(cenv.amap,mItem)) | _ -> false) if not isByrefMethReturnSetter then - errorR (Error (FSComp.SR.tcPropertyCannotBeSet1 nm, mItemIdent)) + errorR (Error(FSComp.SR.tcPropertyCannotBeSet1 (RichText.mkProperty nm), mItemIdent)) // x.P <- ... byref setter - if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable nm, mItemIdent)) + if isNil meths then error (Error(FSComp.SR.tcPropertyIsNotReadable (RichText.mkProperty nm), mItemIdent)) TcMethodApplicationThen cenv env overallTy None tpenv tyArgsOpt objArgs mExprAndItem mItemIdent nm ad PossiblyMutates true meths afterResolution NormalValUse args atomicFlag None delayed else if g.langVersion.SupportsFeature(LanguageFeature.RequiredPropertiesSupport) && pinfo.IsSetterInitOnly then - errorR (Error (FSComp.SR.tcInitOnlyPropertyCannotBeSet1 nm, mItemIdent)) + errorR (Error(FSComp.SR.tcInitOnlyPropertyCannotBeSet1 (RichText.mkProperty nm), mItemIdent)) let args = if pinfo.IsIndexer then args else [] let mut = (if isStructTy g (tyOfExpr g objExpr) then DefinitelyMutates else PossiblyMutates) @@ -10059,7 +10067,7 @@ and TcLookupItemThen cenv overallTy env tpenv mObjExpr objExpr objExprTy delayed | _ -> // Instance property getter let meths = GettersOfPropInfos pinfos - if isNil meths then error (Error (FSComp.SR.tcPropertyIsNotReadable nm, mItemIdent)) + if isNil meths then error (Error(FSComp.SR.tcPropertyIsNotReadable (RichText.mkProperty nm), mItemIdent)) TcMethodApplicationThen cenv env overallTy None tpenv tyArgsOpt objArgs mExprAndItem mItemIdent nm ad PossiblyMutates true meths afterResolution NormalValUse args atomicFlag None delayed | Item.RecdField rfinfo -> @@ -10161,8 +10169,8 @@ and TcEventItemThen (cenv: cenv) overallTy env tpenv mItem mItemIdent mExprAndIt let nm = einfo.EventName match objDetails, einfo.IsStatic with - | Some _, true -> error (Error (FSComp.SR.tcEventIsStatic nm, mItemIdent)) - | None, false -> error (Error (FSComp.SR.tcEventIsNotStatic nm, mItemIdent)) + | Some _, true -> error (Error(FSComp.SR.tcEventIsStatic (RichText.mkEvent nm), mItemIdent)) + | None, false -> error (Error(FSComp.SR.tcEventIsNotStatic (RichText.mkEvent nm), mItemIdent)) | _ -> () // The F# wrappers around events are null safe (impl is in FSharp.Core). Therefore, from an F# perspective, the type of the delegate can be considered Not Null. @@ -10253,14 +10261,14 @@ and TcMethodApplicationThen // Give errors if some things couldn't be assigned if not (isNil attributeAssignedNamedItems) then let (CallerNamedArg(id, _)) = List.head attributeAssignedNamedItems - errorR(Error(FSComp.SR.tcNamedArgumentDidNotMatch(id.idText), id.idRange)) + errorR(Error(FSComp.SR.tcNamedArgumentDidNotMatch(RichText.mkParameter id.idText), id.idRange)) // Resolve the "delayed" lookups let exprTy = (tyOfExpr g expr) for problematicTy in GetDisallowedNullness g exprTy do let denv = env.DisplayEnv - warning(Error(FSComp.SR.tcDisallowedNullableApplication(methodName,NicePrint.minimalStringOfType denv problematicTy), m)) + warning(Error(FSComp.SR.tcDisallowedNullableApplication(RichText.mkMethod methodName, NicePrint.minimalRichTextOfType denv problematicTy), m)) PropagateThenTcDelayed cenv overallTy env tpenv mWholeExpr (MakeApplicableExprNoFlex cenv expr) exprTy atomicFlag delayed @@ -10868,7 +10876,7 @@ and TcMethodApplication if not finalCalledMeth.IsIndexParamArraySetter && not finalCalledMeth.IsIndexerSetter && (finalCalledMeth.ArgSets |> List.existsi (fun i argSet -> argSet.UnnamedCalledArgs |> List.existsi (fun j ca -> ca.Position <> (i, j)))) then - errorR(Deprecated(FSComp.SR.tcUnnamedArgumentsDoNotFormPrefix(), mMethExpr)) + errorR(Deprecated(RichText.mkText (FSComp.SR.tcUnnamedArgumentsDoNotFormPrefix()), mMethExpr)) /// STEP 5. Build the argument list. Adjust for optional arguments, byref arguments and coercions. @@ -10999,7 +11007,7 @@ and TcSetterArgExpr (cenv: cenv) env denv objExpr ad assignedSetter calledFromCo CheckPropInfoAttributes pinfo id.idRange |> CommitOperationResult if g.langVersion.SupportsFeature(LanguageFeature.RequiredPropertiesSupport) && pinfo.IsSetterInitOnly && not calledFromConstructor then - errorR (Error (FSComp.SR.tcInitOnlyPropertyCannotBeSet1 pinfo.PropertyName, m)) + errorR (Error(FSComp.SR.tcInitOnlyPropertyCannotBeSet1 (RichText.mkProperty pinfo.PropertyName), m)) MethInfoChecks g cenv.amap true None [objExpr] ad m pminfo let calledArgTy = List.head (List.head (pminfo.GetParamTypes(cenv.amap, m, pminst))) @@ -11651,7 +11659,7 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt errorR(Error(FSComp.SR.tcPartialActivePattern(), m)) if Option.isSome memberFlagsOpt && not spatsL.IsEmpty then - errorR(Error(FSComp.SR.tcInvalidActivePatternName(apinfo.LogicalName), m)) + errorR(Error(FSComp.SR.tcInvalidActivePatternName(RichText.mkActivePatternCase apinfo.LogicalName), m)) apinfo.ActiveTagsWithRanges |> List.iteri (fun i (_tag, tagRange) -> let item = Item.ActivePatternResult(apinfo, apOverallTy, i, tagRange) @@ -11965,7 +11973,7 @@ and TcAttributeEx canFail (cenv: cenv) (env: TcEnv) attrTgt attrEx (synAttr: Syn match canFail with | TcCanFail.IgnoreAllErrors | TcCanFail.IgnoreMemberResoutionError -> [], true | TcCanFail.ReportAllErrors -> - errorR(Error(FSComp.SR.tcGenericAttributesNotSupported(tcref.DisplayName), mAttr)) + errorR(Error(FSComp.SR.tcGenericAttributesNotSupported(richTextOfEntityRef tcref), mAttr)) [], false else @@ -12031,7 +12039,7 @@ and TcAttributeEx canFail (cenv: cenv) (env: TcEnv) attrTgt attrEx (synAttr: Syn let checkPropSetterAttribAccess m (pinfo: PropInfo) = let setterMeth = pinfo.SetterMethod if not <| IsTypeAndMethInfoAccessible cenv.amap m ad ad setterMeth then - errorR(Error (FSComp.SR.tcPropertyCannotBeSetPrivateSetter(pinfo.PropertyName), m)) + errorR(Error(FSComp.SR.tcPropertyCannotBeSetPrivateSetter(RichText.mkProperty pinfo.PropertyName), m)) let namedAttribArgMap = attributeAssignedNamedItems |> List.map (fun (CallerNamedArg(id, CallerArg(callerArgTy, m, isOpt, callerArgExpr))) -> @@ -12423,7 +12431,7 @@ and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (_: Val option) (a | meths when methInfosEquivByNameAndSig meths -> meths | [] -> let raiseGenericArityMismatch() = - let details = NicePrint.multiLineStringOfMethInfos cenv.infoReader m envinner.DisplayEnv slots + let details = NicePrint.multiLineRichTextOfMethInfos cenv.infoReader m envinner.DisplayEnv slots errorR(Error(FSComp.SR.tcOverrideArityMismatch details, memberId.idRange)) [] @@ -12518,7 +12526,7 @@ and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (_: Val option) (a let kIsGet = (k = SynMemberKind.PropertyGet) if not (if kIsGet then uniqueAbstractProp.HasGetter else uniqueAbstractProp.HasSetter) then - error(Error(FSComp.SR.tcAbstractPropertyMissingGetOrSet(if kIsGet then "getter" else "setter"), memberId.idRange)) + error(Error(FSComp.SR.tcAbstractPropertyMissingGetOrSet(RichText.mkText (if kIsGet then "getter" else "setter")), memberId.idRange)) let uniqueAbstractMeth = if kIsGet then uniqueAbstractProp.GetterMethod else uniqueAbstractProp.SetterMethod @@ -13028,7 +13036,7 @@ and TcLetrecBinding | Some thisVal -> reqdThisValTy, thisVal.Type, thisVal.Range if not (AddCxTypeEqualsTypeUndoIfFailed envRec.DisplayEnv cenv.css rangeForCheck actualThisValTy reqdThisValTy) then - errorR (Error(FSComp.SR.tcNonUniformMemberUse vspec.DisplayName, vspec.Range)) + errorR (Error(FSComp.SR.tcNonUniformMemberUse (richTextOfValName g vspec), vspec.Range)) let preGeneralizationRecBind = { RecBindingInfo = rbind.RecBindingInfo @@ -13427,7 +13435,7 @@ and FixupLetrecBind (cenv: cenv) denv generalizedTyparsForRecursiveBlock (bind: and unionGeneralizedTypars typarSets = List.foldBack (ListSet.unionFavourRight typarEq) typarSets [] -and CheckRecursiveInlineGroup (bindings: PreInitializationGraphEliminationBinding list) = +and CheckRecursiveInlineGroup g (bindings: PreInitializationGraphEliminationBinding list) = let inlineBindings = bindings |> List.filter (fun pgrbind -> @@ -13474,7 +13482,7 @@ and CheckRecursiveInlineGroup (bindings: PreInitializationGraphEliminationBindin // via the FS1113/FS1114/FS1118 "not bound in optimization environment" cascade. // This momentarily surfaces the binding as non-inline to the language service, // which is acceptable because compilation already fails here with FS3890. - errorR(Error(FSComp.SR.tcRecursiveInlineNotAllowed(v.DisplayName), v.Range)) + errorR(Error(FSComp.SR.tcRecursiveInlineNotAllowed(richTextOfValName g v), v.Range)) v.SetInlineInfo ValInline.Never and TcLetrecBindings overridesOK (cenv: cenv) env tpenv (binds, bindsm, scopem) = @@ -13510,7 +13518,7 @@ and TcLetrecBindings overridesOK (cenv: cenv) env tpenv (binds, bindsm, scopem) // Now that we know what we've generalized we can adjust the recursive references let vxbinds = vxbinds |> List.map (FixupLetrecBind cenv env.DisplayEnv generalizedTyparsForRecursiveBlock) - CheckRecursiveInlineGroup vxbinds + CheckRecursiveInlineGroup g vxbinds // Now eliminate any initialization graphs let binds = diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fsi b/src/Compiler/Checking/Expressions/CheckExpressions.fsi index 199ce0e720e..5c17a08aa94 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fsi +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fsi @@ -117,7 +117,7 @@ exception OverrideInExtrinsicAugmentation of range exception NonUniqueInferredAbstractSlot of TcGlobals * DisplayEnv * string * MethInfo * MethInfo * range -exception StandardOperatorRedefinitionWarning of string * range +exception StandardOperatorRedefinitionWarning of RichText * range exception InvalidInternalsVisibleToAssemblyName of badName: string * fileName: string option @@ -484,7 +484,7 @@ val FixupLetrecBind: /// Detect recursive 'inline' bindings within a recursive binding group and /// emit FS3890. Mutates inline info to suppress downstream cascades. -val CheckRecursiveInlineGroup: bindings: PreInitializationGraphEliminationBinding list -> unit +val CheckRecursiveInlineGroup: g: TcGlobals -> bindings: PreInitializationGraphEliminationBinding list -> unit /// Produce a fresh view of an object type, e.g. 'List' becomes 'List' for new /// inference variables with the given rigidity. diff --git a/src/Compiler/Checking/InfoReader.fs b/src/Compiler/Checking/InfoReader.fs index e753ca643e6..e0259eaa358 100644 --- a/src/Compiler/Checking/InfoReader.fs +++ b/src/Compiler/Checking/InfoReader.fs @@ -1038,7 +1038,7 @@ type InfoReader(g: TcGlobals, amap: ImportMap) as this = let checkLanguageFeatureRuntimeAndRecover (infoReader: InfoReader) langFeature m = if not (infoReader.IsLanguageFeatureRuntimeSupported langFeature) then let featureStr = LanguageVersion.GetFeatureString langFeature - errorR (Error(FSComp.SR.chkFeatureNotRuntimeSupported featureStr, m)) + errorR (Error(FSComp.SR.chkFeatureNotRuntimeSupported (RichText.mkText featureStr), m)) let GetIntrinsicConstructorInfosOfType (infoReader: InfoReader) m ty = infoReader.GetIntrinsicConstructorInfosOfTypeAux m ty ty diff --git a/src/Compiler/Checking/MethodCalls.fs b/src/Compiler/Checking/MethodCalls.fs index ea5a15fa543..94aa21ad38c 100644 --- a/src/Compiler/Checking/MethodCalls.fs +++ b/src/Compiler/Checking/MethodCalls.fs @@ -220,8 +220,8 @@ let TryFindRelevantImplicitConversion (infoReader: InfoReader) ad reqdTy actualT Some (minfo, staticTy, (reqdTy, reqdTy2, ignore)) | (minfo, staticTy) :: _ -> Some (minfo, staticTy, (reqdTy, reqdTy2, fun denv -> - let reqdTy2Text, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes denv reqdTy2 actualTy - let implicitsText = NicePrint.multiLineStringOfMethInfos infoReader m denv (List.map fst implicits) + let reqdTy2Text, actualTyText, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv reqdTy2 actualTy + let implicitsText = NicePrint.multiLineRichTextOfMethInfos infoReader m denv (List.map fst implicits) errorR(Error(FSComp.SR.tcAmbiguousImplicitConversion(actualTyText, reqdTy2Text, implicitsText), m)))) | _ -> None else @@ -260,12 +260,12 @@ let rec AdjustRequiredTypeForTypeDirectedConversions (infoReader: InfoReader) ad let g = infoReader.g let warn info denv = - let reqdTyText, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes denv reqdTy actualTy + let reqdTyText, actualTyText, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv reqdTy actualTy match info with | TypeDirectedConversion.BuiltIn -> Error(FSComp.SR.tcBuiltInImplicitConversionUsed(actualTyText, reqdTyText), m) | TypeDirectedConversion.Implicit convMeth -> - let methText = NicePrint.stringOfMethInfo infoReader m denv convMeth + let methText = NicePrint.richTextOfMethInfo infoReader m denv convMeth if isMethodArg then Error(FSComp.SR.tcImplicitConversionUsedForMethodArg(methText, actualTyText, reqdTyText), m) else @@ -720,7 +720,7 @@ type CalledMeth<'T> let names = System.Collections.Generic.HashSet<_>() for CallerNamedArg(nm, _) in namedCallerArgs do if not (names.Add nm.idText) then - errorR(Error(FSComp.SR.typrelNamedArgumentHasBeenAssignedMoreThenOnce nm.idText, m)) + errorR(Error(FSComp.SR.typrelNamedArgumentHasBeenAssignedMoreThenOnce (RichText.mkParameter nm.idText), m)) let argSet = { UnnamedCalledArgs=unnamedCalledArgs; UnnamedCallerArgs=unnamedCallerArgs; ParamArrayCalledArgOpt=paramArrayCalledArgOpt; ParamArrayCallerArgs=paramArrayCallerArgs; AssignedNamedArgs=assignedNamedArgs } @@ -1025,7 +1025,7 @@ let TakeObjAddrForMethodCall g amap (minfo: MethInfo) isMutable m staticTyOpt ob minfo.TryObjArgByrefType(amap, m, minfo.FormalMethodInst) |> Option.iter (fun ty -> if not (isInByrefTy g ty) then - errorR(Error(FSComp.SR.tcCannotCallExtensionMethodInrefToByref(minfo.DisplayName), m))) + errorR(Error(FSComp.SR.tcCannotCallExtensionMethodInrefToByref(RichText.mkMethod minfo.DisplayName), m))) wrap, [objArgExprCoerced] @@ -1202,7 +1202,7 @@ let rec BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst // prohibit calls to methods that are declared in specific array types (Get, Set, Address) // these calls are provided by the runtime and should not be called from the user code if isArrayTy g enclTy then - let tpe = TypeProviderError(FSComp.SR.tcRuntimeSuppliedMethodCannotBeUsedInUserCode(minfo.DisplayName), providedMeth.TypeProviderDesignation, m) + let tpe = TypeProviderError(FSComp.SR.tcRuntimeSuppliedMethodCannotBeUsedInUserCode(RichText.mkMethod minfo.DisplayName), providedMeth.TypeProviderDesignation, m) error tpe let isStruct = isStructTy g enclTy let isCtor = minfo.IsConstructor @@ -1289,7 +1289,7 @@ let rec BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst let ILFieldStaticChecks g amap infoReader ad m (finfo : ILFieldInfo) = CheckILFieldInfoAccessible g amap m ad finfo - if not finfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(finfo.FieldName), m)) + if not finfo.IsStatic then error (Error(FSComp.SR.tcFieldIsNotStatic(RichText.mkField finfo.FieldName), m)) // Static IL interfaces fields are not supported in lower F# versions. if isInterfaceTy g finfo.ApparentEnclosingType then @@ -1306,9 +1306,9 @@ let ILFieldInstanceChecks g amap ad m (finfo : ILFieldInfo) = let MethInfoChecks g amap isInstance tyargsOpt objArgs ad m (minfo: MethInfo) = if minfo.IsInstance <> isInstance then if isInstance then - error (Error (FSComp.SR.csMethodIsNotAnInstanceMethod(minfo.LogicalName), m)) + error (Error(FSComp.SR.csMethodIsNotAnInstanceMethod(RichText.mkMethod minfo.LogicalName), m)) else - error (Error (FSComp.SR.csMethodIsNotAStaticMethod(minfo.LogicalName), m)) + error (Error(FSComp.SR.csMethodIsNotAStaticMethod(RichText.mkMethod minfo.LogicalName), m)) // keep the original accessibility domain to determine type accessibility let adOriginal = ad @@ -1329,7 +1329,7 @@ let MethInfoChecks g amap isInstance tyargsOpt objArgs ad m (minfo: MethInfo) = | _ -> ad if not (minfo.IsProtectedAccessibility && minfo.LogicalName.StartsWithOrdinal("set_")) && not(IsTypeAndMethInfoAccessible amap m adOriginal ad minfo) then - error (Error (FSComp.SR.tcMethodNotAccessible(minfo.LogicalName), m)) + error (Error(FSComp.SR.tcMethodNotAccessible(RichText.mkMethod minfo.LogicalName), m)) if isAnyTupleTy g minfo.ApparentEnclosingType && not minfo.IsExtensionMember && (minfo.LogicalName.StartsWithOrdinal("get_Item") || minfo.LogicalName.StartsWithOrdinal("get_Rest")) then @@ -1768,7 +1768,7 @@ let AdjustCallerArgs tcVal tcFieldInit eCallerMemberName (infoReader: InfoReader match objArgs, lambdaVars with | [objArg], Some _ -> if calledMethInfo.IsExtensionMember && calledMethInfo.ObjArgNeedsAddress(amap, mMethExpr) then - error(Error(FSComp.SR.tcCannotPartiallyApplyExtensionMethodForByref(calledMethInfo.DisplayName), mMethExpr)) + error(Error(FSComp.SR.tcCannotPartiallyApplyExtensionMethodForByref(RichText.mkMethod calledMethInfo.DisplayName), mMethExpr)) let objArgTy = tyOfExpr g objArg let v, ve = mkCompGenLocal mMethExpr "objectArg" objArgTy (fun body -> mkCompGenLet mMethExpr v objArg body), [ve] @@ -1835,7 +1835,7 @@ module ProvidedMethodCalls = let ty = ImportProvidedType amap m objTy let normTy = normalizeEnumTy g ty obj.PUntaint((fun v -> - let fail() = raise (TypeProviderError(FSComp.SR.etUnsupportedConstantType(v.GetType().ToString()), constant.TypeProviderDesignation, m)) + let fail() = raise (TypeProviderError(FSComp.SR.etUnsupportedConstantType(RichText.mkText (v.GetType().ToString())), constant.TypeProviderDesignation, m)) try if isNull v then mkNull m ty else let c = @@ -1935,9 +1935,9 @@ module ProvidedMethodCalls = dict let rec exprToExprAndWitness top (ea: Tainted<(ProvidedExpr | null)>) = - let fail() = error(Error(FSComp.SR.etUnsupportedProvidedExpression(ea.PUntaint((fun etree -> match etree with null -> "" | e -> e.UnderlyingExpressionString), m)), m)) + let fail() = error(Error(FSComp.SR.etUnsupportedProvidedExpression(RichText.mkText (ea.PUntaint((fun etree -> match etree with null -> "" | e -> e.UnderlyingExpressionString), m))), m)) match ea with - | Tainted.Null -> error(Error(FSComp.SR.etNullProvidedExpression(ea.TypeProviderDesignation), m)) + | Tainted.Null -> error(Error(FSComp.SR.etNullProvidedExpression(RichText.mkText ea.TypeProviderDesignation), m)) | Tainted.NonNull ea -> let exprType = ea.PApplyOption((fun x -> x.GetExprType()), m) let exprType = match exprType with | Some exprType -> exprType | None -> fail() @@ -2128,7 +2128,7 @@ module ProvidedMethodCalls = | true, v -> v | _ -> let typeProviderDesignation = DisplayNameOfTypeProvider (pe.TypeProvider, m) - error(Error(FSComp.SR.etIncorrectParameterExpression(typeProviderDesignation, vRaw.Name), m)) + error(Error(FSComp.SR.etIncorrectParameterExpression(RichText.mkText typeProviderDesignation, RichText.mkParameter vRaw.Name), m)) and exprToExpr expr = let _, (resExpr, _) = exprToExprAndWitness false expr diff --git a/src/Compiler/Checking/MethodOverrides.fs b/src/Compiler/Checking/MethodOverrides.fs index 125bed2fdb8..691af43fe55 100644 --- a/src/Compiler/Checking/MethodOverrides.fs +++ b/src/Compiler/Checking/MethodOverrides.fs @@ -115,31 +115,22 @@ exception OverrideDoesntOverride of DisplayEnv * OverrideInfo * MethInfo option module DispatchSlotChecking = /// Print the signature of an override to a buffer as part of an error message - let PrintOverrideToBuffer denv os (Override(_, _, id, methTypars, memberToParentInst, argTys, retTy, _, _, _)) = + let FormatOverride denv (Override(_, _, id, methTypars, memberToParentInst, argTys, retTy, _, _, _)) = let denv = { denv with showTyparBinding = true } let retTy = (retTy |> GetFSharpViewOfReturnType denv.g) let argInfos = match argTys with | [] -> [[(denv.g.unit_ty, ValReprInfo.unnamedTopArg1)]] | _ -> argTys |> List.mapSquared (fun ty -> (ty, ValReprInfo.unnamedTopArg1)) - LayoutRender.bufferL os (NicePrint.prettyLayoutOfMemberSig denv (memberToParentInst, id.idText, methTypars, argInfos, retTy)) + LayoutRender.toRichText (NicePrint.prettyLayoutOfMemberSig denv (memberToParentInst, id.idText, methTypars, argInfos, retTy)) - /// Print the signature of a MethInfo to a buffer as part of an error message - let PrintMethInfoSigToBuffer g amap m denv os minfo = + let FormatMethInfoSig g amap m denv minfo = let denv = { denv with showTyparBinding = true } let (CompiledSig(argTys, retTy, fmethTypars, ttpinst)) = CompiledSigOfMeth g amap m minfo let retTy = (retTy |> GetFSharpViewOfReturnType g) let argInfos = argTys |> List.mapSquared (fun ty -> (ty, ValReprInfo.unnamedTopArg1)) let nm = minfo.LogicalName - LayoutRender.bufferL os (NicePrint.prettyLayoutOfMemberSig denv (ttpinst, nm, fmethTypars, argInfos, retTy)) - - /// Format the signature of an override as a string as part of an error message - let FormatOverride denv d = - buildString (fun buf -> PrintOverrideToBuffer denv buf d) - - /// Format the signature of a MethInfo as a string as part of an error message - let FormatMethInfoSig g amap m denv d = - buildString (fun buf -> PrintMethInfoSigToBuffer g amap m denv buf d) + LayoutRender.toRichText (NicePrint.prettyLayoutOfMemberSig denv (ttpinst, nm, fmethTypars, argInfos, retTy)) /// Get the override info for an existing (inherited) method being used to implement a dispatch slot. let GetInheritedMemberOverrideInfo g amap m parentType (minfo: MethInfo) = @@ -391,13 +382,13 @@ module DispatchSlotChecking = checkLanguageFeatureAndRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m if reqdSlot.PossiblyNoMostSpecificImplementation then - errorR(Error(FSComp.SR.typrelInterfaceMemberNoMostSpecificImplementation(NicePrint.stringOfMethInfo infoReader m denv dispatchSlot), m)) + errorR(Error(FSComp.SR.typrelInterfaceMemberNoMostSpecificImplementation(NicePrint.richTextOfMethInfo infoReader m denv dispatchSlot), m)) // error reporting path let compiledSig = CompiledSigOfMeth g amap m dispatchSlot let noimpl() = - missingOverloadImplementation.Add((isReqdTyInterface, lazy NicePrint.stringOfMethInfo infoReader m denv dispatchSlot)) + missingOverloadImplementation.Add((isReqdTyInterface, lazy NicePrint.richTextOfMethInfo infoReader m denv dispatchSlot)) match overrides |> List.filter (IsPartialMatch g dispatchSlot compiledSig) with | [] -> @@ -431,7 +422,7 @@ module DispatchSlotChecking = elif not (IsTyparKindMatch compiledSig overrideBy) then fail(Error(FSComp.SR.typrelMemberDoesNotHaveCorrectKindsOfGenericParameters(FormatOverride denv overrideBy, FormatMethInfoSig g amap m denv dispatchSlot), overrideBy.Range)) else - fail(Error(FSComp.SR.typrelMemberCannotImplement(FormatOverride denv overrideBy, NicePrint.stringOfMethInfo infoReader m denv dispatchSlot, FormatMethInfoSig g amap m denv dispatchSlot), overrideBy.Range)) + fail(Error(FSComp.SR.typrelMemberCannotImplement(FormatOverride denv overrideBy, NicePrint.richTextOfMethInfo infoReader m denv dispatchSlot, FormatMethInfoSig g amap m denv dispatchSlot), overrideBy.Range)) | overrideBy :: _ -> errorR(Error(FSComp.SR.typrelOverloadNotFound(FormatMethInfoSig g amap m denv dispatchSlot, FormatMethInfoSig g amap m denv dispatchSlot), overrideBy.Range)) @@ -464,13 +455,19 @@ module DispatchSlotChecking = fail(Error(FSComp.SR.typrelNoImplementationGiven(signature), m)) else let signatures = - (missingOverloadImplementation - |> Seq.truncate maxDisplayedOverrides - |> Seq.map (snd >> fun signature -> System.Environment.NewLine + "\t'" + signature.Value + "'") - |> String.concat "") + System.Environment.NewLine + let listed = + missingOverloadImplementation + |> Seq.truncate maxDisplayedOverrides + |> Seq.map (fun (_, signature) -> + RichText.concat + [ RichText.mkText (System.Environment.NewLine + "\t'") + signature.Value + RichText.mkText "'" ]) + |> RichText.concat + RichText.append listed (RichText.mkText System.Environment.NewLine) // we have specific message if the list is truncated - let messageFunction = + let messageFunction: RichText -> int * RichText = match shouldTruncate, messageWithInterfaceSuggestion with | false, true -> FSComp.SR.typrelNoImplementationGivenSeveralWithSuggestion | false, false -> FSComp.SR.typrelNoImplementationGivenSeveral @@ -633,9 +630,11 @@ module DispatchSlotChecking = | possibleDispatchSlots -> let details = possibleDispatchSlots - |> List.map (fun dispatchSlot -> FormatMethInfoSig g amap m denv dispatchSlot) - |> Seq.map (sprintf "%s %s" System.Environment.NewLine) - |> String.concat "" + |> List.map (fun dispatchSlot -> + RichText.append + (RichText.mkText (System.Environment.NewLine + " ")) + (FormatMethInfoSig g amap m denv dispatchSlot)) + |> RichText.concat errorR(Error(FSComp.SR.typrelMemberHasMultiplePossibleDispatchSlots(FormatOverride denv overrideBy, details), overrideBy.Range)) @@ -643,7 +642,7 @@ module DispatchSlotChecking = | [matchedSlot] -> let dispatchSlot = matchedSlot.MethodInfo if dispatchSlot.IsFinal && (isObjExpr || not (typeEquiv g reqdTy dispatchSlot.ApparentEnclosingType)) then - errorR(Error(FSComp.SR.typrelMethodIsSealed(NicePrint.stringOfMethInfo infoReader m denv dispatchSlot), m)) + errorR(Error(FSComp.SR.typrelMethodIsSealed(NicePrint.richTextOfMethInfo infoReader m denv dispatchSlot), m)) | matchedSlots -> // Filter out slots that have DIM coverage directly from RequiredSlot let slotsWithoutDIMCoverage = @@ -656,14 +655,20 @@ module DispatchSlotChecking = isInterfaceTy g dispatchSlot.ApparentEnclosingType || not (DispatchSlotIsAlreadyImplemented g amap m availPriorOverridesKeyed dispatchSlot)) with | h1 :: h2 :: _ -> - errorR(Error(FSComp.SR.typrelOverrideImplementsMoreThenOneSlot((FormatOverride denv overrideBy), (NicePrint.stringOfMethInfo infoReader m denv h1), (NicePrint.stringOfMethInfo infoReader m denv h2)), m)) + errorR(Error(FSComp.SR.typrelOverrideImplementsMoreThenOneSlot((FormatOverride denv overrideBy), (NicePrint.richTextOfMethInfo infoReader m denv h1), (NicePrint.richTextOfMethInfo infoReader m denv h2)), m)) | _ -> // dispatch slots are ordered from the derived classes to base // so we can check the topmost dispatch slot if it is final let allMatchedVirts = matchedSlots |> List.map (fun rs -> rs.MethodInfo) match allMatchedVirts with - | meth :: _ when meth.IsFinal -> errorR(Error(FSComp.SR.tcCannotOverrideSealedMethod - (sprintf "%s::%s" (NicePrint.stringOfTy denv meth.ApparentEnclosingType) meth.LogicalName), m)) + | meth :: _ when meth.IsFinal -> + let name = + RichText.concat + [ NicePrint.richTextOfTy denv meth.ApparentEnclosingType + RichText.mkPunctuation "::" + RichText.mkMethod meth.LogicalName ] + + errorR(Error(FSComp.SR.tcCannotOverrideSealedMethod name, m)) | _ -> () /// Get the slots of a type that can or must be implemented. This depends @@ -769,7 +774,7 @@ module DispatchSlotChecking = let minfo = reqdSlot.MethodInfo // If the slot is optional, then we do not need an explicit implementation. minfo.IsNewSlot && not reqdSlot.IsOptional) then - errorR(Error(FSComp.SR.typrelNeedExplicitImplementation(NicePrint.minimalStringOfType denv ty), reqdTyRange)) + errorR(Error(FSComp.SR.typrelNeedExplicitImplementation(NicePrint.minimalRichTextOfType denv ty), reqdTyRange)) // We also collect up the properties. This is used for abstract slot inference when overriding properties let isRelevantRequiredProperty (x: PropInfo) = @@ -938,9 +943,9 @@ let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader: InfoReader, nenv then (* Warn when we're doing this for class types *) if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then - warning(Error(FSComp.SR.typrelTypeImplementsIComparableShouldOverrideObjectEquals(tycon.DisplayName), tycon.Range)) + warning(Error(FSComp.SR.typrelTypeImplementsIComparableShouldOverrideObjectEquals(richTextOfEntity tycon), tycon.Range)) else - warning(Error(FSComp.SR.typrelTypeImplementsIComparableDefaultObjectEqualsProvided(tycon.DisplayName), tycon.Range)) + warning(Error(FSComp.SR.typrelTypeImplementsIComparableDefaultObjectEqualsProvided(richTextOfEntity tycon), tycon.Range)) AugmentTypeDefinitions.CheckAugmentationAttribs isImplementation g amap tycon // Check some conditions about generic comparison and hashing. We can only check this condition after we've done the augmentation @@ -956,13 +961,13 @@ let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader: InfoReader, nenv if (Option.isSome tycon.GeneratedHashAndEqualsWithComparerValues) && (hasExplicitObjectGetHashCode || hasExplicitObjectEqualsOverride) then - errorR(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCodeOrEquals(tycon.DisplayName), m)) + errorR(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCodeOrEquals(richTextOfEntity tycon), m)) if not hasExplicitObjectEqualsOverride && hasExplicitObjectGetHashCode then - warning(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCode(tycon.DisplayName), m)) + warning(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCode(richTextOfEntity tycon), m)) if hasExplicitObjectEqualsOverride && not hasExplicitObjectGetHashCode then - warning(Error(FSComp.SR.typrelExplicitImplementationOfEquals(tycon.DisplayName), m)) + warning(Error(FSComp.SR.typrelExplicitImplementationOfEquals(richTextOfEntity tycon), m)) // remember these values to ensure we don't generate these methods during codegen tcaug.SetHasObjectGetHashCode hasExplicitObjectGetHashCode diff --git a/src/Compiler/Checking/MethodOverrides.fsi b/src/Compiler/Checking/MethodOverrides.fsi index 4ad9634be2a..4e32cce5b25 100644 --- a/src/Compiler/Checking/MethodOverrides.fsi +++ b/src/Compiler/Checking/MethodOverrides.fsi @@ -83,10 +83,11 @@ exception OverrideDoesntOverride of DisplayEnv * OverrideInfo * MethInfo option module DispatchSlotChecking = /// Format the signature of an override as a string as part of an error message - val FormatOverride: denv: DisplayEnv -> d: OverrideInfo -> string + val FormatOverride: denv: DisplayEnv -> d: OverrideInfo -> RichText /// Format the signature of a MethInfo as a string as part of an error message - val FormatMethInfoSig: g: TcGlobals -> amap: ImportMap -> m: range -> denv: DisplayEnv -> d: MethInfo -> string + val FormatMethInfoSig: + g: TcGlobals -> amap: ImportMap -> m: range -> denv: DisplayEnv -> minfo: MethInfo -> RichText /// Get the override information for an object expression method being used to implement dispatch slots val GetObjectExprOverrideInfo: diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 80e6b7eecca..7c66ef1799e 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -219,7 +219,7 @@ type Item = /// CustomOperation(nm, helpText, methInfo) /// /// Used to indicate the availability or resolution of a custom query operation such as 'sortBy' or 'where' in computation expression syntax - | CustomOperation of string * (unit -> string option) * MethInfo option + | CustomOperation of string * (unit -> RichText option) * MethInfo option /// Represents the resolution of a name to a custom builder in the F# computation expression syntax | CustomBuilder of string * ValRef @@ -1012,7 +1012,7 @@ let CheckForDirectReferenceToGeneratedType (tcref: TyconRef, genOk, m) = match tcref.TypeReprInfo with | TProvidedTypeRepr info when not info.IsErased -> if IsGeneratedTypeDirectReference (info.ProvidedType, m) then - error (Error(FSComp.SR.etDirectReferenceToGeneratedTypeNotAllowed(tcref.DisplayName), m)) + error (Error(FSComp.SR.etDirectReferenceToGeneratedTypeNotAllowed(richTextOfEntityRef tcref), m)) | _ -> () /// This adds a new entity for a lazily discovered provided type into the TAST structure. @@ -2604,14 +2604,14 @@ let CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities // plausible types have different arities (tcrefs |> Seq.distinctBy (fun (_, tcref) -> tcref.Typars.Length) |> Seq.length > 1) -> [ for resInfo, tcref in tcrefs do - let resInfo = resInfo.AddWarning (fun _typarChecker -> errorR(Error(FSComp.SR.nrTypeInstantiationNeededToDisambiguateTypesWithSameName(tcref.DisplayName, tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m))) + let resInfo = resInfo.AddWarning (fun _typarChecker -> errorR(Error(FSComp.SR.nrTypeInstantiationNeededToDisambiguateTypesWithSameName(richTextOfEntityRef tcref, richTextOfEntityRefName tcref tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m))) yield (resInfo, tcref) ] | [(resInfo, tcref)] when typeNameResInfo.StaticArgsInfo.HasNoStaticArgsInfo && ((tcref.Typars).Length - resInfo.EnclosingTypeInst.Length) > 0 && typeNameResInfo.ResolutionFlag = ResolveTypeNamesToTypeRefs -> let resInfo = resInfo.AddWarning (fun (ResultTyparChecker typarChecker) -> if not (typarChecker()) then - warning(Error(FSComp.SR.nrTypeInstantiationIsMissingAndCouldNotBeInferred(tcref.DisplayName, tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m))) + warning(Error(FSComp.SR.nrTypeInstantiationIsMissingAndCouldNotBeInferred(richTextOfEntityRef tcref, richTextOfEntityRefName tcref tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m))) [(resInfo, tcref)] | _ -> @@ -3057,14 +3057,16 @@ let rec ResolveLongIdentInTypePrim (ncenv: NameResolver) nenv lookupKind (resInf |> Array.sort |> Array.map (fun s -> $" %s{s}") |> fun a -> System.String.Join("\n", a) + let message = + FSComp.SR.tcMultipleRecdTypeChoice(RichText.mkText candidates, richTextOfEntityRefName tcref resolvedTypeName, RichText.mkText overlappingNames) if g.langVersion.SupportsFeature(LanguageFeature.WarningWhenMultipleRecdTypeChoice) then - warning(Error(FSComp.SR.tcMultipleRecdTypeChoice(candidates, resolvedTypeName, overlappingNames), m)) + warning(Error(message, m)) else - informationalWarning(Error(FSComp.SR.tcMultipleRecdTypeChoice(candidates, resolvedTypeName, overlappingNames), m)) + informationalWarning(Error(message, m)) | _ -> () - FSComp.SR.undefinedNameFieldConstructorOrMemberWhenTypeIsKnown(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars, s) + FSComp.SR.undefinedNameFieldConstructorOrMemberWhenTypeIsKnown(richTextOfEntityRefName tcref tcref.DisplayNameWithStaticParametersAndUnderscoreTypars, s) | ValueSome tcref -> - FSComp.SR.undefinedNameFieldConstructorOrMemberWhenTypeIsKnown(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars, s) + FSComp.SR.undefinedNameFieldConstructorOrMemberWhenTypeIsKnown(richTextOfEntityRefName tcref tcref.DisplayNameWithStaticParametersAndUnderscoreTypars, s) | _ -> FSComp.SR.undefinedNameFieldConstructorOrMember(s) @@ -3482,7 +3484,7 @@ let rec ResolveExprLongIdentPrim sink (ncenv: NameResolver) first fullyQualified let ResolveExprLongIdent sink (ncenv: NameResolver) m ad nenv typeNameResInfo lid maybeAppliedArgExpr = match lid with - | [] -> raze (Error(FSComp.SR.nrInvalidExpression(textOfLid lid), m)) + | [] -> raze (Error(FSComp.SR.nrInvalidExpression(RichText.mkText (textOfLid lid)), m)) | id :: rest -> ResolveExprLongIdentPrim sink ncenv true OpenQualified m ad nenv typeNameResInfo id rest false maybeAppliedArgExpr //------------------------------------------------------------------------- @@ -3746,7 +3748,7 @@ let SuggestTypeLongIdentInModuleOrNamespace depth (modref: ModuleOrNamespaceRef) if IsEntityAccessible amap m ad (modref.NestedTyconRef e) then addToBuffer e.DisplayName - let errorTextF s = FSComp.SR.undefinedNameTypeIn(s, fullDisplayTextOfModRef modref) + let errorTextF s = FSComp.SR.undefinedNameTypeIn(s, richTextOfQualifiedModRef modref) UndefinedName(depth, errorTextF, id, suggestPossibleTypes) /// Resolve a long identifier representing a type in a module or namespace @@ -4061,8 +4063,8 @@ let ResolveFieldPrim sink (ncenv: NameResolver) nenv ad ty (fldInfo: ExplicitOrS for label in SuggestOtherLabelsOfSameRecordType g nenv ty id allFields do addToBuffer label - let typeName = NicePrint.minimalStringOfType nenv.eDisplayEnv ty - let errorText = FSComp.SR.nrRecordDoesNotContainSuchLabel(typeName, id.idText) + let typeName = NicePrint.minimalRichTextOfType nenv.eDisplayEnv ty + let errorText = FSComp.SR.nrRecordDoesNotContainSuchLabel(typeName, RichText.mkUnresolvedName id.idText) error(ErrorWithSuggestions(errorText, m, id.idText, suggestLabels)) else Some (lookup()) @@ -4128,7 +4130,7 @@ let ResolveNestedField sink (ncenv: NameResolver) nenv ad recdTy lid = | ValueSome (anonInfo, tys) -> match anonInfo.SortedNames |> Array.tryFindIndex (fun x -> x = id.idText) with | Some index -> OneSuccess (Item.AnonRecdField (anonInfo, tys, index, m)) - | _ -> raze (Error(FSComp.SR.nrRecordDoesNotContainSuchLabel(NicePrint.minimalStringOfType nenv.eDisplayEnv ty, id.idText), m)) + | _ -> raze (Error(FSComp.SR.nrRecordDoesNotContainSuchLabel(NicePrint.minimalRichTextOfType nenv.eDisplayEnv ty, RichText.mkUnresolvedName id.idText), m)) | _ -> let otherRecordFields ty = let typeName = NicePrint.minimalStringOfType nenv.eDisplayEnv ty @@ -4149,8 +4151,8 @@ let ResolveNestedField sink (ncenv: NameResolver) nenv ad recdTy lid = for label in SuggestOtherLabelsOfSameRecordType g nenv ty id (otherRecordFields ty) do addToBuffer label - let typeName = NicePrint.minimalStringOfType nenv.eDisplayEnv ty - let errorText = FSComp.SR.nrRecordDoesNotContainSuchLabel(typeName,id.idText) + let typeName = NicePrint.minimalRichTextOfType nenv.eDisplayEnv ty + let errorText = FSComp.SR.nrRecordDoesNotContainSuchLabel(typeName, RichText.mkUnresolvedName id.idText) raze (ErrorWithSuggestions(errorText, m, id.idText, suggestLabels)) else match Map.tryFind id.idText nenv.eFieldLabels with @@ -4361,7 +4363,7 @@ let ResolveLongIdentAsExprAndComputeRange (sink: TcResultsSink) (ncenv: NameReso match item1, item with | Item.MethodGroup(name, minfos1, _), Item.MethodGroup(_, [], _) when not (isNil minfos1) -> - raze(Error(FSComp.SR.methodIsNotStatic name, wholem)) + raze(Error(FSComp.SR.methodIsNotStatic (RichText.mkMethod name), wholem)) | _ -> // Fake idents e.g. 'Microsoft.FSharp.Core.None' have identical ranges for each part diff --git a/src/Compiler/Checking/NameResolution.fsi b/src/Compiler/Checking/NameResolution.fsi index bfa074d6bac..e694758ff3e 100755 --- a/src/Compiler/Checking/NameResolution.fsi +++ b/src/Compiler/Checking/NameResolution.fsi @@ -106,7 +106,7 @@ type Item = /// CustomOperation(nm, helpText, methInfo) /// /// Used to indicate the availability or resolution of a custom query operation such as 'sortBy' or 'where' in computation expression syntax - | CustomOperation of string * (unit -> string option) * MethInfo option + | CustomOperation of string * (unit -> RichText option) * MethInfo option /// Represents the resolution of a name to a custom builder in the F# computation expression syntax | CustomBuilder of string * ValRef diff --git a/src/Compiler/Checking/NicePrint.fs b/src/Compiler/Checking/NicePrint.fs index 7879c4765c3..78ea2a5381f 100644 --- a/src/Compiler/Checking/NicePrint.fs +++ b/src/Compiler/Checking/NicePrint.fs @@ -1510,21 +1510,8 @@ module PrintTastMemberOrVals = let argInfos, retTy = GetTopTauTypeInFSharpForm denv.g valReprInfo.ArgInfos tau v.Range let nameL = - let tagF = - if isForallFunctionTy denv.g v.Type && not (isDiscard v.DisplayNameCore) then - if IsOperatorDisplayName v.DisplayName then - tagOperator - else - tagFunction - elif not v.IsCompiledAsTopLevel && not(isDiscard v.DisplayNameCore) then - tagLocal - elif v.IsModuleBinding then - tagModuleBinding - else - tagUnknownEntity - v.DisplayName - |> tagF + |> tagValName denv.g v |> mkNav v.DefinitionRange |> wordL let nameL = layoutAccessibility denv v.Accessibility nameL @@ -2881,7 +2868,9 @@ let dataExprL denv expr = PrintData.dataExprL denv expr let outputValOrMember denv infoReader os x = x |> PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst denv infoReader |> bufferL os -let stringValOrMember denv infoReader x = x |> PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst denv infoReader |> showL +let richTextValOrMember denv infoReader x = x |> PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst denv infoReader |> toRichText + +let stringValOrMember denv infoReader x = (richTextValOrMember denv infoReader x).Text /// Print members with a qualification showing the type they are contained in let layoutQualifiedValOrMember denv infoReader typarInst vref = @@ -2893,8 +2882,10 @@ let outputQualifiedValOrMember denv infoReader os vref = let outputQualifiedValSpec denv infoReader os vref = outputQualifiedValOrMember denv infoReader os vref -let stringOfQualifiedValOrMember denv infoReader vref = - PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst { denv with showMemberContainers=true; } infoReader vref |> showL +let richTextOfQualifiedValOrMember denv infoReader vref = + PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst { denv with showMemberContainers=true; } infoReader vref |> toRichText + +let stringOfQualifiedValOrMember denv infoReader vref = (richTextOfQualifiedValOrMember denv infoReader vref).Text /// Convert a MethInfo to a string let formatMethInfoToBufferFreeStyle infoReader m denv buf d = @@ -2907,26 +2898,42 @@ let prettyLayoutOfMethInfoFreeStyle infoReader m denv typarInst minfo = let prettyLayoutOfPropInfoFreeStyle g amap m denv d = InfoMemberPrinting.prettyLayoutOfPropInfoFreeStyle g amap m denv d +let richTextOfMethInfo infoReader m denv minfo = + InfoMemberPrinting.prettyLayoutOfMethInfoFreeStyle InfoMemberPrinting.CSharpExtensionTypeDisplay.ReceiverType infoReader m denv emptyTyparInst minfo + |> snd + |> toRichText + /// Convert a MethInfo to a string -let stringOfMethInfo infoReader m denv minfo = - buildString (fun buf -> InfoMemberPrinting.formatMethInfoToBufferFreeStyle InfoMemberPrinting.CSharpExtensionTypeDisplay.ReceiverType infoReader m denv buf minfo) +let stringOfMethInfo infoReader m denv minfo = (richTextOfMethInfo infoReader m denv minfo).Text /// Convert a MethInfo to a string, suitable for the "Available overloads" list /// in overload-resolution error messages. For C#-style extension methods, the /// rendering uses the extension's declaring type rather than the receiver type, /// so the message is not misleading (issue dotnet/fsharp#9838). -let stringOfMethInfoForOverloadError infoReader m denv minfo = - buildString (fun buf -> InfoMemberPrinting.formatMethInfoToBufferFreeStyle InfoMemberPrinting.CSharpExtensionTypeDisplay.DeclaringType infoReader m denv buf minfo) +let richTextOfMethInfoForOverloadError infoReader m denv minfo = + InfoMemberPrinting.prettyLayoutOfMethInfoFreeStyle InfoMemberPrinting.CSharpExtensionTypeDisplay.DeclaringType infoReader m denv emptyTyparInst minfo + |> snd + |> toRichText + +let stringOfMethInfoForOverloadError infoReader m denv minfo = (richTextOfMethInfoForOverloadError infoReader m denv minfo).Text -let stringOfMethInfoFSharpStyle infoReader m denv minfo = +let richTextOfMethInfoFSharpStyle infoReader m denv minfo = InfoMemberPrinting.layoutMethInfoFSharpStyle infoReader m denv minfo - |> showL + |> toRichText + +let stringOfMethInfoFSharpStyle infoReader m denv minfo = (richTextOfMethInfoFSharpStyle infoReader m denv minfo).Text /// Convert MethInfos to lines separated by newline including a newline as the first character -let multiLineStringOfMethInfos infoReader m denv minfos = +let multiLineRichTextOfMethInfos infoReader m denv minfos = minfos - |> List.map (stringOfMethInfo infoReader m denv >> sprintf "%s %s" Environment.NewLine) - |> String.concat "" + |> List.map (fun minfo -> + RichText.append + (RichText.mkText (Environment.NewLine + " ")) + (richTextOfMethInfo infoReader m denv minfo)) + |> RichText.concat + +let multiLineStringOfMethInfos infoReader m denv minfos = + (multiLineRichTextOfMethInfos infoReader m denv minfos).Text let stringOfPropInfo g amap m denv pinfo = buildString (fun buf -> InfoMemberPrinting.formatPropInfoToBufferFreeStyle g amap m denv buf pinfo) @@ -2944,7 +2951,9 @@ let layoutOfParamData denv paramData = InfoMemberPrinting.layoutParamData denv p let layoutExnDef denv infoReader x = x |> TastDefinitionPrinting.layoutExnDefn denv infoReader -let stringOfTyparConstraints denv x = x |> PrintTypes.layoutConstraintsWithInfo denv SimplifyTypes.typeSimplificationInfo0 |> showL +let richTextOfTyparConstraints denv x = x |> PrintTypes.layoutConstraintsWithInfo denv SimplifyTypes.typeSimplificationInfo0 |> toRichText + +let stringOfTyparConstraints denv x = (richTextOfTyparConstraints denv x).Text let layoutTyconDefn denv infoReader ad m (* width *) x = TastDefinitionPrinting.layoutTyconDefn denv infoReader ad m true true (mkLocalEntityRef x) (* |> Display.squashTo width *) @@ -2957,9 +2966,13 @@ let isGeneratedUnionCaseField pos f = TastDefinitionPrinting.isGeneratedUnionCas let isGeneratedExceptionField pos f = TastDefinitionPrinting.isGeneratedExceptionField pos f +let richTextOfTyparConstraint denv tpc = richTextOfTyparConstraints denv [tpc] + let stringOfTyparConstraint denv tpc = stringOfTyparConstraints denv [tpc] -let stringOfTy denv x = x |> PrintTypes.layoutType denv |> showL +let richTextOfTy denv x = x |> PrintTypes.layoutType denv |> toRichText + +let stringOfTy denv x = (richTextOfTy denv x).Text let prettyLayoutOfType denv x = x |> PrintTypes.prettyLayoutOfType denv @@ -2969,15 +2982,26 @@ let prettyLayoutOfTypeNoCx denv x = x |> PrintTypes.prettyLayoutOfTypeNoConstrai let prettyLayoutOfTypar denv x = x |> PrintTypes.layoutTyparRef denv -let prettyStringOfTy denv x = x |> PrintTypes.prettyLayoutOfType denv |> showL +let prettyRichTextOfTy denv x = x |> PrintTypes.prettyLayoutOfType denv |> toRichText + +let prettyStringOfTy denv x = (prettyRichTextOfTy denv x).Text let prettyStringOfTyNoCx denv x = x |> PrintTypes.prettyLayoutOfTypeNoConstraints denv |> showL -let stringOfRecdField denv infoReader enclosingTcref x = x |> TastDefinitionPrinting.layoutRecdField id false denv infoReader enclosingTcref |> showL +let richTextOfRecdField denv infoReader enclosingTcref x = + x |> TastDefinitionPrinting.layoutRecdField id false denv infoReader enclosingTcref |> toRichText + +let stringOfRecdField denv infoReader enclosingTcref x = (richTextOfRecdField denv infoReader enclosingTcref x).Text + +let richTextOfUnionCase denv infoReader enclosingTcref x = + x |> TastDefinitionPrinting.layoutUnionCase denv infoReader WordL.bar enclosingTcref |> toRichText -let stringOfUnionCase denv infoReader enclosingTcref x = x |> TastDefinitionPrinting.layoutUnionCase denv infoReader WordL.bar enclosingTcref |> showL +let stringOfUnionCase denv infoReader enclosingTcref x = (richTextOfUnionCase denv infoReader enclosingTcref x).Text -let stringOfExnDef denv infoReader x = x |> TastDefinitionPrinting.layoutExnDefn denv infoReader |> showL +let richTextOfExnDef denv infoReader x = + x |> TastDefinitionPrinting.layoutExnDefn denv infoReader |> toRichText + +let stringOfExnDef denv infoReader x = (richTextOfExnDef denv infoReader x).Text let stringOfFSAttrib denv x = x |> PrintTypes.layoutAttrib denv |> squareAngleL |> showL @@ -3004,7 +3028,7 @@ let prettyLayoutOfInstAndSig denv x = PrintTypes.prettyLayoutOfInstAndSig denv x /// /// If the output text is different without showing constraints and/or imperative type variable /// annotations and/or fully qualifying paths then don't show them! -let minimalStringsOfTwoTypes denv ty1 ty2 = +let minimalRichTextsOfTwoTypes denv ty1 ty2 = let (ty1, ty2), tpcs = PrettyTypes.PrettifyTypePair denv.g (ty1, ty2) let denv = suppressNullnessAnnotations denv @@ -3012,9 +3036,9 @@ let minimalStringsOfTwoTypes denv ty1 ty2 = // try denv + no type annotations let attempt1 = let denv = { denv with showInferenceTyparAnnotations=false; showStaticallyResolvedTyparAnnotations=false } - let min1 = stringOfTy denv ty1 - let min2 = stringOfTy denv ty2 - if min1 <> min2 then Some (min1, min2, "") else None + let min1 = richTextOfTy denv ty1 + let min2 = richTextOfTy denv ty2 + if min1 <> min2 then Some (min1, min2, RichText.empty) else None match attempt1 with | Some res -> res @@ -3023,9 +3047,9 @@ let minimalStringsOfTwoTypes denv ty1 ty2 = // try denv + no type annotations + show full paths let attempt2 = let denv = { denv with showInferenceTyparAnnotations=false; showStaticallyResolvedTyparAnnotations=false }.SetOpenPaths [] - let min1 = stringOfTy denv ty1 - let min2 = stringOfTy denv ty2 - if min1 <> min2 then Some (min1, min2, "") else None + let min1 = richTextOfTy denv ty1 + let min2 = richTextOfTy denv ty2 + if min1 <> min2 then Some (min1, min2, RichText.empty) else None match attempt2 with | Some res -> res @@ -3033,9 +3057,9 @@ let minimalStringsOfTwoTypes denv ty1 ty2 = // try denv let attempt3 = - let min1 = stringOfTy denv ty1 - let min2 = stringOfTy denv ty2 - if min1 <> min2 then Some (min1, min2, stringOfTyparConstraints denv tpcs) else None + let min1 = richTextOfTy denv ty1 + let min2 = richTextOfTy denv ty2 + if min1 <> min2 then Some (min1, min2, richTextOfTyparConstraints denv tpcs) else None match attempt3 with | Some res -> res @@ -3045,9 +3069,9 @@ let minimalStringsOfTwoTypes denv ty1 ty2 = // try denv + show full paths + static parameters let denv = denv.SetOpenPaths [] let denv = { denv with includeStaticParametersInTypeNames=true } - let min1 = stringOfTy denv ty1 - let min2 = stringOfTy denv ty2 - if min1 <> min2 then Some (min1, min2, stringOfTyparConstraints denv tpcs) else None + let min1 = richTextOfTy denv ty1 + let min2 = richTextOfTy denv ty2 + if min1 <> min2 then Some (min1, min2, richTextOfTyparConstraints denv tpcs) else None match attempt4 with | Some res -> res @@ -3058,29 +3082,42 @@ let minimalStringsOfTwoTypes denv ty1 ty2 = let denv = { denv with includeStaticParametersInTypeNames=true } let makeName t = let assemblyName = PrintTypes.layoutAssemblyName denv t |> function | "" -> "" | name -> $" (%s{name})" - sprintf "%s%s" (stringOfTy denv t) assemblyName + RichText.append (richTextOfTy denv t) (RichText.mkText assemblyName) + + (makeName ty1, makeName ty2, richTextOfTyparConstraints denv tpcs) + +let minimalStringsOfTwoTypes denv ty1 ty2 = + let min1, min2, cxs = minimalRichTextsOfTwoTypes denv ty1 ty2 + min1.Text, min2.Text, cxs.Text - (makeName ty1, makeName ty2, stringOfTyparConstraints denv tpcs) - // Note: Always show imperative annotations when comparing value signatures -let minimalStringsOfTwoValues denv infoReader vref1 vref2 = +let minimalRichTextsOfTwoValues denv infoReader vref1 vref2 = let denv = suppressNullnessAnnotations denv let denvMin = { denv with showInferenceTyparAnnotations=true; showStaticallyResolvedTyparAnnotations=false } - let min1 = buildString (fun buf -> outputQualifiedValOrMember denvMin infoReader buf vref1) - let min2 = buildString (fun buf -> outputQualifiedValOrMember denvMin infoReader buf vref2) + let min1 = richTextOfQualifiedValOrMember denvMin infoReader vref1 + let min2 = richTextOfQualifiedValOrMember denvMin infoReader vref2 if min1 <> min2 then (min1, min2) else let denvMax = { denv with showInferenceTyparAnnotations=true; showStaticallyResolvedTyparAnnotations=true } - let max1 = buildString (fun buf -> outputQualifiedValOrMember denvMax infoReader buf vref1) - let max2 = buildString (fun buf -> outputQualifiedValOrMember denvMax infoReader buf vref2) + let max1 = richTextOfQualifiedValOrMember denvMax infoReader vref1 + let max2 = richTextOfQualifiedValOrMember denvMax infoReader vref2 max1, max2 + +let minimalStringsOfTwoValues denv infoReader vref1 vref2 = + let min1, min2 = minimalRichTextsOfTwoValues denv infoReader vref1 vref2 + min1.Text, min2.Text -let minimalStringOfType denv ty = +let minimalRichTextOfType denv ty = let ty, _cxs = PrettyTypes.PrettifyType denv.g ty let denv = suppressNullnessAnnotations denv let denvMin = { denv with showInferenceTyparAnnotations=false; showStaticallyResolvedTyparAnnotations=false } - showL (PrintTypes.layoutTypeWithInfoAndPrec denvMin SimplifyTypes.typeSimplificationInfo0 5 ty) + toRichText (PrintTypes.layoutTypeWithInfoAndPrec denvMin SimplifyTypes.typeSimplificationInfo0 5 ty) + +let minimalStringOfType denv ty = (minimalRichTextOfType denv ty).Text + +let minimalRichTextOfTypeWithNullness denv ty = + minimalRichTextOfType {denv with showNullnessAnnotations = Some true} ty -let minimalStringOfTypeWithNullness denv ty = +let minimalStringOfTypeWithNullness denv ty = minimalStringOfType {denv with showNullnessAnnotations = Some true} ty diff --git a/src/Compiler/Checking/NicePrint.fsi b/src/Compiler/Checking/NicePrint.fsi index ff55f6cbb03..8c30325cd3d 100644 --- a/src/Compiler/Checking/NicePrint.fsi +++ b/src/Compiler/Checking/NicePrint.fsi @@ -50,6 +50,8 @@ val dataExprL: denv: DisplayEnv -> expr: Expr -> Layout val outputValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> os: StringBuilder -> x: ValRef -> unit +val richTextValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> x: ValRef -> RichText + val stringValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> x: ValRef -> string val layoutQualifiedValOrMember: @@ -63,6 +65,8 @@ val outputQualifiedValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> os val outputQualifiedValSpec: denv: DisplayEnv -> infoReader: InfoReader -> os: StringBuilder -> vref: ValRef -> unit +val richTextOfQualifiedValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> vref: ValRef -> RichText + val stringOfQualifiedValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> vref: ValRef -> string val formatMethInfoToBufferFreeStyle: @@ -79,18 +83,30 @@ val prettyLayoutOfMethInfoFreeStyle: val prettyLayoutOfPropInfoFreeStyle: g: TcGlobals -> amap: ImportMap -> m: range -> denv: DisplayEnv -> d: PropInfo -> Layout +/// Convert a MethInfo to rich text +val richTextOfMethInfo: infoReader: InfoReader -> m: range -> denv: DisplayEnv -> minfo: MethInfo -> RichText + val stringOfMethInfo: infoReader: InfoReader -> m: range -> denv: DisplayEnv -> minfo: MethInfo -> string /// Convert a MethInfo to a string, suitable for the "Available overloads" list /// in overload-resolution error messages. For C#-style extension methods, the /// rendering uses the extension's declaring type rather than the receiver type, /// so the message is not misleading (issue dotnet/fsharp#9838). +val richTextOfMethInfoForOverloadError: + infoReader: InfoReader -> m: range -> denv: DisplayEnv -> minfo: MethInfo -> RichText + val stringOfMethInfoForOverloadError: infoReader: InfoReader -> m: range -> denv: DisplayEnv -> minfo: MethInfo -> string /// Convert a MethInfo to a F# signature +/// Convert a MethInfo to a F# signature as rich text +val richTextOfMethInfoFSharpStyle: infoReader: InfoReader -> m: range -> denv: DisplayEnv -> minfo: MethInfo -> RichText + val stringOfMethInfoFSharpStyle: infoReader: InfoReader -> m: range -> denv: DisplayEnv -> minfo: MethInfo -> string +val multiLineRichTextOfMethInfos: + infoReader: InfoReader -> m: range -> denv: DisplayEnv -> minfos: MethInfo list -> RichText + val multiLineStringOfMethInfos: infoReader: InfoReader -> m: range -> denv: DisplayEnv -> minfos: MethInfo list -> string @@ -105,6 +121,8 @@ val layoutOfParamData: denv: DisplayEnv -> paramData: ParamData -> Layout val layoutExnDef: denv: DisplayEnv -> infoReader: InfoReader -> x: EntityRef -> Layout +val richTextOfTyparConstraints: denv: DisplayEnv -> x: (Typar * TyparConstraint) list -> RichText + val stringOfTyparConstraints: denv: DisplayEnv -> x: (Typar * TyparConstraint) list -> string val layoutTyconDefn: denv: DisplayEnv -> infoReader: InfoReader -> ad: AccessorDomain -> m: range -> x: Tycon -> Layout @@ -119,8 +137,12 @@ val isGeneratedUnionCaseField: pos: int -> f: RecdField -> bool val isGeneratedExceptionField: pos: 'a -> f: RecdField -> bool +val richTextOfTyparConstraint: denv: DisplayEnv -> Typar * TyparConstraint -> RichText + val stringOfTyparConstraint: denv: DisplayEnv -> Typar * TyparConstraint -> string +val richTextOfTy: denv: DisplayEnv -> x: TType -> RichText + val stringOfTy: denv: DisplayEnv -> x: TType -> string val prettyLayoutOfType: denv: DisplayEnv -> x: TType -> Layout @@ -131,14 +153,24 @@ val prettyLayoutOfTypeNoCx: denv: DisplayEnv -> x: TType -> Layout val prettyLayoutOfTypar: denv: DisplayEnv -> x: Typar -> Layout +val prettyRichTextOfTy: denv: DisplayEnv -> x: TType -> RichText + val prettyStringOfTy: denv: DisplayEnv -> x: TType -> string val prettyStringOfTyNoCx: denv: DisplayEnv -> x: TType -> string +val richTextOfRecdField: + denv: DisplayEnv -> infoReader: InfoReader -> enclosingTcref: TyconRef -> x: RecdField -> RichText + val stringOfRecdField: denv: DisplayEnv -> infoReader: InfoReader -> enclosingTcref: TyconRef -> x: RecdField -> string +val richTextOfUnionCase: + denv: DisplayEnv -> infoReader: InfoReader -> enclosingTcref: TyconRef -> x: UnionCase -> RichText + val stringOfUnionCase: denv: DisplayEnv -> infoReader: InfoReader -> enclosingTcref: TyconRef -> x: UnionCase -> string +val richTextOfExnDef: denv: DisplayEnv -> infoReader: InfoReader -> x: EntityRef -> RichText + val stringOfExnDef: denv: DisplayEnv -> infoReader: InfoReader -> x: EntityRef -> string val stringOfFSAttrib: denv: DisplayEnv -> x: Attrib -> string @@ -174,11 +206,20 @@ val prettyLayoutOfInstAndSig: TyparInstantiation * TTypes * TType -> TyparInstantiation * (TTypes * TType) * (Layout list * Layout) * Layout +val minimalRichTextsOfTwoTypes: denv: DisplayEnv -> ty1: TType -> ty2: TType -> RichText * RichText * RichText + val minimalStringsOfTwoTypes: denv: DisplayEnv -> ty1: TType -> ty2: TType -> string * string * string +val minimalRichTextsOfTwoValues: + denv: DisplayEnv -> infoReader: InfoReader -> vref1: ValRef -> vref2: ValRef -> RichText * RichText + val minimalStringsOfTwoValues: denv: DisplayEnv -> infoReader: InfoReader -> vref1: ValRef -> vref2: ValRef -> string * string +val minimalRichTextOfType: denv: DisplayEnv -> ty: TType -> RichText + val minimalStringOfType: denv: DisplayEnv -> ty: TType -> string +val minimalRichTextOfTypeWithNullness: denv: DisplayEnv -> ty: TType -> RichText + val minimalStringOfTypeWithNullness: denv: DisplayEnv -> ty: TType -> string diff --git a/src/Compiler/Checking/PatternMatchCompilation.fs b/src/Compiler/Checking/PatternMatchCompilation.fs index e5af41cb481..7f9fd108c67 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fs +++ b/src/Compiler/Checking/PatternMatchCompilation.fs @@ -26,13 +26,13 @@ open type System.MemoryExtensions /// Exception raised when a pattern match is incomplete. /// Fields: isComputationExpression * (counterExample * isShownAsFieldPattern) option * range -exception MatchIncomplete of bool * (string * bool) option * range +exception MatchIncomplete of bool * (RichText * bool) option * range /// Wrapper that adds a for-loop hint to an existing MatchIncomplete diagnostic. exception MatchIncompleteForLoopHint of exn exception RuleNeverMatched of range -exception EnumMatchIncomplete of bool * (string * bool) option * range +exception EnumMatchIncomplete of bool * (RichText * bool) option * range type ActionOnFailure = | ThrowIncompleteMatchException @@ -371,7 +371,7 @@ let ShowCounterExample g denv m refuted = | (r, eck) :: t -> ((r, eck), t) ||> List.fold (fun (rAcc, eckAcc) (r, eck) -> CombineRefutations g rAcc r, eckAcc.Combine(eck)) - let text = LayoutRender.showL (NicePrint.dataExprL denv counterExample) + let text = LayoutRender.toRichText (NicePrint.dataExprL denv counterExample) let failingWhenClause = refuted |> List.exists (function RefutedWhenClause -> true | _ -> false) Some(text, failingWhenClause, enumCoversKnown) diff --git a/src/Compiler/Checking/PatternMatchCompilation.fsi b/src/Compiler/Checking/PatternMatchCompilation.fsi index de9ab0fe318..8afdc2992f3 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fsi +++ b/src/Compiler/Checking/PatternMatchCompilation.fsi @@ -73,11 +73,11 @@ val internal CompilePattern: /// Exception raised when a pattern match is incomplete. /// Fields: isComputationExpression * (counterExample * isShownAsFieldPattern) option * range -exception internal MatchIncomplete of bool * (string * bool) option * range +exception internal MatchIncomplete of bool * (RichText * bool) option * range /// Wrapper that adds a for-loop hint to an existing MatchIncomplete diagnostic. exception internal MatchIncompleteForLoopHint of exn exception internal RuleNeverMatched of range -exception internal EnumMatchIncomplete of bool * (string * bool) option * range +exception internal EnumMatchIncomplete of bool * (RichText * bool) option * range diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 9849d7ed875..234783d7f3e 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -322,9 +322,9 @@ let BindVal cenv env (v: Val) = not v.Range.IsSynthetic then if v.IsCtorThisVal then - warning (Error(FSComp.SR.chkUnusedThisVariable v.DisplayName, v.Range)) + warning (Error(FSComp.SR.chkUnusedThisVariable (richTextOfValName cenv.g v), v.Range)) else - warning (Error(FSComp.SR.chkUnusedValue v.DisplayName, v.Range)) + warning (Error(FSComp.SR.chkUnusedValue (richTextOfValName cenv.g v), v.Range)) let BindVals cenv env vs = List.iter (BindVal cenv env) vs @@ -500,7 +500,7 @@ let CheckEscapes cenv allowProtected m syntacticArgs body = (* m is a range suit // Inner functions are not guaranteed to compile to method with a predictable arity (number of arguments). // As such, partial applications involving byref arguments could lead to closures containing byrefs. // For safety, such functions are assumed to have no known arity, and so cannot accept byrefs. - errorR(Error(FSComp.SR.chkByrefUsedInInvalidWay(v.DisplayName), m)) + errorR(Error(FSComp.SR.chkByrefUsedInInvalidWay(richTextOfValName cenv.g v), m)) elif v.IsBaseVal then errorR(Error(FSComp.SR.chkBaseUsedInInvalidWay(), m)) @@ -525,7 +525,7 @@ let isLessAccessibleWithVisibility (cenv: cenv) itemAccess refAccess = let thisCompPath = compPathOfCcu cenv.viewCcu isLessAccessible (itemAccess |> AccessInternalsVisibleToAsInternal thisCompPath cenv.internalsVisibleToPaths) refAccess -let CheckTypeForAccess (cenv: cenv) env objName valAcc skipAccessibilityCheckForCompilerGeneratedVal m ty = +let CheckTypeForAccess (cenv: cenv) env (objName: unit -> RichText) valAcc skipAccessibilityCheckForCompilerGeneratedVal m ty = if cenv.reportErrors then let visitType ty = @@ -535,11 +535,11 @@ let CheckTypeForAccess (cenv: cenv) env objName valAcc skipAccessibilityCheckFor | ValueNone -> () | ValueSome tcref -> if not skipAccessibilityCheckForCompilerGeneratedVal && isLessAccessibleWithVisibility cenv tcref.Accessibility valAcc then - errorR(Error(FSComp.SR.chkTypeLessAccessibleThanType(tcref.DisplayName, objName()), m)) + errorR(Error(FSComp.SR.chkTypeLessAccessibleThanType(richTextOfEntityRef tcref, objName()), m)) CheckTypeDeep cenv (visitType, None, None, None, None) cenv.g env NoInfo ty -let WarnOnWrongTypeForAccess (cenv: cenv) env objName valAcc m ty = +let WarnOnWrongTypeForAccess (cenv: cenv) env (objName: unit -> RichText) valAcc m ty = if cenv.reportErrors then let visitType ty = @@ -549,8 +549,8 @@ let WarnOnWrongTypeForAccess (cenv: cenv) env objName valAcc m ty = | ValueNone -> () | ValueSome tcref -> if isLessAccessibleWithVisibility cenv tcref.Accessibility valAcc then - let errorText = FSComp.SR.chkTypeLessAccessibleThanType(tcref.DisplayName, objName()) |> snd - let warningText = errorText + Environment.NewLine + FSComp.SR.tcTypeAbbreviationsCheckedAtCompileTime() + let errorText = FSComp.SR.chkTypeLessAccessibleThanType(richTextOfEntityRef tcref, objName()) |> snd + let warningText = RichText.append errorText (RichText.mkText (Environment.NewLine + FSComp.SR.tcTypeAbbreviationsCheckedAtCompileTime())) warning(ObsoleteDiagnostic(false, None, Some warningText, None, m)) CheckTypeDeep cenv (visitType, None, None, None, None) cenv.g env NoInfo ty @@ -652,8 +652,8 @@ let CheckInterfaceTypeArgForUnimplementedStaticAbstractMembers (cenv: cenv) m (t if hasInterfaceConstraint && isInterfaceTy cenv.g typeArg then match cenv.infoReader.TryFindUnimplementedStaticAbstractMemberOfType m typeArg with | Some memberName -> - let interfaceTypeName = NicePrint.minimalStringOfType cenv.denv typeArg - errorR(Error(FSComp.SR.chkInterfaceWithUnimplementedStaticAbstractMemberUsedAsTypeArgument(interfaceTypeName, memberName), m)) + let interfaceTypeName = NicePrint.minimalRichTextOfType cenv.denv typeArg + errorR(Error(FSComp.SR.chkInterfaceWithUnimplementedStaticAbstractMemberUsedAsTypeArgument(interfaceTypeName, RichText.mkMember memberName), m)) | None -> () /// Check types occurring in the TAST. @@ -664,7 +664,7 @@ let CheckTypeAux permitByRefLike (cenv: cenv) env m ty onInnerByrefError = if tp.IsCompilerGenerated then errorR (Error(FSComp.SR.checkNotSufficientlyGenericBecauseOfScopeAnon(), m)) else - errorR (Error(FSComp.SR.checkNotSufficientlyGenericBecauseOfScope(tp.DisplayName), m)) + errorR (Error(FSComp.SR.checkNotSufficientlyGenericBecauseOfScope(RichText.mkTypeParameter tp.DisplayName), m)) let visitTyconRef (ctx:TypeInstCtx) tcref = let checkInner() = @@ -700,7 +700,7 @@ let CheckTypeAux permitByRefLike (cenv: cenv) env m ty onInnerByrefError = | ValueNone -> () | ValueSome tcref2 -> if isByrefTyconRef cenv.g tcref2 then - errorR(Error(FSComp.SR.chkNoByrefsOfByrefs(NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.chkNoByrefsOfByrefs(NicePrint.minimalRichTextOfType cenv.denv ty), m)) CheckTypesDeep cenv (visitType, None, None, None, None) cenv.g env tinst // Check for interfaces with unimplemented static abstract members used as type arguments @@ -809,13 +809,14 @@ let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) | None -> () | Some exn -> exn - let typ1Str = NicePrint.minimalStringOfType cenv.denv ty1 - let typ2Str = NicePrint.minimalStringOfType cenv.denv ty2 + let typ1Str = NicePrint.minimalRichTextOfType cenv.denv ty1 + let typ2Str = NicePrint.minimalRichTextOfType cenv.denv ty2 + let tcRef1Name = richTextOfEntityRefName tcRef1 tcRef1.DisplayNameWithStaticParametersAndUnderscoreTypars if isObjectExpression then - Error(FSComp.SR.typrelInterfaceWithConcreteAndVariableObjectExpression(tcRef1.DisplayNameWithStaticParametersAndUnderscoreTypars, typ1Str, typ2Str),m) + Error(FSComp.SR.typrelInterfaceWithConcreteAndVariableObjectExpression(tcRef1Name, typ1Str, typ2Str), m) else - let typStr = NicePrint.minimalStringOfType cenv.denv ty - Error(FSComp.SR.typrelInterfaceWithConcreteAndVariable(typStr, tcRef1.DisplayNameWithStaticParametersAndUnderscoreTypars, typ1Str, typ2Str),m) + let typStr = NicePrint.minimalRichTextOfType cenv.denv ty + Error(FSComp.SR.typrelInterfaceWithConcreteAndVariable(typStr, tcRef1Name, typ1Str, typ2Str), m) | NotEqual -> match tryLanguageFeatureErrorOption cenv.g.langVersion LanguageFeature.InterfacesWithMultipleGenericInstantiation m with @@ -847,7 +848,7 @@ and CheckValRef (cenv: cenv) (env: env) v m (ctxt: PermitByRefExpr) = // ByRefLike-typed values can only occur in permitting ctxts if ctxt.Disallow && isByrefLikeTy cenv.g m v.Type then - errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(v.DisplayName), m)) + errorR(Error(FSComp.SR.chkNoByrefAtThisPoint(richTextOfValName cenv.g v.Deref), m)) if env.isInAppExpr then CheckTypePermitAllByrefs cenv env m v.Type // we do checks for byrefs elsewhere @@ -888,9 +889,9 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB let isCompGen = vref.IsCompilerGenerated match isSpanLike, isCompGen with | true, true -> errorR(Error(FSComp.SR.chkNoSpanLikeValueFromExpression(), m)) - | true, false -> errorR(Error(FSComp.SR.chkNoSpanLikeVariable(vref.DisplayName), m)) + | true, false -> errorR(Error(FSComp.SR.chkNoSpanLikeVariable(richTextOfValName g vref.Deref), m)) | false, true -> errorR(Error(FSComp.SR.chkNoByrefAddressOfValueFromExpression(), m)) - | false, false -> errorR(Error(FSComp.SR.chkNoByrefAddressOfLocal(vref.DisplayName), m)) + | false, false -> errorR(Error(FSComp.SR.chkNoByrefAddressOfLocal(richTextOfValName g vref.Deref), m)) let isReturnOfStructThis = ctxt.PermitOnlyReturnable && @@ -924,13 +925,13 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = match argsl with | [] | [_] -> () | _ :: _ :: _ -> - warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(v.DisplayName, 1, argsl.Length), funcRange)) + warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(richTextOfValName g v.Deref, 1, argsl.Length), funcRange)) | OptionalCoerce(Expr.Val (v, _, funcRange)) when valRefEq g v g.invalid_arg_vref -> match argsl with | [] | [_] | [_; _] -> () | _ :: _ :: _ :: _ -> - warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(v.DisplayName, 2, argsl.Length), funcRange)) + warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(richTextOfValName g v.Deref, 2, argsl.Length), funcRange)) | OptionalCoerce(Expr.Val (failwithfFunc, _, funcRange)) when valRefEq g failwithfFunc g.failwithf_vref -> match argsl with @@ -940,7 +941,7 @@ and CheckForOverAppliedExceptionRaisingPrimitive (cenv: cenv) expr = let expected = n + 1 let actual = List.length xs + 1 if expected < actual then - warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(failwithfFunc.DisplayName, expected, actual), funcRange)) + warning(Error(FSComp.SR.checkRaiseFamilyFunctionArgumentCount(richTextOfValName g failwithfFunc.Deref, expected, actual), funcRange)) | None -> () | _ -> () | _ -> () @@ -1094,7 +1095,7 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = | ResumableEntryMatchExpr g (noneBranchExpr, someVar, someBranchExpr, _rebuild) -> if not allowed then - errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumableEntry"), expr.Range)) + errorR(Error(FSComp.SR.tcInvalidResumableConstruct(RichText.mkFunction "__resumableEntry"), expr.Range)) CheckExprNoByrefs cenv env noneBranchExpr BindVal cenv env someVar CheckExprNoByrefs cenv env someBranchExpr @@ -1102,7 +1103,7 @@ and TryCheckResumableCodeConstructs cenv env expr : bool = | ResumeAtExpr g pcExpr -> if not allowed then - errorR(Error(FSComp.SR.tcInvalidResumableConstruct("__resumeAt"), expr.Range)) + errorR(Error(FSComp.SR.tcInvalidResumableConstruct(RichText.mkFunction "__resumeAt"), expr.Range)) CheckExprNoByrefs cenv env pcExpr true @@ -1348,7 +1349,7 @@ and CheckFSharpBaseCall cenv env expr (v, f, _fty, tyargs, baseVal, rest, m) = let g = cenv.g let memberInfo = Option.get v.MemberInfo if memberInfo.MemberFlags.IsDispatchSlot then - errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(v.DisplayName), m)) + errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(richTextOfValName g v.Deref), m)) NoLimit else let env = { env with isInAppExpr = true } @@ -1372,7 +1373,7 @@ and CheckILBaseCall cenv env (ilMethRef, enclTypeInst, methInst, retTypes, tyarg resolveILMethodRefWithRescope (rescopeILType scoref) tcref.ILTyconRawMetadata ilMethRef if mdef.IsAbstract then - errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(mdef.Name), m)) + errorR(Error(FSComp.SR.tcCannotCallAbstractBaseMember(RichText.mkMethod mdef.Name), m)) with _ -> () | _ -> () @@ -1496,7 +1497,7 @@ and CheckNoResumableStmtConstructs cenv _env expr = when valRefEq g v g.cgh__resumeAt_vref || valRefEq g v g.cgh__resumableEntry_vref || valRefEq g v g.cgh__stateMachine_vref -> - errorR(Error(FSComp.SR.tcInvalidResumableConstruct(v.DisplayName), m)) + errorR(Error(FSComp.SR.tcInvalidResumableConstruct(richTextOfValName g v.Deref), m)) | _ -> () and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = @@ -1602,7 +1603,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = if cenv.reportErrors then if ctxt.Disallow then - errorR(Error(FSComp.SR.chkNoAddressOfAtThisPoint(vref.DisplayName), m)) + errorR(Error(FSComp.SR.chkNoAddressOfAtThisPoint(richTextOfValName g vref.Deref), m)) let returningAddrOfLocal = ctxt.PermitOnlyReturnable && @@ -1613,7 +1614,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = if vref.IsCompilerGenerated then errorR(Error(FSComp.SR.chkNoByrefAddressOfValueFromExpression(), m)) else - errorR(Error(FSComp.SR.chkNoByrefAddressOfLocal(vref.DisplayName), m)) + errorR(Error(FSComp.SR.chkNoByrefAddressOfLocal(richTextOfValName g vref.Deref), m)) limit @@ -1622,7 +1623,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = let isVrefLimited = not (HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit) let isArgLimited = HasLimitFlag LimitFlags.StackReferringSpanLike (CheckExprPermitByRefLike cenv env arg) if isVrefLimited && isArgLimited then - errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(vref.DisplayName), m)) + errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(richTextOfValName g vref.Deref), m)) NoLimit | TOp.LValueOp (LByrefGet, vref), _, [] -> @@ -1633,7 +1634,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = if vref.IsCompilerGenerated then errorR(Error(FSComp.SR.chkNoSpanLikeValueFromExpression(), m)) else - errorR(Error(FSComp.SR.chkNoSpanLikeVariable(vref.DisplayName), m)) + errorR(Error(FSComp.SR.chkNoSpanLikeVariable(richTextOfValName g vref.Deref), m)) { scope = 1; flags = LimitFlags.StackReferringSpanLike } elif HasLimitFlag LimitFlags.ByRefOfSpanLike limit then @@ -1645,7 +1646,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = let isVrefLimited = not (HasLimitFlag LimitFlags.StackReferringSpanLike (GetLimitVal cenv env m vref.Deref)) let isArgLimited = HasLimitFlag LimitFlags.StackReferringSpanLike (CheckExprPermitByRefLike cenv env arg) if isVrefLimited && isArgLimited then - errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(vref.DisplayName), m)) + errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(richTextOfValName g vref.Deref), m)) NoLimit | TOp.AnonRecdGet _, _, [arg1] @@ -1669,7 +1670,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = let isLhsLimited = not (HasLimitFlag LimitFlags.ByRefOfStackReferringSpanLike limit1) let isRhsLimited = HasLimitFlag LimitFlags.StackReferringSpanLike limit2 if isLhsLimited && isRhsLimited then - errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(rf.FieldName), m)) + errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(RichText.mkRecordField rf.FieldName), m)) NoLimit | TOp.Coerce, [tgtTy;srcTy], [x] -> @@ -1688,7 +1689,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.ValFieldGetAddr (rfref, _readonly), tyargs, [] -> if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then - errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(rfref.FieldName), m)) + errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(RichText.mkRecordField rfref.FieldName), m)) CheckTypeInstNoByrefs cenv env m tyargs NoLimit @@ -1697,7 +1698,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.ValFieldGetAddr (rfref, _readonly), tyargs, [obj] -> if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then - errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(rfref.FieldName), m)) + errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(RichText.mkRecordField rfref.FieldName), m)) // C# applies a rule where the APIs to struct types can't return the addresses of fields in that struct. // There seems no particular reason for this given that other protections in the language, though allowing @@ -1706,7 +1707,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = errorR(Error(FSComp.SR.chkStructsMayNotReturnAddressesOfContents(), m)) if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then - errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(rfref.FieldName), m)) + errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(RichText.mkRecordField rfref.FieldName), m)) // This construct is used for &(rx.rfield) and &(rx->rfield). Relax to permit byref types for rx. [See Bug 1263]. CheckTypeInstNoByrefs cenv env m tyargs @@ -1725,7 +1726,7 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | TOp.UnionCaseFieldGetAddr (uref, _idx, _readonly), tyargs, [obj] -> if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then - errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(uref.CaseName), m)) + errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(RichText.mkUnionCase uref.CaseName), m)) if ctxt.PermitOnlyReturnable && (match stripDebugPoints obj with Expr.Val (vref, _, _) -> vref.IsMemberThisVal | _ -> false) && isByrefTy g (tyOfExpr g obj) then errorR(Error(FSComp.SR.chkStructsMayNotReturnAddressesOfContents(), m)) @@ -1757,13 +1758,13 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr = | [ I_ldsflda fspec ], [] -> if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then - errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(fspec.Name), m)) + errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(RichText.mkField fspec.Name), m)) NoLimit | [ I_ldflda fspec ], [obj] -> if ctxt.Disallow && cenv.reportErrors && isByrefLikeTy g m (tyOfExpr g expr) then - errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(fspec.Name), m)) + errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(RichText.mkField fspec.Name), m)) // Recursively check in same ctxt, e.g. if at PermitOnlyReturnable the obj arg must also be returnable CheckExpr cenv env obj ctxt @@ -1845,12 +1846,12 @@ and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwa if arg.IsCompilerGenerated then errorR(Error(FSComp.SR.chkErrorUseOfByref(), arg.Range)) else - errorR(Error(FSComp.SR.chkInvalidFunctionParameterType(arg.DisplayName, NicePrint.minimalStringOfType cenv.denv arg.Type), arg.Range)) + errorR(Error(FSComp.SR.chkInvalidFunctionParameterType(RichText.mkParameter arg.DisplayName, NicePrint.minimalRichTextOfType cenv.denv arg.Type), arg.Range)) ) // Check return type CheckTypeAux permitByRefType cenv env mOrig bodyTy (fun () -> - errorR(Error(FSComp.SR.chkInvalidFunctionReturnType(NicePrint.minimalStringOfType cenv.denv bodyTy), mOrig)) + errorR(Error(FSComp.SR.chkInvalidFunctionReturnType(NicePrint.minimalRichTextOfType cenv.denv bodyTy), mOrig)) ) for arg in syntacticArgs do @@ -2053,7 +2054,7 @@ and CheckAttribs cenv env (attribs: Attribs) = if cenv.reportErrors then for tcref, _, m in duplicates do - errorR(Error(FSComp.SR.chkAttrHasAllowMultiFalse(tcref.DisplayName), m)) + errorR(Error(FSComp.SR.chkAttrHasAllowMultiFalse(richTextOfEntityRef tcref), m)) attribs |> List.iter (CheckAttrib cenv env) @@ -2103,7 +2104,7 @@ and CheckInlineValueIsSufficientlyAccessible cenv env (v: Val) bindRhs = else true)) if escapes bindRhs then - errorR(Error(FSComp.SR.optValueMarkedInlineButIncomplete(v.DisplayName), v.Range)) + errorR(Error(FSComp.SR.optValueMarkedInlineButIncomplete(richTextOfValName cenv.g v), v.Range)) and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bind) : Limit = let vref = mkLocalValRef v @@ -2119,14 +2120,14 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin let hasFreeTypars = doesActivePatternHaveFreeTypars g vref if apinfo.ActiveTags.Length > 1 && hasFreeTypars then - errorR(Error(FSComp.SR.activePatternChoiceHasFreeTypars(v.LogicalName), v.Range)) + errorR(Error(FSComp.SR.activePatternChoiceHasFreeTypars(RichText.mkActivePatternCase v.LogicalName), v.Range)) | _ -> () match cenv.potentialUnboundUsesOfVals.TryFind v.Stamp with | None -> () | Some m -> let nm = v.DisplayName - errorR(Error(FSComp.SR.chkMemberUsedInInvalidWay(nm, nm, stringOfRange m), v.Range)) + errorR(Error(FSComp.SR.chkMemberUsedInInvalidWay(RichText.mkMember nm, RichText.mkMember nm, RichText.mkText (stringOfRange m)), v.Range)) v.Type |> CheckTypePermitAllByrefs cenv env v.Range v.Attribs |> CheckAttribs cenv env @@ -2138,7 +2139,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin // Compiler-generated patternInput temps are module-init scaffolding; their promoted // accessibility does not reflect the enclosing binding scope (dotnet/fsharp#4161). let skipAccessibilityCheck = v.IsCompilerGenerated && v.LogicalName.StartsWith("patternInput") - CheckTypeForAccess cenv env (fun () -> NicePrint.stringOfQualifiedValOrMember cenv.denv cenv.infoReader vref) access skipAccessibilityCheck v.Range v.Type + CheckTypeForAccess cenv env (fun () -> NicePrint.richTextOfQualifiedValOrMember cenv.denv cenv.infoReader vref) access skipAccessibilityCheck v.Range v.Type CheckInlineValueIsSufficientlyAccessible cenv env v bindRhs @@ -2365,7 +2366,7 @@ let CheckRecdField isUnion cenv env (tycon: Tycon) (rfield: RecdField) = IsHiddenTyconRepr env.sigToImplRemapInfo tycon || (not isUnion && IsHiddenRecdField env.sigToImplRemapInfo (tcref.MakeNestedRecdFieldRef rfield)) let access = AdjustAccess isHidden (fun () -> tycon.CompilationPath) rfield.Accessibility - CheckTypeForAccess cenv env (fun () -> rfield.LogicalName) access false m fieldTy + CheckTypeForAccess cenv env (fun () -> RichText.mkRecordField rfield.LogicalName) access false m fieldTy if isByrefLikeTyconRef g m tcref then // Permit Span fields in IsByRefLike types @@ -2395,7 +2396,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = CheckAttribs cenv env tycon.Attribs match tycon.TypeAbbrev with - | Some abbrev -> WarnOnWrongTypeForAccess cenv env (fun () -> tycon.CompiledName) tycon.Accessibility tycon.Range abbrev + | Some abbrev -> WarnOnWrongTypeForAccess cenv env (fun () -> richTextOfEntityName tycon tycon.CompiledName) tycon.Accessibility tycon.Range abbrev | _ -> () if cenv.reportErrors then @@ -2464,14 +2465,14 @@ let CheckEntityDefn cenv env (tycon: Entity) = if others |> List.exists (checkForDup EraseAll) then if others |> List.exists (checkForDup EraseNone) then - errorR(Error(FSComp.SR.chkDuplicateMethod(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.chkDuplicateMethod(RichText.mkMethod nm, NicePrint.minimalRichTextOfType cenv.denv ty), m)) else - errorR(Error(FSComp.SR.chkDuplicateMethodWithSuffix(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.chkDuplicateMethodWithSuffix(RichText.mkMethod nm, NicePrint.minimalRichTextOfType cenv.denv ty), m)) let numCurriedArgSets = minfo.NumArgs.Length if numCurriedArgSets > 1 && others |> List.exists (fun minfo2 -> not (IsAbstractDefaultPair2 minfo minfo2)) then - errorR(Error(FSComp.SR.chkDuplicateMethodCurried(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.chkDuplicateMethodCurried(RichText.mkMethod nm, NicePrint.minimalRichTextOfType cenv.denv ty), m)) if numCurriedArgSets > 1 && (minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) @@ -2491,14 +2492,14 @@ let CheckEntityDefn cenv env (tycon: Entity) = let errorIfNotStringTy m ty callerInfo = if not (typeEquiv g g.string_ty ty) then - errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfo |> string, "string", NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.tcCallerInfoWrongType(RichText.mkText (callerInfo |> string), RichText.mkText "string", NicePrint.minimalRichTextOfType cenv.denv ty), m)) let errorIfNotOptional tyToCompare desiredTyName m ty callerInfo = match tryDestOptionalTy g ty with | ValueSome t when typeEquiv g tyToCompare t -> () - | ValueSome innerTy -> errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfo |> string, desiredTyName, NicePrint.minimalStringOfType cenv.denv innerTy), m)) - | ValueNone -> errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfo |> string, desiredTyName, NicePrint.minimalStringOfType cenv.denv ty), m)) + | ValueSome innerTy -> errorR(Error(FSComp.SR.tcCallerInfoWrongType(RichText.mkText (callerInfo |> string), RichText.mkText desiredTyName, NicePrint.minimalRichTextOfType cenv.denv innerTy), m)) + | ValueNone -> errorR(Error(FSComp.SR.tcCallerInfoWrongType(RichText.mkText (callerInfo |> string), RichText.mkText desiredTyName, NicePrint.minimalRichTextOfType cenv.denv ty), m)) minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) |> List.iterSquared (fun (ParamData(_, isInArg, _, optArgInfo, callerInfo, nameOpt, _, ty)) -> @@ -2511,10 +2512,10 @@ let CheckEntityDefn cenv env (tycon: Entity) = match (optArgInfo, callerInfo) with | _, NoCallerInfo -> () - | NotOptional, _ -> errorR(Error(FSComp.SR.tcCallerInfoNotOptional(callerInfo |> string), m)) + | NotOptional, _ -> errorR(Error(FSComp.SR.tcCallerInfoNotOptional(RichText.mkText (callerInfo |> string)), m)) | CallerSide _, CallerLineNumber -> if not (typeEquiv g g.int32_ty ty) then - errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfo |> string, "int", NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.tcCallerInfoWrongType(RichText.mkText (callerInfo |> string), RichText.mkText "int", NicePrint.minimalRichTextOfType cenv.denv ty), m)) | CalleeSide, CallerLineNumber -> errorIfNotOptional g.int32_ty "int" m ty callerInfo | CallerSide _, (CallerFilePath | CallerMemberName) -> errorIfNotStringTy m ty callerInfo | CalleeSide, (CallerFilePath | CallerMemberName) -> errorIfNotOptional g.string_ty "string" m ty callerInfo @@ -2528,12 +2529,12 @@ let CheckEntityDefn cenv env (tycon: Entity) = | Some vref -> vref.DefinitionRange if hashOfImmediateMeths.ContainsKey nm then - errorR(Error(FSComp.SR.chkPropertySameNameMethod(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.chkPropertySameNameMethod(RichText.mkProperty nm, NicePrint.minimalRichTextOfType cenv.denv ty), m)) let others = getHash hashOfImmediateProps nm if pinfo.HasGetter && pinfo.HasSetter && pinfo.GetterMethod.IsVirtual <> pinfo.SetterMethod.IsVirtual then - errorR(Error(FSComp.SR.chkGetterSetterDoNotMatchAbstract(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.chkGetterSetterDoNotMatchAbstract(RichText.mkProperty nm, NicePrint.minimalRichTextOfType cenv.denv ty), m)) let checkForDup erasureFlag pinfo2 = // abstract/default pairs of duplicate properties are OK @@ -2545,9 +2546,9 @@ let CheckEntityDefn cenv env (tycon: Entity) = if others |> List.exists (checkForDup EraseAll) then if others |> List.exists (checkForDup EraseNone) then - errorR(Error(FSComp.SR.chkDuplicateProperty(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.chkDuplicateProperty(RichText.mkProperty nm, NicePrint.minimalRichTextOfType cenv.denv ty), m)) else - errorR(Error(FSComp.SR.chkDuplicatePropertyWithSuffix(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.chkDuplicatePropertyWithSuffix(RichText.mkProperty nm, NicePrint.minimalRichTextOfType cenv.denv ty), m)) // Check to see if one is an indexer and one is not if ( (pinfo.HasGetter && @@ -2559,7 +2560,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = (let nargs = pinfo.GetParamTypes(cenv.amap, m).Length others |> List.exists (fun pinfo2 -> isNil(pinfo2.GetParamTypes(cenv.amap, m)) <> (nargs = 0)))) then - errorR(Error(FSComp.SR.chkPropertySameNameIndexer(nm, NicePrint.minimalStringOfType cenv.denv ty), m)) + errorR(Error(FSComp.SR.chkPropertySameNameIndexer(RichText.mkProperty nm, NicePrint.minimalRichTextOfType cenv.denv ty), m)) // Check to see if the signatures of the both getter and the setter imply the same property type @@ -2568,9 +2569,9 @@ let CheckEntityDefn cenv env (tycon: Entity) = let ty2 = pinfo.DropGetter().GetPropertyType(cenv.amap, m) if not (typeEquivAux EraseNone cenv.amap.g ty1 ty2) then if g.langVersion.SupportsFeature(LanguageFeature.WarningIndexedPropertiesGetSetSameType) && pinfo.IsIndexer then - warning(Error(FSComp.SR.chkIndexedGetterAndSetterHaveSamePropertyType(pinfo.PropertyName, NicePrint.minimalStringOfType cenv.denv ty1, NicePrint.minimalStringOfType cenv.denv ty2), m)) + warning(Error(FSComp.SR.chkIndexedGetterAndSetterHaveSamePropertyType(RichText.mkProperty pinfo.PropertyName, NicePrint.minimalRichTextOfType cenv.denv ty1, NicePrint.minimalRichTextOfType cenv.denv ty2), m)) if not pinfo.IsIndexer then - errorR(Error(FSComp.SR.chkGetterAndSetterHaveSamePropertyType(pinfo.PropertyName, NicePrint.minimalStringOfType cenv.denv ty1, NicePrint.minimalStringOfType cenv.denv ty2), m)) + errorR(Error(FSComp.SR.chkGetterAndSetterHaveSamePropertyType(RichText.mkProperty pinfo.PropertyName, NicePrint.minimalRichTextOfType cenv.denv ty1, NicePrint.minimalRichTextOfType cenv.denv ty2), m)) hashOfImmediateProps[nm] <- pinfo :: others @@ -2589,7 +2590,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = match parentMethsOfSameName |> List.tryFind (checkForDup EraseAll) with | None -> () | Some minfo -> - let mtext = NicePrint.stringOfMethInfo cenv.infoReader m cenv.denv minfo + let mtext = NicePrint.richTextOfMethInfo cenv.infoReader m cenv.denv minfo if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then warning(Error(FSComp.SR.tcNewMemberHidesAbstractMember mtext, m)) else @@ -2604,9 +2605,9 @@ let CheckEntityDefn cenv env (tycon: Entity) = if parentMethsOfSameName |> List.exists (checkForDup EraseAll) then if parentMethsOfSameName |> List.exists (checkForDup EraseNone) then - errorR(Error(FSComp.SR.chkDuplicateMethodInheritedType nm, m)) + errorR(Error(FSComp.SR.chkDuplicateMethodInheritedType (RichText.mkMethod nm), m)) else - errorR(Error(FSComp.SR.chkDuplicateMethodInheritedTypeWithSuffix nm, m)) + errorR(Error(FSComp.SR.chkDuplicateMethodInheritedTypeWithSuffix (RichText.mkMethod nm), m)) // Must use name-based matching (not type-identity) because user code can define @@ -2645,7 +2646,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = // Access checks let access = AdjustAccess (IsHiddenTycon env.sigToImplRemapInfo tycon) (fun () -> tycon.CompilationPath) tycon.Accessibility - let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access false tycon.Range ty + let visitType ty = CheckTypeForAccess cenv env (fun () -> richTextOfEntityName tycon tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access false tycon.Range ty abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType) @@ -2764,7 +2765,7 @@ let CheckForDuplicateExtensionMemberNames (cenv: cenv) (vals: Val seq) = // Found extensions for types with same LogicalName but different fully qualified names // Report error on the second (and subsequent) extensions for v in members |> List.skip 1 do - errorR(Error(FSComp.SR.tcDuplicateExtensionMemberNames(logicalName), v.Range)) + errorR(Error(FSComp.SR.tcDuplicateExtensionMemberNames(RichText.mkMember logicalName), v.Range)) let rec CheckDefnsInModule cenv env mdefs = for mdef in mdefs do diff --git a/src/Compiler/Checking/QuotationTranslator.fs b/src/Compiler/Checking/QuotationTranslator.fs index 82a1fe07145..9d3613db40a 100644 --- a/src/Compiler/Checking/QuotationTranslator.fs +++ b/src/Compiler/Checking/QuotationTranslator.fs @@ -302,7 +302,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : Exp let ty = tyOfExpr g expr match (freeInExpr CollectTyparsAndLocalsNoCaching x0).FreeLocals |> Seq.tryPick (fun v -> if env.vs.ContainsVal v then Some v else None) with - | Some v -> errorR(Error(FSComp.SR.crefBoundVarUsedInSplice(v.DisplayName), v.Range)) + | Some v -> errorR(Error(FSComp.SR.crefBoundVarUsedInSplice(richTextOfValName cenv.g v), v.Range)) | None -> () cenv.exprSplices.Add((x0, m)) diff --git a/src/Compiler/Checking/SignatureConformance.fs b/src/Compiler/Checking/SignatureConformance.fs index 293a8d8e781..5274eb31fa4 100644 --- a/src/Compiler/Checking/SignatureConformance.fs +++ b/src/Compiler/Checking/SignatureConformance.fs @@ -28,15 +28,15 @@ open FSharp.Compiler.TypeProviders type TypeMismatchSource = NullnessOnlyMismatch | RegularMismatch -exception RequiredButNotSpecified of DisplayEnv * ModuleOrNamespaceRef * string * (StringBuilder -> unit) * range +exception RequiredButNotSpecified of DisplayEnv * ModuleOrNamespaceRef * string * (RichTextBuilder -> unit) * range -exception ValueNotContained of kind:TypeMismatchSource * DisplayEnv * InfoReader * ModuleOrNamespaceRef * Val * Val * (string * string * string -> string) +exception ValueNotContained of kind:TypeMismatchSource * DisplayEnv * InfoReader * ModuleOrNamespaceRef * Val * Val * (RichText * RichText * RichText -> RichText) -exception UnionCaseNotContained of DisplayEnv * InfoReader * Tycon * UnionCase * UnionCase * (string * string -> string) +exception UnionCaseNotContained of DisplayEnv * InfoReader * Tycon * UnionCase * UnionCase * (RichText * RichText -> RichText) -exception FSharpExceptionNotContained of DisplayEnv * InfoReader * Tycon * Tycon * (string * string -> string) +exception FSharpExceptionNotContained of DisplayEnv * InfoReader * Tycon * Tycon * (RichText * RichText -> RichText) -exception FieldNotContained of kind:TypeMismatchSource * DisplayEnv * InfoReader * Tycon * Tycon * RecdField * RecdField * (string * string -> string) +exception FieldNotContained of kind:TypeMismatchSource * DisplayEnv * InfoReader * Tycon * Tycon * RecdField * RecdField * (RichText * RichText -> RichText) exception InterfaceNotRevealed of DisplayEnv * TType * range @@ -130,7 +130,7 @@ module private AttributeConformance = for flag in policy do if flag |> Flags.intersects missing then let m = rangeOfMissing classify implAttribs flag fallback - emit(Error (FSComp.SR.implAttributeMissingFromSignature(displayName flag, displayNameOf impl), m)) + emit(Error (FSComp.SR.implAttributeMissingFromSignature(RichText.mkClass (displayName flag), RichText.mkText (displayNameOf impl)), m)) let private emitter (g: TcGlobals) : exn -> unit = if g.langVersion.SupportsFeature LanguageFeature.ErrorOnMissingSignatureAttribute then @@ -235,7 +235,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = if existsSimilarAttrib then let (Attrib(implTcref, _, _, _, _, _, implRange)) = implAttrib - warning(Error(FSComp.SR.tcAttribArgsDiffer(implTcref.DisplayName), implRange)) + warning(Error(FSComp.SR.tcAttribArgsDiffer(richTextOfEntityRef implTcref), implRange)) check keptImplAttribsRev remainingImplAttribs sigAttribs else check (implAttrib :: keptImplAttribsRev) remainingImplAttribs sigAttribs @@ -284,7 +284,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = | TyparConstraint.DefaultsTo(_, _acty, _) -> true | _ -> if not (List.exists (typarConstraintsAEquiv g aenv implTyparCx) sigTypar.Constraints) - then (errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDiffer(sigTypar.Name, LayoutRender.showL(NicePrint.layoutTyparConstraint denv (implTypar, implTyparCx))), m)); false) + then (errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDiffer(RichText.mkTypeParameter sigTypar.Name, LayoutRender.toRichText (NicePrint.layoutTyparConstraint denv (implTypar, implTyparCx))), m)); false) else true) && // Check the constraints in the signature are present in the implementation @@ -297,13 +297,15 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = | TyparConstraint.SupportsEquality _ -> true | _ -> if not (List.exists (fun implTyparCx -> typarConstraintsAEquiv g aenv implTyparCx sigTyparCx) implTypar.Constraints) then - (errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDifferRemove(sigTypar.Name, LayoutRender.showL(NicePrint.layoutTyparConstraint denv (sigTypar, sigTyparCx))), m)); false) + (errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDifferRemove(RichText.mkTypeParameter sigTypar.Name, LayoutRender.toRichText (NicePrint.layoutTyparConstraint denv (sigTypar, sigTyparCx))), m)); false) else true) && (not checkingSig || checkAttribs aenv implTypar.Attribs sigTypar.Attribs implTypar.SetAttribs)) and checkTypeDef (aenv: TypeEquivEnv) (infoReader: InfoReader) (implTycon: Tycon) (sigTycon: Tycon) = let m = implTycon.Range + let kindText = RichText.mkText (implTycon.TypeOrMeasureKind.ToString()) + let implTyconName = richTextOfEntity implTycon implTycon.SetOtherXmlDoc(sigTycon.XmlDoc) @@ -314,12 +316,12 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = checkEnforcedEntityAttribs implTycon sigTycon m if implTycon.LogicalName <> sigTycon.LogicalName then - errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer(implTycon.TypeOrMeasureKind.ToString(), sigTycon.LogicalName, implTycon.LogicalName), m)) + errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer(kindText, richTextOfEntityName sigTycon sigTycon.LogicalName, richTextOfEntityName implTycon implTycon.LogicalName), m)) false else if implTycon.CompiledName <> sigTycon.CompiledName then - errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer(implTycon.TypeOrMeasureKind.ToString(), sigTycon.CompiledName, implTycon.CompiledName), m)) + errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer(kindText, richTextOfEntityName sigTycon sigTycon.CompiledName, richTextOfEntityName implTycon implTycon.CompiledName), m)) false else @@ -329,10 +331,10 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = let sigTypars = sigTycon.Typars if implTypars.Length <> sigTypars.Length then - errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleParameterCountsDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleParameterCountsDiffer(kindText, implTyconName), m)) false elif isLessAccessible implTycon.Accessibility sigTycon.Accessibility then - errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleAccessibilityDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleAccessibilityDiffer(kindText, implTyconName), m)) false else let aenv = aenv.BindEquivTypars implTypars sigTypars @@ -351,7 +353,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = let unimplIntfTys = ListSet.subtract (fun sigIntfTy implIntfTy -> typeAEquiv g aenv implIntfTy sigIntfTy) sigIntfTys implIntfTys (unimplIntfTys |> List.forall (fun ity -> - let errorMessage = FSComp.SR.DefinitionsInSigAndImplNotCompatibleMissingInterface(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, NicePrint.minimalStringOfType denv ity) + let errorMessage = FSComp.SR.DefinitionsInSigAndImplNotCompatibleMissingInterface(kindText, implTyconName, NicePrint.minimalRichTextOfType denv ity) errorR (Error(errorMessage, m)); false)) && let implUserIntfTys = flatten implUserIntfTys @@ -363,43 +365,43 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = let aNull = IsUnionTypeWithNullAsTrueValue g implTycon let fNull = IsUnionTypeWithNullAsTrueValue g sigTycon if aNull && not fNull then - errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull(kindText, implTyconName), m)) false elif fNull && not aNull then - errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull(kindText, implTyconName), m)) false else let aNull2 = TypeNullIsExtraValue g m (generalizedTyconRef g (mkLocalTyconRef implTycon)) let fNull2 = TypeNullIsExtraValue g m (generalizedTyconRef g (mkLocalTyconRef implTycon)) // TODO: should be sigTycon, raises extra errors if aNull2 && not fNull2 then - errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull2(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull2(kindText, implTyconName), m)) false elif fNull2 && not aNull2 then - errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull2(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull2(kindText, implTyconName), m)) false else let aSealed = isSealedTy g (generalizedTyconRef g (mkLocalTyconRef implTycon)) let fSealed = isSealedTy g (generalizedTyconRef g (mkLocalTyconRef sigTycon)) if aSealed && not fSealed then - errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSealed(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSealed(kindText, implTyconName), m)) false elif not aSealed && fSealed then - errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsNotSealed(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsNotSealed(kindText, implTyconName), m)) false else let aPartial = isAbstractTycon implTycon let fPartial = isAbstractTycon sigTycon if aPartial && not fPartial then - errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsAbstract(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsAbstract(kindText, implTyconName), m)) false elif not aPartial && fPartial then - errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureIsAbstract(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR(Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureIsAbstract(kindText, implTyconName), m)) false elif not (typeAEquiv g aenv (superOfTycon g implTycon) (superOfTycon g sigTycon)) then - errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypesHaveDifferentBaseTypes(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypesHaveDifferentBaseTypes(kindText, implTyconName), m)) false else @@ -409,7 +411,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = checkAttribs aenv implTycon.Attribs sigTycon.Attribs (fun attribs -> implTycon.entity_attribs <- WellKnownEntityAttribs.Create(attribs)) && checkModuleOrNamespaceContents implTycon.Range aenv infoReader (mkLocalEntityRef implTycon) sigTycon.ModuleOrNamespaceType - and checkValInfo aenv err (implVal : Val) (sigVal : Val) = + and checkValInfo aenv (err: (RichText * RichText * RichText -> RichText) -> bool) (implVal : Val) (sigVal : Val) = let id = implVal.Id match implVal.ValReprInfo, sigVal.ValReprInfo with | _, None -> true @@ -419,7 +421,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = let mtps = sigTyparNames.Length let nSigArgInfos = sigArgInfos.Length if ntps <> mtps then - err(fun(x, y, z) -> FSComp.SR.ValueNotContainedMutabilityGenericParametersDiffer(x, y, z, string mtps, string ntps)) + err(fun(x, y, z) -> FSComp.SR.ValueNotContainedMutabilityGenericParametersDiffer(x, y, z, RichText.mkText (string mtps), RichText.mkText (string ntps))) elif implValInfo.KindsOfTypars <> sigValInfo.KindsOfTypars then err(FSComp.SR.ValueNotContainedMutabilityGenericParametersAreDifferentKinds) else @@ -435,7 +437,9 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = (fst (List.splitAt nSigArgInfos implArgInfos)) if not argGroupsCompatible then - err(fun(x, y, z) -> FSComp.SR.ValueNotContainedMutabilityAritiesDiffer(x, y, z, id.idText, string nSigArgInfos, id.idText, id.idText)) + err(fun(x, y, z) -> + let name = RichText.mkLocal id.idText + FSComp.SR.ValueNotContainedMutabilityAritiesDiffer(x, y, z, name, RichText.mkText (string nSigArgInfos), name, name)) else let implArgInfos = implArgInfos |> List.truncate nSigArgInfos // When impl has empty group [] (unit param like member M(())), synthesize @@ -621,30 +625,32 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = | _ -> false and checkRecordFields m aenv infoReader (implTycon: Tycon) (sigTycon: Tycon) (implFields: TyconRecdFields) (sigFields: TyconRecdFields) = + let kindText = RichText.mkText (implTycon.TypeOrMeasureKind.ToString()) + let implTyconName = richTextOfEntity implTycon let implFields = implFields.TrueFieldsAsList let sigFields = sigFields.TrueFieldsAsList let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.LogicalName) let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.LogicalName) NameMap.suball2 - (fun fieldName _ -> errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, fieldName), m)); false) + (fun fieldName _ -> errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(kindText, implTyconName, RichText.mkRecordField fieldName), m)); false) (checkField aenv infoReader implTycon sigTycon) m1 m2 && NameMap.suball2 - (fun fieldName _ -> errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldWasPresent(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, fieldName), m)); false) + (fun fieldName _ -> errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldWasPresent(kindText, implTyconName, RichText.mkRecordField fieldName), m)); false) (fun x y -> checkField aenv infoReader implTycon sigTycon y x) m2 m1 && // This check is required because constructors etc. are externally visible // and thus compiled representations do pick up dependencies on the field order (if List.forall2 (checkField aenv infoReader implTycon sigTycon) implFields sigFields then true - else (errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldOrderDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false)) + else (errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldOrderDiffer(kindText, implTyconName), m)); false)) and checkRecordFieldsForExn _g _denv err aenv (infoReader: InfoReader) (enclosingImplTycon: Tycon) (enclosingSigTycon: Tycon) (implFields: TyconRecdFields) (sigFields: TyconRecdFields) = let implFields = implFields.TrueFieldsAsList let sigFields = sigFields.TrueFieldsAsList let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.LogicalName) let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.LogicalName) - NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInSigButNotImpl(s, x, y))); false) (checkField aenv infoReader enclosingImplTycon enclosingSigTycon) m1 m2 && - NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInImplButNotSig(s, x, y))); false) (fun x y -> checkField aenv infoReader enclosingImplTycon enclosingSigTycon y x) m2 m1 && + NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInSigButNotImpl(RichText.mkField s, x, y))); false) (checkField aenv infoReader enclosingImplTycon enclosingSigTycon) m1 m2 && + NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInImplButNotSig(RichText.mkField s, x, y))); false) (fun x y -> checkField aenv infoReader enclosingImplTycon enclosingSigTycon y x) m2 m1 && // This check is required because constructors etc. are externally visible // and thus compiled representations do pick up dependencies on the field order (if List.forall2 (checkField aenv infoReader enclosingImplTycon enclosingSigTycon) implFields sigFields @@ -652,44 +658,48 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = else (errorR(err FSComp.SR.ExceptionDefsNotCompatibleFieldOrderDiffers); false)) and checkVirtualSlots denv infoReader m (implTycon: Tycon) implAbstractSlots sigAbstractSlots = + let kindText = RichText.mkText (implTycon.TypeOrMeasureKind.ToString()) + let implTyconName = richTextOfEntity implTycon let m1 = NameMap.ofKeyedList (fun (v: ValRef) -> v.DisplayName) implAbstractSlots let m2 = NameMap.ofKeyedList (fun (v: ValRef) -> v.DisplayName) sigAbstractSlots (m1, m2) ||> NameMap.suball2 (fun _s vref -> - let kindText = implTycon.TypeOrMeasureKind.ToString() - let valText = NicePrint.stringValOrMember denv infoReader vref - errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInImpl(kindText, implTycon.DisplayName, valText), m)); false) (fun _x _y -> true) && + let valText = NicePrint.richTextValOrMember denv infoReader vref + errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInImpl(kindText, implTyconName, valText), m)); false) (fun _x _y -> true) && (m2, m1) ||> NameMap.suball2 (fun _s vref -> - let kindText = implTycon.TypeOrMeasureKind.ToString() - let valText = NicePrint.stringValOrMember denv infoReader vref - errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInSig(kindText, implTycon.DisplayName, valText), m)); false) (fun _x _y -> true) + let valText = NicePrint.richTextValOrMember denv infoReader vref + errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInSig(kindText, implTyconName, valText), m)); false) (fun _x _y -> true) and checkClassFields isStruct m aenv infoReader (implTycon: Tycon) (signTycon: Tycon) (implFields: TyconRecdFields) (sigFields: TyconRecdFields) = + let kindText = RichText.mkText (implTycon.TypeOrMeasureKind.ToString()) + let implTyconName = richTextOfEntity implTycon let implFields = implFields.TrueFieldsAsList let sigFields = sigFields.TrueFieldsAsList let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.LogicalName) let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.LogicalName) NameMap.suball2 - (fun fieldName _ -> errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, fieldName), m)); false) + (fun fieldName _ -> errorR(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(kindText, implTyconName, RichText.mkRecordField fieldName), m)); false) (checkField aenv infoReader implTycon signTycon) m1 m2 && (if isStruct then NameMap.suball2 - (fun fieldName _ -> warning(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldIsInImplButNotSig(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, fieldName), m)); true) + (fun fieldName _ -> warning(Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldIsInImplButNotSig(kindText, implTyconName, RichText.mkRecordField fieldName), m)); true) (fun x y -> checkField aenv infoReader implTycon signTycon y x) m2 m1 else true) and checkTypeRepr m aenv (infoReader: InfoReader) (implTycon: Tycon) (sigTycon: Tycon) = + let kindText = RichText.mkText (implTycon.TypeOrMeasureKind.ToString()) + let implTyconName = richTextOfEntity implTycon let reportNiceError k s1 s2 = let aset = NameSet.ofList s1 let fset = NameSet.ofList s2 match Zset.elements (Zset.diff aset fset) with | [] -> match Zset.elements (Zset.diff fset aset) with - | [] -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNumbersDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, k), m)); false) - | l -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDefinesButImplDoesNot(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, k, String.concat ";" l), m)); false) - | l -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesButSignatureDoesNot(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, k, String.concat ";" l), m)); false) + | [] -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNumbersDiffer(kindText, implTyconName, RichText.mkText k), m)); false) + | l -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDefinesButImplDoesNot(kindText, implTyconName, RichText.mkText k, RichText.mkText (String.concat ";" l)), m)); false) + | l -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesButSignatureDoesNot(kindText, implTyconName, RichText.mkText k, RichText.mkText (String.concat ";" l)), m)); false) match implTycon.TypeReprInfo, sigTycon.TypeReprInfo with | (TILObjectRepr _ @@ -701,13 +711,13 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = | TFSharpTyconRepr r, TNoRepr -> match r.fsobjmodel_kind with | TFSharpStruct | TFSharpEnum -> - (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesStruct(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) + (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesStruct(kindText, implTyconName), m)); false) | _ -> true | TAsmRepr _, TNoRepr -> - (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleDotNetTypeRepresentationIsHidden(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) + (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleDotNetTypeRepresentationIsHidden(kindText, implTyconName), m)); false) | TMeasureableRepr _, TNoRepr -> - (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsHidden(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) + (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsHidden(kindText, implTyconName), m)); false) // Union types are compatible with union types in signature | TFSharpTyconRepr { fsobjmodel_kind=TFSharpUnion; fsobjmodel_cases=r1}, @@ -746,16 +756,16 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = (returnTypesAEquiv g aenv rty1 rty2))) | _ -> false if not compat then - errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsDifferentKind(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsDifferentKind(kindText, implTyconName), m)) false else let isStruct = (match r1.fsobjmodel_kind with TFSharpStruct -> true | _ -> false) checkClassFields isStruct m aenv infoReader implTycon sigTycon r1.fsobjmodel_rfields r2.fsobjmodel_rfields && checkVirtualSlots denv infoReader m implTycon r1.fsobjmodel_vslots r2.fsobjmodel_vslots | TAsmRepr tcr1, TAsmRepr tcr2 -> - if tcr1 <> tcr2 then (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleILDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) else true + if tcr1 <> tcr2 then (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleILDiffer(kindText, implTyconName), m)); false) else true | TMeasureableRepr ty1, TMeasureableRepr ty2 -> - if typeAEquiv g aenv ty1 ty2 then true else (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) + if typeAEquiv g aenv ty1 ty2 then true else (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer(kindText, implTyconName), m)); false) | TNoRepr, TNoRepr -> true #if !NO_TYPEPROVIDERS | TProvidedTypeRepr info1, TProvidedTypeRepr info2 -> @@ -764,13 +774,15 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = System.Diagnostics.Debug.Assert(false, "unreachable: TProvidedNamespaceRepr only on namespaces, not types" ) true #endif - | TNoRepr, _ -> (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) - | _, _ -> (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) + | TNoRepr, _ -> (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer(kindText, implTyconName), m)); false) + | _, _ -> (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer(kindText, implTyconName), m)); false) and checkTypeAbbrev m aenv (implTycon: Tycon) (sigTycon: Tycon) = + let kindText = RichText.mkText (implTycon.TypeOrMeasureKind.ToString()) + let implTyconName = richTextOfEntity implTycon let kind1 = implTycon.TypeOrMeasureKind let kind2 = sigTycon.TypeOrMeasureKind - if kind1 <> kind2 then (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDeclaresDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, kind2.ToString(), kind1.ToString()), m)); false) + if kind1 <> kind2 then (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDeclaresDiffer(kindText, implTyconName, RichText.mkText (kind2.ToString()), RichText.mkText (kind1.ToString())), m)); false) else match implTycon.TypeAbbrev, sigTycon.TypeAbbrev with | Some ty1, Some ty2 -> @@ -780,8 +792,8 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = else true | None, None -> true - | Some _, None -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationHiddenBySig(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) - | None, Some _ -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleSigHasAbbreviation(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) + | Some _, None -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationHiddenBySig(kindText, implTyconName), m)); false) + | None, Some _ -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleSigHasAbbreviation(kindText, implTyconName), m)); false) and checkModuleOrNamespaceContents m aenv (infoReader: InfoReader) (implModRef: ModuleOrNamespaceRef) (signModType: ModuleOrNamespaceType) = let implModType = implModRef.ModuleOrNamespaceType @@ -790,22 +802,22 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = (implModType.TypesByMangledName, signModType.TypesByMangledName) ||> NameMap.suball2 - (fun s _fx -> errorR(RequiredButNotSpecified(denv, implModRef, "type", (fun os -> Printf.bprintf os "%s" s), m)); false) + (fun s fx -> errorR(RequiredButNotSpecified(denv, implModRef, "type", (fun os -> os.Append(tagEntityRefName (mkLocalEntityRef fx) s)), m)); false) (checkTypeDef aenv infoReader) && (implModType.ModulesAndNamespacesByDemangledName, signModType.ModulesAndNamespacesByDemangledName ) ||> NameMap.suball2 - (fun s fx -> errorR(RequiredButNotSpecified(denv, implModRef, (if fx.IsModule then "module" else "namespace"), (fun os -> Printf.bprintf os "%s" s), m)); false) + (fun s fx -> errorR(RequiredButNotSpecified(denv, implModRef, (if fx.IsModule then "module" else "namespace"), (fun os -> os.Append(tagEntityRefName (mkLocalModuleRef fx) s)), m)); false) (fun x1 x2 -> checkModuleOrNamespace aenv infoReader (mkLocalModuleRef x1) x2) && let sigValHadNoMatchingImplementation (fx: Val) (_closeActualVal: Val option) = errorR(RequiredButNotSpecified(denv, implModRef, "value", (fun os -> (* In the case of missing members show the full required enclosing type and signature *) if fx.IsMember then - NicePrint.outputQualifiedValOrMember denv infoReader os (mkLocalValRef fx) + os.Append(NicePrint.richTextOfQualifiedValOrMember denv infoReader (mkLocalValRef fx)) else - Printf.bprintf os "%s" fx.DisplayName), m)) + os.Append(tagValName g fx fx.DisplayName)), m)) let valuesPartiallyMatch (av: Val) (fv: Val) = let akey = av.GetLinkagePartialKey() @@ -898,14 +910,14 @@ let rec CheckNamesOfModuleOrNamespaceContents denv infoReader (implModRef: Modul let m = implModRef.Range let implModType = implModRef.ModuleOrNamespaceType NameMap.suball2 - (fun s _fx -> errorR(RequiredButNotSpecified(denv, implModRef, "type", (fun os -> Printf.bprintf os "%s" s), m)); false) + (fun s fx -> errorR(RequiredButNotSpecified(denv, implModRef, "type", (fun os -> os.Append(tagEntityRefName (mkLocalEntityRef fx) s)), m)); false) (fun _ _ -> true) implModType.TypesByMangledName signModType.TypesByMangledName && (implModType.ModulesAndNamespacesByDemangledName, signModType.ModulesAndNamespacesByDemangledName ) ||> NameMap.suball2 - (fun s fx -> errorR(RequiredButNotSpecified(denv, implModRef, (if fx.IsModule then "module" else "namespace"), (fun os -> Printf.bprintf os "%s" s), m)); false) + (fun s fx -> errorR(RequiredButNotSpecified(denv, implModRef, (if fx.IsModule then "module" else "namespace"), (fun os -> os.Append(tagEntityRefName (mkLocalModuleRef fx) s)), m)); false) (fun x1 (x2: ModuleOrNamespace) -> CheckNamesOfModuleOrNamespace denv infoReader (mkLocalModuleRef x1) x2.ModuleOrNamespaceType) && (implModType.AllValsAndMembersByLogicalNameUncached, signModType.AllValsAndMembersByLogicalNameUncached) @@ -915,9 +927,9 @@ let rec CheckNamesOfModuleOrNamespaceContents denv infoReader (implModRef: Modul errorR(RequiredButNotSpecified(denv, implModRef, "value", (fun os -> // In the case of missing members show the full required enclosing type and signature if Option.isSome fx.MemberInfo then - NicePrint.outputQualifiedValOrMember denv infoReader os (mkLocalValRef fx) + os.Append(NicePrint.richTextOfQualifiedValOrMember denv infoReader (mkLocalValRef fx)) else - Printf.bprintf os "%s" fx.DisplayName), m)); false) + os.Append(tagValName denv.g fx fx.DisplayName)), m)); false) (fun _ _ -> true) diff --git a/src/Compiler/Checking/SignatureConformance.fsi b/src/Compiler/Checking/SignatureConformance.fsi index 136cedce94f..5140e980f25 100644 --- a/src/Compiler/Checking/SignatureConformance.fsi +++ b/src/Compiler/Checking/SignatureConformance.fsi @@ -17,7 +17,7 @@ type TypeMismatchSource = | NullnessOnlyMismatch | RegularMismatch -exception RequiredButNotSpecified of DisplayEnv * ModuleOrNamespaceRef * string * (StringBuilder -> unit) * range +exception RequiredButNotSpecified of DisplayEnv * ModuleOrNamespaceRef * string * (RichTextBuilder -> unit) * range exception ValueNotContained of kind: TypeMismatchSource * @@ -26,11 +26,17 @@ exception ValueNotContained of ModuleOrNamespaceRef * Val * Val * - (string * string * string -> string) + (RichText * RichText * RichText -> RichText) -exception UnionCaseNotContained of DisplayEnv * InfoReader * Tycon * UnionCase * UnionCase * (string * string -> string) +exception UnionCaseNotContained of + DisplayEnv * + InfoReader * + Tycon * + UnionCase * + UnionCase * + (RichText * RichText -> RichText) -exception FSharpExceptionNotContained of DisplayEnv * InfoReader * Tycon * Tycon * (string * string -> string) +exception FSharpExceptionNotContained of DisplayEnv * InfoReader * Tycon * Tycon * (RichText * RichText -> RichText) exception FieldNotContained of kind: TypeMismatchSource * @@ -40,7 +46,7 @@ exception FieldNotContained of Tycon * RecdField * RecdField * - (string * string -> string) + (RichText * RichText -> RichText) exception InterfaceNotRevealed of DisplayEnv * TType * range diff --git a/src/Compiler/Checking/TailCallChecks.fs b/src/Compiler/Checking/TailCallChecks.fs index 87ee24bbdb4..b58ba59797a 100644 --- a/src/Compiler/Checking/TailCallChecks.fs +++ b/src/Compiler/Checking/TailCallChecks.fs @@ -220,7 +220,7 @@ let CheckForNonTailRecCall (cenv: cenv) expr (tailCall: TailCall) = // ``Warn successfully in match clause`` // ``Warn for byref parameters`` if not canTailCall then - warning (Error(FSComp.SR.chkNotTailRecursive vref.DisplayName, m)) + warning (Error(FSComp.SR.chkNotTailRecursive (richTextOfValName g vref.Deref), m)) | _ -> () | _ -> () @@ -780,7 +780,7 @@ let CheckModuleBinding cenv (isRec: bool) (TBind _ as bind) = match expr with | Expr.Val(valRef = valRef; range = m) -> if isRec && insideSubBindingOrTry && cenv.mustTailCall.Contains valRef.Deref then - warning (Error(FSComp.SR.chkNotTailRecursive valRef.DisplayName, m)) + warning (Error(FSComp.SR.chkNotTailRecursive (richTextOfValName cenv.g valRef.Deref), m)) | Expr.App(funcExpr = funcExpr; args = argExprs) -> checkTailCall insideSubBindingOrTry funcExpr argExprs |> List.iter (checkTailCall insideSubBindingOrTry) diff --git a/src/Compiler/Checking/TypeHierarchy.fs b/src/Compiler/Checking/TypeHierarchy.fs index ec788a3204a..50f8ebb57b5 100644 --- a/src/Compiler/Checking/TypeHierarchy.fs +++ b/src/Compiler/Checking/TypeHierarchy.fs @@ -3,6 +3,7 @@ module internal FSharp.Compiler.TypeHierarchy open Internal.Utilities.Library.Extras +open FSharp.Compiler.Text open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.Import @@ -251,7 +252,7 @@ let FoldHierarchyOfTypeAux followInterfaces allowMultiIntfInst skipUnref visitor | _ -> state - if ndeep > 100 then (errorR(Error((FSComp.SR.recursiveClassHierarchy (showType ty)), m)); (visitedTycon, visited, acc)) else + if ndeep > 100 then (errorR(Error((FSComp.SR.recursiveClassHierarchy (RichText.mkText (showType ty))), m)); (visitedTycon, visited, acc)) else let visitedTycon, visited, acc = if isInterfaceTy g ty then List.foldBack diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs index 021370f2067..681020e8d04 100644 --- a/src/Compiler/Checking/TypeRelations.fs +++ b/src/Compiler/Checking/TypeRelations.fs @@ -4,6 +4,7 @@ /// constraint solving and method overload resolution. module internal FSharp.Compiler.TypeRelations +open FSharp.Compiler.Text open FSharp.Compiler.Features open Internal.Utilities.Collections open Internal.Utilities.Library @@ -193,7 +194,7 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = let join m x = if TypeFeasiblySubsumesType 0 g amap m x CanCoerce maxTy then maxTy, isRefined elif TypeFeasiblySubsumesType 0 g amap m maxTy CanCoerce x then x, true - else errorR(Error(FSComp.SR.typrelCannotResolveImplicitGenericInstantiation((DebugPrint.showType x), (DebugPrint.showType maxTy)), m)); maxTy, isRefined + else errorR(Error(FSComp.SR.typrelCannotResolveImplicitGenericInstantiation(RichText.mkText (DebugPrint.showType x), RichText.mkText (DebugPrint.showType maxTy)), m)); maxTy, isRefined // Don't continue if an error occurred and we set the value eagerly if tp.IsSolved then (maxTy, isRefined), m else match tpc with diff --git a/src/Compiler/Checking/import.fs b/src/Compiler/Checking/import.fs index 86538b5c7ab..e4e18fb4abf 100644 --- a/src/Compiler/Checking/import.fs +++ b/src/Compiler/Checking/import.fs @@ -83,6 +83,17 @@ let CanImportILScopeRef (env: ImportMap) m scoref = | ILScopeRef.Assembly assemblyRef -> isResolved assemblyRef | ILScopeRef.PrimaryAssembly -> isResolved env.g.ilg.primaryAssemblyRef +/// A type's qualified name, classifying the enclosing path, the namespace and the name separately. How +/// the name itself is classified is up to the caller, since the kind of type it is only becomes known +/// once the type has been dereferenced. +let private richTextOfQualifiedTypeName (path: string[]) leafOfName typeName = + let name = RichText.ofQualifiedName leafOfName typeName + + if Array.isEmpty path then + name + else + RichText.concat [ richTextOfPath (Array.toList path); RichText.mkPunctuation "."; name ] + /// Import a reference to a type definition, given the AbstractIL data for the type reference let ImportTypeRefData (env: ImportMap) m (scoref, path, typeName) = @@ -106,13 +117,13 @@ let ImportTypeRefData (env: ImportMap) m (scoref, path, typeName) = match ccu with | ResolvedCcu ccu->ccu | UnresolvedCcu ccuName -> - error (Error(FSComp.SR.impTypeRequiredUnavailable(typeName, ccuName), m)) + error (Error(FSComp.SR.impTypeRequiredUnavailable(RichText.ofQualifiedTypeName typeName, RichText.mkText ccuName), m)) let fakeTyconRef = mkNonLocalTyconRef (mkNonLocalEntityRef ccu path) typeName let tycon = try fakeTyconRef.Deref with _ -> - error (Error(FSComp.SR.impReferencedTypeCouldNotBeFoundInAssembly(String.concat "." (Array.append path [| typeName |]), ccu.AssemblyName), m)) + error (Error(FSComp.SR.impReferencedTypeCouldNotBeFoundInAssembly(richTextOfQualifiedTypeName path RichText.mkUnknownType typeName, RichText.mkText ccu.AssemblyName), m)) #if !NO_TYPEPROVIDERS // Validate (once because of caching) match tycon.TypeReprInfo with @@ -123,7 +134,7 @@ let ImportTypeRefData (env: ImportMap) m (scoref, path, typeName) = () #endif match tryRescopeEntity ccu tycon with - | ValueNone -> error (Error(FSComp.SR.impImportedAssemblyUsesNotPublicType(String.concat "." (Array.toList path@[typeName])), m)) + | ValueNone -> error (Error(FSComp.SR.impImportedAssemblyUsesNotPublicType(richTextOfQualifiedTypeName path (richTextOfEntityName tycon) typeName), m)) | ValueSome tcref -> tcref @@ -422,7 +433,7 @@ let rec ImportProvidedTypeAsILType (env: ImportMap) (m: range) (st: Tainted genericArgs.Length then - error(Error(FSComp.SR.impInvalidNumberOfGenericArguments(tcref.CompiledName, tps.Length, genericArgs.Length), m)) + error(Error(FSComp.SR.impInvalidNumberOfGenericArguments(richTextOfEntityRefName tcref tcref.CompiledName, tps.Length, genericArgs.Length), m)) // We're converting to an IL type, where generic arguments are erased let genericArgs = List.zip tps genericArgs |> List.filter (fun (tp, _) -> not tp.IsErased) |> List.map snd @@ -499,7 +510,7 @@ let rec ImportProvidedType (env: ImportMap) (m: range) (* (tinst: TypeInst) *) ( let tps = tcref.Typars if tps.Length <> genericArgsLength then - error(Error(FSComp.SR.impInvalidNumberOfGenericArguments(tcref.CompiledName, tps.Length, genericArgsLength), m)) + error(Error(FSComp.SR.impInvalidNumberOfGenericArguments(richTextOfEntityRefName tcref tcref.CompiledName, tps.Length, genericArgsLength), m)) let genericArgs = (tps, genericArgs) ||> List.map2 (fun tp genericArg -> @@ -514,10 +525,10 @@ let rec ImportProvidedType (env: ImportMap) (m: range) (* (tinst: TypeInst) *) ( | TType_app (tcref, [], _) when tyconRefEq g tcref g.measureone_tcr -> Measure.One(tcref.Range) | TType_app (tcref, [], _) when tcref.TypeOrMeasureKind = TyparKind.Measure -> Measure.Const(tcref, tcref.Range) | TType_app (tcref, _, _) -> - errorR(Error(FSComp.SR.impInvalidMeasureArgument1(tcref.CompiledName, tp.Name), m)) + errorR(Error(FSComp.SR.impInvalidMeasureArgument1(richTextOfEntityRefName tcref tcref.CompiledName, RichText.mkTypeParameter tp.Name), m)) Measure.One tcref.Range | _ -> - errorR(Error(FSComp.SR.impInvalidMeasureArgument2(tp.Name), m)) + errorR(Error(FSComp.SR.impInvalidMeasureArgument2(RichText.mkTypeParameter tp.Name), m)) Measure.One range0 TType_measure (conv genericArg) @@ -555,7 +566,7 @@ let ImportProvidedMethodBaseAsILMethodRef (env: ImportMap) (m: range) (mbase: Ta | None -> let methodName = minfo.PUntaint((fun minfo -> minfo.Name), m) let typeName = declaringGenericTypeDefn.PUntaint((fun declaringGenericTypeDefn -> string declaringGenericTypeDefn.FullName), m) - error(Error(FSComp.SR.etIncorrectProvidedMethod(DisplayNameOfTypeProvider(minfo.TypeProvider, m), methodName, metadataToken, typeName), m)) + error(Error(FSComp.SR.etIncorrectProvidedMethod(RichText.mkText (DisplayNameOfTypeProvider(minfo.TypeProvider, m)), RichText.mkMethod methodName, metadataToken, RichText.ofQualifiedTypeName typeName), m)) | _ -> match mbase.OfType() with | Some cinfo when cinfo.PUntaint((fun x -> (nonNull x.DeclaringType).IsGenericType), m) -> @@ -587,7 +598,7 @@ let ImportProvidedMethodBaseAsILMethodRef (env: ImportMap) (m: range) (mbase: Ta | Some found -> found.Coerce(m) | None -> let typeName = declaringGenericTypeDefn.PUntaint((fun x -> string x.FullName), m) - error(Error(FSComp.SR.etIncorrectProvidedConstructor(DisplayNameOfTypeProvider(cinfo.TypeProvider, m), typeName), m)) + error(Error(FSComp.SR.etIncorrectProvidedConstructor(RichText.mkText (DisplayNameOfTypeProvider(cinfo.TypeProvider, m)), RichText.ofQualifiedTypeName typeName), m)) | _ -> mbase let retTy = @@ -779,7 +790,7 @@ let ImportILAssemblyExportedType amap m auxModLoader (scoref: ILScopeRef) (expor with :? KeyNotFoundException -> None) with | None -> - error(Error(FSComp.SR.impReferenceToDllRequiredByAssembly(exportedType.ScopeRef.QualifiedName, scoref.QualifiedName, exportedType.Name), m)) + error(Error(FSComp.SR.impReferenceToDllRequiredByAssembly(RichText.mkText exportedType.ScopeRef.QualifiedName, RichText.mkText scoref.QualifiedName, RichText.ofQualifiedTypeName exportedType.Name), m)) | Some preTypeDef -> scoref, preTypeDef ) diff --git a/src/Compiler/Checking/infos.fs b/src/Compiler/Checking/infos.fs index 0730b8b1e79..5f9d4f41ba4 100644 --- a/src/Compiler/Checking/infos.fs +++ b/src/Compiler/Checking/infos.fs @@ -327,7 +327,7 @@ let CrackParamAttribsInfo g (ty: TType, argInfo: ArgReprInfo) = | false, true, true -> match attribs with | ValAttrib g WellKnownValAttributes.CallerMemberNameAttribute (Attrib(_, _, _, _, _, _, callerMemberNameAttributeRange)) -> - warning(Error(FSComp.SR.CallerMemberNameIsOverridden(argInfo.Name.Value.idText), callerMemberNameAttributeRange)) + warning(Error(FSComp.SR.CallerMemberNameIsOverridden(RichText.mkParameter argInfo.Name.Value.idText), callerMemberNameAttributeRange)) CallerFilePath | _ -> failwith "Impossible" | _, _, _ -> @@ -366,7 +366,7 @@ type ILFieldInit with | :? uint64 as i -> ILFieldInit.UInt64 i | _ -> let txt = match v with | null -> "?" | v -> try !!v.ToString() with _ -> "?" - error(Error(FSComp.SR.infosInvalidProvidedLiteralValue(txt), m)) + error(Error(FSComp.SR.infosInvalidProvidedLiteralValue(RichText.mkText txt), m)) /// Compute the OptionalArgInfo for a provided parameter. @@ -408,7 +408,7 @@ let ArbitraryMethodInfoOfPropertyInfo (pi: Tainted) m = elif pi.PUntaint((fun pi -> pi.CanWrite), m) then GetAndSanityCheckProviderMethod m pi (fun pi -> pi.GetSetMethod()) FSComp.SR.etPropertyCanWriteButHasNoSetter else - error(Error(FSComp.SR.etPropertyNeedsCanWriteOrCanRead(pi.PUntaint((fun mi -> mi.Name), m), pi.PUntaint((fun mi -> (nonNull mi.DeclaringType).Name), m)), m)) + error(Error(FSComp.SR.etPropertyNeedsCanWriteOrCanRead(RichText.mkMember (pi.PUntaint((fun mi -> mi.Name), m)), RichText.ofQualifiedTypeName (pi.PUntaint((fun mi -> (nonNull mi.DeclaringType).Name), m))), m)) #endif @@ -2350,7 +2350,7 @@ let private tyConformsToIDelegateEvent g ty = /// Create an error object to raise should an event not have the shape expected by the .NET idiom described further below let nonStandardEventError nm m = - Error (FSComp.SR.eventHasNonStandardType(nm, ("add_"+nm), ("remove_"+nm)), m) + Error(FSComp.SR.eventHasNonStandardType(RichText.mkEvent nm, RichText.mkMethod ("add_"+nm), RichText.mkMethod ("remove_"+nm)), m) /// Find the delegate type that an F# event property implements by looking through the type hierarchy of the type of the property /// for the first instantiation of IDelegateEvent. diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index c4fbea22a66..c9bc8c203d3 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -1398,7 +1398,7 @@ let StorageForVal m v eenv = eenv.valsInScope[v] with :? KeyNotFoundException -> assert false - errorR (Error(FSComp.SR.ilUndefinedValue (showL (valAtBindL v)), m)) + errorR (Error(FSComp.SR.ilUndefinedValue (RichText.mkText (showL (valAtBindL v))), m)) notlazy (Arg 668 (* random value for post-hoc diagnostic analysis on generated tree *) ) v.Force() @@ -3159,7 +3159,10 @@ and GenExprPreSteps (cenv: cenv) (cgbuf: CodeGenBuffer) eenv expr sequel = ] |> String.concat "," - informationalWarning (Error(FSComp.SR.ilxGenUnknownDebugPoint (debugPointName, others), dpExpr.Range)) + informationalWarning ( + Error(FSComp.SR.ilxGenUnknownDebugPoint (RichText.mkText debugPointName, RichText.mkText others), dpExpr.Range) + ) + CG.EmitDebugPoint cgbuf m | true, dp -> // printfn $"---- Found debug point {debugPointName} at {m} --> {dp}" @@ -3211,13 +3214,13 @@ and GenExprPreSteps (cenv: cenv) (cgbuf: CodeGenBuffer) eenv expr sequel = // is important if the nested state machine generates dynamic code (LoweredStateMachineResult.UseAlternative). let eenv = RemoveTemplateReplacement eenv checkLanguageFeatureError cenv.g.langVersion LanguageFeature.ResumableStateMachines expr.Range - warning (Error(FSComp.SR.reprStateMachineNotCompilable msg, expr.Range)) + warning (Error(FSComp.SR.reprStateMachineNotCompilable (RichText.mkText msg), expr.Range)) GenExpr cenv cgbuf eenv altExpr sequel true | LoweredStateMachineResult.NoAlternative msg -> let eenv = RemoveTemplateReplacement eenv checkLanguageFeatureError cenv.g.langVersion LanguageFeature.ResumableStateMachines expr.Range - errorR (Error(FSComp.SR.reprStateMachineNotCompilableNoAlternative msg, expr.Range)) + errorR (Error(FSComp.SR.reprStateMachineNotCompilableNoAlternative (RichText.mkText msg), expr.Range)) GenDefaultValue cenv cgbuf eenv (tyOfExpr cenv.g expr, expr.Range) true | LoweredStateMachineResult.NotAStateMachine -> @@ -4507,7 +4510,7 @@ and GenApp (cenv: cenv) cgbuf eenv (f, fty, tyargs, curriedArgs, m) sequel = || valRefEq g v g.cgh__resumableEntry_vref || valRefEq g v g.cgh__stateMachine_vref -> - errorR (Error(FSComp.SR.ilxgenInvalidConstructInStateMachineDuringCodegen v.DisplayName, m)) + errorR (Error(FSComp.SR.ilxgenInvalidConstructInStateMachineDuringCodegen (richTextOfValName g v.Deref), m)) CG.EmitInstr cgbuf (pop 0) (Push [ g.ilg.typ_Object ]) AI_ldnull GenSequel cenv eenv.cloc cgbuf sequel @@ -5891,7 +5894,7 @@ and GenGetValAddr cenv cgbuf eenv (v: ValRef, m) sequel = | Method _ | Env _ | Null -> - errorR (Error(FSComp.SR.ilAddressOfValueHereIsInvalid v.DisplayName, m)) + errorR (Error(FSComp.SR.ilAddressOfValueHereIsInvalid (richTextOfValName cenv.g v.Deref), m)) CG.EmitInstr cgbuf @@ -10365,9 +10368,9 @@ and GenSetStorage m cgbuf storage = CG.EmitInstr cgbuf (pop 1) Push0 (I_call(Normalcall, mkILMethSpecForMethRefInTy (ilSetterMethRef, ilContainerTy, []), None)) - | StaticProperty(ilGetterMethSpec, _) -> error (Error(FSComp.SR.ilStaticMethodIsNotLambda ilGetterMethSpec.Name, m)) + | StaticProperty(ilGetterMethSpec, _) -> error (Error(FSComp.SR.ilStaticMethodIsNotLambda (RichText.mkMethod ilGetterMethSpec.Name), m)) - | Method(_, _, mspec, _, m, _, _, _, _, _, _, _) -> error (Error(FSComp.SR.ilStaticMethodIsNotLambda mspec.Name, m)) + | Method(_, _, mspec, _, m, _, _, _, _, _, _, _) -> error (Error(FSComp.SR.ilStaticMethodIsNotLambda (RichText.mkMethod mspec.Name), m)) | Null -> CG.EmitInstr cgbuf (pop 1) Push0 AI_pop @@ -10761,7 +10764,7 @@ and GenAttribArg amap (g: TcGlobals) eenv x (ilArgTy: ILType) = else string ilElemTy - error (Error(FSComp.SR.ilCustomAttrInvalidArrayElemType elemTypeName, m)) + error (Error(FSComp.SR.ilCustomAttrInvalidArrayElemType (RichText.ofQualifiedTypeName elemTypeName), m)) else ILAttribElem.Array(ilElemTy, List.map (fun arg -> GenAttribArg amap g eenv arg ilElemTy) args) @@ -12394,7 +12397,10 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) : ILTypeRef option | None -> errorR ( Error( - FSComp.SR.ilFieldDoesNotHaveValidOffsetForStructureLayout (tdef.Name, fdef.Name.Replace("@", "")), + FSComp.SR.ilFieldDoesNotHaveValidOffsetForStructureLayout ( + RichText.ofQualifiedTypeName tdef.Name, + RichText.mkField (fdef.Name.Replace("@", "")) + ), (trimRangeToLine m) ) ) diff --git a/src/Compiler/DependencyManager/DependencyProvider.fs b/src/Compiler/DependencyManager/DependencyProvider.fs index 4321e8e826e..7df14ac3c78 100644 --- a/src/Compiler/DependencyManager/DependencyProvider.fs +++ b/src/Compiler/DependencyManager/DependencyProvider.fs @@ -519,7 +519,7 @@ type DependencyProvider with e -> let e = stripTieWrapper e let n, m = FSComp.SR.couldNotLoadDependencyManagerExtension (path, e.Message) - reportError.Invoke(ErrorReportType.Warning, n, m) + reportError.Invoke(ErrorReportType.Warning, n, m.Text) None) |> Seq.filter (fun a -> assemblyHasAttribute a dependencyManagerAttributeName) @@ -620,7 +620,7 @@ type DependencyProvider let err, msg = this.CreatePackageManagerUnknownError(compilerTools, outputDir, sdkDirOverride, path.Split(':').[0], reportError) - reportError.Invoke(ErrorReportType.Error, err, msg) + reportError.Invoke(ErrorReportType.Error, err, msg.Text) null, null | Some kv -> path, kv.Value @@ -629,7 +629,7 @@ type DependencyProvider with e -> let e = stripTieWrapper e let err, msg = FSComp.SR.packageManagerError e.Message - reportError.Invoke(ErrorReportType.Error, err, msg) + reportError.Invoke(ErrorReportType.Error, err, msg.Text) null, null /// Fetch a dependencymanager that supports a specific key @@ -644,7 +644,7 @@ type DependencyProvider with e -> let e = stripTieWrapper e let err, msg = FSComp.SR.packageManagerError e.Message - reportError.Invoke(ErrorReportType.Error, err, msg) + reportError.Invoke(ErrorReportType.Error, err, msg.Text) null /// Resolve reference for a list of package manager lines @@ -705,7 +705,7 @@ type DependencyProvider dllResolveHandler.RefreshPathsInEnvironment(res.Roots) res | Error(errorNumber, errorData) -> - reportError.Invoke(ErrorReportType.Error, errorNumber, errorData) + reportError.Invoke(ErrorReportType.Error, errorNumber, errorData.Text) ReflectionDependencyManagerProvider.MakeResultFromFields(false, arrEmpty, arrEmpty, seqEmpty, seqEmpty, seqEmpty) interface IDisposable with diff --git a/src/Compiler/DependencyManager/DependencyProvider.fsi b/src/Compiler/DependencyManager/DependencyProvider.fsi index 5ec344287df..0e26d645e02 100644 --- a/src/Compiler/DependencyManager/DependencyProvider.fsi +++ b/src/Compiler/DependencyManager/DependencyProvider.fsi @@ -5,7 +5,7 @@ namespace FSharp.Compiler.DependencyManager open System open System.Runtime.InteropServices -open Internal.Utilities.Library +open FSharp.Compiler.Text /// The results of ResolveDependencies type IResolveDependenciesResult = @@ -114,7 +114,7 @@ type DependencyProvider = /// Returns a formatted error message for the host to present member CreatePackageManagerUnknownError: - string seq * string * sdkDirOverride: string option * string * ResolvingErrorReport -> int * string + string seq * string * sdkDirOverride: string option * string * ResolvingErrorReport -> int * RichText /// Resolve reference for a list of package manager lines member Resolve: diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs index 7e04ef173f6..c1da8d3c1fd 100644 --- a/src/Compiler/Driver/CompilerConfig.fs +++ b/src/Compiler/Driver/CompilerConfig.fs @@ -1050,7 +1050,7 @@ type TcConfigBuilder = let reportError = ResolvingErrorReport(fun errorType err msg -> - let error = err, msg + let error = err, RichText.mkText msg match errorType with | ErrorReportType.Warning -> warning (Error(error, m)) diff --git a/src/Compiler/Driver/CompilerDiagnostics.fs b/src/Compiler/Driver/CompilerDiagnostics.fs index 86194f4ead8..61fa12e7f62 100644 --- a/src/Compiler/Driver/CompilerDiagnostics.fs +++ b/src/Compiler/Driver/CompilerDiagnostics.fs @@ -642,7 +642,17 @@ let (|InvalidArgument|_|) (exn: exn) = | :? ArgumentException as e -> ValueSome e.Message | _ -> ValueNone -let OutputNameSuggestions (os: StringBuilder) suggestNames suggestionsF idText = +/// Classifies a name that failed to resolve. It stands for nothing, so it is not an entity of unknown +/// kind but a name of its own kind. +let richTextOfUnresolvedName name = + RichText.mkUnresolvedName (ConvertValLogicalNameToDisplayNameCore name) + +/// Classifies a name that does resolve but whose kind is not known here, e.g. one offered as a +/// suggestion in place of a name that did not resolve +let richTextOfNameOfUnknownKind name = + RichText.mkUnknownEntity (ConvertValLogicalNameToDisplayNameCore name) + +let OutputNameSuggestions (os: RichTextBuilder) suggestNames suggestionsF idText = if suggestNames then let buffer = DiagnosticResolutionHints.SuggestionBuffer idText @@ -650,55 +660,55 @@ let OutputNameSuggestions (os: StringBuilder) suggestNames suggestionsF idText = suggestionsF buffer.Add if not buffer.IsEmpty then - os.AppendString " " - os.AppendString(FSComp.SR.undefinedNameSuggestionsIntro ()) + os.Append " " + os.Append(FSComp.SR.undefinedNameSuggestionsIntro ()) for value in buffer do - os.AppendLine() |> ignore - os.AppendString " " - os.AppendString(ConvertValLogicalNameToDisplayNameCore value) + os.Append(RichText.mkLineBreak Environment.NewLine) + os.Append " " + os.Append(richTextOfNameOfUnknownKind value) -let OutputTypesNotInEqualityRelationContextInfo contextInfo ty1 ty2 m (os: StringBuilder) fallback = +let OutputTypesNotInEqualityRelationContextInfo contextInfo (ty1: RichText) (ty2: RichText) m (os: RichTextBuilder) fallback = match contextInfo with - | ContextInfo.IfExpression range when equals range m -> os.AppendString(FSComp.SR.ifExpression (ty1, ty2)) + | ContextInfo.IfExpression range when equals range m -> os.Append(FSComp.SR.ifExpression (ty1, ty2)) | ContextInfo.CollectionElement(isArray, range) when equals range m -> if isArray then - os.AppendString(FSComp.SR.arrayElementHasWrongType (ty1, ty2)) + os.Append(FSComp.SR.arrayElementHasWrongType (ty1, ty2)) else - os.AppendString(FSComp.SR.listElementHasWrongType (ty1, ty2)) - | ContextInfo.OmittedElseBranch range when equals range m -> os.AppendString(FSComp.SR.missingElseBranch ty2) - | ContextInfo.ElseBranchResult range when equals range m -> os.AppendString(FSComp.SR.elseBranchHasWrongType (ty1, ty2)) + os.Append(FSComp.SR.listElementHasWrongType (ty1, ty2)) + | ContextInfo.OmittedElseBranch range when equals range m -> os.Append(FSComp.SR.missingElseBranch (ty2)) + | ContextInfo.ElseBranchResult range when equals range m -> os.Append(FSComp.SR.elseBranchHasWrongType (ty1, ty2)) | ContextInfo.FollowingPatternMatchClause range when equals range m -> - os.AppendString(FSComp.SR.followingPatternMatchClauseHasWrongType (ty1, ty2)) - | ContextInfo.PatternMatchGuard range when equals range m -> os.AppendString(FSComp.SR.patternMatchGuardIsNotBool ty2) + os.Append(FSComp.SR.followingPatternMatchClauseHasWrongType (ty1, ty2)) + | ContextInfo.PatternMatchGuard range when equals range m -> os.Append(FSComp.SR.patternMatchGuardIsNotBool (ty2)) | contextInfo -> fallback contextInfo type Exception with - member exn.Output(os: StringBuilder, suggestNames) = + member exn.Output(os: RichTextBuilder, suggestNames) = let typeEquationMessage g ty2 normalE tupleE = if isAnyTupleTy g ty2 then tupleE else normalE match exn with // TODO: this is now unused...? | ConstraintSolverTupleDiffLengths(_, _, tl1, tl2, m, m2) -> - os.AppendString(ConstraintSolverTupleDiffLengthsE().Format tl1.Length tl2.Length) + os.Append(ConstraintSolverTupleDiffLengthsE().Format tl1.Length tl2.Length) if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format(stringOfRange m)) + os.Append(SeeAlsoE().Format(stringOfRange m)) | ConstraintSolverInfiniteTypes(denv, contextInfo, ty1, ty2, m, m2) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(ConstraintSolverInfiniteTypesE().Format ty1 ty2) + let ty1, ty2, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 + os.Append(ConstraintSolverInfiniteTypesE(), ty1, ty2) match contextInfo with - | ContextInfo.ReturnInComputationExpression -> os.AppendString(" " + FSComp.SR.returnUsedInsteadOfReturnBang ()) - | ContextInfo.YieldInComputationExpression -> os.AppendString(" " + FSComp.SR.yieldUsedInsteadOfYieldBang ()) + | ContextInfo.ReturnInComputationExpression -> os.Append(" " + FSComp.SR.returnUsedInsteadOfReturnBang ()) + | ContextInfo.YieldInComputationExpression -> os.Append(" " + FSComp.SR.yieldUsedInsteadOfYieldBang ()) | _ -> () if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format(stringOfRange m)) + os.Append(SeeAlsoE().Format(stringOfRange m)) | ConstraintSolverNullnessWarningEquivWithTypes(denv, ty1, ty2, _nullness1, _nullness2, m, m2) -> @@ -708,12 +718,12 @@ type Exception with showNullnessAnnotations = Some true } - let t1, _t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + let t1, _t2, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 - os.Append(ConstraintSolverNullnessWarningEquivWithTypesE().Format t1) |> ignore + os.Append(ConstraintSolverNullnessWarningEquivWithTypesE(), t1) if m.StartLine <> m2.StartLine then - os.Append(SeeAlsoE().Format(stringOfRange m)) |> ignore + os.Append(SeeAlsoE().Format(stringOfRange m)) | ConstraintSolverNullnessWarningWithTypes(denv, ty1, ty2, _nullness1, _nullness2, m, m2) -> @@ -723,12 +733,12 @@ type Exception with showNullnessAnnotations = Some true } - let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + let t1, t2, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 - os.Append(ConstraintSolverNullnessWarningWithTypesE().Format t1 t2) |> ignore + os.Append(ConstraintSolverNullnessWarningWithTypesE(), t1, t2) if m.StartLine <> m2.StartLine || m.EndLine <> m2.EndLine then - os.Append(SeeAlsoE().Format(stringOfRange m)) |> ignore + os.Append(SeeAlsoE().Format(stringOfRange m)) | ConstraintSolverNullnessWarningWithType(denv, ty, _, m, m2) -> @@ -738,66 +748,67 @@ type Exception with showNullnessAnnotations = Some true } - let t = NicePrint.minimalStringOfType denv ty - os.Append(ConstraintSolverNullnessWarningWithTypeE().Format(t)) |> ignore + os.Append(ConstraintSolverNullnessWarningWithTypeE(), NicePrint.minimalRichTextOfType denv ty) if m.StartLine <> m2.StartLine || m.EndLine <> m2.EndLine then - os.Append(SeeAlsoE().Format(stringOfRange m)) |> ignore + os.Append(SeeAlsoE().Format(stringOfRange m)) | ConstraintSolverNullnessWarningOnDotAccess(denv, objTy, memberName, bindingName, m, m2) -> - let tyStr = NicePrint.minimalStringOfTypeWithNullness denv objTy + let tyText = NicePrint.minimalRichTextOfTypeWithNullness denv objTy match bindingName with | Some name -> - os.Append(ConstraintSolverNullnessWarningOnDotAccessWithBindingE().Format memberName name tyStr) - |> ignore - | None -> - os.Append(ConstraintSolverNullnessWarningOnDotAccessE().Format memberName tyStr) - |> ignore + os.Append( + ConstraintSolverNullnessWarningOnDotAccessWithBindingE(), + RichText.mkMember memberName, + RichText.mkLocal name, + tyText + ) + | None -> os.Append(ConstraintSolverNullnessWarningOnDotAccessE(), RichText.mkMember memberName, tyText) if m.StartLine <> m2.StartLine || m.EndLine <> m2.EndLine then - os.Append(SeeAlsoE().Format(stringOfRange m2)) |> ignore + os.Append(SeeAlsoE().Format(stringOfRange m2)) else - os.Append(".") |> ignore + os.Append(".") | ConstraintSolverNullnessWarning(msg, m, m2) -> - os.Append(ConstraintSolverNullnessWarningE().Format(msg)) |> ignore + os.Append(ConstraintSolverNullnessWarningE(), msg) if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format(stringOfRange m2)) + os.Append(SeeAlsoE().Format(stringOfRange m2)) | ConstraintSolverMissingConstraint(denv, tpr, tpc, m, m2) -> - os.AppendString(ConstraintSolverMissingConstraintE().Format(NicePrint.stringOfTyparConstraint denv (tpr, tpc))) + os.Append(ConstraintSolverMissingConstraintE(), NicePrint.richTextOfTyparConstraint denv (tpr, tpc)) if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format(stringOfRange m)) + os.Append(SeeAlsoE().Format(stringOfRange m)) | ConstraintSolverTypesNotInEqualityRelation(denv, ty1, ty2, m, m2, contextInfo) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1str, ty2str, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + let ty1Text, ty2Text, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 match ty1, ty2 with - | TType_measure _, TType_measure _ -> os.AppendString(ConstraintSolverTypesNotInEqualityRelation1E().Format ty1str ty2str) + | TType_measure _, TType_measure _ -> os.Append(ConstraintSolverTypesNotInEqualityRelation1E(), ty1Text, ty2Text) | _ -> - OutputTypesNotInEqualityRelationContextInfo contextInfo ty1str ty2str m os (fun _ -> - os.AppendString(ConstraintSolverTypesNotInEqualityRelation2E().Format ty1str ty2str)) + OutputTypesNotInEqualityRelationContextInfo contextInfo ty1Text ty2Text m os (fun _ -> + os.Append(ConstraintSolverTypesNotInEqualityRelation2E(), ty1Text, ty2Text)) if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format(stringOfRange m)) + os.Append(SeeAlsoE().Format(stringOfRange m)) | ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, m, m2) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(ConstraintSolverTypesNotInSubsumptionRelationE().Format ty2 ty1 cxs) + let ty1, ty2, cxs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 + os.Append(ConstraintSolverTypesNotInSubsumptionRelationE(), ty2, ty1, cxs) if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format(stringOfRange m2)) + os.Append(SeeAlsoE().Format(stringOfRange m2)) | ConstraintSolverError(msg, m, m2) -> - os.AppendString msg + os.Append msg if m.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format(stringOfRange m2)) + os.Append(SeeAlsoE().Format(stringOfRange m2)) | ErrorFromAddingTypeEquation(g, denv, ty1, ty2, ConstraintSolverTypesNotInEqualityRelation(_, ty1b, ty2b, m, _, contextInfo), _) when typeEquiv g ty1 ty1b && typeEquiv g ty2 ty2b @@ -805,17 +816,17 @@ type Exception with let typeEquation1E = typeEquationMessage g ty2 ErrorFromAddingTypeEquation1E ErrorFromAddingTypeEquation1TupleE - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + let ty1, ty2, tpcs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 OutputTypesNotInEqualityRelationContextInfo contextInfo ty1 ty2 m os (fun contextInfo -> match contextInfo with | ContextInfo.TupleInRecordFields -> - os.AppendString(typeEquation1E().Format ty2 ty1 tpcs) - os.AppendString(Environment.NewLine + FSComp.SR.commaInsteadOfSemicolonInRecord ()) - | _ when ty2 = "bool" && ty1.EndsWithOrdinal(" ref") -> - os.AppendString(typeEquation1E().Format ty2 ty1 tpcs) - os.AppendString(Environment.NewLine + FSComp.SR.derefInsteadOfNot ()) - | _ -> os.AppendString(typeEquation1E().Format ty2 ty1 tpcs)) + os.Append(typeEquation1E (), ty2, ty1, tpcs) + os.Append(Environment.NewLine + FSComp.SR.commaInsteadOfSemicolonInRecord ()) + | _ when ty2.Text = "bool" && ty1.Text.EndsWithOrdinal(" ref") -> + os.Append(typeEquation1E (), ty2, ty1, tpcs) + os.Append(Environment.NewLine + FSComp.SR.derefInsteadOfNot ()) + | _ -> os.Append(typeEquation1E (), ty2, ty1, tpcs)) | ErrorFromAddingTypeEquation(_, _, _, _, (ConstraintSolverTypesNotInEqualityRelation(_, _, _, _, _, contextInfo) as e), _) when (match contextInfo with @@ -831,27 +842,30 @@ type Exception with | ErrorFromAddingTypeEquation(error = ConstraintSolverError _ as e) -> e.Output(os, suggestNames) | ErrorFromAddingTypeEquation(_g, denv, ty1, ty2, ConstraintSolverTupleDiffLengths(_, contextInfo, tl1, tl2, m1, m2), m) -> - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - let messageArgs = tl1.Length, ty1, tl2.Length, ty2 + let ty1, ty2, tpcs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 + + let tupleLengthsMessage (message: int * RichText * int * RichText -> RichText) = message (tl1.Length, ty1, tl2.Length, ty2) - if ty1 <> ty2 + tpcs then + if ty1.Text <> ty2.Text + tpcs.Text then match contextInfo with - | ContextInfo.IfExpression range when equals range m -> os.AppendString(FSComp.SR.ifExpressionTuple messageArgs) + | ContextInfo.IfExpression range when equals range m -> os.Append(tupleLengthsMessage FSComp.SR.ifExpressionTuple) | ContextInfo.ElseBranchResult range when equals range m -> - os.AppendString(FSComp.SR.elseBranchHasWrongTypeTuple messageArgs) + os.Append(tupleLengthsMessage FSComp.SR.elseBranchHasWrongTypeTuple) | ContextInfo.FollowingPatternMatchClause range when equals range m -> - os.AppendString(FSComp.SR.followingPatternMatchClauseHasWrongTypeTuple messageArgs) + os.Append(tupleLengthsMessage FSComp.SR.followingPatternMatchClauseHasWrongTypeTuple) | ContextInfo.CollectionElement(isArray, range) when equals range m -> if isArray then - os.AppendString(FSComp.SR.arrayElementHasWrongTypeTuple messageArgs) + os.Append(tupleLengthsMessage FSComp.SR.arrayElementHasWrongTypeTuple) else - os.AppendString(FSComp.SR.listElementHasWrongTypeTuple messageArgs) - | _ -> os.AppendString(ErrorFromAddingTypeEquationTuplesE().Format tl1.Length ty1 tl2.Length ty2 tpcs) + os.Append(tupleLengthsMessage FSComp.SR.listElementHasWrongTypeTuple) + | _ -> + os.Append(fun rich -> + ErrorFromAddingTypeEquationTuplesE().Format tl1.Length (rich ty1) tl2.Length (rich ty2) (rich tpcs)) else - os.AppendString(ConstraintSolverTupleDiffLengthsE().Format tl1.Length tl2.Length) + os.Append(ConstraintSolverTupleDiffLengthsE().Format tl1.Length tl2.Length) if m1.StartLine <> m2.StartLine then - os.AppendString(SeeAlsoE().Format(stringOfRange m1)) + os.Append(SeeAlsoE().Format(stringOfRange m1)) | ErrorFromAddingTypeEquation(g, denv, ty1, ty2, e, _) -> let typeEquation2E = @@ -859,10 +873,10 @@ type Exception with let e = if not (typeEquiv g ty1 ty2) then - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + let ty1, ty2, tpcs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 - if ty1 <> ty2 + tpcs then - os.AppendString(typeEquation2E().Format ty1 ty2 tpcs) + if ty1.Text <> ty2.Text + tpcs.Text then + os.Append(typeEquation2E (), ty1, ty2, tpcs) e @@ -881,36 +895,35 @@ type Exception with e.Output(os, suggestNames) | ErrorFromApplyingDefault(_, denv, _, defaultType, e, _) -> - let defaultType = NicePrint.minimalStringOfType denv defaultType - os.AppendString(ErrorFromApplyingDefault1E().Format defaultType) + os.Append(ErrorFromApplyingDefault1E(), NicePrint.minimalRichTextOfType denv defaultType) e.Output(os, suggestNames) - os.AppendString(ErrorFromApplyingDefault2E().Format) + os.Append(ErrorFromApplyingDefault2E().Format) | ErrorsFromAddingSubsumptionConstraint(g, denv, ty1, ty2, e, contextInfo, _) -> match contextInfo with | ContextInfo.DowncastUsedInsteadOfUpcast isOperator -> - let ty1, ty2, _ = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + let ty1, ty2, _ = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 if isOperator then - os.AppendString(FSComp.SR.considerUpcastOperator (ty1, ty2) |> snd) + os.Append(snd (FSComp.SR.considerUpcastOperator (ty1, ty2))) else - os.AppendString(FSComp.SR.considerUpcast (ty1, ty2) |> snd) + os.Append(snd (FSComp.SR.considerUpcast (ty1, ty2))) | _ -> if not (typeEquiv g ty1 ty2) then - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + let ty1, ty2, tpcs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 - if ty1 <> (ty2 + tpcs) then - os.AppendString(ErrorsFromAddingSubsumptionConstraintE().Format ty2 ty1 tpcs) + if ty1.Text <> ty2.Text + tpcs.Text then + os.Append(ErrorsFromAddingSubsumptionConstraintE(), ty2, ty1, tpcs) else e.Output(os, suggestNames) else e.Output(os, suggestNames) - | UpperCaseIdentifierInPattern _ -> os.AppendString(UpperCaseIdentifierInPatternE().Format) + | UpperCaseIdentifierInPattern _ -> os.Append(UpperCaseIdentifierInPatternE().Format) - | NotUpperCaseConstructor _ -> os.AppendString(NotUpperCaseConstructorE().Format) + | NotUpperCaseConstructor _ -> os.Append(NotUpperCaseConstructorE().Format) - | NotUpperCaseConstructorWithoutRQA _ -> os.AppendString(NotUpperCaseConstructorWithoutRQAE().Format) + | NotUpperCaseConstructorWithoutRQA _ -> os.Append(NotUpperCaseConstructorWithoutRQAE().Format) | ErrorFromAddingConstraint(_, e, _) -> e.Output(os, suggestNames) @@ -919,7 +932,7 @@ type Exception with | TypeProviders.ProvidedTypeResolution(_, e) -> e.Output(os, suggestNames) - | :? TypeProviderError as e -> os.AppendString(e.ContextualErrorMessage) + | :? TypeProviderError as e -> os.Append(e.ContextualErrorRichMessage) #endif | UnresolvedOverloading(denv, callerArgs, failure, m) -> @@ -954,16 +967,16 @@ type Exception with NicePrint.prettyLayoutsOfUnresolvedOverloading denv argRepr retTy genericParameterTypes match callerArgs.ArgumentNamesAndTypes with - | [] -> None, LayoutRender.showL retTyL, LayoutRender.showL genParamTysL + | [] -> None, LayoutRender.toRichText retTyL, LayoutRender.toRichText genParamTysL | items -> - let args = LayoutRender.showL argsL + let args = LayoutRender.toRichText argsL - let prefixMessage = + let prefixMessage: RichText -> RichText = match items with | [ _ ] -> FSComp.SR.csNoOverloadsFoundArgumentsPrefixSingular | _ -> FSComp.SR.csNoOverloadsFoundArgumentsPrefixPlural - Some(prefixMessage args), LayoutRender.showL retTyL, LayoutRender.showL genParamTysL + Some(prefixMessage args), LayoutRender.toRichText retTyL, LayoutRender.toRichText genParamTysL let knownReturnType = match knownReturnType with @@ -982,49 +995,55 @@ type Exception with | :? ArgDoesNotMatchError as x -> let nameOrOneBasedIndexMessage = x.calledArg.NameOpt - |> Option.map (fun n -> FSComp.SR.csOverloadCandidateNamedArgumentTypeMismatch n.idText) + |> Option.map (fun n -> FSComp.SR.csOverloadCandidateNamedArgumentTypeMismatch (RichText.mkParameter n.idText)) |> Option.defaultValue ( - FSComp.SR.csOverloadCandidateIndexedArgumentTypeMismatch ((vsnd x.calledArg.Position) + 1) + RichText.mkText (FSComp.SR.csOverloadCandidateIndexedArgumentTypeMismatch ((vsnd x.calledArg.Position) + 1)) ) //snd - sprintf " // %s" nameOrOneBasedIndexMessage - | _ -> "" + RichText.append (RichText.mkText " // ") nameOrOneBasedIndexMessage + | _ -> RichText.empty - (NicePrint.stringOfMethInfoForOverloadError x.infoReader m displayEnv x.methodSlot.Method) - + paramInfo + RichText.append (NicePrint.richTextOfMethInfoForOverloadError x.infoReader m displayEnv x.methodSlot.Method) paramInfo let nl = Environment.NewLine let formatOverloads (overloads: OverloadInformation list) = overloads |> List.map (overloadMethodInfo denv m) - |> List.sort + |> List.sortBy (fun overload -> overload.Text) |> List.map FSComp.SR.formatDashItem - |> String.concat nl + |> RichText.concatWith (RichText.mkText nl) // assemble final message composing the parts let msg = let optionalParts = - [ knownReturnType; genericParametersMessage; argsMessage ] - |> List.choose id - |> String.concat (nl + nl) - |> fun result -> - if String.IsNullOrEmpty(result) then - nl - else - nl + nl + result + nl + nl + let result = + [ knownReturnType; genericParametersMessage; argsMessage ] + |> List.choose id + |> RichText.concatWith (RichText.mkText (nl + nl)) + + if result.IsEmpty then + RichText.mkText nl + else + RichText.concat [ RichText.mkText (nl + nl); result; RichText.mkText (nl + nl) ] match failure with | NoOverloadsFound(methodName, overloads, _) -> - FSComp.SR.csNoOverloadsFound methodName - + optionalParts - + (FSComp.SR.csAvailableOverloads (formatOverloads overloads)) - | PossibleCandidates(methodName, [], _, _) -> FSComp.SR.csMethodIsOverloaded methodName + RichText.concat + [ + FSComp.SR.csNoOverloadsFound (RichText.mkMethod methodName) + optionalParts + FSComp.SR.csAvailableOverloads (formatOverloads overloads) + ] + | PossibleCandidates(methodName, [], _, _) -> FSComp.SR.csMethodIsOverloaded (RichText.mkMethod methodName) | PossibleCandidates(methodName, overloads, _, incomparableInfo) -> let baseMessage = - FSComp.SR.csMethodIsOverloaded methodName - + optionalParts - + FSComp.SR.csCandidates (formatOverloads overloads) + RichText.concat + [ + FSComp.SR.csMethodIsOverloaded (RichText.mkMethod methodName) + optionalParts + FSComp.SR.csCandidates (formatOverloads overloads) + ] match incomparableInfo with | Some info -> @@ -1047,117 +1066,134 @@ type Exception with FSComp.SR.csConcretenessMoreConcreteAt (info.Method2Signature, formatPositions info.Method2BetterPositions) ) - baseMessage + nl + FSComp.SR.csIncomparableConcreteness (line1 + nl + line2) + RichText.concat + [ + baseMessage + RichText.mkText nl + RichText.mkText (FSComp.SR.csIncomparableConcreteness (line1 + nl + line2)) + ] | None -> baseMessage - os.AppendString msg + os.Append msg | UnresolvedConversionOperator(denv, fromTy, toTy, _) -> - let ty1, ty2, _tpcs = NicePrint.minimalStringsOfTwoTypes denv fromTy toTy - os.AppendString(FSComp.SR.csTypeDoesNotSupportConversion (ty1, ty2)) + let ty1, ty2, _tpcs = NicePrint.minimalRichTextsOfTwoTypes denv fromTy toTy + os.Append(FSComp.SR.csTypeDoesNotSupportConversion (ty1, ty2)) - | FunctionExpected _ -> os.AppendString(FunctionExpectedE().Format) + | FunctionExpected _ -> os.Append(FunctionExpectedE().Format) - | BakedInMemberConstraintName(nm, _) -> os.AppendString(BakedInMemberConstraintNameE().Format nm) + | BakedInMemberConstraintName(nm, _) -> os.Append(BakedInMemberConstraintNameE(), RichText.mkMember nm) - | StandardOperatorRedefinitionWarning(msg, _) -> os.AppendString msg + | StandardOperatorRedefinitionWarning(msg, _) -> os.Append msg - | BadEventTransformation _ -> os.AppendString(BadEventTransformationE().Format) + | BadEventTransformation _ -> os.Append(BadEventTransformationE().Format) - | ParameterlessStructCtor _ -> os.AppendString(ParameterlessStructCtorE().Format) + | ParameterlessStructCtor _ -> os.Append(ParameterlessStructCtorE().Format) - | InterfaceNotRevealed(denv, intfTy, _) -> - os.AppendString(InterfaceNotRevealedE().Format(NicePrint.minimalStringOfType denv intfTy)) + | InterfaceNotRevealed(denv, intfTy, _) -> os.Append(InterfaceNotRevealedE(), NicePrint.minimalRichTextOfType denv intfTy) | NotAFunctionButIndexer(_, _, name, _, _, old) -> if old then match name with - | Some name -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexerWithName name) - | _ -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexer ()) + | Some name -> os.Append(FSComp.SR.notAFunctionButMaybeIndexerWithName (RichText.mkLocal name)) + | _ -> os.Append(FSComp.SR.notAFunctionButMaybeIndexer ()) else match name with - | Some name -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexerWithName2 name) - | _ -> os.AppendString(FSComp.SR.notAFunctionButMaybeIndexer2 ()) + | Some name -> os.Append(FSComp.SR.notAFunctionButMaybeIndexerWithName2 (RichText.mkLocal name)) + | _ -> os.Append(FSComp.SR.notAFunctionButMaybeIndexer2 ()) | NotAFunction(denv, ty, _, marg) -> if marg.StartColumn = 0 then - os.AppendString(FSComp.SR.notAFunctionButMaybeDeclaration ()) + os.Append(FSComp.SR.notAFunctionButMaybeDeclaration ()) elif isTyparTy denv.g ty then - os.AppendString(FSComp.SR.notAFunction ()) + os.Append(FSComp.SR.notAFunction ()) else - os.AppendString(FSComp.SR.notAFunctionWithType (NicePrint.prettyStringOfTy denv ty)) + os.Append(FSComp.SR.notAFunctionWithType (NicePrint.prettyRichTextOfTy denv ty)) | TyconBadArgs(_, tcref, d, _) -> let exp = tcref.Typars.Length if exp = 0 then - os.AppendString(FSComp.SR.buildUnexpectedTypeArgs (fullDisplayTextOfTyconRef tcref, d)) + os.Append(FSComp.SR.buildUnexpectedTypeArgs (richTextOfQualifiedTyconRef tcref, d)) else - os.AppendString(TyconBadArgsE().Format (fullDisplayTextOfTyconRef tcref) exp d) + os.Append(fun rich -> TyconBadArgsE().Format (rich (richTextOfQualifiedTyconRef tcref)) exp d) - | IndeterminateType _ -> os.AppendString(IndeterminateTypeE().Format) + | IndeterminateType _ -> os.Append(IndeterminateTypeE().Format) | NameClash(nm, k1, nm1, _, k2, nm2, _) -> if nm = nm1 && nm1 = nm2 && k1 = k2 then - os.AppendString(NameClash1E().Format k1 nm1) + os.Append(NameClash1E(), RichText.mkText k1, richTextOfNameOfUnknownKind nm1) else - os.AppendString(NameClash2E().Format k1 nm1 nm k2 nm2) + os.Append(fun rich -> + NameClash2E().Format + k1 + (rich (richTextOfNameOfUnknownKind nm1)) + (rich (richTextOfNameOfUnknownKind nm)) + k2 + (rich (richTextOfNameOfUnknownKind nm2))) | Duplicate(k, s, _) -> if k = "member" then - os.AppendString(Duplicate1E().Format(ConvertValLogicalNameToDisplayNameCore s)) + os.Append(Duplicate1E(), RichText.mkMember (ConvertValLogicalNameToDisplayNameCore s)) else - os.AppendString(Duplicate2E().Format k (ConvertValLogicalNameToDisplayNameCore s)) + os.Append(Duplicate2E(), RichText.mkText k, richTextOfNameOfUnknownKind s) | UndefinedName(_, k, id, suggestionsF) -> - os.AppendString(k (ConvertValLogicalNameToDisplayNameCore id.idText)) + os.Append(k (richTextOfUnresolvedName id.idText)) OutputNameSuggestions os suggestNames suggestionsF id.idText | InternalUndefinedItemRef(f, smr, ccuName, s) -> let _, errs = f (smr, ccuName, s) - os.AppendString errs + os.Append errs - | FieldNotMutable _ -> os.AppendString(FieldNotMutableE().Format) + | FieldNotMutable _ -> os.Append(FieldNotMutableE().Format) | FieldsFromDifferentTypes(_, fref1, fref2, _) -> - os.AppendString(FieldsFromDifferentTypesE().Format fref1.FieldName fref2.FieldName) + os.Append(FieldsFromDifferentTypesE(), RichText.mkRecordField fref1.FieldName, RichText.mkRecordField fref2.FieldName) - | VarBoundTwice id -> os.AppendString(VarBoundTwiceE().Format(ConvertValLogicalNameToDisplayNameCore id.idText)) + | VarBoundTwice id -> os.Append(VarBoundTwiceE(), RichText.mkLocal (ConvertValLogicalNameToDisplayNameCore id.idText)) | Recursion(denv, id, ty1, ty2, _) -> - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(RecursionE().Format (ConvertValLogicalNameToDisplayNameCore id.idText) ty1 ty2 tpcs) + let ty1, ty2, tpcs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 + + let name = RichText.mkFunction (ConvertValLogicalNameToDisplayNameCore id.idText) + + os.Append(RecursionE(), name, ty1, ty2, tpcs) | InvalidRuntimeCoercion(denv, ty1, ty2, _) -> - let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(InvalidRuntimeCoercionE().Format ty1 ty2 tpcs) + let ty1, ty2, tpcs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 + os.Append(InvalidRuntimeCoercionE(), ty1, ty2, tpcs) | IndeterminateRuntimeCoercion(denv, ty1, ty2, _) -> - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(IndeterminateRuntimeCoercionE().Format ty1 ty2) + let ty1, ty2, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 + os.Append(IndeterminateRuntimeCoercionE(), ty1, ty2) | IndeterminateStaticCoercion(denv, ty1, ty2, _) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(IndeterminateStaticCoercionE().Format ty1 ty2) + let ty1, ty2, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 + os.Append(IndeterminateStaticCoercionE(), ty1, ty2) | StaticCoercionShouldUseBox(denv, ty1, ty2, _) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(StaticCoercionShouldUseBoxE().Format ty1 ty2) + let ty1, ty2, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 + os.Append(StaticCoercionShouldUseBoxE(), ty1, ty2) - | TypeIsImplicitlyAbstract _ -> os.AppendString(TypeIsImplicitlyAbstractE().Format) + | TypeIsImplicitlyAbstract _ -> os.Append(TypeIsImplicitlyAbstractE().Format) | NonRigidTypar(denv, tpnmOpt, typarRange, ty1, ty2, _) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) let (ty1, ty2), _cxs = PrettyTypes.PrettifyTypePair denv.g (ty1, ty2) + let ty2 = NicePrint.richTextOfTy denv ty2 + match tpnmOpt with - | None -> os.AppendString(NonRigidTypar1E().Format (stringOfRange typarRange) (NicePrint.stringOfTy denv ty2)) + | None -> os.Append(NonRigidTypar1E(), RichText.mkText (stringOfRange typarRange), ty2) | Some tpnm -> + let tpnm = RichText.mkTypeParameter tpnm + match ty1 with - | TType_measure _ -> os.AppendString(NonRigidTypar2E().Format tpnm (NicePrint.stringOfTy denv ty2)) - | _ -> os.AppendString(NonRigidTypar3E().Format tpnm (NicePrint.stringOfTy denv ty2)) + | TType_measure _ -> os.Append(NonRigidTypar2E(), tpnm, ty2) + | _ -> os.Append(NonRigidTypar3E(), tpnm, ty2) | SyntaxError(ctxt, _) -> let ctxt = unbox> ctxt @@ -1397,14 +1433,14 @@ type Exception with #endif match ctxt.CurrentToken with - | None -> os.AppendString(UnexpectedEndOfInputE().Format) + | None -> os.Append(UnexpectedEndOfInputE().Format) | Some token -> let tokenId = token |> Parser.tagOfToken |> Parser.tokenTagToTokenId match tokenId, token with - | EndOfStructuredConstructToken, _ -> os.AppendString(OBlockEndSentenceE().Format) - | Parser.TOKEN_LEX_FAILURE, Parser.LEX_FAILURE str -> os.AppendString str - | token, _ -> os.AppendString(UnexpectedE().Format(token |> tokenIdToText)) + | EndOfStructuredConstructToken, _ -> os.Append(OBlockEndSentenceE().Format) + | Parser.TOKEN_LEX_FAILURE, Parser.LEX_FAILURE str -> os.Append str + | token, _ -> os.Append(UnexpectedE().Format(token |> tokenIdToText)) // Search for a state producing a single recognized non-terminal in the states on the stack let foundInContext = @@ -1502,126 +1538,137 @@ type Exception with match prodIds with | [ Parser.NONTERM_interaction ] -> - os.AppendString(NONTERM_interactionE().Format) + os.Append(NONTERM_interactionE().Format) true | [ Parser.NONTERM_hashDirective ] -> - os.AppendString(NONTERM_hashDirectiveE().Format) + os.Append(NONTERM_hashDirectiveE().Format) true | [ Parser.NONTERM_fieldDecl ] -> - os.AppendString(NONTERM_fieldDeclE().Format) + os.Append(NONTERM_fieldDeclE().Format) true | [ Parser.NONTERM_unionCaseRepr ] -> - os.AppendString(NONTERM_unionCaseReprE().Format) + os.Append(NONTERM_unionCaseReprE().Format) true | [ Parser.NONTERM_localBinding ] -> - os.AppendString(NONTERM_localBindingE().Format) + os.Append(NONTERM_localBindingE().Format) true | [ Parser.NONTERM_hardwhiteLetBindings ] -> - os.AppendString(NONTERM_hardwhiteLetBindingsE().Format) + os.Append(NONTERM_hardwhiteLetBindingsE().Format) true | [ Parser.NONTERM_classDefnMember ] -> - os.AppendString(NONTERM_classDefnMemberE().Format) + os.Append(NONTERM_classDefnMemberE().Format) true | [ Parser.NONTERM_defnBindings ] -> - os.AppendString(NONTERM_defnBindingsE().Format) + os.Append(NONTERM_defnBindingsE().Format) true | [ Parser.NONTERM_classMemberSpfn ] -> - os.AppendString(NONTERM_classMemberSpfnE().Format) + os.Append(NONTERM_classMemberSpfnE().Format) true | [ Parser.NONTERM_classMemberSpfnGetSetElements ] -> - os.AppendString(NONTERM_classMemberSpfnGetSetElementsE().Format) + os.Append(NONTERM_classMemberSpfnGetSetElementsE().Format) true | [ Parser.NONTERM_autoPropsDefnDecl ] -> - os.AppendString(NONTERM_autoPropsDefnDeclE().Format) + os.Append(NONTERM_autoPropsDefnDeclE().Format) true | [ Parser.NONTERM_valSpfn ] -> - os.AppendString(NONTERM_valSpfnE().Format) + os.Append(NONTERM_valSpfnE().Format) true | [ Parser.NONTERM_tyconSpfn ] -> - os.AppendString(NONTERM_tyconSpfnE().Format) + os.Append(NONTERM_tyconSpfnE().Format) true | [ Parser.NONTERM_anonLambdaExpr ] -> - os.AppendString(NONTERM_anonLambdaExprE().Format) + os.Append(NONTERM_anonLambdaExprE().Format) true | [ Parser.NONTERM_attrUnionCaseDecl ] -> - os.AppendString(NONTERM_attrUnionCaseDeclE().Format) + os.Append(NONTERM_attrUnionCaseDeclE().Format) true | [ Parser.NONTERM_cPrototype ] -> - os.AppendString(NONTERM_cPrototypeE().Format) + os.Append(NONTERM_cPrototypeE().Format) true | [ Parser.NONTERM_objExpr | Parser.NONTERM_objectImplementationMembers ] -> - os.AppendString(NONTERM_objectImplementationMembersE().Format) + os.Append(NONTERM_objectImplementationMembersE().Format) true | [ Parser.NONTERM_ifExprThen | Parser.NONTERM_ifExprElifs | Parser.NONTERM_ifExprCases ] -> - os.AppendString(NONTERM_ifExprCasesE().Format) + os.Append(NONTERM_ifExprCasesE().Format) true | [ Parser.NONTERM_openDecl ] -> - os.AppendString(NONTERM_openDeclE().Format) + os.Append(NONTERM_openDeclE().Format) true | [ Parser.NONTERM_fileModuleSpec ] -> - os.AppendString(NONTERM_fileModuleSpecE().Format) + os.Append(NONTERM_fileModuleSpecE().Format) true | [ Parser.NONTERM_patternClauses ] -> - os.AppendString(NONTERM_patternClausesE().Format) + os.Append(NONTERM_patternClausesE().Format) true | [ Parser.NONTERM_beginEndExpr ] -> - os.AppendString(NONTERM_beginEndExprE().Format) + os.Append(NONTERM_beginEndExprE().Format) true | [ Parser.NONTERM_recdExpr ] -> - os.AppendString(NONTERM_recdExprE().Format) + os.Append(NONTERM_recdExprE().Format) true | [ Parser.NONTERM_tyconDefn ] -> - os.AppendString(NONTERM_tyconDefnE().Format) + os.Append(NONTERM_tyconDefnE().Format) true | [ Parser.NONTERM_exconCore ] -> - os.AppendString(NONTERM_exconCoreE().Format) + os.Append(NONTERM_exconCoreE().Format) true | [ Parser.NONTERM_typeNameInfo ] -> - os.AppendString(NONTERM_typeNameInfoE().Format) + os.Append(NONTERM_typeNameInfoE().Format) true | [ Parser.NONTERM_attributeList ] -> - os.AppendString(NONTERM_attributeListE().Format) + os.Append(NONTERM_attributeListE().Format) true | [ Parser.NONTERM_quoteExpr ] -> - os.AppendString(NONTERM_quoteExprE().Format) + os.Append(NONTERM_quoteExprE().Format) true | [ Parser.NONTERM_typeConstraint ] -> - os.AppendString(NONTERM_typeConstraintE().Format) + os.Append(NONTERM_typeConstraintE().Format) true | [ NONTERM_Category_ImplementationFile ] -> - os.AppendString(NONTERM_Category_ImplementationFileE().Format) + os.Append(NONTERM_Category_ImplementationFileE().Format) true | [ NONTERM_Category_Definition ] -> - os.AppendString(NONTERM_Category_DefinitionE().Format) + os.Append(NONTERM_Category_DefinitionE().Format) true | [ NONTERM_Category_SignatureFile ] -> - os.AppendString(NONTERM_Category_SignatureFileE().Format) + os.Append(NONTERM_Category_SignatureFileE().Format) true | [ NONTERM_Category_Pattern ] -> - os.AppendString(NONTERM_Category_PatternE().Format) + os.Append(NONTERM_Category_PatternE().Format) true | [ NONTERM_Category_Expr ] -> - os.AppendString(NONTERM_Category_ExprE().Format) + os.Append(NONTERM_Category_ExprE().Format) true | [ NONTERM_Category_Type ] -> - os.AppendString(NONTERM_Category_TypeE().Format) + os.Append(NONTERM_Category_TypeE().Format) true | [ Parser.NONTERM_typeArgsActual ] -> - os.AppendString(NONTERM_typeArgsActualE().Format) + os.Append(NONTERM_typeArgsActualE().Format) true | _ -> false) #if DEBUG if not foundInContext then - Printf.bprintf - os - ". (no 'in' context found: %+A)" - (List.mapSquared Parser.prodIdxToNonTerminal ctxt.ReducibleProductions) + os.Append( + sprintf ". (no 'in' context found: %+A)" (List.mapSquared Parser.prodIdxToNonTerminal ctxt.ReducibleProductions) + ) #else foundInContext |> ignore // suppress unused variable warning in RELEASE #endif + // tokenIdToText describes a token as a keyword, as a symbol, or by a category such as + // 'identifier'. The message drops that wording, so it is what tells us how to classify + // what is left of it. let fix (s: string) = - s.Replace(SR.GetString("FixKeyword"), "").Replace(SR.GetString("FixSymbol"), "").Replace(SR.GetString("FixReplace"), "") + let keyword = SR.GetString("FixKeyword") + let symbol = SR.GetString("FixSymbol") + + let tag = + if s.Contains keyword then TextTag.Keyword + elif s.Contains symbol then TextTag.Punctuation + else TextTag.Text + + s.Replace(keyword, "").Replace(symbol, "").Replace(SR.GetString("FixReplace"), "") + |> RichText.ofTag tag let tokenNames = ctxt.ShiftTokens @@ -1636,10 +1683,10 @@ type Exception with |> Set.toList match tokenNames with - | [ tokenName1 ] -> os.AppendString(TokenName1E().Format(fix tokenName1)) - | [ tokenName1; tokenName2 ] -> os.AppendString(TokenName1TokenName2E().Format (fix tokenName1) (fix tokenName2)) + | [ tokenName1 ] -> os.Append(TokenName1E(), fix tokenName1) + | [ tokenName1; tokenName2 ] -> os.Append(TokenName1TokenName2E(), fix tokenName1, fix tokenName2) | [ tokenName1; tokenName2; tokenName3 ] -> - os.AppendString(TokenName1TokenName2TokenName3E().Format (fix tokenName1) (fix tokenName2) (fix tokenName3)) + os.Append(TokenName1TokenName2TokenName3E(), fix tokenName1, fix tokenName2, fix tokenName3) | _ -> () (* Printf.bprintf os ".\n\n state = %A\n token = %A\n expect (shift) %A\n expect (reduce) %A\n prods=%A\n non terminals: %A" @@ -1656,26 +1703,26 @@ type Exception with let ty, _cxs = PrettyTypes.PrettifyType denv.g ty if isTyparTy denv.g ty then - os.AppendString(RuntimeCoercionSourceSealed1E().Format(NicePrint.stringOfTy denv ty)) + os.Append(RuntimeCoercionSourceSealed1E(), NicePrint.richTextOfTy denv ty) else - os.AppendString(RuntimeCoercionSourceSealed2E().Format(NicePrint.stringOfTy denv ty)) + os.Append(RuntimeCoercionSourceSealed2E(), NicePrint.richTextOfTy denv ty) | CoercionTargetSealed(denv, ty, _) -> // REVIEW: consider if we need to show _cxs (the type parameter constraints) let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - os.AppendString(CoercionTargetSealedE().Format(NicePrint.stringOfTy denv ty)) + os.Append(CoercionTargetSealedE(), NicePrint.richTextOfTy denv ty) - | UpcastUnnecessary _ -> os.AppendString(UpcastUnnecessaryE().Format) + | UpcastUnnecessary _ -> os.Append(UpcastUnnecessaryE().Format) - | TypeTestUnnecessary _ -> os.AppendString(TypeTestUnnecessaryE().Format) + | TypeTestUnnecessary _ -> os.Append(TypeTestUnnecessaryE().Format) - | QuotationTranslator.IgnoringPartOfQuotedTermWarning(msg, _) -> Printf.bprintf os "%s" msg + | QuotationTranslator.IgnoringPartOfQuotedTermWarning(msg, _) -> os.Append msg | OverrideDoesntOverride(denv, impl, minfoVirtOpt, g, amap, m) -> let sig1 = DispatchSlotChecking.FormatOverride denv impl match minfoVirtOpt with - | None -> os.AppendString(OverrideDoesntOverride1E().Format sig1) + | None -> os.Append(OverrideDoesntOverride1E(), sig1) | Some minfoVirt -> // https://github.com/dotnet/fsharp/issues/35 // Improve error message when attempting to override generic return type with unit: @@ -1692,150 +1739,143 @@ type Exception with match minfoVirt.ApparentEnclosingType with | TType_app(tycon, tyargs, _) when tycon.IsFSharpInterfaceTycon && hasUnitTType_app tyargs -> // match abstract member with 'unit' passed as generic argument - os.AppendString(OverrideDoesntOverride4E().Format sig1) + os.Append(OverrideDoesntOverride4E(), sig1) | _ -> - os.AppendString(OverrideDoesntOverride2E().Format sig1) + os.Append(OverrideDoesntOverride2E(), sig1) let sig2 = DispatchSlotChecking.FormatMethInfoSig g amap m denv minfoVirt if sig1 <> sig2 then - os.AppendString(OverrideDoesntOverride3E().Format sig2) + os.Append(OverrideDoesntOverride3E(), sig2) // If implementation and required slot doesn't have same "instance-ness", then tell user that. if impl.IsInstance <> minfoVirt.IsInstance then // Required slot is instance, meaning implementation is static, tell user that we expect instance. if minfoVirt.IsInstance then - os.AppendString(OverrideShouldBeStatic().Format) + os.Append(OverrideShouldBeStatic().Format) else - os.AppendString(OverrideShouldBeInstance().Format) + os.Append(OverrideShouldBeInstance().Format) - | UnionCaseWrongArguments(_, n1, n2, _) -> os.AppendString(UnionCaseWrongArgumentsE().Format n2 n1) + | UnionCaseWrongArguments(_, n1, n2, _) -> os.Append(UnionCaseWrongArgumentsE().Format n2 n1) - | UnionPatternsBindDifferentNames _ -> os.AppendString(UnionPatternsBindDifferentNamesE().Format) + | UnionPatternsBindDifferentNames _ -> os.Append(UnionPatternsBindDifferentNamesE().Format) | ValueNotContained(_, denv, infoReader, mref, implVal, sigVal, f) -> let text1, text2 = - NicePrint.minimalStringsOfTwoValues denv infoReader (mkLocalValRef implVal) (mkLocalValRef sigVal) + NicePrint.minimalRichTextsOfTwoValues denv infoReader (mkLocalValRef implVal) (mkLocalValRef sigVal) - os.AppendString(f ((fullDisplayTextOfModRef mref), text1, text2)) + os.Append(f (richTextOfQualifiedModRef mref, text1, text2)) | UnionCaseNotContained(denv, infoReader, enclosingTycon, v1, v2, f) -> let enclosingTcref = mkLocalEntityRef enclosingTycon - os.AppendString( + os.Append( f ( - (NicePrint.stringOfUnionCase denv infoReader enclosingTcref v1), - (NicePrint.stringOfUnionCase denv infoReader enclosingTcref v2) + (NicePrint.richTextOfUnionCase denv infoReader enclosingTcref v1), + (NicePrint.richTextOfUnionCase denv infoReader enclosingTcref v2) ) ) | FSharpExceptionNotContained(denv, infoReader, v1, v2, f) -> - os.AppendString( + os.Append( f ( - (NicePrint.stringOfExnDef denv infoReader (mkLocalEntityRef v1)), - (NicePrint.stringOfExnDef denv infoReader (mkLocalEntityRef v2)) + (NicePrint.richTextOfExnDef denv infoReader (mkLocalEntityRef v1)), + (NicePrint.richTextOfExnDef denv infoReader (mkLocalEntityRef v2)) ) ) | FieldNotContained(_, denv, infoReader, enclosingTycon, _, v1, v2, f) -> let enclosingTcref = mkLocalEntityRef enclosingTycon - os.AppendString( + os.Append( f ( - (NicePrint.stringOfRecdField denv infoReader enclosingTcref v1), - (NicePrint.stringOfRecdField denv infoReader enclosingTcref v2) + (NicePrint.richTextOfRecdField denv infoReader enclosingTcref v1), + (NicePrint.richTextOfRecdField denv infoReader enclosingTcref v2) ) ) | RequiredButNotSpecified(_, mref, k, name, _) -> - let nsb = StringBuilder() + let nsb = RichTextBuilder() name nsb - os.AppendString(RequiredButNotSpecifiedE().Format (fullDisplayTextOfModRef mref) k (nsb.ToString())) - | UseOfAddressOfOperator _ -> os.AppendString(UseOfAddressOfOperatorE().Format) + os.Append(RequiredButNotSpecifiedE(), richTextOfQualifiedModRef mref, RichText.mkText k, nsb.ToRichText()) + + | UseOfAddressOfOperator _ -> os.Append(UseOfAddressOfOperatorE().Format) - | DefensiveCopyWarning(s, _) -> os.AppendString(DefensiveCopyWarningE().Format s) + | DefensiveCopyWarning(s, _) -> os.Append(DefensiveCopyWarningE().Format s) - | DeprecatedThreadStaticBindingWarning _ -> os.AppendString(DeprecatedThreadStaticBindingWarningE().Format) + | DeprecatedThreadStaticBindingWarning _ -> os.Append(DeprecatedThreadStaticBindingWarningE().Format) | FunctionValueUnexpected(denv, ty, _) -> let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - let errorText = FunctionValueUnexpectedE().Format(NicePrint.stringOfTy denv ty) - os.AppendString errorText + os.Append(FunctionValueUnexpectedE(), NicePrint.richTextOfTy denv ty) | UnitTypeExpected(denv, ty, _) -> let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - let warningText = UnitTypeExpectedE().Format(NicePrint.stringOfTy denv ty) - os.AppendString warningText + os.Append(UnitTypeExpectedE(), NicePrint.richTextOfTy denv ty) | UnitTypeExpectedWithEquality(denv, ty, _) -> let ty, _cxs = PrettyTypes.PrettifyType denv.g ty - - let warningText = - UnitTypeExpectedWithEqualityE().Format(NicePrint.stringOfTy denv ty) - - os.AppendString warningText + os.Append(UnitTypeExpectedWithEqualityE(), NicePrint.richTextOfTy denv ty) | UnitTypeExpectedWithPossiblePropertySetter(denv, ty, bindingName, propertyName, _) -> let ty, _cxs = PrettyTypes.PrettifyType denv.g ty + let ty = NicePrint.richTextOfTy denv ty - let warningText = - UnitTypeExpectedWithPossiblePropertySetterE().Format (NicePrint.stringOfTy denv ty) bindingName propertyName - - os.AppendString warningText + os.Append(UnitTypeExpectedWithPossiblePropertySetterE(), ty, RichText.mkLocal bindingName, RichText.mkProperty propertyName) | UnitTypeExpectedWithPossibleAssignment(denv, ty, isAlreadyMutable, bindingName, _) -> let ty, _cxs = PrettyTypes.PrettifyType denv.g ty + let ty = NicePrint.richTextOfTy denv ty - let warningText = - if isAlreadyMutable then - UnitTypeExpectedWithPossibleAssignmentToMutableE().Format (NicePrint.stringOfTy denv ty) bindingName - else - UnitTypeExpectedWithPossibleAssignmentE().Format (NicePrint.stringOfTy denv ty) bindingName + let bindingName = RichText.mkLocal bindingName - os.AppendString warningText + if isAlreadyMutable then + os.Append(UnitTypeExpectedWithPossibleAssignmentToMutableE(), ty, bindingName) + else + os.Append(UnitTypeExpectedWithPossibleAssignmentE(), ty, bindingName) - | RecursiveUseCheckedAtRuntime _ -> os.AppendString(RecursiveUseCheckedAtRuntimeE().Format) + | RecursiveUseCheckedAtRuntime _ -> os.Append(RecursiveUseCheckedAtRuntimeE().Format) - | LetRecUnsound(_, [ v ], _) -> os.AppendString(LetRecUnsound1E().Format v.DisplayName) + | LetRecUnsound(denv, [ v ], _) -> os.Append(LetRecUnsound1E(), richTextOfValName denv.g v.Deref) - | LetRecUnsound(_, path, _) -> - let bos = StringBuilder() + | LetRecUnsound(denv, path, _) -> + let bos = RichTextBuilder() (path.Tail @ [ path.Head ]) - |> List.iter (fun (v: ValRef) -> bos.AppendString(LetRecUnsoundInnerE().Format v.DisplayName)) + |> List.iter (fun (v: ValRef) -> bos.Append(LetRecUnsoundInnerE(), richTextOfValName denv.g v.Deref)) - os.AppendString(LetRecUnsound2E().Format (List.head path).DisplayName (bos.ToString())) + os.Append(LetRecUnsound2E(), richTextOfValName denv.g (List.head path).Deref, bos.ToRichText()) - | LetRecEvaluatedOutOfOrder _ -> os.AppendString(LetRecEvaluatedOutOfOrderE().Format) + | LetRecEvaluatedOutOfOrder _ -> os.Append(LetRecEvaluatedOutOfOrderE().Format) - | LetRecCheckedAtRuntime _ -> os.AppendString(LetRecCheckedAtRuntimeE().Format) + | LetRecCheckedAtRuntime _ -> os.Append(LetRecCheckedAtRuntimeE().Format) - | SelfRefObjCtor(false, _) -> os.AppendString(SelfRefObjCtor1E().Format) + | SelfRefObjCtor(false, _) -> os.Append(SelfRefObjCtor1E().Format) - | SelfRefObjCtor(true, _) -> os.AppendString(SelfRefObjCtor2E().Format) + | SelfRefObjCtor(true, _) -> os.Append(SelfRefObjCtor2E().Format) - | VirtualAugmentationOnNullValuedType _ -> os.AppendString(VirtualAugmentationOnNullValuedTypeE().Format) + | VirtualAugmentationOnNullValuedType _ -> os.Append(VirtualAugmentationOnNullValuedTypeE().Format) - | NonVirtualAugmentationOnNullValuedType _ -> os.AppendString(NonVirtualAugmentationOnNullValuedTypeE().Format) + | NonVirtualAugmentationOnNullValuedType _ -> os.Append(NonVirtualAugmentationOnNullValuedTypeE().Format) | NonUniqueInferredAbstractSlot(_, denv, bindnm, bvirt1, bvirt2, _) -> - os.AppendString(NonUniqueInferredAbstractSlot1E().Format bindnm) + os.Append(NonUniqueInferredAbstractSlot1E(), RichText.mkMember bindnm) let ty1 = bvirt1.ApparentEnclosingType let ty2 = bvirt2.ApparentEnclosingType // REVIEW: consider if we need to show _cxs (the type parameter constraints) - let ty1, ty2, _cxs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - os.AppendString(NonUniqueInferredAbstractSlot2E().Format) + let ty1, ty2, _cxs = NicePrint.minimalRichTextsOfTwoTypes denv ty1 ty2 + os.Append(NonUniqueInferredAbstractSlot2E().Format) if ty1 <> ty2 then - os.AppendString(NonUniqueInferredAbstractSlot3E().Format ty1 ty2) + os.Append(NonUniqueInferredAbstractSlot3E(), ty1, ty2) - os.AppendString(NonUniqueInferredAbstractSlot4E().Format) + os.Append(NonUniqueInferredAbstractSlot4E().Format) | DiagnosticWithText(_, s, _) - | DiagnosticEnabledWithLanguageFeature(_, s, _, _) -> os.AppendString s + | DiagnosticEnabledWithLanguageFeature(_, s, _, _) -> os.Append s | DiagnosticWithSuggestions(_, s, _, idText, suggestionF) -> - os.AppendString(ConvertValLogicalNameToDisplayNameCore s) + os.Append s OutputNameSuggestions os suggestNames suggestionF idText | InternalError(s, _) @@ -1847,52 +1887,52 @@ type Exception with let f2 = SR.GetString("Failure2") match s with - | f when f = f1 -> os.AppendString(Failure3E().Format s) - | f when f = f2 -> os.AppendString(Failure3E().Format s) - | _ -> os.AppendString(Failure4E().Format s) + | f when f = f1 -> os.Append(Failure3E().Format s) + | f when f = f2 -> os.Append(Failure3E().Format s) + | _ -> os.Append(Failure4E().Format s) #if DEBUG - Printf.bprintf os "\nStack Trace\n%s\n" (exn.ToString()) + os.Append(sprintf "\nStack Trace\n%s\n" (exn.ToString())) Debug.Assert(false, sprintf "Unexpected exception seen in compiler: %s\n%s" s (exn.ToString())) #endif | WrappedError(e, _) -> e.Output(os, suggestNames) | PatternMatchCompilation.MatchIncomplete(isComp, cexOpt, _) -> - os.AppendString(MatchIncomplete1E().Format) + os.Append(MatchIncomplete1E().Format) match cexOpt with | None -> () - | Some(cex, false) -> os.AppendString(MatchIncomplete2E().Format cex) - | Some(cex, true) -> os.AppendString(MatchIncomplete3E().Format cex) + | Some(cex, false) -> os.Append(MatchIncomplete2E(), cex) + | Some(cex, true) -> os.Append(MatchIncomplete3E(), cex) if isComp then - os.AppendString(MatchIncomplete4E().Format) + os.Append(MatchIncomplete4E().Format) | PatternMatchCompilation.MatchIncompleteForLoopHint(PatternMatchCompilation.MatchIncomplete(isComp, cexOpt, _)) -> - os.AppendString(MatchIncomplete1E().Format) + os.Append(MatchIncomplete1E().Format) match cexOpt with | None -> () - | Some(cex, false) -> os.AppendString(MatchIncomplete2E().Format cex) - | Some(cex, true) -> os.AppendString(MatchIncomplete3E().Format cex) + | Some(cex, false) -> os.Append(MatchIncomplete2E(), cex) + | Some(cex, true) -> os.Append(MatchIncomplete3E(), cex) - os.AppendString(MatchIncompleteForLoopE().Format) + os.Append(MatchIncompleteForLoopE().Format) if isComp then - os.AppendString(MatchIncomplete4E().Format) + os.Append(MatchIncomplete4E().Format) | PatternMatchCompilation.EnumMatchIncomplete(isComp, cexOpt, _) -> - os.AppendString(EnumMatchIncomplete1E().Format) + os.Append(EnumMatchIncomplete1E().Format) match cexOpt with | None -> () - | Some(cex, false) -> os.AppendString(MatchIncomplete2E().Format cex) - | Some(cex, true) -> os.AppendString(MatchIncomplete3E().Format cex) + | Some(cex, false) -> os.Append(MatchIncomplete2E(), cex) + | Some(cex, true) -> os.Append(MatchIncomplete3E(), cex) if isComp then - os.AppendString(MatchIncomplete4E().Format) + os.Append(MatchIncomplete4E().Format) - | PatternMatchCompilation.RuleNeverMatched _ -> os.AppendString(RuleNeverMatchedE().Format) + | PatternMatchCompilation.RuleNeverMatched _ -> os.Append(RuleNeverMatchedE().Format) | ValNotMutable(_, vref, _) -> let name = vref.DisplayName @@ -1903,35 +1943,35 @@ type Exception with else ValNotMutableE().Format name - os.AppendString msg + os.Append msg - | ValNotLocal _ -> os.AppendString(ValNotLocalE().Format) + | ValNotLocal _ -> os.Append(ValNotLocalE().Format) | ObsoleteDiagnostic(message = message) -> - os.AppendString(Obsolete1E().Format) + os.Append(Obsolete1E().Format) match message with - | Some message when message <> "" -> os.AppendString(Obsolete2E().Format message) + | Some message when not message.IsEmpty -> os.Append(Obsolete2E(), message) | _ -> () | Experimental(message = message) -> - os.AppendString(Experimental1E().Format) + os.Append(Experimental1E().Format) match message with - | Some message when message <> "" -> os.AppendString(Experimental2E().Format message) + | Some message when message <> "" -> os.Append(Experimental2E().Format message) | _ -> () - os.AppendString(Experimental3E().Format) + os.Append(Experimental3E().Format) - | PossibleUnverifiableCode _ -> os.AppendString(PossibleUnverifiableCodeE().Format) + | PossibleUnverifiableCode _ -> os.Append(PossibleUnverifiableCodeE().Format) - | UserCompilerMessage(msg, _, _) -> os.AppendString msg + | UserCompilerMessage(msg, _, _) -> os.Append msg - | Deprecated(s, _) -> os.AppendString(DeprecatedE().Format s) + | Deprecated(s, _) -> os.Append(DeprecatedE(), s) - | LibraryUseOnly _ -> os.AppendString(LibraryUseOnlyE().Format) + | LibraryUseOnly _ -> os.Append(LibraryUseOnlyE().Format) - | MissingFields(sl, _) -> os.AppendString(MissingFieldsE().Format(String.concat "," sl + ".")) + | MissingFields(sl, _) -> os.Append(MissingFieldsE().Format(String.concat "," sl + ".")) | ValueRestriction(denv, infoReader, v, _, _) -> let denv = @@ -1941,141 +1981,134 @@ type Exception with let tau = v.TauType - if isFunTy denv.g tau && (arityOfVal v).HasNoArgs then - let msg = - ValueRestrictionFunctionE().Format - v.DisplayName - (NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) - v.DisplayName + let name = richTextOfValName denv.g v - os.AppendString msg - else - let msg = - ValueRestrictionE().Format - v.DisplayName - (NicePrint.stringOfQualifiedValOrMember denv infoReader (mkLocalValRef v)) - v.DisplayName + let signature = + NicePrint.richTextOfQualifiedValOrMember denv infoReader (mkLocalValRef v) - os.AppendString msg + if isFunTy denv.g tau && (arityOfVal v).HasNoArgs then + os.Append(ValueRestrictionFunctionE(), name, signature, name) + else + os.Append(ValueRestrictionE(), name, signature, name) - | Parsing.RecoverableParseError -> os.AppendString(RecoverableParseErrorE().Format) + | Parsing.RecoverableParseError -> os.Append(RecoverableParseErrorE().Format) - | ReservedKeyword(s, _) -> os.AppendString(ReservedKeywordE().Format s) + | ReservedKeyword(s, _) -> os.Append(ReservedKeywordE(), s) - | IndentationProblem(s, _) -> os.AppendString(IndentationProblemE().Format s) + | IndentationProblem(s, _) -> os.Append(IndentationProblemE().Format s) - | OverrideInIntrinsicAugmentation _ -> os.AppendString(OverrideInIntrinsicAugmentationE().Format) + | OverrideInIntrinsicAugmentation _ -> os.Append(OverrideInIntrinsicAugmentationE().Format) - | OverrideInExtrinsicAugmentation _ -> os.AppendString(OverrideInExtrinsicAugmentationE().Format) + | OverrideInExtrinsicAugmentation _ -> os.Append(OverrideInExtrinsicAugmentationE().Format) - | IntfImplInIntrinsicAugmentation _ -> os.AppendString(IntfImplInIntrinsicAugmentationE().Format) + | IntfImplInIntrinsicAugmentation _ -> os.Append(IntfImplInIntrinsicAugmentationE().Format) - | IntfImplInExtrinsicAugmentation _ -> os.AppendString(IntfImplInExtrinsicAugmentationE().Format) + | IntfImplInExtrinsicAugmentation _ -> os.Append(IntfImplInExtrinsicAugmentationE().Format) | UnresolvedReferenceError(assemblyName, _) - | UnresolvedReferenceNoRange assemblyName -> os.AppendString(UnresolvedReferenceNoRangeE().Format assemblyName) + | UnresolvedReferenceNoRange assemblyName -> os.Append(UnresolvedReferenceNoRangeE().Format assemblyName) | UnresolvedPathReference(assemblyName, pathname, _) | UnresolvedPathReferenceNoRange(assemblyName, pathname) -> - os.AppendString(UnresolvedPathReferenceNoRangeE().Format pathname assemblyName) + os.Append(UnresolvedPathReferenceNoRangeE().Format pathname assemblyName) - | DeprecatedCommandLineOptionFull(fullText, _) -> os.AppendString fullText + | DeprecatedCommandLineOptionFull(fullText, _) -> os.Append fullText - | DeprecatedCommandLineOptionForHtmlDoc(optionName, _) -> os.AppendString(FSComp.SR.optsDCLOHtmlDoc optionName) + | DeprecatedCommandLineOptionForHtmlDoc(optionName, _) -> os.Append(FSComp.SR.optsDCLOHtmlDoc optionName) | DeprecatedCommandLineOptionSuggestAlternative(optionName, altOption, _) -> - os.AppendString(FSComp.SR.optsDCLODeprecatedSuggestAlternative (optionName, altOption)) + os.Append(FSComp.SR.optsDCLODeprecatedSuggestAlternative (optionName, altOption)) - | InternalCommandLineOption(optionName, _) -> os.AppendString(FSComp.SR.optsInternalNoDescription optionName) + | InternalCommandLineOption(optionName, _) -> os.Append(FSComp.SR.optsInternalNoDescription optionName) - | DeprecatedCommandLineOptionNoDescription(optionName, _) -> os.AppendString(FSComp.SR.optsDCLONoDescription optionName) + | DeprecatedCommandLineOptionNoDescription(optionName, _) -> os.Append(FSComp.SR.optsDCLONoDescription optionName) - | HashIncludeNotAllowedInNonScript _ -> os.AppendString(HashIncludeNotAllowedInNonScriptE().Format) + | HashIncludeNotAllowedInNonScript _ -> os.Append(HashIncludeNotAllowedInNonScriptE().Format) - | HashReferenceNotAllowedInNonScript _ -> os.AppendString(HashReferenceNotAllowedInNonScriptE().Format) + | HashReferenceNotAllowedInNonScript _ -> os.Append(HashReferenceNotAllowedInNonScriptE().Format) - | HashDirectiveNotAllowedInNonScript _ -> os.AppendString(HashDirectiveNotAllowedInNonScriptE().Format) + | HashDirectiveNotAllowedInNonScript _ -> os.Append(HashDirectiveNotAllowedInNonScriptE().Format) - | FileNameNotResolved(fileName, locations, _) -> os.AppendString(FileNameNotResolvedE().Format fileName locations) + | FileNameNotResolved(fileName, locations, _) -> os.Append(FileNameNotResolvedE().Format fileName locations) - | AssemblyNotResolved(originalName, _) -> os.AppendString(AssemblyNotResolvedE().Format originalName) + | AssemblyNotResolved(originalName, _) -> os.Append(AssemblyNotResolvedE().Format originalName) | IllegalFileNameChar(fileName, invalidChar) -> - os.AppendString(FSComp.SR.buildUnexpectedFileNameCharacter (fileName, string invalidChar) |> snd) + os.Append(FSComp.SR.buildUnexpectedFileNameCharacter (fileName, string invalidChar) |> snd) | HashLoadedSourceHasIssues(infos, warnings, errors, _) -> match warnings, errors with | _, e :: _ -> - os.AppendString(HashLoadedSourceHasIssues2E().Format) + os.Append(HashLoadedSourceHasIssues2E().Format) e.Output(os, suggestNames) | e :: _, _ -> - os.AppendString(HashLoadedSourceHasIssues1E().Format) + os.Append(HashLoadedSourceHasIssues1E().Format) e.Output(os, suggestNames) | [], [] -> - os.AppendString(HashLoadedSourceHasIssues0E().Format) + os.Append(HashLoadedSourceHasIssues0E().Format) infos.Head.Output(os, suggestNames) - | HashLoadedScriptConsideredSource _ -> os.AppendString(HashLoadedScriptConsideredSourceE().Format) + | HashLoadedScriptConsideredSource _ -> os.Append(HashLoadedScriptConsideredSourceE().Format) | InvalidInternalsVisibleToAssemblyName(badName, fileNameOption) -> match fileNameOption with - | Some file -> os.AppendString(InvalidInternalsVisibleToAssemblyName1E().Format badName file) - | None -> os.AppendString(InvalidInternalsVisibleToAssemblyName2E().Format badName) + | Some file -> os.Append(InvalidInternalsVisibleToAssemblyName1E().Format badName file) + | None -> os.Append(InvalidInternalsVisibleToAssemblyName2E().Format badName) - | LoadedSourceNotFoundIgnoring(fileName, _) -> os.AppendString(LoadedSourceNotFoundIgnoringE().Format fileName) + | LoadedSourceNotFoundIgnoring(fileName, _) -> os.Append(LoadedSourceNotFoundIgnoringE().Format fileName) | MSBuildReferenceResolutionWarning(code, message, _) - | MSBuildReferenceResolutionError(code, message, _) -> os.AppendString(MSBuildReferenceResolutionErrorE().Format message code) + | MSBuildReferenceResolutionError(code, message, _) -> os.Append(MSBuildReferenceResolutionErrorE().Format message code) | ArgumentsInSigAndImplMismatch(sigArg, implArg) -> - os.AppendString(ArgumentsInSigAndImplMismatchE().Format sigArg.idText implArg.idText) + os.Append(ArgumentsInSigAndImplMismatchE(), RichText.mkParameter sigArg.idText, RichText.mkParameter implArg.idText) | DefinitionsInSigAndImplNotCompatibleAbbreviationsDiffer(denv, implTycon, _sigTycon, implTypeAbbrev, sigTypeAbbrev, _m) -> - let s1, s2, _ = NicePrint.minimalStringsOfTwoTypes denv implTypeAbbrev sigTypeAbbrev - - os.AppendString( - DefinitionsInSigAndImplNotCompatibleAbbreviationsDifferE().Format - (implTycon.TypeOrMeasureKind.ToString()) - implTycon.DisplayName - s1 - s2 + let s1, s2, _ = + NicePrint.minimalRichTextsOfTwoTypes denv implTypeAbbrev sigTypeAbbrev + + os.Append( + DefinitionsInSigAndImplNotCompatibleAbbreviationsDifferE(), + RichText.mkText (implTycon.TypeOrMeasureKind.ToString()), + richTextOfEntity implTycon, + s1, + s2 ) | InvalidAttributeTargetForLanguageElement(elementTargets, allowedTargets, _m) -> if Array.isEmpty elementTargets then - os.AppendString(InvalidAttributeTargetForLanguageElement2E().Format) + os.Append(InvalidAttributeTargetForLanguageElement2E().Format) else let elementTargets = String.concat ", " elementTargets let allowedTargets = allowedTargets |> String.concat ", " - os.AppendString(InvalidAttributeTargetForLanguageElement1E().Format elementTargets allowedTargets) + os.Append(InvalidAttributeTargetForLanguageElement1E().Format elementTargets allowedTargets) - | NoConstructorsAvailableForType(t, denv, _) -> - os.AppendString(NoConstructorsAvailableForTypeE().Format(NicePrint.minimalStringOfType denv t)) + | NoConstructorsAvailableForType(t, denv, _) -> os.Append(NoConstructorsAvailableForTypeE(), NicePrint.minimalRichTextOfType denv t) // Strip TargetInvocationException wrappers | :? TargetInvocationException as e when isNotNull e.InnerException -> (!!e.InnerException).Output(os, suggestNames) - | :? FileNotFoundException as exn -> Printf.bprintf os "%s" exn.Message + | :? FileNotFoundException as exn -> os.Append exn.Message - | :? DirectoryNotFoundException as exn -> Printf.bprintf os "%s" exn.Message + | :? DirectoryNotFoundException as exn -> os.Append exn.Message - | :? ArgumentException as exn -> Printf.bprintf os "%s" exn.Message + | :? ArgumentException as exn -> os.Append exn.Message - | :? NotSupportedException as exn -> Printf.bprintf os "%s" exn.Message + | :? NotSupportedException as exn -> os.Append exn.Message - | :? IOException as exn -> Printf.bprintf os "%s" exn.Message + | :? IOException as exn -> os.Append exn.Message - | :? UnauthorizedAccessException as exn -> Printf.bprintf os "%s" exn.Message + | :? UnauthorizedAccessException as exn -> os.Append exn.Message - | :? InvalidOperationException as exn when exn.Message.Contains "ControlledExecution.Run" -> Printf.bprintf os "%s" exn.Message + | :? InvalidOperationException as exn when exn.Message.Contains "ControlledExecution.Run" -> os.Append exn.Message | exn -> - os.AppendString(TargetInvocationExceptionWrapperE().Format exn.Message) + os.Append(TargetInvocationExceptionWrapperE().Format exn.Message) #if DEBUG - Printf.bprintf os "\nStack Trace\n%s\n" (exn.ToString()) + os.Append(sprintf "\nStack Trace\n%s\n" (exn.ToString())) if showAssertForUnexpectedException.Value then Debug.Assert(false, sprintf "Unknown exception seen in compiler: %s" (exn.ToString())) @@ -2085,30 +2118,21 @@ type Exception with type PhasedDiagnostic with // remove any newlines and tabs - member x.OutputCore(os: StringBuilder, flattenErrors: bool, suggestNames: bool) = - let buf = StringBuilder() + member x.FormatRichCore(flattenErrors: bool, suggestNames: bool) = + let buf = RichTextBuilder() x.Exception.Output(buf, suggestNames) - let text = - if flattenErrors then - NormalizeErrorString(buf.ToString()) - else - buf.ToString() + let text = buf.ToRichText() - os.AppendString text + if flattenErrors then NormalizeErrorRichText text else text - member x.FormatCore(flattenErrors: bool, suggestNames: bool) = - let os = StringBuilder() - x.OutputCore(os, flattenErrors, suggestNames) - os.ToString() + member x.FormatCore(flattenErrors: bool, suggestNames: bool) = x.FormatRichCore(flattenErrors, suggestNames).Text member x.EagerlyFormatCore(suggestNames: bool) = match x.Range with | Some m -> - let buf = StringBuilder() - x.Exception.Output(buf, suggestNames) - let message = buf.ToString() + let message = x.FormatRichCore(false, suggestNames) let exn = DiagnosticWithText(x.Number, message, m) { x with Exception = exn } | None -> x diff --git a/src/Compiler/Driver/CompilerDiagnostics.fsi b/src/Compiler/Driver/CompilerDiagnostics.fsi index 0cf57b81e8c..30ef273f143 100644 --- a/src/Compiler/Driver/CompilerDiagnostics.fsi +++ b/src/Compiler/Driver/CompilerDiagnostics.fsi @@ -57,6 +57,9 @@ type PhasedDiagnostic with /// Eagerly format a PhasedDiagnostic return as a new PhasedDiagnostic requiring no formatting of types. member EagerlyFormatCore: suggestNames: bool -> PhasedDiagnostic + /// Format the core of the diagnostic as rich text. Doesn't include the range information. + member FormatRichCore: flattenErrors: bool * suggestNames: bool -> RichText + /// Format the core of the diagnostic as a string. Doesn't include the range information. member FormatCore: flattenErrors: bool * suggestNames: bool -> string diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index 46a3b83b604..68edbca6bef 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -1958,7 +1958,16 @@ and [] TcImports match providers with | [] -> let typeName = !!typeof.FullName - warning (Error(FSComp.SR.etHostingAssemblyFoundWithoutHosts (fileNameOfRuntimeAssembly, typeName), m)) + + warning ( + Error( + FSComp.SR.etHostingAssemblyFoundWithoutHosts ( + RichText.mkText fileNameOfRuntimeAssembly, + RichText.ofQualifiedTypeName typeName + ), + m + ) + ) | _ -> #if DEBUG diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index 1590b9fe458..17a316b7553 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -105,7 +105,15 @@ let ComputeAnonModuleName check defaultNamespace fileName (m: range) = let modname = CanonicalizeFilename fileName if check && not (IsValidAnonModuleName modname) && not (IsScript fileName) then - warning (Error(FSComp.SR.buildImplicitModuleIsNotLegalIdentifier (modname, (FileSystemUtils.fileNameOfPath fileName)), m)) + warning ( + Error( + FSComp.SR.buildImplicitModuleIsNotLegalIdentifier ( + RichText.mkModule modname, + RichText.mkText (FileSystemUtils.fileNameOfPath fileName) + ), + m + ) + ) let combined = match defaultNamespace with @@ -827,7 +835,7 @@ let ProcessMetaCommandsFromInput errorR (HashDirectiveNotAllowedInNonScript m) else let arg = (parsedHashDirectiveArguments [] tcConfig.langVersion) - warning (Error((FSComp.SR.fsiInvalidDirective (c, String.concat " " arg)), m)) + warning (Error((FSComp.SR.fsiInvalidDirective (RichText.mkKeyword c, RichText.mkText (String.concat " " arg))), m)) state @@ -1174,7 +1182,7 @@ let SkippedImplFilePlaceholder (tcConfig: TcConfig, tcImports: TcImports, tcGlob // Check if we've already seen an implementation for this fragment if Zset.contains qualNameOfFile tcState.tcsRootImpls then - errorR (Error(FSComp.SR.buildImplementationAlreadyGiven qualNameOfFile.Text, input.Range)) + errorR (Error(FSComp.SR.buildImplementationAlreadyGiven (RichText.mkModule qualNameOfFile.Text), input.Range)) let hadSig = rootSigOpt.IsSome @@ -1234,11 +1242,11 @@ let CheckOneInput // Check if we've seen this top module signature before. if Zmap.mem qualNameOfFile tcState.tcsRootSigs then - errorR (Error(FSComp.SR.buildSignatureAlreadySpecified qualNameOfFile.Text, m.StartRange)) + errorR (Error(FSComp.SR.buildSignatureAlreadySpecified (RichText.mkModule qualNameOfFile.Text), m.StartRange)) // Check if the implementation came first in compilation order if Zset.contains qualNameOfFile tcState.tcsRootImpls then - errorR (Error(FSComp.SR.buildImplementationAlreadyGivenDetail qualNameOfFile.Text, m)) + errorR (Error(FSComp.SR.buildImplementationAlreadyGivenDetail (RichText.mkModule qualNameOfFile.Text), m)) // Typecheck the signature file let! tcEnv, sigFileType, createsGeneratedProvidedTypes = @@ -1285,7 +1293,7 @@ let CheckOneInput // Check if we've already seen an implementation for this fragment if Zset.contains qualNameOfFile tcState.tcsRootImpls then - errorR (Error(FSComp.SR.buildImplementationAlreadyGiven qualNameOfFile.Text, m)) + errorR (Error(FSComp.SR.buildImplementationAlreadyGiven (RichText.mkModule qualNameOfFile.Text), m)) let hadSig = rootSigOpt.IsSome @@ -1372,7 +1380,7 @@ let CheckClosedInputSetFinish (declaredImpls: CheckedImplFile list, tcState) = tcState.tcsRootSigs |> Zmap.iter (fun qualNameOfFile _ -> if not (Zset.contains qualNameOfFile tcState.tcsRootImpls) then - errorR (Error(FSComp.SR.buildSignatureWithoutImplementation qualNameOfFile.Text, qualNameOfFile.Range))) + errorR (Error(FSComp.SR.buildSignatureWithoutImplementation (RichText.mkModule qualNameOfFile.Text), qualNameOfFile.Range))) tcState, declaredImpls, ccuContents @@ -1451,11 +1459,11 @@ let CheckOneInputWithCallback // Check if we've seen this top module signature before. if Zmap.mem qualNameOfFile tcState.tcsRootSigs then - errorR (Error(FSComp.SR.buildSignatureAlreadySpecified qualNameOfFile.Text, m.StartRange)) + errorR (Error(FSComp.SR.buildSignatureAlreadySpecified (RichText.mkModule qualNameOfFile.Text), m.StartRange)) // Check if the implementation came first in compilation order if Zset.contains qualNameOfFile tcState.tcsRootImpls then - errorR (Error(FSComp.SR.buildImplementationAlreadyGivenDetail qualNameOfFile.Text, m)) + errorR (Error(FSComp.SR.buildImplementationAlreadyGivenDetail (RichText.mkModule qualNameOfFile.Text), m)) // Typecheck the signature file let! tcEnv, sigFileType, createsGeneratedProvidedTypes = @@ -1533,7 +1541,7 @@ let CheckOneInputWithCallback (fun tcState -> // Check if we've already seen an implementation for this fragment if Zset.contains qualNameOfFile tcState.tcsRootImpls then - errorR (Error(FSComp.SR.buildImplementationAlreadyGiven qualNameOfFile.Text, m)) + errorR (Error(FSComp.SR.buildImplementationAlreadyGiven (RichText.mkModule qualNameOfFile.Text), m)) let ccuSigForFile, fsTcState = AddCheckResultsToTcState diff --git a/src/Compiler/Driver/ScriptClosure.fs b/src/Compiler/Driver/ScriptClosure.fs index a83b49a2a0e..a61e49cd656 100644 --- a/src/Compiler/Driver/ScriptClosure.fs +++ b/src/Compiler/Driver/ScriptClosure.fs @@ -328,7 +328,7 @@ module ScriptPreprocessClosure = and reportError m = ResolvingErrorReport(fun errorType err msg -> - let error = err, msg + let error = err, RichText.mkText msg match errorType with | ErrorReportType.Warning -> warning (Error(error, m)) @@ -353,7 +353,7 @@ module ScriptPreprocessClosure = match managerOpt with | Null -> - let err = + let number, message = dependencyProvider.CreatePackageManagerUnknownError( tcConfig.compilerToolPaths, outputDir, @@ -362,7 +362,7 @@ module ScriptPreprocessClosure = reportError m ) - errorR (Error(err, m)) + errorR (Error((number, message), m)) | NonNull dependencyManager -> yield! resolvePackageManagerLines m packageManagerLines scriptName packageManagerKey dependencyManager diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index 0690d97786a..1565cacd8b3 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -393,7 +393,12 @@ let TryFindVersionAttribute g attrib attribName attribs deterministic = match AttributeHelpers.TryFindStringAttribute g attrib attribs with | Some versionString -> if deterministic && versionString.Contains("*") then - errorR (Error(FSComp.SR.fscAssemblyWildcardAndDeterminism (attribName, versionString), rangeStartup)) + errorR ( + Error( + FSComp.SR.fscAssemblyWildcardAndDeterminism (RichText.mkClass attribName, RichText.mkText versionString), + rangeStartup + ) + ) try Some(parseILVersion versionString) diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 947ed8fcca2..b274796ff49 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -40,6 +40,8 @@ $(IntermediateOutputPath)$(TargetFramework)\ false Debug;Release + + true @@ -102,27 +104,31 @@ - FSComp.txt + true FSIstrings.txt + true FSStrings.resx FSStrings.resources + + + + + + + - - - - diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index c0e2d558610..77351b7dd89 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -78,10 +78,10 @@ let (|StopProcessing|_|) exn = let StopProcessing<'T> = StopProcessingExn None // int is e.g. 191 in FS0191 -exception DiagnosticWithText of number: int * message: string * range: range with +exception DiagnosticWithText of number: int * message: RichText * range: range with override this.Message = match this :> exn with - | DiagnosticWithText(_, msg, _) -> msg + | DiagnosticWithText(_, msg, _) -> msg.Text | _ -> "impossible" exception InternalError of message: string * range: range with @@ -101,11 +101,11 @@ exception InternalException of exn: Exception * msg: string * range: range with | InternalException(exn, _, _) -> exn.ToString() | _ -> "impossible" -exception UserCompilerMessage of message: string * number: int * range: range +exception UserCompilerMessage of message: RichText * number: int * range: range exception LibraryUseOnly of range: range -exception Deprecated of message: string * range: range +exception Deprecated of message: RichText * range: range exception Experimental of message: string option * diagnosticId: string option * urlFormat: string option * range: range @@ -123,14 +123,14 @@ exception UnresolvedPathReferenceNoRange of assemblyName: string * path: string exception UnresolvedPathReference of assemblyName: string * path: string * range: range -exception DiagnosticWithSuggestions of number: int * message: string * range: range * identifier: string * suggestions: Suggestions with // int is e.g. 191 in FS0191 +exception DiagnosticWithSuggestions of number: int * message: RichText * range: range * identifier: string * suggestions: Suggestions with // int is e.g. 191 in FS0191 override this.Message = match this :> exn with - | DiagnosticWithSuggestions(_, msg, _, _, _) -> msg + | DiagnosticWithSuggestions(_, msg, _, _, _) -> msg.Text | _ -> "impossible" /// A diagnostic that is raised when enabled manually, or by default with a language feature -exception DiagnosticEnabledWithLanguageFeature of number: int * message: string * range: range * enabledByLangFeature: bool +exception DiagnosticEnabledWithLanguageFeature of number: int * message: RichText * range: range * enabledByLangFeature: bool type ObsoleteDiagnosticInfo = | ObsoleteDiagnosticInfo of isError: bool * diagnosticId: string option * message: string option * urlFormat: string option @@ -138,7 +138,7 @@ type ObsoleteDiagnosticInfo = exception ObsoleteDiagnostic of isError: bool * diagnosticId: string option * - message: string option * + message: RichText option * urlFormat: string option * range: range @@ -146,7 +146,7 @@ exception ObsoleteDiagnostic of /// an DiagnosticWithText as an exception even if it's a warning. /// /// We will eventually rename this to remove this use of "Error" -let Error ((n, text), m) = DiagnosticWithText(n, text, m) +let Error ((n, text): int * RichText, m) = DiagnosticWithText(n, text, m) /// The F# compiler code currently uses 'ErrorWithSuggestions(...)' in many places to create /// an DiagnosticWithText as an exception even if it's a warning. @@ -605,14 +605,14 @@ let stopProcessingRecovery exn m = let errorRecoveryNoRange exn = DiagnosticsThreadStatics.DiagnosticsLogger.ErrorRecoveryNoRange exn -let deprecatedWithError s m = errorR (Deprecated(s, m)) +let deprecatedWithError (s: RichText) m = errorR (Deprecated(s, m)) let libraryOnlyError m = errorR (LibraryUseOnly m) let libraryOnlyWarning m = warning (LibraryUseOnly m) let deprecatedOperator m = - deprecatedWithError (FSComp.SR.elDeprecatedOperator ()) m + deprecatedWithError (RichText.mkText (FSComp.SR.elDeprecatedOperator ())) m [] let suppressErrorReporting f = @@ -826,6 +826,49 @@ let NormalizeErrorString (text: string) = buf.ToString() +let NormalizeErrorRichText (text: RichText) = + let full = text.Text + + // 'NormalizeErrorString' trims the message as a whole, so the trimmed range is computed over all + // parts rather than over each part on its own. + let mutable startIndex = 0 + let mutable endIndex = full.Length + + while startIndex < endIndex && Char.IsWhiteSpace full[startIndex] do + startIndex <- startIndex + 1 + + while endIndex > startIndex && Char.IsWhiteSpace full[endIndex - 1] do + endIndex <- endIndex - 1 + + let parts = ResizeArray() + let buf = System.Text.StringBuilder() + let mutable index = 0 + // Set once a '\r' was replaced, so that a '\n' completing the sequence produces no second proxy, + // even when it belongs to the next part + let mutable skipLineFeed = false + + for part in text.Parts do + buf.Clear() |> ignore + + for c in part.Text do + if index >= startIndex && index < endIndex then + match c with + | '\n' when skipLineFeed -> () + | '\r' + | '\n' -> buf.Append stringThatIsAProxyForANewlineInFlatErrors |> ignore + | c -> + // handle remaining chars: control - replace with space, others - keep unchanged + buf.Append(if Char.IsControl c then ' ' else c) |> ignore + + skipLineFeed <- c = '\r' + + index <- index + 1 + + if buf.Length > 0 then + parts.Add(TaggedText(part.Tag, buf.ToString())) + + RichText.ofParts (parts.ToArray()) + /// Indicates whether a language feature check should be skipped. Typically used in recursive functions /// where we don't want repeated recursive calls to raise the same diagnostic multiple times. [] diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fsi b/src/Compiler/Facilities/DiagnosticsLogger.fsi index a6e787e8c8b..66377aac861 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fsi +++ b/src/Compiler/Facilities/DiagnosticsLogger.fsi @@ -46,27 +46,27 @@ val (|StopProcessing|_|): exn: exn -> unit voption val StopProcessing<'T> : exn /// Represents a diagnostic exception whose text comes via SR.* -exception DiagnosticWithText of number: int * message: string * range: range +exception DiagnosticWithText of number: int * message: RichText * range: range /// A diagnostic that is raised when enabled manually, or by default with a language feature exception DiagnosticEnabledWithLanguageFeature of number: int * - message: string * + message: RichText * range: range * enabledByLangFeature: bool /// Creates a diagnostic exception whose text comes via SR.* -val Error: (int * string) * range -> exn +val Error: (int * RichText) * range -> exn exception InternalError of message: string * range: range exception InternalException of exn: Exception * msg: string * range: range -exception UserCompilerMessage of message: string * number: int * range: range +exception UserCompilerMessage of message: RichText * number: int * range: range exception LibraryUseOnly of range: range -exception Deprecated of message: string * range: range +exception Deprecated of message: RichText * range: range exception Experimental of message: string option * diagnosticId: string option * urlFormat: string option * range: range @@ -82,7 +82,7 @@ exception UnresolvedPathReference of assemblyName: string * path: string * range exception DiagnosticWithSuggestions of number: int * - message: string * + message: RichText * range: range * identifier: string * suggestions: Suggestions @@ -97,15 +97,15 @@ type ObsoleteDiagnosticInfo = exception ObsoleteDiagnostic of isError: bool * diagnosticId: string option * - message: string option * + message: RichText option * urlFormat: string option * range: range /// Creates a DiagnosticWithSuggestions whose text comes via SR.* -val ErrorWithSuggestions: (int * string) * range * string * Suggestions -> exn +val ErrorWithSuggestions: (int * RichText) * range * string * Suggestions -> exn /// Creates a DiagnosticEnabledWithLanguageFeature whose text comes via SR.* -val ErrorEnabledWithLanguageFeature: (int * string) * range * bool -> exn +val ErrorEnabledWithLanguageFeature: (int * RichText) * range * bool -> exn val inline protectAssemblyExploration: dflt: 'T -> f: (unit -> 'T) -> 'T @@ -330,7 +330,7 @@ val stopProcessingRecovery: exn: exn -> m: range -> unit val errorRecoveryNoRange: exn: exn -> unit -val deprecatedWithError: s: string -> m: range -> unit +val deprecatedWithError: s: RichText -> m: range -> unit val libraryOnlyError: m: range -> unit @@ -441,6 +441,10 @@ val NewlineifyErrorString: message: string -> string /// which is decoded by the IDE with 'NewlineifyErrorString' back into newlines, so that multi-line errors can be displayed in QuickInfo val NormalizeErrorString: text: string -> string +/// Same as 'NormalizeErrorString', but applied to the parts of a rich message, so that the +/// classification of each part is preserved. Parts left empty by normalization are dropped. +val NormalizeErrorRichText: text: RichText -> RichText + /// Indicates whether a language feature check should be skipped. Typically used in recursive functions /// where we don't want repeated recursive calls to raise the same diagnostic multiple times. [] diff --git a/src/Compiler/Facilities/RichText.fs b/src/Compiler/Facilities/RichText.fs new file mode 100644 index 00000000000..13c953cd794 --- /dev/null +++ b/src/Compiler/Facilities/RichText.fs @@ -0,0 +1,280 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Compiler.Text + +open System +open System.Text +open FSharp.Compiler.DiagnosticMessage +open FSharp.Compiler.Text + +[] +type RichText(parts: TaggedText[]) = + + let text = + match parts with + | [||] -> "" + | [| part |] -> part.Text + | parts -> + let capacity = parts |> Array.sumBy _.Text.Length + let buf = StringBuilder(capacity) + + for part in parts do + buf.Append(part.Text) |> ignore + + buf.ToString() + + member _.Parts = parts + + member _.Text = text + + member _.IsEmpty = Array.isEmpty parts + + override _.ToString() = text + + override _.Equals(other) = + match other with + | :? RichText as other -> text = other.Text + | _ -> false + + override _.GetHashCode() = text.GetHashCode() + +module RichText = + + let empty = RichText([||]) + + let ofParts (parts: TaggedText[]) = + if Array.isEmpty parts then empty else RichText(parts) + + let ofTaggedText (part: TaggedText) = RichText([| part |]) + + let ofTag tag (text: string) = + if String.IsNullOrEmpty text then + empty + else + ofTaggedText (TaggedText.mkTag tag text) + + let mkText text = ofTag TextTag.Text text + let mkActivePatternCase text = ofTag TextTag.ActivePatternCase text + let mkActivePatternResult text = ofTag TextTag.ActivePatternResult text + let mkAlias text = ofTag TextTag.Alias text + let mkClass text = ofTag TextTag.Class text + let mkDelegate text = ofTag TextTag.Delegate text + let mkEnum text = ofTag TextTag.Enum text + let mkEvent text = ofTag TextTag.Event text + let mkField text = ofTag TextTag.Field text + let mkFunction text = ofTag TextTag.Function text + let mkInterface text = ofTag TextTag.Interface text + let mkKeyword text = ofTag TextTag.Keyword text + let mkLineBreak text = ofTag TextTag.LineBreak text + let mkLocal text = ofTag TextTag.Local text + let mkMember text = ofTag TextTag.Member text + let mkMethod text = ofTag TextTag.Method text + let mkModule text = ofTag TextTag.Module text + let mkModuleBinding text = ofTag TextTag.ModuleBinding text + let mkNamespace text = ofTag TextTag.Namespace text + let mkNumericLiteral text = ofTag TextTag.NumericLiteral text + let mkOperator text = ofTag TextTag.Operator text + let mkParameter text = ofTag TextTag.Parameter text + let mkProperty text = ofTag TextTag.Property text + let mkPunctuation text = ofTag TextTag.Punctuation text + let mkRecord text = ofTag TextTag.Record text + let mkRecordField text = ofTag TextTag.RecordField text + let mkSpace text = ofTag TextTag.Space text + let mkStringLiteral text = ofTag TextTag.StringLiteral text + let mkStruct text = ofTag TextTag.Struct text + let mkTypeParameter text = ofTag TextTag.TypeParameter text + let mkUnion text = ofTag TextTag.Union text + let mkUnionCase text = ofTag TextTag.UnionCase text + let mkUnknownEntity text = ofTag TextTag.UnknownEntity text + let mkUnknownType text = ofTag TextTag.UnknownType text + let mkUnresolvedName text = ofTag TextTag.UnresolvedName text + + let append (left: RichText) (right: RichText) = + if left.IsEmpty then right + elif right.IsEmpty then left + else RichText(Array.append left.Parts right.Parts) + + let concat (texts: RichText seq) = + let parts = ResizeArray() + + for text in texts do + parts.AddRange(text.Parts) + + ofParts (parts.ToArray()) + + let concatWith (separator: RichText) (texts: RichText seq) = + let parts = ResizeArray() + let mutable needsSeparator = false + + for text in texts do + if needsSeparator then + parts.AddRange separator.Parts + + needsSeparator <- true + parts.AddRange text.Parts + + ofParts (parts.ToArray()) + + let collectParts mapping (text: RichText) = + ofParts (Array.collect mapping text.Parts) + + let ofQualifiedName leafOfName (name: string) = + match name.LastIndexOf '.' with + | -1 -> leafOfName name + | i -> + let path = name.Substring(0, i) + let leaf = name.Substring(i + 1) + + let namespaceParts = + path.Split '.' + |> Array.map (ofTag TextTag.Namespace) + |> concatWith (ofTag TextTag.Punctuation ".") + + concat [ namespaceParts; ofTag TextTag.Punctuation "."; leafOfName leaf ] + + let ofQualifiedTypeName name = ofQualifiedName mkUnknownType name + +module RichMessage = + + /// Characters that can stand in for a classified argument while the message is formatted. Control + /// characters, so that in practice the first one is always free. + let private candidateMarkers = + [| + for c in '\u0001' .. '\u001f' do + if c <> '\n' && c <> '\r' && c <> '\t' then + c + |] + + /// Replaces the markers in a formatted message with the parts they stand for + let private splice (marker: char) (args: ResizeArray) (text: string) = + let parts = ResizeArray() + let buf = StringBuilder() + let mutable i = 0 + + let addPendingText () = + if buf.Length > 0 then + parts.Add(TaggedText.tagText (buf.ToString())) + buf.Clear() |> ignore + + while i < text.Length do + // A marker is the character followed by the argument index and the character again + let mutable index = 0 + let mutable j = i + 1 + + if text[i] = marker then + while j < text.Length && text[j] >= '0' && text[j] <= '9' do + index <- index * 10 + int text[j] - int '0' + j <- j + 1 + + if + text[i] = marker + && j > i + 1 + && j < text.Length + && text[j] = marker + && index < args.Count + then + addPendingText () + parts.AddRange(args[index].Parts) + i <- j + 1 + else + buf.Append(text[i]) |> ignore + i <- i + 1 + + addPendingText () + RichText.ofParts (parts.ToArray()) + + /// A resource accessor returns an already-formatted message, so the holes can no longer be told + /// apart afterwards. The message is therefore formatted twice: once with the argument texts, which + /// is what it has to read as, and once with a marker per classified argument, which the parts are + /// then spliced back into. Splicing the formatted message rather than the template is what makes + /// this survive a translation reordering, repeating or dropping holes. + /// + /// The marker is picked absent from the first result, so no argument and no translation can contain + /// one. Should the two disagree anyway, the text is what the reader sees, so it wins and the + /// classification is dropped. + let private formatWithMarkers (format: (RichText -> string) -> 'T) (getText: 'T -> string) = + let plain = format (fun arg -> arg.Text) + let plainText = getText plain + + let marker = candidateMarkers |> Array.tryFind (fun c -> plainText.IndexOf c < 0) + + match marker with + | None -> plain, RichText.mkText plainText + | Some marker -> + let args = ResizeArray() + + let addArg (arg: RichText) = + let index = args.Count + args.Add arg + String.Concat(string marker, string index, string marker) + + let spliced = splice marker args (getText (format addArg)) + + if spliced.Text = plainText then + plain, spliced + else + plain, RichText.mkText plainText + + let text (format: (RichText -> string) -> string) = formatWithMarkers format id |> snd + + let numbered (format: (RichText -> string) -> int * RichText) = + let (number, _), text = + formatWithMarkers format (fun (_, message: RichText) -> message.Text) + + number, text + +[] +type RichTextBuilder() = + let parts = ResizeArray() + + // NavigableTaggedText and other subclasses carry data that merging would lose + let isPlain (part: TaggedText) = part.GetType() = typeof + + /// A message is built from many pieces, and where one piece ends tells a consumer nothing unless + /// the classification changes there + let mergeAdjacentParts () = + let merged = ResizeArray(parts.Count) + + for part in parts do + if + merged.Count > 0 + && merged[merged.Count - 1].Tag = part.Tag + && isPlain merged[merged.Count - 1] + && isPlain part + then + merged[merged.Count - 1] <- TaggedText(part.Tag, merged[merged.Count - 1].Text + part.Text) + else + merged.Add part + + merged.ToArray() + + member _.Append(value: string) = + if not (String.IsNullOrEmpty value) then + parts.Add(TaggedText.tagText value) + + member _.Append(value: TaggedText) = parts.Add value + + member _.Append(value: RichText) = parts.AddRange value.Parts + + member this.Append(message: ResourceString string>, a0: RichText) = + this.Append(fun rich -> message.Format(rich a0)) + + member this.Append(message: ResourceString string -> string>, a0: RichText, a1: RichText) = + this.Append(fun rich -> message.Format (rich a0) (rich a1)) + + member this.Append(message: ResourceString string -> string -> string>, a0: RichText, a1: RichText, a2: RichText) = + this.Append(fun rich -> message.Format (rich a0) (rich a1) (rich a2)) + + member this.Append + (message: ResourceString string -> string -> string -> string>, a0: RichText, a1: RichText, a2: RichText, a3: RichText) + = + this.Append(fun rich -> message.Format (rich a0) (rich a1) (rich a2) (rich a3)) + + member this.Append(format: (RichText -> string) -> string) = this.Append(RichMessage.text format) + + member _.IsEmpty = parts.Count = 0 + + member _.ToRichText() = + RichText.ofParts (mergeAdjacentParts ()) + + override this.ToString() = this.ToRichText().Text diff --git a/src/Compiler/Facilities/RichText.fsi b/src/Compiler/Facilities/RichText.fsi new file mode 100644 index 00000000000..8a091d83ab6 --- /dev/null +++ b/src/Compiler/Facilities/RichText.fsi @@ -0,0 +1,176 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Compiler.Text + +open FSharp.Compiler.DiagnosticMessage + +/// Represents text made of tagged parts, e.g. a diagnostic message in which types, identifiers and +/// punctuation are classified, so that tooling is able to render them with colors. +/// +/// Text that carries no classification is represented as a single part tagged TextTag.Text, so that +/// a plain string is always representable and Text is always equal to the original string. +/// +/// Two rich texts are equal when they read the same. Classification does not take part in equality, +/// since the places that compare texts - such as deciding whether two types can be told apart in a +/// message - are asking about what reaches the reader. +[] +type public RichText = + + /// Gets the tagged parts of the text + member Parts: TaggedText[] + + /// Gets the text of all parts concatenated + member Text: string + + /// Gets whether the text has no parts + member IsEmpty: bool + +module internal RichText = + + /// Text with no parts + val empty: RichText + + /// Creates text from already tagged parts + val ofParts: parts: TaggedText[] -> RichText + + /// Creates text from a single tagged part + val ofTaggedText: part: TaggedText -> RichText + + /// Creates text from a single part with the given classification. Text that is empty has no parts, + /// so that where a part boundary falls is never visible in the result. + val ofTag: tag: TextTag -> text: string -> RichText + + /// Creates text from a single part with the classification the name says, for the classifications + /// a diagnostic message uses. mkText is unclassified text, i.e. text with nothing in it to classify. + /// Prefer computing the classification from what is being named, as richTextOfEntityRefName and + /// richTextOfValName do, over choosing one of these by hand. + val mkText: text: string -> RichText + val mkActivePatternCase: text: string -> RichText + val mkActivePatternResult: text: string -> RichText + val mkAlias: text: string -> RichText + val mkClass: text: string -> RichText + val mkDelegate: text: string -> RichText + val mkEnum: text: string -> RichText + val mkEvent: text: string -> RichText + val mkField: text: string -> RichText + val mkFunction: text: string -> RichText + val mkInterface: text: string -> RichText + val mkKeyword: text: string -> RichText + val mkLineBreak: text: string -> RichText + val mkLocal: text: string -> RichText + val mkMember: text: string -> RichText + val mkMethod: text: string -> RichText + val mkModule: text: string -> RichText + val mkModuleBinding: text: string -> RichText + val mkNamespace: text: string -> RichText + val mkNumericLiteral: text: string -> RichText + val mkOperator: text: string -> RichText + val mkParameter: text: string -> RichText + val mkProperty: text: string -> RichText + val mkPunctuation: text: string -> RichText + val mkRecord: text: string -> RichText + val mkRecordField: text: string -> RichText + val mkSpace: text: string -> RichText + val mkStringLiteral: text: string -> RichText + val mkStruct: text: string -> RichText + val mkTypeParameter: text: string -> RichText + val mkUnion: text: string -> RichText + val mkUnionCase: text: string -> RichText + val mkUnknownEntity: text: string -> RichText + val mkUnknownType: text: string -> RichText + val mkUnresolvedName: text: string -> RichText + + /// Concatenates two texts + val append: left: RichText -> right: RichText -> RichText + + /// Concatenates any number of texts + val concat: texts: RichText seq -> RichText + + /// Concatenates any number of texts, inserting a separator between them + val concatWith: separator: RichText -> texts: RichText seq -> RichText + + /// Replaces every part with zero or more parts, e.g. to split parts containing line breaks + val collectParts: mapping: (TaggedText -> TaggedText[]) -> text: RichText -> RichText + + /// A dotted name, classifying the namespace and the dots, and the name itself with the given + /// constructor. For names that arrive from metadata, reflection or a type provider as one string; + /// not for an assembly-qualified name, since an assembly version has dots in it too. + val ofQualifiedName: leafOfName: (string -> RichText) -> name: string -> RichText + + /// A dotted type name whose kind is not known, e.g. because the type could not be dereferenced + val ofQualifiedTypeName: name: string -> RichText + +/// Splices classified arguments into the holes of a message that comes from a resource file. +/// +/// A resource accessor returns a message that is already formatted, so the holes can no longer be told +/// apart afterwards. Instead the message is formatted with a sentinel in place of each classified +/// argument, and the sentinels are then replaced with the parts they stand for. This way the resource +/// key stays a compile-checked member reference, and translations are free to reorder, repeat or drop +/// holes. +/// +/// This is what the generated FSComp accessors taking classified arguments are built on. Call those +/// directly where they exist; these take a function instead, for the messages that have no such +/// overload - the ones from FSStrings: +/// +/// RichMessage.text (fun rich -> RecursionE().Format name (rich ty1) (rich ty2) (rich tpcs)) +module internal RichMessage = + + /// Formats a message with no diagnostic number + val text: format: ((RichText -> string) -> string) -> RichText + + /// Formats a message with a diagnostic number. The formatted message it is given is the + /// unclassified text the numbered accessors return, i.e. one part, which the parts standing in for + /// the classified arguments are spliced back into. + val numbered: format: ((RichText -> string) -> int * RichText) -> int * RichText + +/// Accumulates rich text. Adjacent parts with the same classification are merged, so that where one +/// append ended is not visible in the result. +/// +/// AppendString has the same name and signature as the StringBuilder extension in lib.fs, so that +/// message formatting code can be moved over to rich text without being rewritten, and can then be +/// converted to emit classified parts one message at a time. +[] +type internal RichTextBuilder = + + new: unit -> RichTextBuilder + + /// Appends unclassified text, tagged TextTag.Text + member Append: value: string -> unit + + /// Appends a single tagged part + member Append: value: TaggedText -> unit + + /// Appends the parts of another rich text + member Append: value: RichText -> unit + + /// Appends a message from FSStrings, classifying each of its arguments. The FSComp accessors are + /// generated with overloads taking classified arguments, so those are called directly and their + /// result appended; the FSStrings ones are declared by hand and have no such overload. + member Append: message: ResourceString string> * a0: RichText -> unit + + /// Appends a message from a resource file, classifying each of its arguments + member Append: message: ResourceString string -> string> * a0: RichText * a1: RichText -> unit + + /// Appends a message from a resource file, classifying each of its arguments + member Append: + message: ResourceString string -> string -> string> * a0: RichText * a1: RichText * a2: RichText -> + unit + + /// Appends a message from a resource file, classifying each of its arguments + member Append: + message: ResourceString string -> string -> string -> string> * + a0: RichText * + a1: RichText * + a2: RichText * + a3: RichText -> + unit + + /// Appends a message whose arguments are spliced in by the given function, for messages that mix + /// classified and plain arguments. See RichMessage. + member Append: format: ((RichText -> string) -> string) -> unit + + /// Gets whether nothing has been appended + member IsEmpty: bool + + /// Gets the accumulated text + member ToRichText: unit -> RichText diff --git a/src/Compiler/Facilities/TextLayoutRender.fs b/src/Compiler/Facilities/TextLayoutRender.fs index 7babb76ca29..a3c95148df0 100644 --- a/src/Compiler/Facilities/TextLayoutRender.fs +++ b/src/Compiler/Facilities/TextLayoutRender.fs @@ -203,10 +203,9 @@ module LayoutRender = let bufferL os layout = renderL (bufferR os) layout |> ignore - let emitL f layout = - renderL (taggedTextListR f) layout |> ignore - let toArray layout = let output = ResizeArray() renderL (taggedTextListR output.Add) layout |> ignore output.ToArray() + + let toRichText layout = RichText.ofParts (toArray layout) diff --git a/src/Compiler/Facilities/TextLayoutRender.fsi b/src/Compiler/Facilities/TextLayoutRender.fsi index 96d4b13a184..6692e3d0f02 100644 --- a/src/Compiler/Facilities/TextLayoutRender.fsi +++ b/src/Compiler/Facilities/TextLayoutRender.fsi @@ -28,7 +28,7 @@ module internal LayoutRender = val internal toArray: Layout -> TaggedText[] - val internal emitL: (TaggedText -> unit) -> Layout -> unit + val internal toRichText: Layout -> RichText val internal mkNav: range -> TaggedText -> TaggedText diff --git a/src/Compiler/Interactive/fsi.fs b/src/Compiler/Interactive/fsi.fs index 42d714c4db8..b08cd26b90f 100644 --- a/src/Compiler/Interactive/fsi.fs +++ b/src/Compiler/Interactive/fsi.fs @@ -252,7 +252,7 @@ module internal Utilities = let reportError m = let report errorType err msg = - let error = err, msg + let error = err, RichText.mkText msg match errorType with | ErrorReportType.Warning -> warning (Error(error, m)) @@ -326,7 +326,7 @@ type ILMultiInMemoryAssemblyEmitEnv asmName /// Convert an ILAssemblyRef to a dynamic System.Type given the dynamic emit context - let convResolveAssemblyRef (asmref: ILAssemblyRef) qualifiedName = + let convResolveAssemblyRef (asmref: ILAssemblyRef) (tref: ILTypeRef) = let assembly = match resolveAssemblyRef asmref with | Some(Choice1Of2 path) -> @@ -339,27 +339,44 @@ type ILMultiInMemoryAssemblyEmitEnv let asmName = convAssemblyRef asmref FileSystem.AssemblyLoader.AssemblyLoad asmName - let typT = assembly.GetType qualifiedName + let typT = assembly.GetType tref.BasicQualifiedName match typT with - | null -> error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, asmref.QualifiedName), range0)) + | null -> + error ( + Error( + FSComp.SR.itemNotFoundDuringDynamicCodeGen ( + RichText.mkText "type", + richTextOfILTypeRef tref, + RichText.mkText asmref.QualifiedName + ), + range0 + ) + ) | res -> res /// Convert an Abstract IL type reference to System.Type let convTypeRefAux (tref: ILTypeRef) = - let qualifiedName = - (String.concat "+" (tref.Enclosing @ [ tref.Name ])).Replace(",", @"\,") - match tref.Scope with - | ILScopeRef.Assembly asmref -> convResolveAssemblyRef asmref qualifiedName + | ILScopeRef.Assembly asmref -> convResolveAssemblyRef asmref tref | ILScopeRef.Module _ | ILScopeRef.Local -> - let typT = Type.GetType qualifiedName + let typT = Type.GetType tref.BasicQualifiedName match typT with - | null -> error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, ""), range0)) + | null -> + error ( + Error( + FSComp.SR.itemNotFoundDuringDynamicCodeGen ( + RichText.mkText "type", + richTextOfILTypeRef tref, + RichText.mkText "" + ), + range0 + ) + ) | res -> res - | ILScopeRef.PrimaryAssembly -> convResolveAssemblyRef ilg.primaryAssemblyRef qualifiedName + | ILScopeRef.PrimaryAssembly -> convResolveAssemblyRef ilg.primaryAssemblyRef tref /// Convert an ILTypeRef to a dynamic System.Type given the dynamic emit context let convTypeRef (tref: ILTypeRef) = @@ -385,7 +402,14 @@ type ILMultiInMemoryAssemblyEmitEnv match res with | null -> error ( - Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", tspec.TypeRef.QualifiedName, tspec.Scope.QualifiedName), range0) + Error( + FSComp.SR.itemNotFoundDuringDynamicCodeGen ( + RichText.mkText "type", + richTextOfILTypeRef tspec.TypeRef, + RichText.mkText tspec.Scope.QualifiedName + ), + range0 + ) ) | _ -> res @@ -2804,7 +2828,7 @@ type internal FsiDynamicCompiler ) with | Null -> - let err = + let number, message = fsiOptions.DependencyProvider.CreatePackageManagerUnknownError( tcConfigB.compilerToolPaths, outputDir, @@ -2813,7 +2837,7 @@ type internal FsiDynamicCompiler reportError m ) - errorR (Error(err, m)) + errorR (Error((number, message), m)) istate | NonNull dependencyManager -> let directive d = @@ -3044,7 +3068,7 @@ type internal FsiDynamicCompiler ) if IsCompilerGeneratedName name then - invalidArg "name" (FSComp.SR.lexhlpIdentifiersContainingAtSymbolReserved () |> snd) + invalidArg "name" (FSComp.SR.lexhlpIdentifiersContainingAtSymbolReserved () |> snd).Text let istate, tys = importReflectionType istate (value.GetType()) let ty = List.head tys @@ -3877,7 +3901,13 @@ type FsiInteractionProcessor | "show" -> fsiConsolePrompt.ShowPrompt <- true | "hide" -> fsiConsolePrompt.ShowPrompt <- false | "skip" -> fsiConsolePrompt.SkipNext() - | _ -> error (Error((FSComp.SR.fsiInvalidDirective ("prompt", String.concat " " [ showPrompt ])), m)) + | _ -> + error ( + Error( + (FSComp.SR.fsiInvalidDirective (RichText.mkKeyword "prompt", RichText.mkText (String.concat " " [ showPrompt ]))), + m + ) + ) istate, Completed None @@ -3944,13 +3974,13 @@ type FsiInteractionProcessor match args with | [] -> fsiOptions.ShowHelp(m) | [ arg ] -> runhDirective diagnosticsLogger ctok istate arg - | _ -> warning (Error((FSComp.SR.fsiInvalidDirective ("help", String.concat " " args)), m)) + | _ -> warning (Error((FSComp.SR.fsiInvalidDirective (RichText.mkKeyword "help", RichText.mkText (String.concat " " args))), m)) istate, Completed None | ParsedHashDirective(c, hashArguments, m) -> let arg = (parsedHashDirectiveArguments hashArguments tcConfigB.langVersion) - warning (Error((FSComp.SR.fsiInvalidDirective (c, String.concat " " arg)), m)) + warning (Error((FSComp.SR.fsiInvalidDirective (RichText.mkKeyword c, RichText.mkText (String.concat " " arg))), m)) istate, Completed None /// Most functions return a step status - this decides whether to continue and propagates the diff --git a/src/Compiler/Optimize/LowerLocalMutables.fs b/src/Compiler/Optimize/LowerLocalMutables.fs index 169c658c4bc..9d969d8fd34 100644 --- a/src/Compiler/Optimize/LowerLocalMutables.fs +++ b/src/Compiler/Optimize/LowerLocalMutables.fs @@ -175,7 +175,7 @@ let TransformImplFile g amap implFile = implFile else for fv in localsToTransform do - warning (Error(FSComp.SR.abImplicitHeapAllocation(fv.DisplayName), fv.Range)) + warning (Error(FSComp.SR.abImplicitHeapAllocation(richTextOfValName g fv), fv.Range)) let heapValMap = [ for localVal in localsToTransform do diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index f6d1efe5019..e8b76d1044d 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -640,7 +640,7 @@ let GetInfoForLocalValue cenv env (v: Val) m = | Some vval -> vval | None -> if not v.IsDispatchSlot && v.ShouldInline then - errorR(Error(FSComp.SR.optValueMarkedInlineButWasNotBoundInTheOptEnv(fullDisplayTextOfValRef (mkLocalValRef v)), m)) + errorR(Error(FSComp.SR.optValueMarkedInlineButWasNotBoundInTheOptEnv(richTextOfQualifiedValRef (mkLocalValRef v)), m)) UnknownValInfo let TryGetInfoForCcu env (ccu: CcuThunk) = env.globalModuleInfos.TryFind(ccu.AssemblyName) @@ -774,7 +774,7 @@ let MakeValueInfoForValue g m vref vinfo = #if DEBUG let rec check x = match x with - | ValValue (vref2, detail) -> if valRefEq g vref vref2 then error(Error(FSComp.SR.optRecursiveValValue(showL(exprValueInfoL g vinfo)), m)) else check detail + | ValValue (vref2, detail) -> if valRefEq g vref vref2 then error(Error(FSComp.SR.optRecursiveValValue(RichText.mkText (showL(exprValueInfoL g vinfo))), m)) else check detail | SizeValue (_n, detail) -> check detail | _ -> () check vinfo @@ -3302,11 +3302,11 @@ and OptimizeVal cenv env expr (v: ValRef, m) = if cenv.settings.alwaysInline then if v.ShouldInline then match valInfoForVal.ValExprInfo with - | UnknownValue -> error(Error(FSComp.SR.optFailedToInlineValue(v.DisplayName), m)) - | _ -> warning(Error(FSComp.SR.optFailedToInlineValue(v.DisplayName), m)) + | UnknownValue -> error(Error(FSComp.SR.optFailedToInlineValue(richTextOfValName g v.Deref), m)) + | _ -> warning(Error(FSComp.SR.optFailedToInlineValue(richTextOfValName g v.Deref), m)) if v.InlineIfLambda then - warning(Error(FSComp.SR.optFailedToInlineSuggestedValue(v.DisplayName), m)) + warning(Error(FSComp.SR.optFailedToInlineSuggestedValue(richTextOfValName g v.Deref), m)) expr, (AddValEqualityInfo g m v { Info=valInfoForVal.ValExprInfo @@ -4558,7 +4558,7 @@ and OptimizeBinding cenv isRec env (TBind(vref, expr, spBind)) = // excluded, as they are expanded transitively when the outer member is inlined. let fvs = freeInExpr CollectLocals exprOptimized if fvs.FreeLocals |> Zset.exists (fun v -> not v.ShouldInline && not (canAccessFromEverywhere v.Accessibility)) then - errorR(Error(FSComp.SR.optValueMarkedInlineButIncomplete(vref.DisplayName), vref.Range)) + errorR(Error(FSComp.SR.optValueMarkedInlineButIncomplete(richTextOfValName g vref), vref.Range)) let env = BindInternalLocalVal cenv vref (mkValInfo einfo vref) env diff --git a/src/Compiler/Service/FSharpCheckerResults.fs b/src/Compiler/Service/FSharpCheckerResults.fs index 3d029caa33a..34ed0788337 100644 --- a/src/Compiler/Service/FSharpCheckerResults.fs +++ b/src/Compiler/Service/FSharpCheckerResults.fs @@ -2392,7 +2392,7 @@ type internal TypeCheckInfo let tip = PrintUtilities.squashToWidth width tip - let tip = LayoutRender.toArray tip + let tip = LayoutRender.toRichText tip ToolTipText.ToolTipText [ ToolTipElement.Single(tip, FSharpXmlDoc.None) ] | [] -> @@ -2415,7 +2415,7 @@ type internal TypeCheckInfo for line in lines -> let tip = wordL (TaggedText.tagStringLiteral line) let tip = PrintUtilities.squashToWidth width tip - let tip = LayoutRender.toArray tip + let tip = LayoutRender.toRichText tip ToolTipElement.Single(tip, FSharpXmlDoc.None) ] @@ -2960,7 +2960,7 @@ module internal ParseAndCheckFile = // the formatting of types in it may change (for example, 'a to obj) // // So we'll create a diagnostic later, but cache the FormatCore message now - diagnostic.Exception.Data["CachedFormatCore"] <- diagnostic.FormatCore(flatErrors, suggestNamesForErrors) + diagnostic.Exception.Data["CachedFormatCore"] <- diagnostic.FormatRichCore(flatErrors, suggestNamesForErrors) diagnosticsCollector.Add(diagnostic) if diagnostic.Severity = FSharpDiagnosticSeverity.Error then @@ -3510,7 +3510,7 @@ type FSharpCheckFileResults match Tokenization.FSharpKeywords.KeywordsDescriptionLookup kw with | None -> () | Some kwDescription -> - let kwText = kw |> TaggedText.tagKeyword |> wordL |> LayoutRender.toArray + let kwText = kw |> TaggedText.tagKeyword |> wordL |> LayoutRender.toRichText yield ToolTipElement.Single(kwText, FSharpXmlDoc.FromXmlText(Xml.XmlDoc([| kwDescription |], range0))) ] diff --git a/src/Compiler/Service/ServiceCompilerDiagnostics.fs b/src/Compiler/Service/ServiceCompilerDiagnostics.fs index 345c4771601..fb4bf719413 100644 --- a/src/Compiler/Service/ServiceCompilerDiagnostics.fs +++ b/src/Compiler/Service/ServiceCompilerDiagnostics.fs @@ -17,7 +17,7 @@ module CompilerDiagnostics = match diagnosticKind with | FSharpDiagnosticKind.AddIndexerDot -> FSComp.SR.addIndexerDot () | FSharpDiagnosticKind.ReplaceWithSuggestion s -> FSComp.SR.replaceWithSuggestion s - | FSharpDiagnosticKind.RemoveIndexerDot -> FSComp.SR.tcIndexNotationDeprecated () |> snd + | FSharpDiagnosticKind.RemoveIndexerDot -> (FSComp.SR.tcIndexNotationDeprecated () |> snd).Text let GetSuggestedNames (suggestionsF: FSharp.Compiler.DiagnosticsLogger.Suggestions) (unresolvedIdentifier: string) = let buffer = SuggestionBuffer(unresolvedIdentifier) diff --git a/src/Compiler/Service/ServiceDeclarationLists.fs b/src/Compiler/Service/ServiceDeclarationLists.fs index d8d63b4688a..e5d76901a02 100644 --- a/src/Compiler/Service/ServiceDeclarationLists.fs +++ b/src/Compiler/Service/ServiceDeclarationLists.fs @@ -38,14 +38,14 @@ open FSharp.Compiler.TypedTreeOps type ToolTipElementData = { Symbol: FSharpSymbol option - MainDescription: TaggedText[] + MainDescription: RichText XmlDoc: FSharpXmlDoc - TypeMapping: TaggedText[] list - Remarks: TaggedText[] option + TypeMapping: RichText list + Remarks: RichText option ParamName : string option } - static member internal Create(layout, xml, ?typeMapping, ?paramName, ?remarks, ?symbol) = - { MainDescription=layout; XmlDoc=xml; TypeMapping=defaultArg typeMapping []; ParamName=paramName; Remarks=remarks; Symbol = symbol } + static member internal Create(mainDescription, xml, ?typeMapping, ?paramName, ?remarks, ?symbol) = + { MainDescription=mainDescription; XmlDoc=xml; TypeMapping=defaultArg typeMapping []; ParamName=paramName; Remarks=remarks; Symbol = symbol } /// A single data tip display element [] @@ -58,8 +58,8 @@ type ToolTipElement = /// An error occurred formatting this element | CompositionError of errorText: string - static member Single(layout, xml, ?typeMapping, ?paramName, ?remarks, ?symbol) = - Group [ ToolTipElementData.Create(layout, xml, ?typeMapping=typeMapping, ?paramName=paramName, ?remarks=remarks, ?symbol = symbol) ] + static member Single(mainDescription, xml, ?typeMapping, ?paramName, ?remarks, ?symbol) = + Group [ ToolTipElementData.Create(mainDescription, xml, ?typeMapping=typeMapping, ?paramName=paramName, ?remarks=remarks, ?symbol = symbol) ] /// Information for building a data tip box. type ToolTipText = @@ -102,7 +102,7 @@ module DeclarationListHelpers = /// Generate the structured tooltip for a method info let FormatOverloadsToList (infoReader: InfoReader) m denv (item: ItemWithInst) minfos symbol (width: int option) : ToolTipElement = ToolTipFault |> Option.iter (fun msg -> - let exn = Error((0, msg), range0) + let exn = Error((0, RichText.mkText msg), range0) let ph = PhasedDiagnostic.Create(exn, BuildPhase.TypeCheck, FSharpDiagnosticSeverity.Error) simulateError ph) @@ -112,9 +112,9 @@ module DeclarationListHelpers = let xml = GetXmlCommentForMethInfoItem infoReader m item.Item minfo let tpsL = FormatTyparMapping denv prettyTyparInst let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - let tpsL = List.map toArray tpsL - ToolTipElementData.Create(layout, xml, tpsL, ?symbol = symbol) ] + let mainDescription = toRichText layout + let typeMapping = List.map toRichText tpsL + ToolTipElementData.Create(mainDescription, xml, typeMapping, ?symbol = symbol) ] ToolTipElement.Group layouts @@ -171,11 +171,11 @@ module DeclarationListHelpers = let prettyTyparInst, resL = layoutQualifiedValOrMember denv infoReader item.TyparInstantiation vref let remarks = OutputFullName displayFullName pubpathOfValRef fullDisplayTextOfValRefAsLayout vref let tpsL = FormatTyparMapping denv prettyTyparInst - let tpsL = List.map toArray tpsL + let typeMapping = List.map toRichText tpsL let resL = PrintUtilities.squashToWidth width resL - let resL = toArray resL - let remarks = toArray remarks - ToolTipElement.Single(resL, xml, tpsL, remarks=remarks, ?symbol = symbol) + let mainDescription = toRichText resL + let remarks = toRichText remarks + ToolTipElement.Single(mainDescription, xml, typeMapping, remarks=remarks, ?symbol = symbol) // Union tags (constructors) | Item.UnionCase(ucinfo, _) -> @@ -191,8 +191,8 @@ module DeclarationListHelpers = (if List.isEmpty recd then emptyL else layoutUnionCases denv infoReader ucinfo.TyconRef recd ^^ WordL.arrow) ^^ layoutType denv unionTy let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) // Active pattern tag inside the declaration (result) | Item.ActivePatternResult(apinfo, ty, idx, _) -> @@ -203,8 +203,8 @@ module DeclarationListHelpers = RightL.colon ^^ layoutType denv ty let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) // Active pattern tags | Item.ActivePatternCase apref -> @@ -222,19 +222,19 @@ module DeclarationListHelpers = let tpsL = FormatTyparMapping denv prettyTyparInst - let layout = toArray layout - let tpsL = List.map toArray tpsL - let remarks = toArray remarks - ToolTipElement.Single (layout, xml, tpsL, remarks=remarks, ?symbol = symbol) + let mainDescription = toRichText layout + let typeMapping = List.map toRichText tpsL + let remarks = toRichText remarks + ToolTipElement.Single (mainDescription, xml, typeMapping, remarks=remarks, ?symbol = symbol) // F# exception names | Item.ExnCase ecref -> let layout = layoutExnDef denv infoReader ecref let layout = PrintUtilities.squashToWidth width layout let remarks = OutputFullName displayFullName pubpathOfTyconRef fullDisplayTextOfExnRefAsLayout ecref - let layout = toArray layout - let remarks = toArray remarks - ToolTipElement.Single (layout, xml, remarks=remarks, ?symbol = symbol) + let mainDescription = toRichText layout + let remarks = toRichText remarks + ToolTipElement.Single (mainDescription, xml, remarks=remarks, ?symbol = symbol) | Item.RecdField rfinfo when rfinfo.TyconRef.IsFSharpException -> let ty, _ = PrettyTypes.PrettifyType g rfinfo.FieldType @@ -245,8 +245,8 @@ module DeclarationListHelpers = RightL.colon ^^ layoutType denv ty let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, paramName = id, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, paramName = id, ?symbol = symbol) // F# record field names | Item.RecdField rfinfo -> @@ -264,8 +264,8 @@ module DeclarationListHelpers = | Some lit -> try WordL.equals ^^ layoutConst denv.g ty lit with _ -> emptyL ) let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) | Item.UnionCaseField (ucinfo, fieldIndex) -> let rfield = ucinfo.UnionCase.GetFieldByIndex(fieldIndex) @@ -277,8 +277,8 @@ module DeclarationListHelpers = RightL.colon ^^ layoutType denv fieldTy let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, paramName = id.idText, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, paramName = id.idText, ?symbol = symbol) // Not used | Item.NewDef id -> @@ -286,8 +286,8 @@ module DeclarationListHelpers = wordL (tagText (FSComp.SR.typeInfoPatternVariable())) ^^ wordL (tagUnknownEntity id.idText) let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) // .NET fields | Item.ILField finfo -> @@ -306,8 +306,8 @@ module DeclarationListHelpers = try layoutConst denv.g (finfo.FieldType(infoReader.amap, m)) (CheckExpressions.TcFieldInit m v) with _ -> emptyL ) let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) // .NET events | Item.Event einfo -> @@ -321,15 +321,15 @@ module DeclarationListHelpers = RightL.colon ^^ layoutType denv eventTy let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) // F# and .NET properties | Item.Property(info = pinfo :: _) -> let layout = prettyLayoutOfPropInfoFreeStyle g amap m denv pinfo let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) // Custom operations in queries | Item.CustomOperation (customOpName, usageText, Some minfo) -> @@ -342,7 +342,7 @@ module DeclarationListHelpers = RightL.colon ^^ ( match usageText() with - | Some t -> wordL (tagText t) + | Some t -> wordL (tagText t.Text) | None -> let argTys = ParamNameAndTypesOfUnaryCustomOperation g minfo |> List.map (fun (ParamNameAndType(_, ty)) -> ty) let argTys, _ = PrettyTypes.PrettifyTypes g argTys @@ -355,8 +355,8 @@ module DeclarationListHelpers = wordL (tagMethod minfo.DisplayName) let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) // F# constructors and methods | Item.CtorGroup(_, minfos) @@ -373,8 +373,8 @@ module DeclarationListHelpers = layoutType denv delFuncTy ^^ RightL.rightParen let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single(layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single(mainDescription, xml, ?symbol = symbol) // Types. | Item.Types(_, TType_app(tcref, _, _) :: _) @@ -389,22 +389,22 @@ module DeclarationListHelpers = let layout = layoutTyconDefn denv infoReader ad m (* width *) tcref.Deref let layout = PrintUtilities.squashToWidth width layout let remarks = OutputFullName displayFullName pubpathOfTyconRef fullDisplayTextOfTyconRefAsLayout tcref - let layout = toArray layout - let remarks = toArray remarks - ToolTipElement.Single (layout, xml, remarks=remarks, ?symbol = symbol) + let mainDescription = toRichText layout + let remarks = toRichText remarks + ToolTipElement.Single (mainDescription, xml, remarks=remarks, ?symbol = symbol) // Type variables | Item.TypeVar (_, typar) -> let layout = prettyLayoutOfTypar denv typar let layout = PrintUtilities.squashToWidth width layout - ToolTipElement.Single (toArray layout, xml, ?symbol = symbol) + ToolTipElement.Single (toRichText layout, xml, ?symbol = symbol) // Traits | Item.Trait traitInfo -> let denv = { denv with shortConstraints = false} let layout = prettyLayoutOfTrait denv traitInfo let layout = PrintUtilities.squashToWidth width layout - ToolTipElement.Single (toArray layout, xml, ?symbol = symbol) + ToolTipElement.Single (toRichText layout, xml, ?symbol = symbol) // F# Modules and namespaces | Item.ModuleOrNamespaces(modref :: _ as modrefs) -> @@ -435,21 +435,21 @@ module DeclarationListHelpers = ( if not (List.isEmpty namesToAdd) then SepL.lineBreak ^^ - List.fold ( fun s (i, txt) -> + List.fold ( fun s (i, txt: string) -> s ^^ SepL.lineBreak ^^ - wordL (tagText ((if i = 0 then FSComp.SR.typeInfoFromFirst else FSComp.SR.typeInfoFromNext) txt)) + wordL (tagText (if i = 0 then FSComp.SR.typeInfoFromFirst txt else FSComp.SR.typeInfoFromNext txt)) ) emptyL namesToAdd else emptyL ) let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) else let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, ?symbol = symbol) | Item.AnonRecdField(anon, argTys, i, _) -> let argTy = argTys[i] @@ -461,8 +461,8 @@ module DeclarationListHelpers = RightL.colon ^^ layoutType denv argTy let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, FSharpXmlDoc.None, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, FSharpXmlDoc.None, ?symbol = symbol) // Named parameters | Item.OtherName (ident = Some id; argType = argTy) -> @@ -473,8 +473,8 @@ module DeclarationListHelpers = RightL.colon ^^ layoutType denv argTy let layout = PrintUtilities.squashToWidth width layout - let layout = toArray layout - ToolTipElement.Single (layout, xml, paramName = id.idText, ?symbol = symbol) + let mainDescription = toRichText layout + ToolTipElement.Single (mainDescription, xml, paramName = id.idText, ?symbol = symbol) | Item.SetterArg (_, item) -> FormatItemDescriptionToToolTipElement displayFullName infoReader ad m denv (ItemWithNoInst item) symbol width @@ -526,7 +526,7 @@ module DeclarationListHelpers = /// Represents one parameter for one method (or other item) in a group. [] -type MethodGroupItemParameter(name: string, canonicalTypeTextForSorting: string, display: TaggedText[], isOptional: bool) = +type MethodGroupItemParameter(name: string, canonicalTypeTextForSorting: string, display: RichText, isOptional: bool) = /// The name of the parameter. member _.ParameterName = name @@ -558,7 +558,7 @@ module internal DescriptionListsImpl = let PrettyParamOfRecdField g denv (f: RecdField) = let display = prettyLayoutOfType denv f.FormalType - let display = toArray display + let display = toRichText display MethodGroupItemParameter( name = f.DisplayNameCore, canonicalTypeTextForSorting = printCanonicalizedTypeName g denv f.FormalType, @@ -572,7 +572,7 @@ module internal DescriptionListsImpl = initial.Display else let display = layoutOfParamData denv (ParamData(false, false, false, NotOptional, NoCallerInfo, Some f.Id, ReflectedArgInfo.None, f.FormalType)) - toArray display + toRichText display MethodGroupItemParameter( name=initial.ParameterName, @@ -582,7 +582,7 @@ module internal DescriptionListsImpl = let ParamOfParamData g denv (ParamData(_isParamArrayArg, _isInArg, _isOutArg, optArgInfo, _callerInfo, nmOpt, _reflArgInfo, pty) as paramData) = let display = layoutOfParamData denv paramData - let display = toArray display + let display = toRichText display MethodGroupItemParameter( name = (match nmOpt with None -> "" | Some pn -> pn.idText), canonicalTypeTextForSorting = printCanonicalizedTypeName g denv pty, @@ -629,7 +629,7 @@ module internal DescriptionListsImpl = let prettyParams = (paramInfo, prettyParamTys, prettyParamTysL) |||> List.map3 (fun (nm, isOptArg, paramPrefix) tauTy tyL -> let display = paramPrefix ^^ tyL - let display = toArray display + let display = toRichText display MethodGroupItemParameter( name = nm, canonicalTypeTextForSorting = printCanonicalizedTypeName g denv tauTy, @@ -649,7 +649,7 @@ module internal DescriptionListsImpl = let parameters = (prettyParamTys, prettyParamTysL) ||> List.map2 (fun paramTy tyL -> - let display = toArray tyL + let display = toRichText tyL MethodGroupItemParameter( name = "", canonicalTypeTextForSorting = printCanonicalizedTypeName g denv paramTy, @@ -676,7 +676,7 @@ module internal DescriptionListsImpl = let spName = sp.PUntaint((fun sp -> sp.Name), m) let spOpt = sp.PUntaint((fun sp -> sp.IsOptional), m) let display = (if spOpt then SepL.questionMark else emptyL) ^^ wordL (tagParameter spName) ^^ RightL.colon ^^ spKind - let display = toArray display + let display = toRichText display MethodGroupItemParameter( name = spName, canonicalTypeTextForSorting = showL spKind, @@ -1023,7 +1023,7 @@ type DeclarationListItem(textInDeclList: string, textInCode: string, fullName: s member _.Description = match kind, info with | CompletionItemKind.SuggestedName, _ -> - ToolTipText [ ToolTipElement.Single ([| tagText (FSComp.SR.suggestedName()) |], FSharpXmlDoc.None) ] + ToolTipText [ ToolTipElement.Single (RichText.mkText (FSComp.SR.suggestedName()), FSharpXmlDoc.None) ] | _, Choice1Of2 (items: CompletionItem list, infoReader, ad, m, denv) -> ToolTipText(items |> List.map (fun x -> FormatStructuredDescriptionOfItem true infoReader ad m denv x.ItemWithInst None None)) | _, Choice2Of2 result -> @@ -1272,7 +1272,7 @@ type DeclarationListInfo(declarations: DeclarationListItem[], isForType: bool, i // Note: instances of this type do not hold any references to any compiler resources. [] type MethodGroupItem(description: ToolTipText, xmlDoc: FSharpXmlDoc, - returnType: TaggedText[], parameters: MethodGroupItemParameter[], + returnType: RichText, parameters: MethodGroupItemParameter[], hasParameters: bool, hasParamArrayArg: bool, staticParameters: MethodGroupItemParameter[]) = /// The description representation for the method (or other item) @@ -1365,10 +1365,10 @@ type MethodGroup( name: string, unsortedMethods: MethodGroupItem[] ) = #endif | _ -> true - let prettyRetTyL = toArray prettyRetTyL + let returnType = toRichText prettyRetTyL MethodGroupItem( description = description, - returnType = prettyRetTyL, + returnType = returnType, xmlDoc = GetXmlCommentForItem infoReader m flatItem, parameters = (prettyParams |> Array.ofList), hasParameters = hasStaticParameters, diff --git a/src/Compiler/Service/ServiceDeclarationLists.fsi b/src/Compiler/Service/ServiceDeclarationLists.fsi index fbf74a4ab75..a81764dfa0d 100644 --- a/src/Compiler/Service/ServiceDeclarationLists.fsi +++ b/src/Compiler/Service/ServiceDeclarationLists.fsi @@ -19,21 +19,21 @@ type public ToolTipElementData = { Symbol: FSharpSymbol option - MainDescription: TaggedText[] + MainDescription: RichText XmlDoc: FSharpXmlDoc /// typar instantiation text, to go after xml - TypeMapping: TaggedText[] list + TypeMapping: RichText list /// Extra text, goes at the end - Remarks: TaggedText[] option + Remarks: RichText option /// Parameter name ParamName: string option } - static member internal Create: layout: TaggedText[] * xml: FSharpXmlDoc * ?typeMapping: TaggedText[] list * ?paramName: string * ?remarks: TaggedText[] * ?symbol: FSharpSymbol -> ToolTipElementData + static member internal Create: mainDescription: RichText * xml: FSharpXmlDoc * ?typeMapping: RichText list * ?paramName: string * ?remarks: RichText * ?symbol: FSharpSymbol -> ToolTipElementData /// A single tool tip display element // @@ -48,7 +48,7 @@ type public ToolTipElement = /// An error occurred formatting this element | CompositionError of errorText: string - static member Single: layout: TaggedText[] * xml: FSharpXmlDoc * ?typeMapping: TaggedText[] list * ?paramName: string * ?remarks: TaggedText[] * ?symbol: FSharpSymbol -> ToolTipElement + static member Single: mainDescription: RichText * xml: FSharpXmlDoc * ?typeMapping: RichText list * ?paramName: string * ?remarks: RichText * ?symbol: FSharpSymbol -> ToolTipElement /// Information for building a tool tip box. // @@ -184,7 +184,7 @@ type public MethodGroupItemParameter = /// The representation for the parameter including its name, its type and visual indicators of other /// information such as whether it is optional. - member Display: TaggedText[] + member Display: RichText /// Is the parameter optional member IsOptional: bool @@ -201,7 +201,7 @@ type public MethodGroupItem = member Description: ToolTipText /// The tagged text for the return type for the method (or other item) - member ReturnTypeText: TaggedText[] + member ReturnTypeText: RichText /// The parameters of the method in the overload set member Parameters: MethodGroupItemParameter[] diff --git a/src/Compiler/Symbols/FSharpDiagnostic.fs b/src/Compiler/Symbols/FSharpDiagnostic.fs index 06097f35ad0..37cc6ed3698 100644 --- a/src/Compiler/Symbols/FSharpDiagnostic.fs +++ b/src/Compiler/Symbols/FSharpDiagnostic.fs @@ -131,11 +131,12 @@ module ExtendedData = open ExtendedData -type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, defaultSeverity: FSharpDiagnosticSeverity, message: string, subcategory: string, errorNum: int, numberPrefix: string, extendedData: IFSharpDiagnosticExtendedData option) = +type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, defaultSeverity: FSharpDiagnosticSeverity, message: RichText, subcategory: string, errorNum: int, numberPrefix: string, extendedData: IFSharpDiagnosticExtendedData option) = member _.Range = m member _.Severity = severity member _.DefaultSeverity = defaultSeverity - member _.Message = message + member _.Message = message.Text + member _.RichMessage = message member _.Subcategory = subcategory member _.ErrorNumber = errorNum member _.ErrorNumberPrefix = numberPrefix @@ -168,7 +169,7 @@ type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, defaultSever | FSharpDiagnosticSeverity.Error -> "error" | FSharpDiagnosticSeverity.Info -> "info" | FSharpDiagnosticSeverity.Hidden -> "hidden" - sprintf "%s (%d,%d)-(%d,%d) %s %s %s" fileName s.Line (s.Column + 1) e.Line (e.Column + 1) subcategory severity message + sprintf "%s (%d,%d)-(%d,%d) %s %s %s" fileName s.Line (s.Column + 1) e.Line (e.Column + 1) subcategory severity message.Text /// Decompose a warning or error into parts: position, severity, message, error number static member CreateFromException(diagnostic: PhasedDiagnostic, suggestNames: bool, flatErrors: bool, symbolEnv: SymbolEnv option) = @@ -228,8 +229,8 @@ type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, defaultSever let msg = match diagnostic.Exception.Data["CachedFormatCore"] with - | :? string as message -> message - | _ -> diagnostic.FormatCore(flatErrors, suggestNames) + | :? RichText as message -> message + | _ -> diagnostic.FormatRichCore(flatErrors, suggestNames) let errorNum = diagnostic.Number let m = match diagnostic.Range with Some m -> m.ApplyLineDirectives() | None -> range0 @@ -239,7 +240,12 @@ type FSharpDiagnostic(m: range, severity: FSharpDiagnosticSeverity, defaultSever static member NormalizeErrorString(text) = NormalizeErrorString(text) - static member Create(severity, message, number, range, ?numberPrefix, ?subcategory) = + static member Create(severity, message: string, number, range, ?numberPrefix, ?subcategory) = + let subcategory = defaultArg subcategory BuildPhaseSubcategory.TypeCheck + let numberPrefix = defaultArg numberPrefix "FS" + FSharpDiagnostic(range, severity, severity, RichText.mkText message, subcategory, number, numberPrefix, None) + + static member Create(severity, message: RichText, number, range, ?numberPrefix, ?subcategory) = let subcategory = defaultArg subcategory BuildPhaseSubcategory.TypeCheck let numberPrefix = defaultArg numberPrefix "FS" FSharpDiagnostic(range, severity, severity, message, subcategory, number, numberPrefix, None) diff --git a/src/Compiler/Symbols/FSharpDiagnostic.fsi b/src/Compiler/Symbols/FSharpDiagnostic.fsi index 35b96efe629..124506ca6c6 100644 --- a/src/Compiler/Symbols/FSharpDiagnostic.fsi +++ b/src/Compiler/Symbols/FSharpDiagnostic.fsi @@ -202,6 +202,10 @@ type FSharpDiagnostic = /// Gets the message for the diagnostic member Message: string + /// Gets the message for the diagnostic as parts classified by their kind, e.g. so that tooling is + /// able to render it with colors. Message is the text of all parts concatenated. + member RichMessage: RichText + /// Gets the subcategory for the diagnostic member Subcategory: string @@ -228,6 +232,17 @@ type FSharpDiagnostic = ?subcategory: string -> FSharpDiagnostic + /// Creates a diagnostic whose message parts are classified by their kind, e.g. so that tooling is + /// able to render it with colors + static member Create: + severity: FSharpDiagnosticSeverity * + message: RichText * + number: int * + range: range * + ?numberPrefix: string * + ?subcategory: string -> + FSharpDiagnostic + static member internal CreateFromException: diagnostic: PhasedDiagnostic * suggestNames: bool * flatErrors: bool * symbolEnv: SymbolEnv option -> FSharpDiagnostic diff --git a/src/Compiler/Symbols/Symbols.fs b/src/Compiler/Symbols/Symbols.fs index 2ac5b309e2a..5d18fb864cb 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -2776,11 +2776,11 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = prefix + x.LogicalName with _ -> "??" - member x.FormatLayout (displayContext: FSharpDisplayContext) = + member x.FormatRichText (displayContext: FSharpDisplayContext) = match x.IsMember, d with | true, V v -> NicePrint.prettyLayoutOfMemberNoInstShort { (displayContext.Contents cenv.g) with showMemberContainers=true } v.Deref - |> LayoutRender.toArray + |> LayoutRender.toRichText | _,_ -> checkIsResolved() let ty = @@ -2793,9 +2793,9 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = mkIteratedFunTy cenv.g (List.map (mkRefTupledTy cenv.g) argTysl) retTy | V v -> v.TauType NicePrint.prettyLayoutOfTypeNoCx (displayContext.Contents cenv.g) ty - |> LayoutRender.toArray + |> LayoutRender.toRichText - member x.GetReturnTypeLayout (displayContext: FSharpDisplayContext) = + member x.GetReturnTypeRichText (displayContext: FSharpDisplayContext) = checkIsResolved() match d with | E _ @@ -2804,11 +2804,11 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | M m -> let retTy = m.GetFSharpReturnType(cenv.amap, range0, m.FormalMethodInst) NicePrint.layoutType (displayContext.Contents cenv.g) retTy - |> LayoutRender.toArray + |> LayoutRender.toRichText |> Some | V v -> NicePrint.layoutOfValReturnType (displayContext.Contents cenv.g) v - |> LayoutRender.toArray + |> LayoutRender.toRichText |> Some member x.GetValSignatureText (displayContext: FSharpDisplayContext, m: range) = @@ -3174,15 +3174,15 @@ type FSharpType(cenv, ty:TType) = protect <| fun () -> NicePrint.prettyStringOfTy (context.Contents cenv.g) ty - member _.FormatLayout(context: FSharpDisplayContext) = + member _.FormatRichText(context: FSharpDisplayContext) = protect <| fun () -> NicePrint.prettyLayoutOfTypeNoCx (context.Contents cenv.g) ty - |> LayoutRender.toArray + |> LayoutRender.toRichText - member _.FormatLayoutWithConstraints(context: FSharpDisplayContext) = + member _.FormatRichTextWithConstraints(context: FSharpDisplayContext) = protect <| fun () -> NicePrint.prettyLayoutOfType (context.Contents cenv.g) ty - |> LayoutRender.toArray + |> LayoutRender.toRichText override _.ToString() = protect <| fun () -> diff --git a/src/Compiler/Symbols/Symbols.fsi b/src/Compiler/Symbols/Symbols.fsi index 8ce2cf390b4..a01d72242a1 100644 --- a/src/Compiler/Symbols/Symbols.fsi +++ b/src/Compiler/Symbols/Symbols.fsi @@ -998,10 +998,10 @@ type FSharpMemberOrFunctionOrValue = member IsConstructor: bool /// Format the type using the rules of the given display context - member FormatLayout: displayContext: FSharpDisplayContext -> TaggedText[] + member FormatRichText: displayContext: FSharpDisplayContext -> RichText /// Format the type using the rules of the given display context - member GetReturnTypeLayout: displayContext: FSharpDisplayContext -> TaggedText[] option + member GetReturnTypeRichText: displayContext: FSharpDisplayContext -> RichText option /// Get the signature text to include this Symbol into an existing signature file. member GetValSignatureText: displayContext: FSharpDisplayContext * m: range -> string option @@ -1171,10 +1171,10 @@ type FSharpType = member FormatWithConstraints: context: FSharpDisplayContext -> string /// Format the type using the rules of the given display context - member FormatLayout: context: FSharpDisplayContext -> TaggedText[] + member FormatRichText: context: FSharpDisplayContext -> RichText /// Format the type - with constraints - using the rules of the given display context - member FormatLayoutWithConstraints: context: FSharpDisplayContext -> TaggedText[] + member FormatRichTextWithConstraints: context: FSharpDisplayContext -> RichText /// Instantiate generic type parameters in a type member Instantiate: (FSharpGenericParameter * FSharpType) list -> FSharpType diff --git a/src/Compiler/SyntaxTree/LexHelpers.fs b/src/Compiler/SyntaxTree/LexHelpers.fs index 67bb21789c3..8ad7501c7fe 100644 --- a/src/Compiler/SyntaxTree/LexHelpers.fs +++ b/src/Compiler/SyntaxTree/LexHelpers.fs @@ -291,7 +291,7 @@ let escape c = // Keyword table //----------------------------------------------------------------------- -exception ReservedKeyword of string * range +exception ReservedKeyword of RichText * range module Keywords = type private compatibilityMode = @@ -426,7 +426,7 @@ module Keywords = | true, v -> match v with | RESERVED -> - warning (ReservedKeyword(FSComp.SR.lexhlpIdentifierReserved (s), lexbuf.LexemeRange)) + warning (ReservedKeyword(FSComp.SR.lexhlpIdentifierReserved (RichText.mkKeyword s), lexbuf.LexemeRange)) IdentifierToken args lexbuf s | _ -> v | _ -> diff --git a/src/Compiler/SyntaxTree/LexHelpers.fsi b/src/Compiler/SyntaxTree/LexHelpers.fsi index 2adc11d5b13..f2dae34bfd8 100644 --- a/src/Compiler/SyntaxTree/LexHelpers.fsi +++ b/src/Compiler/SyntaxTree/LexHelpers.fsi @@ -105,7 +105,7 @@ val unicodeGraphLong: string -> LongUnicodeLexResult val escape: char -> char -exception ReservedKeyword of string * range +exception ReservedKeyword of RichText * range module Keywords = diff --git a/src/Compiler/SyntaxTree/ParseHelpers.fs b/src/Compiler/SyntaxTree/ParseHelpers.fs index dd74829bd2d..9605fce5f2d 100644 --- a/src/Compiler/SyntaxTree/ParseHelpers.fs +++ b/src/Compiler/SyntaxTree/ParseHelpers.fs @@ -798,7 +798,7 @@ let mkRecdField (lidwd: SynLongIdent) = lidwd, true // Used for 'do expr' in a class. let mkSynDoBinding (vis: SynAccess option, mDo, expr, m) = match vis with - | Some vis -> errorR (Error(FSComp.SR.parsDoCannotHaveVisibilityDeclarations (vis |> string), m)) + | Some vis -> errorR (Error(FSComp.SR.parsDoCannotHaveVisibilityDeclarations (RichText.mkKeyword (vis |> string)), m)) | None -> () SynBinding( diff --git a/src/Compiler/SyntaxTree/ParseHelpers.fsi b/src/Compiler/SyntaxTree/ParseHelpers.fsi index 44d0b317abf..bcaa5bc9b19 100644 --- a/src/Compiler/SyntaxTree/ParseHelpers.fsi +++ b/src/Compiler/SyntaxTree/ParseHelpers.fsi @@ -124,9 +124,9 @@ val grabXmlDoc: parseState: IParseState * optAttributes: SynAttributeList list * val ParseAssemblyCodeType: s: string -> reportLibraryOnlyFeatures: bool -> langVersion: LanguageVersion -> m: range -> ILType -val reportParseErrorAt: range -> (int * string) -> unit +val reportParseErrorAt: range -> (int * RichText) -> unit -val raiseParseErrorAt: range -> (int * string) -> 'a +val raiseParseErrorAt: range -> (int * RichText) -> 'a val mkSynMemberDefnGetSet: parseState: IParseState -> diff --git a/src/Compiler/SyntaxTree/WarnScopes.fs b/src/Compiler/SyntaxTree/WarnScopes.fs index a0d9a773714..729a4d31385 100644 --- a/src/Compiler/SyntaxTree/WarnScopes.fs +++ b/src/Compiler/SyntaxTree/WarnScopes.fs @@ -81,7 +81,7 @@ module internal WarnScopes = None | false, _ -> Some(s, s) - let parseInt (intString: string, argString) = + let parseInt (intString: string, argString: string) = match System.Int32.TryParse intString with | true, i -> Some i | false, _ -> @@ -143,7 +143,7 @@ module internal WarnScopes = | "warnon" -> argCaptures |> List.choose (mkDirective WarnCmd.Warnon) | "nowarn" -> argCaptures |> List.choose (mkDirective WarnCmd.Nowarn) | _ -> // like "warnonx" - errorR (Error(FSComp.SR.fsiInvalidDirective ($"#{dIdent}", ""), directiveRange)) + errorR (Error(FSComp.SR.fsiInvalidDirective (RichText.mkKeyword $"#{dIdent}", RichText.empty), directiveRange)) [] { @@ -244,7 +244,7 @@ module internal WarnScopes = | WarnScope.OpenOff m' :: _ | WarnScope.On m' :: _ -> if scopedNowarnFeatureIsSupported then - informationalWarning (Error(FSComp.SR.lexWarnDirectivesMustMatch ("#nowarn", m'.StartLine), m)) + informationalWarning (Error(FSComp.SR.lexWarnDirectivesMustMatch (RichText.mkKeyword "#nowarn", m'.StartLine), m)) warnScopeMap | scopes -> warnScopeMap.Add(n, WarnScope.OpenOff(mkScope m m) :: scopes) @@ -253,7 +253,7 @@ module internal WarnScopes = | WarnScope.OpenOff m' :: t -> warnScopeMap.Add(n, WarnScope.Off(mkScope m' m) :: t) | WarnScope.OpenOn m' :: _ | WarnScope.Off m' :: _ -> - warning (Error(FSComp.SR.lexWarnDirectivesMustMatch ("#warnon", m'.EndLine), m)) + warning (Error(FSComp.SR.lexWarnDirectivesMustMatch (RichText.mkKeyword "#warnon", m'.EndLine), m)) warnScopeMap | scopes -> warnScopeMap.Add(n, WarnScope.OpenOn(mkScope m m) :: scopes) diff --git a/src/Compiler/SyntaxTree/XmlDoc.fs b/src/Compiler/SyntaxTree/XmlDoc.fs index 7a381310ca8..3a987257a17 100644 --- a/src/Compiler/SyntaxTree/XmlDoc.fs +++ b/src/Compiler/SyntaxTree/XmlDoc.fs @@ -97,7 +97,7 @@ type XmlDoc(unprocessedLines: string[], range: range) = let nm = attr.Value if not (paramNames |> List.contains nm) then - warning (Error(FSComp.SR.xmlDocInvalidParameterName nm, doc.Range)) + warning (Error(FSComp.SR.xmlDocInvalidParameterName (RichText.mkParameter nm), doc.Range)) let paramsWithDocs = [ @@ -111,12 +111,12 @@ type XmlDoc(unprocessedLines: string[], range: range) = for p in paramNames do if not (paramsWithDocs |> List.contains p) then - warning (Error(FSComp.SR.xmlDocMissingParameter p, doc.Range)) + warning (Error(FSComp.SR.xmlDocMissingParameter (RichText.mkParameter p), doc.Range)) let duplicates = paramsWithDocs |> List.duplicates for d in duplicates do - warning (Error(FSComp.SR.xmlDocDuplicateParameter d, doc.Range)) + warning (Error(FSComp.SR.xmlDocDuplicateParameter (RichText.mkParameter d), doc.Range)) for pref in xml.Descendants(XName.op_Implicit "paramref") do match pref.Attribute(!!(XName.op_Implicit "name")) with @@ -125,7 +125,7 @@ type XmlDoc(unprocessedLines: string[], range: range) = let nm = attr.Value if not (paramNames |> List.contains nm) then - warning (Error(FSComp.SR.xmlDocInvalidParameterName nm, doc.Range)) + warning (Error(FSComp.SR.xmlDocInvalidParameterName (RichText.mkParameter nm), doc.Range)) with e -> warning (Error(FSComp.SR.xmlDocBadlyFormed e.Message, doc.Range)) diff --git a/src/Compiler/TypedTree/TypeProviders.fs b/src/Compiler/TypedTree/TypeProviders.fs index 5491ae2a322..92edd78568a 100644 --- a/src/Compiler/TypedTree/TypeProviders.fs +++ b/src/Compiler/TypedTree/TypeProviders.fs @@ -59,10 +59,10 @@ let GetTypeProviderImplementationTypes ( let exnMsg = e.Message match designTimeAssemblyPathOpt with | None -> - let msg = FSComp.SR.etProviderHasWrongDesignerAssemblyNoPath(attrName, designTimeAssemblyNameString, exnTypeName, exnMsg) + let msg = FSComp.SR.etProviderHasWrongDesignerAssemblyNoPath(RichText.mkClass attrName, RichText.mkText designTimeAssemblyNameString, RichText.mkText exnTypeName, RichText.mkText exnMsg) raise (TypeProviderError(msg, runTimeAssemblyFileName, m)) | Some designTimeAssemblyPath -> - let msg = FSComp.SR.etProviderHasWrongDesignerAssembly(attrName, designTimeAssemblyNameString, designTimeAssemblyPath, exnTypeName, exnMsg) + let msg = FSComp.SR.etProviderHasWrongDesignerAssembly(RichText.mkClass attrName, RichText.mkText designTimeAssemblyNameString, RichText.mkText designTimeAssemblyPath, RichText.mkText exnTypeName, RichText.mkText exnMsg) raise (TypeProviderError(msg, runTimeAssemblyFileName, m)) let designTimeAssemblyOpt = getTypeProviderAssembly (runTimeAssemblyFileName, designTimeAssemblyNameString, compilerToolPaths, raiseError) @@ -85,11 +85,11 @@ let GetTypeProviderImplementationTypes ( let exnMsg = e.Message match e with | :? FileLoadException -> - let msg = FSComp.SR.etProviderHasDesignerAssemblyDependency(designTimeAssemblyNameString, folder, exnTypeName, exnMsg) + let msg = FSComp.SR.etProviderHasDesignerAssemblyDependency(RichText.mkText designTimeAssemblyNameString, RichText.mkText folder, RichText.mkText exnTypeName, RichText.mkText exnMsg) raise (TypeProviderError(msg, runTimeAssemblyFileName, m)) | _ -> - let msg = FSComp.SR.etProviderHasDesignerAssemblyException(designTimeAssemblyNameString, folder, exnTypeName, exnMsg) + let msg = FSComp.SR.etProviderHasDesignerAssemblyException(RichText.mkText designTimeAssemblyNameString, RichText.mkText folder, RichText.mkText exnTypeName, RichText.mkText exnMsg) raise (TypeProviderError(msg, runTimeAssemblyFileName, m)) | None -> [] @@ -119,7 +119,7 @@ let CreateTypeProvider ( f () with err -> let e = StripException (StripException err) - raise (TypeProviderError(FSComp.SR.etTypeProviderConstructorException(e.Message), !! typeProviderImplementationType.FullName, m)) + raise (TypeProviderError(FSComp.SR.etTypeProviderConstructorException(RichText.mkText e.Message), !! typeProviderImplementationType.FullName, m)) let getReferencedAssemblies () = resolutionEnvironment.GetReferencedAssemblies() |> Array.distinct @@ -168,7 +168,7 @@ let GetTypeProvidersOfAssembly ( else Some (AssemblyName designTimeName) with :? ArgumentException -> - errorR(Error(FSComp.SR.etInvalidTypeProviderAssemblyName(runtimeAssemblyFilename, designTimeName), m)) + errorR(Error(FSComp.SR.etInvalidTypeProviderAssemblyName(RichText.mkText runtimeAssemblyFilename, RichText.mkText designTimeName), m)) None [ @@ -194,7 +194,7 @@ let GetTypeProvidersOfAssembly ( ] with :? TypeProviderError as tpe -> - tpe.Iter(fun e -> errorR(Error((e.Number, e.ContextualErrorMessage), m)) ) + tpe.Iter(fun e -> errorR(Error((e.Number, e.ContextualErrorRichMessage), m)) ) [] let providers = Tainted<_>.CreateAll(providerSpecs) @@ -208,7 +208,7 @@ let TryTypeMember<'T,'U>(st: Tainted<'T>, fullName, memberName, m, recover, f: ' try st.PApply (f, m) with :? TypeProviderError as tpe -> - tpe.Iter (fun e -> errorR(Error(FSComp.SR.etUnexpectedExceptionFromProvidedTypeMember(fullName, memberName, e.ContextualErrorMessage), m))) + tpe.Iter (fun e -> errorR(Error(FSComp.SR.etUnexpectedExceptionFromProvidedTypeMember(RichText.ofQualifiedTypeName fullName, RichText.mkMember memberName, e.ContextualErrorRichMessage), m))) st.PApplyNoFailure(fun _ -> recover) /// Try to access a member on a provided type, where the result is an array of values, catching and reporting errors @@ -216,7 +216,7 @@ let TryTypeMemberArray (st: Tainted<_>, fullName, memberName, m, f) = try st.PApplyArray(f, memberName, m) with :? TypeProviderError as tpe -> - tpe.Iter (fun e -> error(Error(FSComp.SR.etUnexpectedExceptionFromProvidedTypeMember(fullName, memberName, e.ContextualErrorMessage), m))) + tpe.Iter (fun e -> error(Error(FSComp.SR.etUnexpectedExceptionFromProvidedTypeMember(RichText.ofQualifiedTypeName fullName, RichText.mkMember memberName, e.ContextualErrorRichMessage), m))) [||] /// Try to access a member on a provided type, catching and reporting errors and checking the result is non-null, @@ -224,7 +224,7 @@ let TryTypeMemberNonNull<'T, 'U when 'U : not null and 'U : not struct>(st: Tain f: 'T -> 'U | null) : Tainted<'U> = match TryTypeMember<'T, 'U | null>(st, fullName, memberName, m, withNull recover, f) with | Tainted.Null -> - errorR(Error(FSComp.SR.etUnexpectedNullFromProvidedTypeMember(fullName, memberName), m)) + errorR(Error(FSComp.SR.etUnexpectedNullFromProvidedTypeMember(RichText.ofQualifiedTypeName fullName, RichText.mkMember memberName), m)) st.PApplyNoFailure(fun _ -> recover) | Tainted.NonNull r -> r @@ -234,7 +234,7 @@ let TryMemberMember (mi: Tainted<_>, typeName, memberName, memberMemberName, m, try mi.PApply (f, m) with :? TypeProviderError as tpe -> - tpe.Iter (fun e -> errorR(Error(FSComp.SR.etUnexpectedExceptionFromProvidedMemberMember(memberMemberName, typeName, memberName, e.ContextualErrorMessage), m))) + tpe.Iter (fun e -> errorR(Error(FSComp.SR.etUnexpectedExceptionFromProvidedMemberMember(RichText.mkMember memberMemberName, RichText.ofQualifiedTypeName typeName, RichText.mkMember memberName, e.ContextualErrorRichMessage), m))) mi.PApplyNoFailure(fun _ -> recover) /// Get the string to show for the name of a type provider @@ -248,12 +248,12 @@ let ValidateNamespaceName(name, typeProvider: Tainted, m, nsp: st | NonNull nsp -> if String.IsNullOrWhiteSpace nsp then // Empty namespace is not allowed - errorR(Error(FSComp.SR.etEmptyNamespaceOfTypeNotAllowed(name, typeProvider.PUntaint((fun tp -> tp.GetType().Name), m)), m)) + errorR(Error(FSComp.SR.etEmptyNamespaceOfTypeNotAllowed(RichText.ofQualifiedTypeName name, RichText.mkText (typeProvider.PUntaint((fun tp -> tp.GetType().Name), m))), m)) else for s in nsp.Split('.') do match s.IndexOfAny(PrettyNaming.IllegalCharactersInTypeAndNamespaceNames) with | -1 -> () - | n -> errorR(Error(FSComp.SR.etIllegalCharactersInNamespaceName(string s[n], s), m)) + | n -> errorR(Error(FSComp.SR.etIllegalCharactersInNamespaceName(RichText.mkText (string s[n]), RichText.mkNamespace s), m)) let bindingFlags = BindingFlags.DeclaredOnly ||| @@ -1032,26 +1032,26 @@ let CheckAndComputeProvidedNameProperty(m, st: Tainted, proj, prop let name : string | null = try st.PUntaint(proj, m) with :? TypeProviderError as tpe -> - let newError = tpe.MapText((fun msg -> FSComp.SR.etProvidedTypeWithNameException(propertyString, msg)), st.TypeProviderDesignation, m) + let newError = tpe.MapText((fun msg -> FSComp.SR.etProvidedTypeWithNameException(RichText.mkMember propertyString, msg)), st.TypeProviderDesignation, m) raise newError if String.IsNullOrEmpty name then - raise (TypeProviderError(FSComp.SR.etProvidedTypeWithNullOrEmptyName propertyString, st.TypeProviderDesignation, m)) + raise (TypeProviderError(FSComp.SR.etProvidedTypeWithNullOrEmptyName (RichText.mkMember propertyString), st.TypeProviderDesignation, m)) !!name /// Verify that this type provider has supported attributes let ValidateAttributesOfProvidedType (m, st: Tainted) = let fullName = CheckAndComputeProvidedNameProperty(m, st, (fun st -> st.FullName), "FullName") if TryTypeMember(st, fullName, "IsGenericType", m, false, fun st->st.IsGenericType) |> unmarshal then - errorR(Error(FSComp.SR.etMustNotBeGeneric fullName, m)) + errorR(Error(FSComp.SR.etMustNotBeGeneric (RichText.ofQualifiedTypeName fullName), m)) if TryTypeMember(st, fullName, "IsArray", m, false, fun st->st.IsArray) |> unmarshal then - errorR(Error(FSComp.SR.etMustNotBeAnArray fullName, m)) + errorR(Error(FSComp.SR.etMustNotBeAnArray (RichText.ofQualifiedTypeName fullName), m)) TryTypeMemberNonNull(st, fullName, "GetInterfaces", m, [||], fun st -> st.GetInterfaces()) |> ignore /// Verify that a provided type has the expected name let ValidateExpectedName m expectedPath expectedName (st: Tainted) = let name = CheckAndComputeProvidedNameProperty(m, st, (fun st -> st.Name), "Name") if name <> expectedName then - raise (TypeProviderError(FSComp.SR.etProvidedTypeHasUnexpectedName(expectedName, name), st.TypeProviderDesignation, m)) + raise (TypeProviderError(FSComp.SR.etProvidedTypeHasUnexpectedName(RichText.ofQualifiedTypeName expectedName, RichText.ofQualifiedTypeName name), st.TypeProviderDesignation, m)) let namespaceName = TryTypeMember(st, name, "Namespace", m, ("":_|null), fun st -> st.Namespace) |> unmarshal @@ -1071,7 +1071,7 @@ let ValidateExpectedName m expectedPath expectedName (st: Tainted) if path <> expectedPath then let expectedPath = String.Join(".", expectedPath) let path = String.Join(".", path) - errorR(Error(FSComp.SR.etProvidedTypeHasUnexpectedPath(expectedPath, path), m)) + errorR(Error(FSComp.SR.etProvidedTypeHasUnexpectedPath(RichText.mkNamespace expectedPath, RichText.mkNamespace path), m)) /// Eagerly validate a range of conditions on a provided type, after static instantiation (if any) has occurred let ValidateProvidedTypeAfterStaticInstantiation(m, st: Tainted, expectedPath: string[], expectedName: string) = @@ -1102,18 +1102,18 @@ let ValidateProvidedTypeAfterStaticInstantiation(m, st: Tainted, e // This needs to be a *shallow* exploration. Otherwise, as in Freebase sample the entire database could be explored. for mi in usedMembers do match mi with - | Tainted.Null -> errorR(Error(FSComp.SR.etNullMember fullName, m)) + | Tainted.Null -> errorR(Error(FSComp.SR.etNullMember (RichText.ofQualifiedTypeName fullName), m)) | Tainted.NonNull _ -> let memberName = TryMemberMember(mi, fullName, "Name", "Name", m, "invalid provided type member name", fun mi -> mi.Name) |> unmarshal if String.IsNullOrEmpty memberName then - errorR(Error(FSComp.SR.etNullOrEmptyMemberName fullName, m)) + errorR(Error(FSComp.SR.etNullOrEmptyMemberName (RichText.ofQualifiedTypeName fullName), m)) else let miDeclaringType = TryMemberMember(mi, fullName, memberName, "DeclaringType", m, (ProvidedType.CreateNoContext(typeof) |> withNull), fun mi -> mi.DeclaringType) match miDeclaringType with // Generated nested types may have null DeclaringType | Tainted.Null when mi.OfType().IsSome -> () | Tainted.Null -> - errorR(Error(FSComp.SR.etNullMemberDeclaringType(fullName, memberName), m)) + errorR(Error(FSComp.SR.etNullMemberDeclaringType(RichText.ofQualifiedTypeName fullName, RichText.mkMember memberName), m)) | Tainted.NonNull miDeclaringType -> let miDeclaringTypeFullName = TryMemberMember (miDeclaringType, fullName, memberName, "FullName", m, @@ -1122,14 +1122,14 @@ let ValidateProvidedTypeAfterStaticInstantiation(m, st: Tainted, e |> unmarshal if not (ProvidedType.TaintedEquals (st, miDeclaringType)) then - errorR(Error(FSComp.SR.etNullMemberDeclaringTypeDifferentFromProvidedType(fullName, memberName, miDeclaringTypeFullName), m)) + errorR(Error(FSComp.SR.etNullMemberDeclaringTypeDifferentFromProvidedType(RichText.ofQualifiedTypeName fullName, RichText.mkMember memberName, RichText.ofQualifiedTypeName miDeclaringTypeFullName), m)) match mi.OfType() with | Some mi -> let isPublic = TryMemberMember(mi, fullName, memberName, "IsPublic", m, true, fun mi->mi.IsPublic) |> unmarshal let isGenericMethod = TryMemberMember(mi, fullName, memberName, "IsGenericMethod", m, true, fun mi->mi.IsGenericMethod) |> unmarshal if not isPublic || isGenericMethod then - errorR(Error(FSComp.SR.etMethodHasRequirements(fullName, memberName), m)) + errorR(Error(FSComp.SR.etMethodHasRequirements(RichText.mkMember memberName, RichText.ofQualifiedTypeName fullName), m)) | None -> match mi.OfType() with | Some subType -> ValidateAttributesOfProvidedType(m, subType) @@ -1150,14 +1150,14 @@ let ValidateProvidedTypeAfterStaticInstantiation(m, st: Tainted, e let canWrite = TryMemberMember(pi, fullName, memberName, "CanWrite", m, expectWrite, fun pi-> pi.CanWrite) |> unmarshal match expectRead, canRead with | false, false | true, true-> () - | false, true -> errorR(Error(FSComp.SR.etPropertyCanReadButHasNoGetter(memberName, fullName), m)) - | true, false -> errorR(Error(FSComp.SR.etPropertyHasGetterButNoCanRead(memberName, fullName), m)) + | false, true -> errorR(Error(FSComp.SR.etPropertyCanReadButHasNoGetter(RichText.mkMember memberName, RichText.ofQualifiedTypeName fullName), m)) + | true, false -> errorR(Error(FSComp.SR.etPropertyHasGetterButNoCanRead(RichText.mkMember memberName, RichText.ofQualifiedTypeName fullName), m)) match expectWrite, canWrite with | false, false | true, true-> () - | false, true -> errorR(Error(FSComp.SR.etPropertyCanWriteButHasNoSetter(memberName, fullName), m)) - | true, false -> errorR(Error(FSComp.SR.etPropertyHasSetterButNoCanWrite(memberName, fullName), m)) + | false, true -> errorR(Error(FSComp.SR.etPropertyCanWriteButHasNoSetter(RichText.mkMember memberName, RichText.ofQualifiedTypeName fullName), m)) + | true, false -> errorR(Error(FSComp.SR.etPropertyHasSetterButNoCanWrite(RichText.mkMember memberName, RichText.ofQualifiedTypeName fullName), m)) if not canRead && not canWrite then - errorR(Error(FSComp.SR.etPropertyNeedsCanWriteOrCanRead(memberName, fullName), m)) + errorR(Error(FSComp.SR.etPropertyNeedsCanWriteOrCanRead(RichText.mkMember memberName, RichText.ofQualifiedTypeName fullName), m)) | None -> match mi.OfType() with @@ -1167,8 +1167,8 @@ let ValidateProvidedTypeAfterStaticInstantiation(m, st: Tainted, e let adder = TryMemberMember(ei, fullName, memberName, "GetAddMethod", m, null, fun ei-> ei.GetAddMethod()) let remover = TryMemberMember(ei, fullName, memberName, "GetRemoveMethod", m, null, fun ei-> ei.GetRemoveMethod()) match adder, remover with - | Tainted.Null, _ -> errorR(Error(FSComp.SR.etEventNoAdd(memberName, fullName), m)) - | _, Tainted.Null -> errorR(Error(FSComp.SR.etEventNoRemove(memberName, fullName), m)) + | Tainted.Null, _ -> errorR(Error(FSComp.SR.etEventNoAdd(RichText.mkMember memberName, RichText.ofQualifiedTypeName fullName), m)) + | _, Tainted.Null -> errorR(Error(FSComp.SR.etEventNoRemove(RichText.mkMember memberName, RichText.ofQualifiedTypeName fullName), m)) | _, _ -> () | None -> match mi.OfType() with @@ -1177,7 +1177,7 @@ let ValidateProvidedTypeAfterStaticInstantiation(m, st: Tainted, e match mi.OfType() with | Some _ -> () // TODO: Fields must be public, literals must have a value etc. | None -> - errorR(Error(FSComp.SR.etUnsupportedMemberKind(memberName, fullName), m)) + errorR(Error(FSComp.SR.etUnsupportedMemberKind(RichText.mkMember memberName, RichText.ofQualifiedTypeName fullName), m)) let ValidateProvidedTypeDefinition(m, st: Tainted, expectedPath: string[], expectedName: string) = @@ -1192,7 +1192,7 @@ let ValidateProvidedTypeDefinition(m, st: Tainted, expectedPath: s // This excludes, for example, types with '.' in them which would not be resolvable during name resolution. match expectedName.IndexOfAny(PrettyNaming.IllegalCharactersInTypeAndNamespaceNames) with | -1 -> () - | n -> errorR(Error(FSComp.SR.etIllegalCharactersInTypeName(string expectedName[n], expectedName), m)) + | n -> errorR(Error(FSComp.SR.etIllegalCharactersInTypeName(RichText.mkText (string expectedName[n]), RichText.ofQualifiedTypeName expectedName), m)) let staticParameters = st.PApplyWithProvider((fun (st, provider) -> st.GetStaticParameters provider), range=m) if staticParameters.PUntaint((fun a -> (nonNull a).Length), m) = 0 then @@ -1283,7 +1283,7 @@ let TryApplyProvidedMethod(methBeforeArgs: Tainted, staticAr | Tainted.NonNull methWithArguments -> let actualName = methWithArguments.PUntaint((fun x -> x.Name), m) if actualName <> mangledName then - error(Error(FSComp.SR.etProvidedAppliedMethodHadWrongName(methWithArguments.TypeProviderDesignation, mangledName, actualName), m)) + error(Error(FSComp.SR.etProvidedAppliedMethodHadWrongName(RichText.mkText methWithArguments.TypeProviderDesignation, RichText.mkMember mangledName, RichText.mkMember actualName), m)) Some methWithArguments @@ -1312,7 +1312,7 @@ let TryApplyProvidedType(typeBeforeArguments: Tainted, optGenerate let checkTypeName() = let expectedTypeNameAfterArguments = fullTypePathAfterArguments[fullTypePathAfterArguments.Length-1] if actualName <> expectedTypeNameAfterArguments then - error(Error(FSComp.SR.etProvidedAppliedTypeHadWrongName(typeWithArguments.TypeProviderDesignation, expectedTypeNameAfterArguments, actualName), m)) + error(Error(FSComp.SR.etProvidedAppliedTypeHadWrongName(RichText.mkText typeWithArguments.TypeProviderDesignation, RichText.ofQualifiedTypeName expectedTypeNameAfterArguments, RichText.ofQualifiedTypeName actualName), m)) Some (typeWithArguments, checkTypeName) /// Given a mangled name reference to a non-nested provided type, resolve it. @@ -1324,7 +1324,7 @@ let TryLinkProvidedType(resolver: Tainted, moduleOrNamespace: str try PrettyNaming.DemangleProvidedTypeName typeLogicalName with PrettyNaming.InvalidMangledStaticArg piece -> - error(Error(FSComp.SR.etProvidedTypeReferenceInvalidText piece, range0)) + error(Error(FSComp.SR.etProvidedTypeReferenceInvalidText (RichText.mkText piece), range0)) let argSpecsTable = dict argNamesAndValues let typeBeforeArguments = ResolveProvidedType(resolver, range0, moduleOrNamespace, typeName) @@ -1368,15 +1368,15 @@ let TryLinkProvidedType(resolver: Tainted, moduleOrNamespace: str | "System.Char" -> box (char arg) | "System.Boolean" -> box (arg = "True") | "System.String" -> box (string arg) - | s -> error(Error(FSComp.SR.etUnknownStaticArgumentKind(s, typeLogicalName), range0)) + | s -> error(Error(FSComp.SR.etUnknownStaticArgumentKind(RichText.mkText s, RichText.ofQualifiedTypeName typeLogicalName), range0)) | _ -> if sp.PUntaint ((fun sp -> sp.IsOptional), range) then match sp.PUntaint((fun sp -> sp.RawDefaultValue), range) with - | null -> error (Error(FSComp.SR.etStaticParameterRequiresAValue (spName, typeBeforeArgumentsName, typeBeforeArgumentsName, spName), range0)) + | null -> error (Error(FSComp.SR.etStaticParameterRequiresAValue (RichText.mkParameter spName, RichText.ofQualifiedTypeName typeBeforeArgumentsName, RichText.ofQualifiedTypeName typeBeforeArgumentsName, RichText.mkParameter spName), range0)) | v -> v else - error(Error(FSComp.SR.etProvidedTypeReferenceMissingArgument spName, range0))) + error(Error(FSComp.SR.etProvidedTypeReferenceMissingArgument (RichText.mkParameter spName), range0))) match TryApplyProvidedType(typeBeforeArguments, None, staticArgs, range0) with @@ -1399,7 +1399,7 @@ let GetProvidedNamespaceAsPath (m, resolver: Tainted, namespaceNa | Null -> [] | NonNull namespaceName -> if namespaceName.Length = 0 then - errorR(Error(FSComp.SR.etEmptyNamespaceNotAllowed(DisplayNameOfTypeProvider(resolver.TypeProvider, m)), m)) + errorR(Error(FSComp.SR.etEmptyNamespaceNotAllowed(RichText.mkText (DisplayNameOfTypeProvider(resolver.TypeProvider, m))), m)) GetPartsOfNamespaceRecover namespaceName /// Get the parts of the name that encloses the .NET type including nested types. diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 1686f36aa28..78a07c081c1 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -508,11 +508,11 @@ type EntityFlags(flags: int64) = exception UndefinedName of depth: int * - error: (string -> string) * + error: (RichText -> RichText) * id: Ident * suggestions: Suggestions -exception InternalUndefinedItemRef of (string * string * string -> int * string) * string * string * string +exception InternalUndefinedItemRef of (string * string * string -> int * RichText) * string * string * string [] type ModuleOrNamespaceKind = @@ -1001,7 +1001,9 @@ type Entity = member x.CompilationPath = match x.CompilationPathOpt with | Some cpath -> cpath - | None -> error(Error(FSComp.SR.tastTypeOrModuleNotConcrete(x.LogicalName), x.Range)) + | None -> + let tag = if x.IsModuleOrNamespace then TextTag.Module else TextTag.Class + error(Error(FSComp.SR.tastTypeOrModuleNotConcrete(RichText.ofTag tag x.LogicalName), x.Range)) /// Get a table of fields for all the F#-defined record, struct and class fields in this type definition, including /// static fields, 'val' declarations and hidden fields from the compilation of implicit class constructions. diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 25149889328..98c4ab0e840 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -315,9 +315,9 @@ type EntityFlags = /// This bit is reserved for us in the pickle format, see pickle.fs, it's being listed here to stop it ever being used for anything else static member ReservedBitForPickleFormatTyconReprFlag: int64 -exception UndefinedName of depth: int * error: (string -> string) * id: Ident * suggestions: Suggestions +exception UndefinedName of depth: int * error: (RichText -> RichText) * id: Ident * suggestions: Suggestions -exception InternalUndefinedItemRef of (string * string * string -> int * string) * string * string * string +exception InternalUndefinedItemRef of (string * string * string -> int * RichText) * string * string * string [] type ModuleOrNamespaceKind = diff --git a/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs index 0d74adb8be2..36fb37643f1 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs @@ -457,7 +457,14 @@ module internal ExprFolding = not (c.FieldByIndex n).IsMutable && not (entityRefInThisAssembly g.compilingFSharpCore tcref) then - errorR (Error(FSComp.SR.tastRecursiveValuesMayNotAppearInConstructionOfType (tcref.LogicalName), m)) + errorR ( + Error( + FSComp.SR.tastRecursiveValuesMayNotAppearInConstructionOfType ( + richTextOfEntityRefName tcref tcref.LogicalName + ), + m + ) + ) mkUnionCaseFieldSet (access, c, tinst, n, e, m)))) @@ -477,8 +484,8 @@ module internal ExprFolding = errorR ( Error( FSComp.SR.tastRecursiveValuesMayNotBeAssignedToNonMutableField ( - fspec.rfield_id.idText, - tcref.LogicalName + RichText.mkField fspec.rfield_id.idText, + richTextOfEntityRefName tcref tcref.LogicalName ), m ) diff --git a/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fs b/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fs index 80f6bee3b5b..9606877a495 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fs @@ -1381,6 +1381,41 @@ module internal MemberRepresentation = else tagClass name + let richTextOfEntityRefName xref name = + RichText.ofTaggedText (tagEntityRefName xref name) + + let richTextOfEntityName (entity: Entity) name = + richTextOfEntityRefName (mkLocalEntityRef entity) name + + let richTextOfEntityRef (xref: EntityRef) = + richTextOfEntityRefName xref xref.DisplayName + + let richTextOfEntity (entity: Entity) = + richTextOfEntityName entity entity.DisplayName + + let tagValName g (v: Val) name = + let isDiscard (name: string) = name.StartsWithOrdinal "_" + + if v.IsMember then + if (arityOfVal v).HasNoArgs then + tagMember name + else + tagMethod name + elif isForallFunctionTy g v.Type && not (isDiscard v.DisplayNameCore) then + if IsOperatorDisplayName v.DisplayName then + tagOperator name + else + tagFunction name + elif not v.IsCompiledAsTopLevel && not (isDiscard v.DisplayNameCore) then + tagLocal name + elif v.IsModuleBinding then + tagModuleBinding name + else + tagUnknownEntity name + + let richTextOfValName g (v: Val) = + RichText.ofTaggedText (tagValName g v v.DisplayName) + let fullDisplayTextOfTyconRef (tcref: TyconRef) = fullNameOfEntityRef (fun tcref -> tcref.DisplayNameWithStaticParametersAndUnderscoreTypars) tcref @@ -1416,6 +1451,9 @@ module internal MemberRepresentation = let fullDisplayTextOfModRef r = fullNameOfEntityRef (fun eref -> eref.DemangledModuleOrNamespaceName) r + let fullDisplayTextOfModRefAsLayout r = + fullNameOfEntityRefAsLayout (fun eref -> eref.DemangledModuleOrNamespaceName) r + let fullDisplayTextOfTyconRefAsLayout tcref = fullNameOfEntityRefAsLayout (fun tcref -> tcref.DisplayNameWithStaticParametersAndUnderscoreTypars) tcref @@ -1473,6 +1511,20 @@ module internal MemberRepresentation = | ValueSome pathText -> pathText ^^ SepL.dot ^^ wordL n //pathText +.+ vref.DisplayName + // A qualified name is classified one component at a time: each name by what it names and each dot + // as punctuation. Splicing the flattened text into a message instead would classify the dots, and + // every component, as whatever the last component happens to be. + let richTextOfPath p = toRichText (layoutOfPath p) + + let richTextOfQualifiedModRef r = + toRichText (fullDisplayTextOfModRefAsLayout r) + + let richTextOfQualifiedTyconRef tcref = + toRichText (fullDisplayTextOfTyconRefAsLayout tcref) + + let richTextOfQualifiedValRef vref = + toRichText (fullDisplayTextOfValRefAsLayout vref) + let fullMangledPathToTyconRef (tcref: TyconRef) = match tcref with | ERefLocal _ -> diff --git a/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fsi b/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fsi index 5024964297e..0e9761fe5ea 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.FreeVars.fsi @@ -310,6 +310,27 @@ module internal MemberRepresentation = val tagEntityRefName: xref: EntityRef -> name: string -> TaggedText + /// A name of an entity as rich text, classified by the kind of entity it names. Use this only when + /// the name is not the entity's display name, e.g. its compiled or fully qualified one. + val richTextOfEntityRefName: xref: EntityRef -> name: string -> RichText + + /// A name of an entity as rich text, classified by the kind of entity it names. Use this only when + /// the name is not the entity's display name. + val richTextOfEntityName: entity: Entity -> name: string -> RichText + + /// The display name of an entity as rich text, classified by the kind of entity it is + val richTextOfEntityRef: xref: EntityRef -> RichText + + /// The display name of an entity as rich text, classified by the kind of entity it is + val richTextOfEntity: entity: Entity -> RichText + + /// The tag for the name of a value, by what kind of value it is. This is the choice the signature + /// printer makes, so that a name in a message reads the way it does in a signature. + val tagValName: g: TcGlobals -> v: Val -> name: string -> TaggedText + + /// The display name of a value as rich text, classified by what kind of value it is + val richTextOfValName: g: TcGlobals -> v: Val -> RichText + /// Return the full text for an item as we want it displayed to the user as a fully qualified entity val fullDisplayTextOfModRef: ModuleOrNamespaceRef -> string @@ -323,6 +344,19 @@ module internal MemberRepresentation = val fullDisplayTextOfTyconRefAsLayout: TyconRef -> Layout + /// A dotted path as rich text, classifying each component and each dot separately + val richTextOfPath: string list -> RichText + + /// The fully qualified name of a module or namespace, classifying each component and each dot + /// separately, so that a dot never reads as part of a name + val richTextOfQualifiedModRef: ModuleOrNamespaceRef -> RichText + + /// The fully qualified name of a type, classifying each component and each dot separately + val richTextOfQualifiedTyconRef: TyconRef -> RichText + + /// The fully qualified name of a value, classifying each component and each dot separately + val richTextOfQualifiedValRef: ValRef -> RichText + val fullDisplayTextOfExnRef: TyconRef -> string val fullDisplayTextOfExnRefAsLayout: TyconRef -> Layout diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs index 27522bcc7af..516c1010bec 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs @@ -623,16 +623,40 @@ module internal SignatureOps = match entity1.IsNamespace, entity2.IsNamespace, entity1.IsModule, entity2.IsModule with | true, true, _, _ -> () | true, _, _, true - | _, true, true, _ -> errorR (Error(FSComp.SR.tastNamespaceAndModuleWithSameNameInAssembly (textOfPath path2), entity2.Range)) + | _, true, true, _ -> + errorR (Error(FSComp.SR.tastNamespaceAndModuleWithSameNameInAssembly (richTextOfPath path2), entity2.Range)) | true, _, _, _ | _, true, _, _ -> - errorR (Error(FSComp.SR.tastNamespaceAndTypeWithSameNameInAssembly (textOfPath path2, entity2.LogicalName), entity2.Range)) + errorR ( + Error( + FSComp.SR.tastNamespaceAndTypeWithSameNameInAssembly ( + richTextOfPath path2, + richTextOfEntityName entity2 entity2.LogicalName + ), + entity2.Range + ) + ) | false, false, false, false -> - errorR (Error(FSComp.SR.tastDuplicateTypeDefinitionInAssembly (entity2.LogicalName, textOfPath path), entity2.Range)) - | false, false, true, true -> errorR (Error(FSComp.SR.tastTwoModulesWithSameNameInAssembly (textOfPath path2), entity2.Range)) + errorR ( + Error( + FSComp.SR.tastDuplicateTypeDefinitionInAssembly ( + richTextOfEntityName entity2 entity2.LogicalName, + richTextOfPath path + ), + entity2.Range + ) + ) + | false, false, true, true -> + errorR (Error(FSComp.SR.tastTwoModulesWithSameNameInAssembly (richTextOfPath path2), entity2.Range)) | _ -> errorR ( - Error(FSComp.SR.tastConflictingModuleAndTypeDefinitionInAssembly (entity2.LogicalName, textOfPath path), entity2.Range) + Error( + FSComp.SR.tastConflictingModuleAndTypeDefinitionInAssembly ( + richTextOfEntityName entity2 entity2.LogicalName, + richTextOfPath path + ), + entity2.Range + ) ) entity1 diff --git a/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs b/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs index 4b4f4ccee29..55e8e71b3f2 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs @@ -312,7 +312,7 @@ module internal XmlDocSignatures = let vtps = v.Typars |> Zset.ofList typarOrder if not (isFunTy g v.TauType) then - errorR (Error(FSComp.SR.activePatternIdentIsNotFunctionTyped (v.LogicalName), v.Range)) + errorR (Error(FSComp.SR.activePatternIdentIsNotFunctionTyped (RichText.mkActivePatternCase v.LogicalName), v.Range)) let argTys, resty = stripFunTy g vty diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index 4fe8eaf121f..5b64b10f600 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -33,7 +33,7 @@ open FSharp.Compiler.TcGlobals let verbose = false #endif -let ffailwith fileName str = +let ffailwith (fileName: string) (str: string) = let msg = FSComp.SR.pickleErrorReadingWritingMetadata (fileName, str) System.Diagnostics.Debug.Assert(false, msg) failwith msg @@ -2380,7 +2380,7 @@ let p_tyar_spec_data (x: Typar) st = let p_tyar_spec (x: Typar) st = //Disabled, workaround for bug 2721: if x.Rigidity <> TyparRigidity.Rigid then warning(Error(sprintf "p_tyar_spec: typar#%d is not rigid" x.Stamp, x.Range)) if x.IsFromError then - warning (Error((0, "p_tyar_spec: from error"), x.Range)) + warning (Error((0, RichText.mkText "p_tyar_spec: from error"), x.Range)) p_osgn_decl st.otypars p_tyar_spec_data x st diff --git a/src/Compiler/TypedTree/tainted.fs b/src/Compiler/TypedTree/tainted.fs index 1017d62ef62..34fc40528b0 100644 --- a/src/Compiler/TypedTree/tainted.fs +++ b/src/Compiler/TypedTree/tainted.fs @@ -23,33 +23,35 @@ type internal TypeProviderError errNum: int, tpDesignation: string, m: range, - errors: string list, + errors: RichText list, typeNameContext: string option, methodNameContext: string option ) = inherit Exception() - new((errNum, msg: string), tpDesignation,m) = + new((errNum, msg: RichText), tpDesignation,m) = TypeProviderError(errNum, tpDesignation, m, [msg]) - - new(errNum, tpDesignation, m, messages: seq) = + + new(errNum, tpDesignation, m, messages: seq) = TypeProviderError(errNum, tpDesignation, m, List.ofSeq messages, None, None) member _.Number = errNum member _.Range = m - override _.Message = + member _.RichMessage = match errors with | [text] -> text | inner -> // imitates old-fashioned behavior with merged text // usually should not fall into this case (only if someone takes Message directly instead of using Iter) inner - |> String.concat Environment.NewLine + |> RichText.concatWith (RichText.mkText Environment.NewLine) + + override this.Message = this.RichMessage.Text member _.MapText(f, tpDesignation, m) = - let (errNum: int), _ = f "" + let (errNum: int), _ = f RichText.empty TypeProviderError(errNum, tpDesignation, m, (Seq.map (f >> snd) errors)) member _.WithContext(typeNameContext:string, methodNameContext:string) = @@ -60,14 +62,21 @@ type internal TypeProviderError // TPE having type\method name as contextual information // without context: Type Provider 'TP' has reported the error: MSG // with context: Type Provider 'TP' has reported the error in method M of type T: MSG - member this.ContextualErrorMessage= + member this.ContextualErrorRichMessage = match typeNameContext, methodNameContext with | Some tc, Some mc -> - let _,msgWithPrefix = FSComp.SR.etProviderErrorWithContext(tpDesignation, tc, mc, this.Message) + let _,msgWithPrefix = + FSComp.SR.etProviderErrorWithContext( + RichText.mkText tpDesignation, + RichText.ofQualifiedTypeName tc, + RichText.mkMethod mc, + this.RichMessage) msgWithPrefix | _ -> - let _,msgWithPrefix = FSComp.SR.etProviderError(tpDesignation, this.Message) + let _,msgWithPrefix = FSComp.SR.etProviderError(RichText.mkText tpDesignation, this.RichMessage) msgWithPrefix + + member this.ContextualErrorMessage = this.ContextualErrorRichMessage.Text /// provides uniform way to handle plain and composite instances of TypeProviderError member this.Iter f = @@ -101,11 +110,11 @@ type internal Tainted<'T> (context: TaintedContext, value: 'T) = | :? TypeProviderError -> reraise() | :? AggregateException as ae -> let errNum,_ = FSComp.SR.etProviderError("", "") - let messages = [for e in ae.InnerExceptions -> if isNull e.InnerException then e.Message else (e.Message + ": " + e.GetBaseException().Message)] + let messages = [for e in ae.InnerExceptions -> RichText.mkText (if isNull e.InnerException then e.Message else (e.Message + ": " + e.GetBaseException().Message))] raise <| TypeProviderError(errNum, this.TypeProviderDesignation, range, messages) | e -> let errNum,_ = FSComp.SR.etProviderError("", "") - let error = if isNull e.InnerException then e.Message else (e.Message + ": " + e.GetBaseException().Message) + let error = RichText.mkText (if isNull e.InnerException then e.Message else (e.Message + ": " + e.GetBaseException().Message)) raise <| TypeProviderError((errNum, error), this.TypeProviderDesignation, range) member _.TypeProvider = Tainted<_>(context, context.TypeProvider) @@ -132,16 +141,16 @@ type internal Tainted<'T> (context: TaintedContext, value: 'T) = let u = this.Protect (fun x -> f (x, context.TypeProvider)) range Tainted(context, u) - member this.PApplyArray(f, methodName, range:range) = + member this.PApplyArray(f, methodName: string, range:range) = let a : 'U[] | null = this.Protect f range match a with - | Null -> raise <| TypeProviderError(FSComp.SR.etProviderReturnedNull(methodName), this.TypeProviderDesignation, range) + | Null -> raise <| TypeProviderError(FSComp.SR.etProviderReturnedNull(RichText.mkMethod methodName), this.TypeProviderDesignation, range) | NonNull a -> a |> Array.map (fun u -> Tainted(context,u)) - member this.PApplyFilteredArray(factory, filter, methodName, range:range) = + member this.PApplyFilteredArray(factory, filter, methodName: string, range:range) = let a : 'U[] | null = this.Protect factory range match a with - | Null -> raise <| TypeProviderError(FSComp.SR.etProviderReturnedNull(methodName), this.TypeProviderDesignation, range) + | Null -> raise <| TypeProviderError(FSComp.SR.etProviderReturnedNull(RichText.mkMethod methodName), this.TypeProviderDesignation, range) | NonNull a -> a |> Array.filter filter |> Array.map (fun u -> Tainted(context,u)) member this.PApplyOption(f, range: range) = diff --git a/src/Compiler/TypedTree/tainted.fsi b/src/Compiler/TypedTree/tainted.fsi index 2d3e5baa465..2a84acb05d2 100644 --- a/src/Compiler/TypedTree/tainted.fsi +++ b/src/Compiler/TypedTree/tainted.fsi @@ -22,22 +22,27 @@ type internal TypeProviderError = inherit System.Exception /// creates new instance of TypeProviderError that represents one error - new: (int * string) * string * range -> TypeProviderError + new: (int * RichText) * string * range -> TypeProviderError /// creates new instance of TypeProviderError that represents collection of errors - new: int * string * range * seq -> TypeProviderError + new: int * string * range * seq -> TypeProviderError member Number: int member Range: range + /// The message of this error, with the classification of its parts + member RichMessage: RichText + + member ContextualErrorRichMessage: RichText + member ContextualErrorMessage: string /// creates new instance of TypeProviderError with specified type\method names member WithContext: string * string -> TypeProviderError /// creates new instance of TypeProviderError based on current instance information(message) - member MapText: (string -> int * string) * string * range -> TypeProviderError + member MapText: (RichText -> int * RichText) * string * range -> TypeProviderError /// provides uniform way to process aggregated errors member Iter: (TypeProviderError -> unit) -> unit diff --git a/src/Compiler/Utilities/sformat.fs b/src/Compiler/Utilities/sformat.fs index 174094b800a..e97978f4615 100644 --- a/src/Compiler/Utilities/sformat.fs +++ b/src/Compiler/Utilities/sformat.fs @@ -72,6 +72,7 @@ type TextTag = | Punctuation | UnknownType | UnknownEntity + | UnresolvedName type TaggedText(tag: TextTag, text: string) = member x.Tag = tag @@ -213,6 +214,7 @@ module TaggedText = let tagUnion t = mkTag TextTag.Union t let tagMember t = mkTag TextTag.Member t let tagUnknownEntity t = mkTag TextTag.UnknownEntity t + let tagUnresolvedName t = mkTag TextTag.UnresolvedName t let tagUnknownType t = mkTag TextTag.UnknownType t // common tagged literals diff --git a/src/Compiler/Utilities/sformat.fsi b/src/Compiler/Utilities/sformat.fsi index 224452b7ee4..6a652b5fb02 100644 --- a/src/Compiler/Utilities/sformat.fsi +++ b/src/Compiler/Utilities/sformat.fsi @@ -69,6 +69,7 @@ type TextTag = | Punctuation | UnknownType | UnknownEntity + | UnresolvedName /// Represents text with a tag type public TaggedText = @@ -159,6 +160,7 @@ module internal TaggedText = val internal tagUnion: string -> TaggedText val internal tagMember: string -> TaggedText val internal tagUnknownEntity: string -> TaggedText + val internal tagUnresolvedName: string -> TaggedText val internal tagUnknownType: string -> TaggedText val internal leftAngle: TaggedText diff --git a/src/Compiler/lex.fsl b/src/Compiler/lex.fsl index ac73fd06961..ebd8ab27ca1 100644 --- a/src/Compiler/lex.fsl +++ b/src/Compiler/lex.fsl @@ -109,13 +109,13 @@ let lexemeTrimRightToInt32 args lexbuf n = let checkExprOp (lexbuf:UnicodeLexing.Lexbuf) = if lexbuf.LexemeContains ':' then - deprecatedWithError (FSComp.SR.lexCharNotAllowedInOperatorNames(":")) lexbuf.LexemeRange + deprecatedWithError (FSComp.SR.lexCharNotAllowedInOperatorNames(RichText.mkOperator ":")) lexbuf.LexemeRange if lexbuf.LexemeContains '$' then - deprecatedWithError (FSComp.SR.lexCharNotAllowedInOperatorNames("$")) lexbuf.LexemeRange + deprecatedWithError (FSComp.SR.lexCharNotAllowedInOperatorNames(RichText.mkOperator "$")) lexbuf.LexemeRange let checkExprGreaterColonOp (lexbuf:UnicodeLexing.Lexbuf) = if lexbuf.LexemeContains '$' then - deprecatedWithError (FSComp.SR.lexCharNotAllowedInOperatorNames("$")) lexbuf.LexemeRange + deprecatedWithError (FSComp.SR.lexCharNotAllowedInOperatorNames(RichText.mkOperator "$")) lexbuf.LexemeRange let unexpectedChar lexbuf = LEX_FAILURE (FSComp.SR.lexUnexpectedChar(lexeme lexbuf)) @@ -1013,7 +1013,7 @@ rule token (args: LexArgs) (skip: bool) = parse { // Treat shebangs like regular comments, but they are only allowed at the start of a file let m = lexbuf.LexemeRange let tok = LINE_COMMENT (LexCont.SingleLineComment(args.ifdefStack, args.stringNest, 1, m)) - let tok = shouldStartFile args lexbuf m (0,FSComp.SR.lexHashBangMustBeFirstInFile()) tok + let tok = shouldStartFile args lexbuf m (0, RichText.mkText (FSComp.SR.lexHashBangMustBeFirstInFile())) tok if not skip then tok else singleLineComment (None,1,m,m,args) skip lexbuf } | "#light" anywhite* newline diff --git a/src/Compiler/pars.fsy b/src/Compiler/pars.fsy index 058eaf4f402..31e653689fc 100644 --- a/src/Compiler/pars.fsy +++ b/src/Compiler/pars.fsy @@ -747,7 +747,7 @@ valSpfn: { if Option.isSome $2 then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(), rhs parseState 2)) let attr1, attr2, isInline, isMutable, vis2, id, doc, explicitValTyparDecls, (ty, arity), (mEquals, konst: SynExpr option) = ($1), ($4), (Option.isSome $5), (Option.isSome $6), ($7), ($8), grabXmlDoc(parseState, $1, 1), ($9), ($11), ($12) let vis2 = SynValSigAccess.Single(vis2) - if not (isNil attr2) then errorR(Deprecated(FSComp.SR.parsAttributesMustComeBeforeVal(), rhs parseState 4)) + if not (isNil attr2) then errorR(Deprecated(RichText.mkText (FSComp.SR.parsAttributesMustComeBeforeVal()), rhs parseState 4)) let m = rhs2 parseState 1 11 |> unionRangeWithXmlDoc doc @@ -2947,7 +2947,7 @@ unionCaseReprElement: unionCaseRepr: | braceFieldDeclList - { errorR(Deprecated(FSComp.SR.parsConsiderUsingSeparateRecordType(), lhs parseState)) + { errorR(Deprecated(RichText.mkText (FSComp.SR.parsConsiderUsingSeparateRecordType()), lhs parseState)) let fields = $1 |> List.choose (function SynFieldOrSpread.Field field -> Some field | _ -> None) fields, rhs parseState 1 } @@ -5477,7 +5477,7 @@ atomicExprQualification: | SynExpr.IndexRange(None, mOperator, None, _m1, _m2, _) -> mkSynDot mDot mLhs e (SynIdent(ident(CompileOpName "*", mOperator), Some(IdentTrivia.OriginalNotationWithParen(lpr, "*", rpr)))) | _ -> - errorR(Deprecated(FSComp.SR.astDeprecatedIndexerNotation(), lhs parseState)) + errorR(Deprecated(RichText.mkText (FSComp.SR.astDeprecatedIndexerNotation()), lhs parseState)) exprFromParseError $2) } | LBRACK typedSequentialExpr RBRACK @@ -7178,7 +7178,7 @@ opt_ODECLEND: | /* EMPTY */ { } deprecated_opt_equals: - | EQUALS { deprecatedWithError (FSComp.SR.parsNoEqualShouldFollowNamespace()) (lhs parseState); () } + | EQUALS { deprecatedWithError (RichText.mkText (FSComp.SR.parsNoEqualShouldFollowNamespace())) (lhs parseState); () } | /* EMPTY */ { } opt_OBLOCKSEP: diff --git a/src/FSharp.Build/FSharpEmbedResourceText.fs b/src/FSharp.Build/FSharpEmbedResourceText.fs index a1f5f56dba3..85ed65710de 100644 --- a/src/FSharp.Build/FSharpEmbedResourceText.fs +++ b/src/FSharp.Build/FSharpEmbedResourceText.fs @@ -393,10 +393,21 @@ open Printf static member SwallowResourceText: bool with get, set // END BOILERPLATE" - let generateResxAndSource (fileName: string) = + /// Marks a generated file as having the overloads taking classified text, and brings RichText into + /// scope for them + let richTextOpen = "open FSharp.Compiler.Text" + + let generateResxAndSource (item: ITaskItem) = + let fileName = item.ItemSpec + try let printMessage fmt = Printf.ksprintf this.Log.LogMessage fmt + // Opt in with true on the EmbeddedText item. Only assemblies that can + // see FSharp.Compiler.Text.RichText are able to compile the classified overloads. + let richText = + System.String.Equals(item.GetMetadata "RichText", "true", System.StringComparison.OrdinalIgnoreCase) + let justFileName = Path.GetFileNameWithoutExtension(fileName) // .txt if justFileName |> Seq.exists (System.Char.IsLetterOrDigit >> not) then @@ -424,7 +435,14 @@ open Printf condition4 && (File.GetLastWriteTimeUtc(fileName) <= File.GetLastWriteTimeUtc(outXmlFileName)) - if condition5 then + // A generated file does not record whether it was generated with RichText, so the flag has + // to be recovered from the open the generator emits for it, or an existing file would be + // taken as up-to-date after the flag changed + let condition6 = + condition5 + && (richText = (File.ReadLines(outFileName) |> Seq.truncate 40 |> Seq.contains richTextOpen)) + + if condition6 then printMessage "Skipping generation of %s and %s from %s since up-to-date" outFileName outXmlFileName fileName Some(fileName, outFileSignatureName, outFileName, outXmlFileName) @@ -438,7 +456,8 @@ open Printf elif not condition2 then 2 elif not condition3 then 3 elif not condition4 then 4 - else 5) + elif not condition5 then 5 + else 6) printMessage "Reading %s" fileName @@ -499,6 +518,11 @@ open Printf fprintfn outSignature "namespace %s" justFileName fprintfn out "%s" stringBoilerPlatePrefix fprintfn outSignature "%s" stringBoilerPlatePrefix + + if richText then + fprintfn out "%s" richTextOpen + fprintfn outSignature "%s" richTextOpen + fprintfn out "type internal SR private() =" fprintfn outSignature "type internal SR =" fprintfn outSignature " private new: unit -> SR" @@ -552,20 +576,28 @@ open Printf | None -> "" | Some n -> sprintf "%d, " n - fprintfn - out - " static member %s%s = (%sGetStringFunc(\"%s\",\"%s\") %s)" - ident - (formalArgs.ToString()) - errPrefix - ident - justPercentsFromFormatString - (actualArgs.ToString()) + // A numbered message is a diagnostic message, and a diagnostic is created from rich + // text, so the accessor returns text that is already converted - a message with + // nothing classified in it is one unclassified part. Unnumbered messages are plain + // strings spliced into other text and stay strings. + let numberedReturnsRichText = richText && optErrNum.IsSome + + let messageExpr = + let getString = + sprintf "GetStringFunc(\"%s\",\"%s\") %s" ident justPercentsFromFormatString (actualArgs.ToString()) + + if numberedReturnsRichText then + sprintf "RichText.mkText (%s)" getString + else + getString + + fprintfn out " static member %s%s = (%s%s)" ident (formalArgs.ToString()) errPrefix messageExpr let signatureMember = let returnType = match optErrNum with | None -> "string" + | Some _ when numberedReturnsRichText -> "int * RichText" | Some _ -> "int * string" if Array.isEmpty holes then @@ -576,7 +608,59 @@ open Printf |> String.concat " * " |> fun parameters -> sprintf " static member %s: %s -> %s" ident parameters returnType - fprintfn outSignature "%s" signatureMember) + fprintfn outSignature "%s" signatureMember + + // An overload taking the string holes as classified text, so that callers can keep + // the classification of types and names they splice into the message. The string + // overload is called with a sentinel per hole, which RichMessage then replaces with + // the parts it stands for - see the RichMessage module. + if richText && holes |> Array.contains "System.String" then + let richHole holeType = + if holeType = "System.String" then + "RichText" + else + holeType + + let richFormalArgs = + holes + |> Array.mapi (fun idx holeType -> sprintf "a%d : %s" idx (richHole holeType)) + |> String.concat ", " + + let richActualArgs = + holes + |> Array.mapi (fun idx holeType -> + if holeType = "System.String" then + sprintf "rich a%d" idx + else + sprintf "a%d" idx) + |> String.concat ", " + + let format, richReturnType = + match optErrNum with + | None -> "text", "RichText" + | Some _ -> "numbered", "int * RichText" + + fprintfn out " /// %s" str + fprintfn out " /// (Originally from %s:%d)" fileName (lineNum + 1) + + fprintfn + out + " static member %s(%s) = RichMessage.%s (fun rich -> SR.%s(%s))" + ident + richFormalArgs + format + ident + richActualArgs + + let richParameters = + holes + |> Array.mapi (fun idx holeType -> sprintf "a%i: %s" idx (richHole holeType)) + |> String.concat " * " + + fprintfn outSignature " /// %s" str + fprintfn outSignature " /// (Originally from %s:%d)" fileName (lineNum + 1) + + fprintfn outSignature " static member %s: %s -> %s" ident richParameters richReturnType) printMessage "Generating .resx for %s" outFileName fprintfn out "" @@ -632,9 +716,7 @@ open Printf override this.Execute() = try - let generatedFiles = - this.EmbeddedText - |> Array.choose (fun item -> generateResxAndSource item.ItemSpec) + let generatedFiles = this.EmbeddedText |> Array.choose generateResxAndSource let generatedSource, generatedResx = [| diff --git a/tests/AheadOfTime/Trimming/check.ps1 b/tests/AheadOfTime/Trimming/check.ps1 index 406eefc616e..240ff643de3 100644 --- a/tests/AheadOfTime/Trimming/check.ps1 +++ b/tests/AheadOfTime/Trimming/check.ps1 @@ -68,7 +68,7 @@ $allErrors += CheckTrim -root "SelfContained_Trimming_Test" -tfm "net9.0" -outpu # Check net9.0 trimmed assemblies with static linked FSharpCore. # Statically links FSharp.Compiler.Service; the size is stable now that its codegen is # deterministic (#19928/#19929). Update if compiler/trimming output intentionally changes. -$allErrors += CheckTrim -root "StaticLinkedFSharpCore_Trimming_Test" -tfm "net9.0" -outputfile "StaticLinkedFSharpCore_Trimming_Test.dll" -expected_len 9174016 -callerLineNumber 71 +$allErrors += CheckTrim -root "StaticLinkedFSharpCore_Trimming_Test" -tfm "net9.0" -outputfile "StaticLinkedFSharpCore_Trimming_Test.dll" -expected_len 9174528 -callerLineNumber 71 # Check net9.0 trimmed assemblies with F# metadata resources removed $allErrors += CheckTrim -root "FSharpMetadataResource_Trimming_Test" -tfm "net9.0" -outputfile "FSharpMetadataResource_Trimming_Test.dll" -expected_len 7613440 -callerLineNumber 74 diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/ByteStrings.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/ByteStrings.fs index b3469959680..174f71aa09e 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/ByteStrings.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/ByteStrings.fs @@ -4,19 +4,22 @@ open Xunit open FSharp.Test.Compiler /// `'%s' is not a valid character literal.` with note about wrapped value and error soon -let private invalidCharWarningMsg value wrapped = +let private invalidCharWarningMsg (value: string) (wrapped: string) = FSComp.SR.lexInvalidCharLiteralInString (value, wrapped) |> snd + |> _.Text /// `This byte array literal contains %d characters that do not encode as a single byte` let private invalidTwoByteErrorMsg count = FSComp.SR.lexByteArrayCannotEncode (count) |> snd + |> _.Text /// `This byte array literal contains %d non-ASCII characters.` let private invalidAsciiWarningMsg count = FSComp.SR.lexByteArrayOutisdeAscii (count) |> snd + |> _.Text [] let ``Decimal char > 255 is not valid``() = diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/CharByteLiterals.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/CharByteLiterals.fs index 87f895709c7..49d7dcb3f85 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/CharByteLiterals.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/CharByteLiterals.fs @@ -7,6 +7,7 @@ open FSharp.Test.Compiler let private invalidTrigraphCharWarningMsg = FSComp.SR.lexInvalidTrigraphAsciiByteLiteral () |> snd + |> _.Text [] let ``all byte char notations pass type check`` () = diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/Strings.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/Strings.fs index 28922805ca3..7fc8edbac97 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/Strings.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/LexicalAnalysis/Strings.fs @@ -4,9 +4,10 @@ open Xunit open FSharp.Test.Compiler /// `'%s' is not a valid character literal.` with note about wrapped value and error soon -let private invalidCharWarningMsg value wrapped = +let private invalidCharWarningMsg (value: string) (wrapped: string) = FSComp.SR.lexInvalidCharLiteralInString (value, wrapped) |> snd + |> _.Text [] let ``Decimal char > 255 is not valid``() = diff --git a/tests/FSharp.Compiler.ComponentTests/Diagnostics/RichDiagnosticTests.fs b/tests/FSharp.Compiler.ComponentTests/Diagnostics/RichDiagnosticTests.fs new file mode 100644 index 00000000000..b766aea5f45 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Diagnostics/RichDiagnosticTests.fs @@ -0,0 +1,184 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Diagnostics + +open Xunit +open FSharp.Test +open FSharp.Test.Assert +open FSharp.Compiler.Text + +/// Checks the classification of diagnostic messages that were converted to rich text. +/// See docs/rich-diagnostics.md. +module RichDiagnosticTests = + + let private singleDiagnostic source = + match CompilerAssert.TypeCheckWithOptions [||] source with + | [| diagnostic |] -> diagnostic + | diagnostics -> failwith $"Expected a single diagnostic, got:\n%A{diagnostics}" + + let private diagnostic number source = + let diagnostics = CompilerAssert.TypeCheckWithOptions [||] source + + match diagnostics |> Array.tryFind (fun d -> d.ErrorNumber = number) with + | Some diagnostic -> diagnostic + | None -> failwith $"Expected a diagnostic FS%04d{number}, got:\n%A{diagnostics}" + + let private assertMessageParts expected source = + (singleDiagnostic source).RichMessage |> assertRichTextParts expected + + let private assertMessagePartsOf number expected source = + (diagnostic number source).RichMessage |> assertRichTextParts expected + + [] + let ``Undefined value name is classified`` () = + "let _ = someUndefinedValue" + |> assertMessageParts + [ TextTag.Text, "The value or constructor '" + TextTag.UnresolvedName, "someUndefinedValue" + TextTag.Text, "' is not defined." ] + + [] + let ``Undefined type name is classified`` () = + "let _: SomeUndefinedType = ()" + |> assertMessageParts + [ TextTag.Text, "The type '" + TextTag.UnresolvedName, "SomeUndefinedType" + TextTag.Text, "' is not defined." ] + + [] + let ``Undefined name suggestions are classified`` () = + """ +let frobnicate = 1 +let _ = frobnicatf +""" + |> assertMessageParts + [ TextTag.Text, "The value or constructor '" + TextTag.UnresolvedName, "frobnicatf" + TextTag.Text, "' is not defined. Maybe you want one of the following:" + TextTag.LineBreak, System.Environment.NewLine + TextTag.Text, " " + TextTag.UnknownEntity, "frobnicate" ] + + [] + let ``Message of an unconverted diagnostic is a single part`` () = + // FS0067 carries no arguments, so there is nothing in it to classify + let diagnostic = + diagnostic 67 "let _ = System.Collections.Generic.Dictionary() :?> System.Collections.IDictionary" + + diagnostic.RichMessage.Parts.Length |> shouldEqual 1 + diagnostic.RichMessage.Text |> shouldEqual diagnostic.Message + + [] + let ``Type of an ignored result is classified`` () = + "1 + 1" + |> assertMessagePartsOf + 20 + [ TextTag.Text, "The result of this expression has type '" + TextTag.Struct, "int" + TextTag.Text, "' and is implicitly ignored. Consider using 'ignore' to discard this value explicitly, e.g. 'expr |> ignore', or 'let' to bind the result to a name, e.g. 'let result = expr'." ] + + [] + let ``Type of an unexpected function value is classified`` () = + """ +let f x = x + 1 +let _: int = f +""" + |> assertMessagePartsOf + 1 + [ TextTag.Text, "This expression was expected to have type\n '" + TextTag.Struct, "int" + TextTag.Text, "' \nbut here has type\n '" + TextTag.Struct, "int" + TextTag.Space, " " + TextTag.Punctuation, "->" + TextTag.Space, " " + TextTag.Struct, "int" + TextTag.Text, "' " ] + + [] + let ``Type of a sealed coercion source is classified`` () = + "let _ = 1 :?> string" + |> assertMessageParts + [ TextTag.Text, "The type '" + TextTag.Struct, "int" + TextTag.Text, "' does not have any proper subtypes and cannot be used as the source of a type test or runtime coercion." ] + + [] + let ``Types of a mismatch are classified`` () = + "let _: int = \"\"" + |> assertMessagePartsOf + 1 + [ TextTag.Text, "This expression was expected to have type\n '" + TextTag.Struct, "int" + TextTag.Text, "' \nbut here has type\n '" + TextTag.Alias, "string" + TextTag.Text, "' " ] + + [] + let ``Types of a mismatch in a list element are classified`` () = + "let _ = [ 1; \"\" ]" + |> assertMessagePartsOf + 1 + [ TextTag.Text, "All elements of a list must be implicitly convertible to the type of the first element, which here is '" + TextTag.Struct, "int" + TextTag.Text, "'. This element has type '" + TextTag.Alias, "string" + TextTag.Text, "'." ] + + [] + let ``Type of a missing else branch is classified`` () = + "let _ = if true then 1" + |> assertMessagePartsOf + 1 + [ TextTag.Text, "This 'if' expression is missing an 'else' branch. Because 'if' is an expression, and not a statement, add an 'else' branch which also returns a value of type '" + TextTag.Struct, "int" + TextTag.Text, "'." ] + + [] + let ``Types of a downcast used instead of an upcast are classified`` () = + """ +open System.Collections.Generic +let orig = Dictionary() +let _ = orig :?> IDictionary +""" + |> assertMessagePartsOf + 3198 + [ TextTag.Text, "The conversion from " + TextTag.Class, "Dictionary" + TextTag.Punctuation, "<" + TextTag.Alias, "obj" + TextTag.Punctuation, "," + TextTag.Alias, "obj" + TextTag.Punctuation, ">" + TextTag.Text, " to " + TextTag.Interface, "IDictionary" + TextTag.Punctuation, "<" + TextTag.Alias, "obj" + TextTag.Punctuation, "," + TextTag.Alias, "obj" + TextTag.Punctuation, ">" + TextTag.Text, " is a compile-time safe upcast, not a downcast. Consider using the :> (upcast) operator instead of the :?> (downcast) operator." ] + + /// Every part of a type is classified on its own, not just the type as a whole + [] + let ``Parts of a tuple type are classified`` () = + "let _: int * int = 1, 2, 3" + |> assertMessagePartsOf + 1 + [ TextTag.Text, "Type mismatch. Expecting a tuple of length 2 of type\n " + TextTag.Struct, "int" + TextTag.Space, " " + TextTag.Punctuation, "*" + TextTag.Space, " " + TextTag.Struct, "int" + TextTag.Text, " \nbut given a tuple of length 3 of type\n " + TextTag.Struct, "int" + TextTag.Space, " " + TextTag.Punctuation, "*" + TextTag.Space, " " + TextTag.Struct, "int" + TextTag.Space, " " + TextTag.Punctuation, "*" + TextTag.Space, " " + TextTag.Struct, "int" + TextTag.Text, " \n" ] diff --git a/tests/FSharp.Compiler.ComponentTests/Diagnostics/RichTextTests.fs b/tests/FSharp.Compiler.ComponentTests/Diagnostics/RichTextTests.fs new file mode 100644 index 00000000000..70924b45dc2 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Diagnostics/RichTextTests.fs @@ -0,0 +1,266 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Diagnostics + +open Xunit +open FSharp.Test +open FSharp.Test.Assert +open FSharp.Compiler.Text +open FSharp.Compiler.Text.Layout +open FSharp.Compiler.DiagnosticsLogger + +module RichTextTests = + + let private tagged tag text = TaggedText(tag, text) + + let private proxy = stringThatIsAProxyForANewlineInFlatErrors + + [] + let ``Empty text has no parts and empty string`` () = + RichText.empty.Parts |> shouldBeEmpty + RichText.empty.Text |> shouldEqual "" + RichText.empty.IsEmpty |> shouldBeTrue + + [] + let ``Plain string becomes a single Text part`` () = + let text = RichText.mkText "The type 'int' is not defined." + + text |> assertRichTextParts [ TextTag.Text, "The type 'int' is not defined." ] + text.Text |> shouldEqual "The type 'int' is not defined." + + [] + let ``Empty string produces no parts, whatever the classification`` () = + (RichText.mkText "").IsEmpty |> shouldBeTrue + (RichText.mkMethod "").IsEmpty |> shouldBeTrue + (RichText.ofTag TextTag.Class "").IsEmpty |> shouldBeTrue + + [] + let ``Parts are dumped as tag and text pairs`` () = + RichText.ofParts + [| tagged TextTag.Text "The type " + tagged TextTag.Punctuation "'" + tagged TextTag.Class "Foo" + tagged TextTag.Punctuation "'" |] + |> assertRichTextParts + [ TextTag.Text, "The type " + TextTag.Punctuation, "'" + TextTag.Class, "Foo" + TextTag.Punctuation, "'" ] + + [] + let ``Text is the concatenation of all parts`` () = + let text = + RichText.ofParts + [| tagged TextTag.Text "The type " + tagged TextTag.Class "Foo" + tagged TextTag.Text " is not defined." |] + + text.Text |> shouldEqual "The type Foo is not defined." + + [] + let ``Control characters are escaped in the dump`` () = + RichText.mkText "line\r\n\tcolumn \"quoted\" back\\slash" + |> dumpRichText + |> shouldEqual "Text \"line\\r\\n\\tcolumn \\\"quoted\\\" back\\\\slash\"" + + /// Equality asks what reaches the reader, so neither the classification nor where the part + /// boundaries fall takes part in it + [] + let ``Texts that read the same are equal`` () = + let classified = + RichText.ofParts [| tagged TextTag.Class "Fo"; tagged TextTag.Struct "o" |] + + classified = RichText.mkText "Foo" |> shouldBeTrue + classified.GetHashCode() |> shouldEqual ((RichText.mkText "Foo").GetHashCode()) + + RichText.empty = RichText.mkText "" |> shouldBeTrue + + [] + let ``Texts that read differently are not equal`` () = + RichText.ofTaggedText (tagged TextTag.Class "Foo") = RichText.ofTaggedText (tagged TextTag.Class "Bar") + |> shouldBeFalse + + RichText.mkText("Foo").Equals(box 1) |> shouldBeFalse + + [] + let ``Append keeps parts of both sides`` () = + RichText.append (RichText.mkText "expected ") (RichText.ofTaggedText (tagged TextTag.Class "int")) + |> assertRichTextParts [ TextTag.Text, "expected "; TextTag.Class, "int" ] + + [] + let ``Append with an empty operand returns the other one`` () = + let text = RichText.mkText "abc" + + RichText.append RichText.empty text |> shouldBe text + RichText.append text RichText.empty |> shouldBe text + + [] + let ``Concat flattens all parts in order`` () = + let text = + RichText.concat + [ RichText.mkText "a" + RichText.empty + RichText.ofTaggedText (tagged TextTag.Keyword "let") + RichText.mkText "b" ] + + text |> assertRichTextParts [ TextTag.Text, "a"; TextTag.Keyword, "let"; TextTag.Text, "b" ] + text.Text |> shouldEqual "aletb" + + [] + let ``Concat of nothing is empty`` () = + (RichText.concat []).IsEmpty |> shouldBeTrue + + [] + let ``ConcatWith puts the separator between the texts only`` () = + let comma = RichText.mkText "," + + [ RichText.ofTaggedText (tagged TextTag.Class "A") + RichText.ofTaggedText (tagged TextTag.Struct "B") ] + |> RichText.concatWith comma + |> assertRichTextParts [ TextTag.Class, "A"; TextTag.Text, ","; TextTag.Struct, "B" ] + + [ RichText.mkText "only" ] |> RichText.concatWith comma |> assertRichTextParts [ TextTag.Text, "only" ] + (RichText.concatWith comma []).IsEmpty |> shouldBeTrue + + [] + let ``CollectParts can split a part into several`` () = + let splitTextOnNewline (part: TaggedText) = + if part.Tag <> TextTag.Text then + [| part |] + else + part.Text.Split('\n') + |> Array.mapi (fun i line -> + if i = 0 then + [| tagged TextTag.Text line |] + else + [| tagged TextTag.LineBreak "\n"; tagged TextTag.Text line |]) + |> Array.concat + + let text = + RichText.ofParts + [| tagged TextTag.Text "first\nsecond" + tagged TextTag.Class "Foo\nBar" |] + |> RichText.collectParts splitTextOnNewline + + text + |> assertRichTextParts + [ TextTag.Text, "first" + TextTag.LineBreak, "\n" + TextTag.Text, "second" + TextTag.Class, "Foo\nBar" ] + + text.Text |> shouldEqual "first\nsecondFoo\nBar" + + [] + let ``CollectParts dropping every part gives empty text`` () = + (RichText.mkText "abc" |> RichText.collectParts (fun _ -> [||])).IsEmpty + |> shouldBeTrue + + [] + let ``Layout parts are preserved`` () = + let layout = + wordL (TaggedText.tagKeyword "val") ^^ wordL (TaggedText.tagClass "int") + + let text = LayoutRender.toRichText layout + + text + |> assertRichTextParts [ TextTag.Keyword, "val"; TextTag.Space, " "; TextTag.Class, "int" ] + + text.Text |> shouldEqual (LayoutRender.showL layout) + + [] + let ``Builder appends strings, parts, texts and layouts`` () = + let builder = RichTextBuilder() + builder.IsEmpty |> shouldBeTrue + + builder.Append "The type " + builder.Append "" + builder.Append(tagged TextTag.Class "Foo") + builder.Append(RichText.mkText " is not compatible with ") + builder.Append(LayoutRender.toRichText (wordL (TaggedText.tagClass "Bar"))) + + builder.IsEmpty |> shouldBeFalse + + let text = builder.ToRichText() + + text + |> assertRichTextParts + [ TextTag.Text, "The type " + TextTag.Class, "Foo" + TextTag.Text, " is not compatible with " + TextTag.Class, "Bar" ] + + text.Text |> shouldEqual "The type Foo is not compatible with Bar" + builder.ToString() |> shouldEqual text.Text + + [] + let ``Empty builder produces empty text`` () = + let builder = RichTextBuilder() + builder.Append "" + builder.ToRichText().IsEmpty |> shouldBeTrue + + /// The marker that stands in for a classified argument while the message is formatted is chosen + /// absent from the message, so an argument that happens to contain one cannot be mistaken for it + [] + let ``An argument containing a marker character does not corrupt the message`` () = + let hostile = "before\u000110\u0001after" + + let text = + RichMessage.text (fun rich -> sprintf "%s and %s" hostile (rich (RichText.mkClass "Foo"))) + + text.Text |> shouldEqual (sprintf "%s and Foo" hostile) + text.Parts |> Array.exists (fun part -> part.Tag = TextTag.Class && part.Text = "Foo") |> shouldBeTrue + + /// The message has to read the same whether or not the arguments are classified + [] + let ``Splicing survives a hole that is reordered, repeated and dropped`` () = + let one = RichText.mkClass "One" + let two = RichText.mkStruct "Two" + + let text = + RichMessage.text (fun rich -> sprintf "%s %s %s" (rich two) (rich one) (rich two)) + + text.Text |> shouldEqual "Two One Two" + + text + |> assertRichTextParts + [ TextTag.Struct, "Two" + TextTag.Text, " " + TextTag.Class, "One" + TextTag.Text, " " + TextTag.Struct, "Two" ] + + [] + let ``Normalization keeps the classification of every part`` () = + RichText.ofParts + [| tagged TextTag.Text " The type\n" + tagged TextTag.Class "Foo\tBar" + tagged TextTag.Text "\r\nis not defined. " |] + |> NormalizeErrorRichText + |> assertRichTextParts + [ TextTag.Text, $"The type{proxy}" + TextTag.Class, "Foo Bar" + TextTag.Text, $"{proxy}is not defined." ] + + [] + // Line break forms, including ones split across parts + [] + [] + [] + [] + [] + [] + [] + // Control characters + [] + // Trimming spans parts + [] + [] + [] + // No normalization needed + [] + let ``Normalization of parts agrees with normalization of the whole message`` (first: string) (second: string) = + let text = + RichText.ofParts [| tagged TextTag.Text first; tagged TextTag.Class second |] + + (NormalizeErrorRichText text).Text |> shouldEqual (NormalizeErrorString text.Text) diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 6e40917f747..194292ab223 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -499,6 +499,8 @@ + + diff --git a/tests/FSharp.Compiler.Service.Tests/Checker.fs b/tests/FSharp.Compiler.Service.Tests/Checker.fs index dc86d85c1ad..187d0cc53bf 100644 --- a/tests/FSharp.Compiler.Service.Tests/Checker.fs +++ b/tests/FSharp.Compiler.Service.Tests/Checker.fs @@ -302,9 +302,7 @@ module AssertHelpers = Assert.Equal(1, items.Length) match items[0] with | ToolTipElement.Group [ singleElement ] -> - let toolTipText = - singleElement.MainDescription - |> taggedTextToString - toolTipText, singleElement.XmlDoc, singleElement.Remarks |> Option.map taggedTextToString + let toolTipText = singleElement.MainDescription.Text + toolTipText, singleElement.XmlDoc, singleElement.Remarks |> Option.map _.Text | _ -> failwith $"Expected group, got {items[0]}" diff --git a/tests/FSharp.Compiler.Service.Tests/Common.fs b/tests/FSharp.Compiler.Service.Tests/Common.fs index 990ded3e52d..04e88750f97 100644 --- a/tests/FSharp.Compiler.Service.Tests/Common.fs +++ b/tests/FSharp.Compiler.Service.Tests/Common.fs @@ -481,9 +481,6 @@ let findSymbolUse (evaluateSymbol:FSharpSymbolUse->bool) (results: FSharpCheckFi let symbolUses = getSymbolUses results symbolUses |> Seq.find (fun symbolUse -> evaluateSymbol symbolUse) -let taggedTextToString (tts: TaggedText[]) = - tts |> Array.map (fun tt -> tt.Text) |> String.concat "" - let getRangeCoords (r: range) = (r.StartLine, r.StartColumn), (r.EndLine, r.EndColumn) diff --git a/tests/FSharp.Compiler.Service.Tests/EditorServiceAsserts.fs b/tests/FSharp.Compiler.Service.Tests/EditorServiceAsserts.fs index d32b76d097b..c364bac5e9c 100644 --- a/tests/FSharp.Compiler.Service.Tests/EditorServiceAsserts.fs +++ b/tests/FSharp.Compiler.Service.Tests/EditorServiceAsserts.fs @@ -41,7 +41,7 @@ module EditorServiceAsserts = elements |> List.collect (fun e -> match e with - | ToolTipElement.Group items -> items |> List.map (fun d -> taggedTextToString d.MainDescription) + | ToolTipElement.Group items -> items |> List.map (fun d -> d.MainDescription.Text) | _ -> []) let flattenItemDescription (tooltip: ToolTipText) = @@ -236,12 +236,12 @@ module EditorServiceAsserts = | ToolTipElement.Group elements -> elements |> List.collect (fun e -> - [ taggedTextToString e.MainDescription + [ e.MainDescription.Text match e.XmlDoc with | FSharpXmlDoc.FromXmlText xmlDoc -> String.concat "\n" xmlDoc.UnprocessedLines | _ -> "" match e.Remarks with - | Some r -> taggedTextToString r + | Some r -> r.Text | None -> "" ]) | ToolTipElement.CompositionError err -> [ err ] | ToolTipElement.None -> []) @@ -471,7 +471,7 @@ module EditorServiceAsserts = checkResults.GetMethods(context.Pos.Line, context.Pos.Column, context.LineText, Some context.Names) let private paramDisplays (m: MethodGroupItem) = - m.Parameters |> Array.map (fun p -> taggedTextToString p.Display) |> Array.toList + m.Parameters |> Array.map (fun p -> p.Display.Text) |> Array.toList let private describeMethodGroup (mg: MethodGroup) = if mg.Methods.Length = 0 then @@ -525,6 +525,6 @@ module EditorServiceAsserts = let mg = getMethodGroup markedSource if mg.Methods.Length = 0 then failwithf "Expected a method group, but got none. Looking for return type %A" expected - let actual = taggedTextToString mg.Methods[0].ReturnTypeText + let actual = mg.Methods[0].ReturnTypeText.Text if actual <> expected then failwithf "Expected first overload return type %A but got %A:\n%s" expected actual (describeMethodGroup mg) diff --git a/tests/FSharp.Compiler.Service.Tests/EditorTests.fs b/tests/FSharp.Compiler.Service.Tests/EditorTests.fs index e60365488e4..7fb046be29f 100644 --- a/tests/FSharp.Compiler.Service.Tests/EditorTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/EditorTests.fs @@ -98,7 +98,7 @@ let ``Intro test`` () = // Print concatenated parameter lists [ for mi in methods.Methods do - yield methods.MethodName , [ for p in mi.Parameters do yield p.Display |> taggedTextToString ] ] + yield methods.MethodName , [ for p in mi.Parameters do yield p.Display.Text ] ] |> shouldEqual [("Concat", ["[] args: obj []"]); ("Concat", ["[] values: string []"]); @@ -1973,7 +1973,7 @@ do let x = 1 in () let su = checkResults |> findSymbolUseByName "x" match checkResults.GetDescription(su.Symbol, su.GenericArguments, true, su.Range) with | ToolTipText [ToolTipElement.Group [data]] -> - data.MainDescription |> Array.map (fun text -> text.Text) |> String.concat "" |> shouldEqual "val x: int" + data.MainDescription.Text |> shouldEqual "val x: int" | elements -> failwith $"Tooltip elements: {elements}" let hasRecordField (fieldName:string) (symbolUses: FSharpSymbolUse list) = diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl index 9ec2c21251c..bff5dd54c5d 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl @@ -2729,7 +2729,7 @@ FSharp.Compiler.DependencyManager.AssemblyResolveHandler: Void .ctor(FSharp.Comp FSharp.Compiler.DependencyManager.DependencyProvider: FSharp.Compiler.DependencyManager.IDependencyManagerProvider TryFindDependencyManagerByKey(System.Collections.Generic.IEnumerable`1[System.String], System.String, Microsoft.FSharp.Core.FSharpOption`1[System.String], FSharp.Compiler.DependencyManager.ResolvingErrorReport, System.String) FSharp.Compiler.DependencyManager.DependencyProvider: FSharp.Compiler.DependencyManager.IResolveDependenciesResult Resolve(FSharp.Compiler.DependencyManager.IDependencyManagerProvider, System.String, System.Collections.Generic.IEnumerable`1[System.Tuple`2[System.String,System.String]], FSharp.Compiler.DependencyManager.ResolvingErrorReport, System.String, System.String, System.String, System.String, System.String, Int32) FSharp.Compiler.DependencyManager.DependencyProvider: System.String[] GetRegisteredDependencyManagerHelpText(System.Collections.Generic.IEnumerable`1[System.String], System.String, Microsoft.FSharp.Core.FSharpOption`1[System.String], FSharp.Compiler.DependencyManager.ResolvingErrorReport) -FSharp.Compiler.DependencyManager.DependencyProvider: System.Tuple`2[System.Int32,System.String] CreatePackageManagerUnknownError(System.Collections.Generic.IEnumerable`1[System.String], System.String, Microsoft.FSharp.Core.FSharpOption`1[System.String], System.String, FSharp.Compiler.DependencyManager.ResolvingErrorReport) +FSharp.Compiler.DependencyManager.DependencyProvider: System.Tuple`2[System.Int32,FSharp.Compiler.Text.RichText] CreatePackageManagerUnknownError(System.Collections.Generic.IEnumerable`1[System.String], System.String, Microsoft.FSharp.Core.FSharpOption`1[System.String], System.String, FSharp.Compiler.DependencyManager.ResolvingErrorReport) FSharp.Compiler.DependencyManager.DependencyProvider: System.Tuple`2[System.String,FSharp.Compiler.DependencyManager.IDependencyManagerProvider] TryFindDependencyManagerInPath(System.Collections.Generic.IEnumerable`1[System.String], System.String, Microsoft.FSharp.Core.FSharpOption`1[System.String], FSharp.Compiler.DependencyManager.ResolvingErrorReport, System.String) FSharp.Compiler.DependencyManager.DependencyProvider: Void .ctor() FSharp.Compiler.DependencyManager.DependencyProvider: Void .ctor(FSharp.Compiler.DependencyManager.AssemblyResolutionProbe, FSharp.Compiler.DependencyManager.NativeResolutionProbe) @@ -2931,6 +2931,7 @@ FSharp.Compiler.Diagnostics.ExtendedData: FSharp.Compiler.Diagnostics.ExtendedDa FSharp.Compiler.Diagnostics.ExtendedData: FSharp.Compiler.Diagnostics.ExtendedData+TypeExtendedData FSharp.Compiler.Diagnostics.ExtendedData: FSharp.Compiler.Diagnostics.ExtendedData+TypeMismatchDiagnosticExtendedData FSharp.Compiler.Diagnostics.ExtendedData: FSharp.Compiler.Diagnostics.ExtendedData+ValueNotContainedDiagnosticExtendedData +FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Diagnostics.FSharpDiagnostic Create(FSharp.Compiler.Diagnostics.FSharpDiagnosticSeverity, FSharp.Compiler.Text.RichText, Int32, FSharp.Compiler.Text.Range, Microsoft.FSharp.Core.FSharpOption`1[System.String], Microsoft.FSharp.Core.FSharpOption`1[System.String]) FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Diagnostics.FSharpDiagnostic Create(FSharp.Compiler.Diagnostics.FSharpDiagnosticSeverity, System.String, Int32, FSharp.Compiler.Text.Range, Microsoft.FSharp.Core.FSharpOption`1[System.String], Microsoft.FSharp.Core.FSharpOption`1[System.String]) FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Diagnostics.FSharpDiagnosticSeverity DefaultSeverity FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Diagnostics.FSharpDiagnosticSeverity Severity @@ -2942,6 +2943,8 @@ FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Text.Position get_ FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Text.Position get_Start() FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Text.Range Range FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Text.Range get_Range() +FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Text.RichText RichMessage +FSharp.Compiler.Diagnostics.FSharpDiagnostic: FSharp.Compiler.Text.RichText get_RichMessage() FSharp.Compiler.Diagnostics.FSharpDiagnostic: Int32 EndColumn FSharp.Compiler.Diagnostics.FSharpDiagnostic: Int32 EndLine FSharp.Compiler.Diagnostics.FSharpDiagnostic: Int32 ErrorNumber @@ -3804,12 +3807,12 @@ FSharp.Compiler.EditorServices.MethodGroupItem: FSharp.Compiler.EditorServices.T FSharp.Compiler.EditorServices.MethodGroupItem: FSharp.Compiler.EditorServices.ToolTipText get_Description() FSharp.Compiler.EditorServices.MethodGroupItem: FSharp.Compiler.Symbols.FSharpXmlDoc XmlDoc FSharp.Compiler.EditorServices.MethodGroupItem: FSharp.Compiler.Symbols.FSharpXmlDoc get_XmlDoc() -FSharp.Compiler.EditorServices.MethodGroupItem: FSharp.Compiler.Text.TaggedText[] ReturnTypeText -FSharp.Compiler.EditorServices.MethodGroupItem: FSharp.Compiler.Text.TaggedText[] get_ReturnTypeText() +FSharp.Compiler.EditorServices.MethodGroupItem: FSharp.Compiler.Text.RichText ReturnTypeText +FSharp.Compiler.EditorServices.MethodGroupItem: FSharp.Compiler.Text.RichText get_ReturnTypeText() FSharp.Compiler.EditorServices.MethodGroupItemParameter: Boolean IsOptional FSharp.Compiler.EditorServices.MethodGroupItemParameter: Boolean get_IsOptional() -FSharp.Compiler.EditorServices.MethodGroupItemParameter: FSharp.Compiler.Text.TaggedText[] Display -FSharp.Compiler.EditorServices.MethodGroupItemParameter: FSharp.Compiler.Text.TaggedText[] get_Display() +FSharp.Compiler.EditorServices.MethodGroupItemParameter: FSharp.Compiler.Text.RichText Display +FSharp.Compiler.EditorServices.MethodGroupItemParameter: FSharp.Compiler.Text.RichText get_Display() FSharp.Compiler.EditorServices.MethodGroupItemParameter: System.String CanonicalTypeTextForSorting FSharp.Compiler.EditorServices.MethodGroupItemParameter: System.String ParameterName FSharp.Compiler.EditorServices.MethodGroupItemParameter: System.String get_CanonicalTypeTextForSorting() @@ -4744,7 +4747,7 @@ FSharp.Compiler.EditorServices.ToolTipElement: Boolean get_IsNone() FSharp.Compiler.EditorServices.ToolTipElement: FSharp.Compiler.EditorServices.ToolTipElement NewCompositionError(System.String) FSharp.Compiler.EditorServices.ToolTipElement: FSharp.Compiler.EditorServices.ToolTipElement NewGroup(Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.EditorServices.ToolTipElementData]) FSharp.Compiler.EditorServices.ToolTipElement: FSharp.Compiler.EditorServices.ToolTipElement None -FSharp.Compiler.EditorServices.ToolTipElement: FSharp.Compiler.EditorServices.ToolTipElement Single(FSharp.Compiler.Text.TaggedText[], FSharp.Compiler.Symbols.FSharpXmlDoc, Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Text.TaggedText[]]], Microsoft.FSharp.Core.FSharpOption`1[System.String], Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.TaggedText[]], Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpSymbol]) +FSharp.Compiler.EditorServices.ToolTipElement: FSharp.Compiler.EditorServices.ToolTipElement Single(FSharp.Compiler.Text.RichText, FSharp.Compiler.Symbols.FSharpXmlDoc, Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Text.RichText]], Microsoft.FSharp.Core.FSharpOption`1[System.String], Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.RichText], Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpSymbol]) FSharp.Compiler.EditorServices.ToolTipElement: FSharp.Compiler.EditorServices.ToolTipElement get_None() FSharp.Compiler.EditorServices.ToolTipElement: FSharp.Compiler.EditorServices.ToolTipElement+CompositionError FSharp.Compiler.EditorServices.ToolTipElement: FSharp.Compiler.EditorServices.ToolTipElement+Group @@ -4760,20 +4763,20 @@ FSharp.Compiler.EditorServices.ToolTipElementData: Boolean Equals(System.Object) FSharp.Compiler.EditorServices.ToolTipElementData: Boolean Equals(System.Object, System.Collections.IEqualityComparer) FSharp.Compiler.EditorServices.ToolTipElementData: FSharp.Compiler.Symbols.FSharpXmlDoc XmlDoc FSharp.Compiler.EditorServices.ToolTipElementData: FSharp.Compiler.Symbols.FSharpXmlDoc get_XmlDoc() -FSharp.Compiler.EditorServices.ToolTipElementData: FSharp.Compiler.Text.TaggedText[] MainDescription -FSharp.Compiler.EditorServices.ToolTipElementData: FSharp.Compiler.Text.TaggedText[] get_MainDescription() +FSharp.Compiler.EditorServices.ToolTipElementData: FSharp.Compiler.Text.RichText MainDescription +FSharp.Compiler.EditorServices.ToolTipElementData: FSharp.Compiler.Text.RichText get_MainDescription() FSharp.Compiler.EditorServices.ToolTipElementData: Int32 GetHashCode() FSharp.Compiler.EditorServices.ToolTipElementData: Int32 GetHashCode(System.Collections.IEqualityComparer) -FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Text.TaggedText[]] TypeMapping -FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Text.TaggedText[]] get_TypeMapping() +FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Text.RichText] TypeMapping +FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Text.RichText] get_TypeMapping() FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpSymbol] Symbol FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpSymbol] get_Symbol() -FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.TaggedText[]] Remarks -FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.TaggedText[]] get_Remarks() +FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.RichText] Remarks +FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.RichText] get_Remarks() FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Core.FSharpOption`1[System.String] ParamName FSharp.Compiler.EditorServices.ToolTipElementData: Microsoft.FSharp.Core.FSharpOption`1[System.String] get_ParamName() FSharp.Compiler.EditorServices.ToolTipElementData: System.String ToString() -FSharp.Compiler.EditorServices.ToolTipElementData: Void .ctor(Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpSymbol], FSharp.Compiler.Text.TaggedText[], FSharp.Compiler.Symbols.FSharpXmlDoc, Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Text.TaggedText[]], Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.TaggedText[]], Microsoft.FSharp.Core.FSharpOption`1[System.String]) +FSharp.Compiler.EditorServices.ToolTipElementData: Void .ctor(Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpSymbol], FSharp.Compiler.Text.RichText, FSharp.Compiler.Symbols.FSharpXmlDoc, Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Text.RichText], Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.RichText], Microsoft.FSharp.Core.FSharpOption`1[System.String]) FSharp.Compiler.EditorServices.ToolTipText: Boolean Equals(FSharp.Compiler.EditorServices.ToolTipText) FSharp.Compiler.EditorServices.ToolTipText: Boolean Equals(FSharp.Compiler.EditorServices.ToolTipText, System.Collections.IEqualityComparer) FSharp.Compiler.EditorServices.ToolTipText: Boolean Equals(System.Object) @@ -5743,7 +5746,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: FSharp.Compiler.Symbols.F FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: FSharp.Compiler.Symbols.FSharpXmlDoc get_XmlDoc() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: FSharp.Compiler.Text.Range DeclarationLocation FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: FSharp.Compiler.Text.Range get_DeclarationLocation() -FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: FSharp.Compiler.Text.TaggedText[] FormatLayout(FSharp.Compiler.Symbols.FSharpDisplayContext) +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: FSharp.Compiler.Text.RichText FormatRichText(FSharp.Compiler.Symbols.FSharpDisplayContext) FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Int32 GetHashCode() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpEntity] ApparentEnclosingEntity FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpEntity] DeclaringEntity @@ -5755,7 +5758,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSh FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpObsoleteDiagnosticInfo] get_ObsoleteDiagnosticInfo() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpType] FullTypeSafe FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpType] get_FullTypeSafe() -FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.TaggedText[]] GetReturnTypeLayout(FSharp.Compiler.Symbols.FSharpDisplayContext) +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.RichText] GetReturnTypeRichText(FSharp.Compiler.Symbols.FSharpDisplayContext) FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[System.Collections.Generic.IList`1[FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue]] GetOverloads(Boolean) FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[System.Object] LiteralValue FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Microsoft.FSharp.Core.FSharpOption`1[System.Object] get_LiteralValue() @@ -5981,8 +5984,8 @@ FSharp.Compiler.Symbols.FSharpType: FSharp.Compiler.Symbols.FSharpType Prettify( FSharp.Compiler.Symbols.FSharpType: FSharp.Compiler.Symbols.FSharpType StripAbbreviations() FSharp.Compiler.Symbols.FSharpType: FSharp.Compiler.Symbols.FSharpType get_AbbreviatedType() FSharp.Compiler.Symbols.FSharpType: FSharp.Compiler.Symbols.FSharpType get_ErasedType() -FSharp.Compiler.Symbols.FSharpType: FSharp.Compiler.Text.TaggedText[] FormatLayout(FSharp.Compiler.Symbols.FSharpDisplayContext) -FSharp.Compiler.Symbols.FSharpType: FSharp.Compiler.Text.TaggedText[] FormatLayoutWithConstraints(FSharp.Compiler.Symbols.FSharpDisplayContext) +FSharp.Compiler.Symbols.FSharpType: FSharp.Compiler.Text.RichText FormatRichText(FSharp.Compiler.Symbols.FSharpDisplayContext) +FSharp.Compiler.Symbols.FSharpType: FSharp.Compiler.Text.RichText FormatRichTextWithConstraints(FSharp.Compiler.Symbols.FSharpDisplayContext) FSharp.Compiler.Symbols.FSharpType: Int32 GetHashCode() FSharp.Compiler.Symbols.FSharpType: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpType] BaseType FSharp.Compiler.Symbols.FSharpType: Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Symbols.FSharpType] get_BaseType() @@ -11248,6 +11251,15 @@ FSharp.Compiler.Text.RangeModule: System.String stringOfRange(FSharp.Compiler.Te FSharp.Compiler.Text.RangeModule: System.Tuple`2[System.String,System.Tuple`2[System.Tuple`2[System.Int32,System.Int32],System.Tuple`2[System.Int32,System.Int32]]] toFileZ(FSharp.Compiler.Text.Range) FSharp.Compiler.Text.RangeModule: System.Tuple`2[System.Tuple`2[System.Int32,System.Int32],System.Tuple`2[System.Int32,System.Int32]] toZ(FSharp.Compiler.Text.Range) FSharp.Compiler.Text.RangeModule: Void outputRange(System.IO.TextWriter, FSharp.Compiler.Text.Range) +FSharp.Compiler.Text.RichText: Boolean Equals(System.Object) +FSharp.Compiler.Text.RichText: Boolean IsEmpty +FSharp.Compiler.Text.RichText: Boolean get_IsEmpty() +FSharp.Compiler.Text.RichText: FSharp.Compiler.Text.TaggedText[] Parts +FSharp.Compiler.Text.RichText: FSharp.Compiler.Text.TaggedText[] get_Parts() +FSharp.Compiler.Text.RichText: Int32 GetHashCode() +FSharp.Compiler.Text.RichText: System.String Text +FSharp.Compiler.Text.RichText: System.String ToString() +FSharp.Compiler.Text.RichText: System.String get_Text() FSharp.Compiler.Text.SourceText: FSharp.Compiler.Text.ISourceText ofString(System.String) FSharp.Compiler.Text.SourceTextNew: FSharp.Compiler.Text.ISourceTextNew ofISourceText(FSharp.Compiler.Text.ISourceText) FSharp.Compiler.Text.SourceTextNew: FSharp.Compiler.Text.ISourceTextNew ofString(System.String) @@ -11307,6 +11319,7 @@ FSharp.Compiler.Text.TextTag+Tags: Int32 TypeParameter FSharp.Compiler.Text.TextTag+Tags: Int32 Union FSharp.Compiler.Text.TextTag+Tags: Int32 UnionCase FSharp.Compiler.Text.TextTag+Tags: Int32 UnknownEntity +FSharp.Compiler.Text.TextTag+Tags: Int32 UnresolvedName FSharp.Compiler.Text.TextTag+Tags: Int32 UnknownType FSharp.Compiler.Text.TextTag: Boolean Equals(FSharp.Compiler.Text.TextTag) FSharp.Compiler.Text.TextTag: Boolean Equals(FSharp.Compiler.Text.TextTag, System.Collections.IEqualityComparer) @@ -11345,6 +11358,7 @@ FSharp.Compiler.Text.TextTag: Boolean IsTypeParameter FSharp.Compiler.Text.TextTag: Boolean IsUnion FSharp.Compiler.Text.TextTag: Boolean IsUnionCase FSharp.Compiler.Text.TextTag: Boolean IsUnknownEntity +FSharp.Compiler.Text.TextTag: Boolean IsUnresolvedName FSharp.Compiler.Text.TextTag: Boolean IsUnknownType FSharp.Compiler.Text.TextTag: Boolean get_IsActivePatternCase() FSharp.Compiler.Text.TextTag: Boolean get_IsActivePatternResult() @@ -11379,6 +11393,7 @@ FSharp.Compiler.Text.TextTag: Boolean get_IsTypeParameter() FSharp.Compiler.Text.TextTag: Boolean get_IsUnion() FSharp.Compiler.Text.TextTag: Boolean get_IsUnionCase() FSharp.Compiler.Text.TextTag: Boolean get_IsUnknownEntity() +FSharp.Compiler.Text.TextTag: Boolean get_IsUnresolvedName() FSharp.Compiler.Text.TextTag: Boolean get_IsUnknownType() FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag ActivePatternCase FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag ActivePatternResult @@ -11413,6 +11428,7 @@ FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag TypeParameter FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag Union FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag UnionCase FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag UnknownEntity +FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag UnresolvedName FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag UnknownType FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag get_ActivePatternCase() FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag get_ActivePatternResult() @@ -11447,6 +11463,7 @@ FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag get_TypeParameter() FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag get_Union() FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag get_UnionCase() FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag get_UnknownEntity() +FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag get_UnresolvedName() FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag get_UnknownType() FSharp.Compiler.Text.TextTag: FSharp.Compiler.Text.TextTag+Tags FSharp.Compiler.Text.TextTag: Int32 GetHashCode() @@ -12697,4 +12714,4 @@ Internal.Utilities.Library.InterruptibleLazy`1[T]: Internal.Utilities.Library.In Internal.Utilities.Library.InterruptibleLazy`1[T]: T Force() Internal.Utilities.Library.InterruptibleLazy`1[T]: T Value Internal.Utilities.Library.InterruptibleLazy`1[T]: T get_Value() -Internal.Utilities.Library.InterruptibleLazy`1[T]: Void .ctor(Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,T]) \ No newline at end of file +Internal.Utilities.Library.InterruptibleLazy`1[T]: Void .ctor(Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,T]) diff --git a/tests/FSharp.Compiler.Service.Tests/FsiHelpTests.fs b/tests/FSharp.Compiler.Service.Tests/FsiHelpTests.fs index 110cc1a09e7..f8d69da1824 100644 --- a/tests/FSharp.Compiler.Service.Tests/FsiHelpTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/FsiHelpTests.fs @@ -1,5 +1,6 @@ namespace FSharp.Compiler.UnitTests +open FSharp.Compiler.Text open FSharp.Test.Assert open Xunit @@ -30,7 +31,7 @@ module FsiHelpTests = [] let ``Can get help for FSComp.SR.considerUpcast`` () = - match FSharp.Compiler.Interactive.FsiHelp.Logic.Quoted.tryGetHelp <@ FSComp.SR.considerUpcast @> with + match FSharp.Compiler.Interactive.FsiHelp.Logic.Quoted.tryGetHelp <@ (FSComp.SR.considerUpcast: string * string -> int * RichText) @> with | ValueSome h -> h.Assembly |> shouldBe "FSharp.Compiler.Service.dll" h.FullName |> shouldBe "FSComp.SR.considerUpcast" diff --git a/tests/FSharp.Compiler.Service.Tests/RecordConstructorTests.fs b/tests/FSharp.Compiler.Service.Tests/RecordConstructorTests.fs index bae298a2a24..39dd327a01c 100644 --- a/tests/FSharp.Compiler.Service.Tests/RecordConstructorTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/RecordConstructorTests.fs @@ -18,9 +18,8 @@ let r = MyRecord(1, 2) let private tooltipToString (ToolTipText items) = items |> List.collect (function - | ToolTipElement.Group elements -> elements |> List.collect (fun e -> List.ofArray e.MainDescription) + | ToolTipElement.Group elements -> elements |> List.map (fun e -> e.MainDescription.Text) | _ -> []) - |> List.map (fun t -> t.Text) |> String.concat "" [] diff --git a/tests/FSharp.Compiler.Service.Tests/TooltipTests.fs b/tests/FSharp.Compiler.Service.Tests/TooltipTests.fs index 70b5e949a3d..14d0b7adb90 100644 --- a/tests/FSharp.Compiler.Service.Tests/TooltipTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/TooltipTests.fs @@ -291,8 +291,7 @@ let testToolTipSquashing source = | ToolTipElement.Group gr -> gr |> List.map (fun g -> g.MainDescription) | _ -> failwith "expected TooltipElement.Group") |> List.concat - |> Array.concat - |> Array.sumBy (fun t -> if t.Tag = TextTag.LineBreak then 1 else 0) + |> List.sumBy (fun t -> t.Parts |> Array.sumBy (fun t -> if t.Tag = TextTag.LineBreak then 1 else 0)) let squashedBreaks = groupsSquashed |> List.map @@ -301,9 +300,8 @@ let testToolTipSquashing source = | ToolTipElement.Group gr -> gr |> List.map (fun g -> g.MainDescription) | _ -> failwith "expected TooltipElement.Group") |> List.concat - |> Array.concat - |> Array.sumBy (fun t -> if t.Tag = TextTag.LineBreak then 1 else 0) - + |> List.sumBy (fun t -> t.Parts |> Array.sumBy (fun t -> if t.Tag = TextTag.LineBreak then 1 else 0)) + Assert.True(breaks < squashedBreaks) | _ -> failwith "Expected checking to succeed." @@ -380,7 +378,7 @@ let getMainDescriptionTags (ToolTipText(items)) = | _ -> failwith $"Expected single group in tooltip, got {items}" let assertNameTagInTooltip expectedTag expectedName (tooltip: ToolTipText) = - let tags = getMainDescriptionTags tooltip + let tags = (getMainDescriptionTags tooltip).Parts let found = tags |> Array.exists (fun t -> t.Tag = expectedTag && t.Text = expectedName) let desc = tags |> Array.map (fun t -> sprintf "(%A, %s)" t.Tag t.Text) |> String.concat ", " Assert.True(found, sprintf "Expected tag %A with text '%s' in tooltip, but found: %s" expectedTag expectedName desc) @@ -893,8 +891,7 @@ let private renderAllGroups (ToolTipText elements) = match el with | ToolTipElement.Group items -> for item in items do - for line in item.MainDescription do - sb.Append(line.Text) |> ignore + sb.Append(item.MainDescription.Text) |> ignore sb.Append('\n') |> ignore for line in item.XmlDoc |> (function FSharpXmlDoc.FromXmlText t -> t.UnprocessedLines |> Array.toList | _ -> []) do sb.AppendLine(line) |> ignore diff --git a/tests/FSharp.Test.Utilities/Compiler.fs b/tests/FSharp.Test.Utilities/Compiler.fs index ef14fbb0849..720619a43e0 100644 --- a/tests/FSharp.Test.Utilities/Compiler.fs +++ b/tests/FSharp.Test.Utilities/Compiler.fs @@ -422,6 +422,11 @@ $ code --diff {outFile} {expectedFile} let private fromFSharpDiagnostic (errors: FSharpDiagnostic[]) : (SourceCodeFileName * ErrorInfo) list = let toErrorInfo (e: FSharpDiagnostic) : SourceCodeFileName * ErrorInfo = + // Every diagnostic assertion in the test suite doubles as a check that classifying message + // parts doesn't change the message itself. See docs/rich-diagnostics.md. + if e.RichMessage.Text <> e.Message then + failwith $"Rich message text doesn't match the message.\nMessage: %A{e.Message}\nParts:\n%s{dumpRichText e.RichMessage}" + let errorNumber = e.ErrorNumber let severity = e.Severity let error = diff --git a/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj b/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj index 5654f9e8192..4ffdca6d934 100644 --- a/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj +++ b/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj @@ -34,6 +34,7 @@ + diff --git a/tests/FSharp.Test.Utilities/RichTextHelpers.fs b/tests/FSharp.Test.Utilities/RichTextHelpers.fs new file mode 100644 index 00000000000..5a4d75ba2c8 --- /dev/null +++ b/tests/FSharp.Test.Utilities/RichTextHelpers.fs @@ -0,0 +1,35 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Test + +open FSharp.Compiler.Text + +[] +module RichTextHelpers = + + let private escape (text: string) = + text + .Replace("\\", "\\\\") + .Replace("\"", "\\\"") + .Replace("\r", "\\r") + .Replace("\n", "\\n") + .Replace("\t", "\\t") + + /// Renders a single tagged part as `Tag "text"` + let dumpTaggedText (part: TaggedText) = + sprintf "%A \"%s\"" part.Tag (escape part.Text) + + /// Renders rich text as one `Tag "text"` line per part, so that tag sequences are readable and + /// can be compared directly in test expectations. + let dumpRichText (text: RichText) = + text.Parts |> Array.map dumpTaggedText |> String.concat "\n" + + /// Asserts that rich text consists of exactly the given parts. + /// Both sides are compared as dumps, so that a mismatch is reported part by part. + let assertRichTextParts (expected: (TextTag * string) list) (text: RichText) = + let expected = + expected + |> List.map (fun (tag, text) -> dumpTaggedText (TaggedText(tag, text))) + |> String.concat "\n" + + FSharp.Test.Assert.shouldEqual expected (dumpRichText text) diff --git a/vsintegration/src/FSharp.Editor/Common/RoslynHelpers.fs b/vsintegration/src/FSharp.Editor/Common/RoslynHelpers.fs index eb951181241..2679740fbb3 100644 --- a/vsintegration/src/FSharp.Editor/Common/RoslynHelpers.fs +++ b/vsintegration/src/FSharp.Editor/Common/RoslynHelpers.fs @@ -98,6 +98,7 @@ module internal RoslynHelpers = | TextTag.Punctuation -> TextTags.Punctuation | TextTag.Text | TextTag.ModuleBinding // why no 'Identifier'? Does it matter? + | TextTag.UnresolvedName | TextTag.UnknownEntity -> TextTags.Text let CollectTaggedText (list: List<_>) (t: TaggedText) = @@ -287,11 +288,6 @@ module internal OpenDeclarationHelper = sourceText, minPos |> Option.defaultValue 0 -[] -module internal TaggedText = - let toString (tts: TaggedText[]) = - tts |> Array.map (fun tt -> tt.Text) |> String.concat "" - // http://www.fssnip.net/7S3/title/Intersperse-a-list module List = /// The intersperse function takes an element and a list and diff --git a/vsintegration/src/FSharp.Editor/Completion/SignatureHelp.fs b/vsintegration/src/FSharp.Editor/Completion/SignatureHelp.fs index 9842f3f578c..f0da3b2b683 100644 --- a/vsintegration/src/FSharp.Editor/Completion/SignatureHelp.fs +++ b/vsintegration/src/FSharp.Editor/Completion/SignatureHelp.fs @@ -231,7 +231,7 @@ type internal FSharpSignatureHelpProvider [] (serviceProvi editorOptions.QuickInfo.ShowRemarks ) - p.Display |> Seq.iter (RoslynHelpers.CollectTaggedText parts) + p.Display.Parts |> Seq.iter (RoslynHelpers.CollectTaggedText parts) { ParameterName = p.ParameterName @@ -454,8 +454,8 @@ type internal FSharpSignatureHelpProvider [] (serviceProvi if argument.Count = 1 then let argument = argument.[0] - let taggedText = argument.Type.FormatLayout symbolUse.DisplayContext - taggedText |> Seq.iter (RoslynHelpers.CollectTaggedText tt) + let typeText = argument.Type.FormatRichText symbolUse.DisplayContext + typeText.Parts |> Seq.iter (RoslynHelpers.CollectTaggedText tt) let name = let displayName = argument.DisplayName @@ -513,8 +513,8 @@ type internal FSharpSignatureHelpProvider [] (serviceProvi let tt = ResizeArray() - let taggedText = arg.Type.FormatLayout symbolUse.DisplayContext - taggedText |> Seq.iter (RoslynHelpers.CollectTaggedText tt) + let typeText = arg.Type.FormatRichText symbolUse.DisplayContext + typeText.Parts |> Seq.iter (RoslynHelpers.CollectTaggedText tt) let name = if String.IsNullOrWhiteSpace(arg.DisplayName) then diff --git a/vsintegration/src/FSharp.Editor/DocComments/XMLDocumentation.fs b/vsintegration/src/FSharp.Editor/DocComments/XMLDocumentation.fs index 7c587b206c7..02684cece56 100644 --- a/vsintegration/src/FSharp.Editor/DocComments/XMLDocumentation.fs +++ b/vsintegration/src/FSharp.Editor/DocComments/XMLDocumentation.fs @@ -468,7 +468,7 @@ module internal XmlDocumentation = let usageCollector: ITaggedTextCollector = TextSanitizingCollector(usage.Add, lineLimit = lineLimit) - let ProcessGenericParameters (tps: TaggedText[] list) = + let ProcessGenericParameters (tps: RichText list) = if not tps.IsEmpty then AppendHardLine typeParameterMapCollector AppendOnNewLine typeParameterMapCollector (SR.GenericParametersHeader()) @@ -476,7 +476,7 @@ module internal XmlDocumentation = for tp in tps do AppendHardLine typeParameterMapCollector typeParameterMapCollector.Add(tagSpace " ") - tp |> Array.iter typeParameterMapCollector.Add + tp.Parts |> Array.iter typeParameterMapCollector.Add let collectDocumentation () = [ documentation; typeParameterMap; exceptions; usage ] @@ -489,7 +489,7 @@ module internal XmlDocumentation = match dataTipElement with | ToolTipElement.Group overloads when not overloads.IsEmpty -> overloads[.. overLoadsLimit - 1] - |> List.map (fun item -> item.MainDescription) + |> List.map (fun item -> item.MainDescription.Parts) |> List.intersperse [| lineBreak |] |> Seq.concat |> Seq.iter textCollector.Add @@ -501,9 +501,9 @@ module internal XmlDocumentation = item0.Remarks |> Option.iter (fun r -> - if TaggedText.toString r <> "" then + if r.Text <> "" then AppendHardLine usageCollector - r |> Seq.iter usageCollector.Add) + r.Parts |> Seq.iter usageCollector.Add) AppendXmlComment(documentationProvider, xmlCollector, exnCollector, item0.XmlDoc, true, false, showRemarks, item0.ParamName) @@ -552,7 +552,7 @@ module internal XmlDocumentation = AddSeparator textCollector AddSeparator xmlCollector - let ProcessGenericParameters (tps: TaggedText[] list) = + let ProcessGenericParameters (tps: RichText list) = if not tps.IsEmpty then AppendHardLine typeParameterMapCollector AppendOnNewLine typeParameterMapCollector (SR.GenericParametersHeader()) @@ -560,7 +560,7 @@ module internal XmlDocumentation = for tp in tps do AppendHardLine typeParameterMapCollector typeParameterMapCollector.Add(tagSpace " ") - tp |> Array.iter typeParameterMapCollector.Add + tp.Parts |> Array.iter typeParameterMapCollector.Add let Process add (dataTipElement: ToolTipElement) = @@ -576,11 +576,11 @@ module internal XmlDocumentation = if showText then let AppendOverload (item: ToolTipElementData) = - if TaggedText.toString item.MainDescription <> "" then + if item.MainDescription.Text <> "" then if not textCollector.IsEmpty then AppendHardLine textCollector - item.MainDescription |> Seq.iter textCollector.Add + item.MainDescription.Parts |> Seq.iter textCollector.Add AppendOverload(overloads.[0]) @@ -604,9 +604,9 @@ module internal XmlDocumentation = item0.Remarks |> Option.iter (fun r -> - if TaggedText.toString r <> "" then + if r.Text <> "" then AppendHardLine usageCollector - r |> Seq.iter usageCollector.Add) + r.Parts |> Seq.iter usageCollector.Add) AppendXmlComment( documentationProvider, diff --git a/vsintegration/src/FSharp.Editor/Hints/InlayReturnTypeHints.fs b/vsintegration/src/FSharp.Editor/Hints/InlayReturnTypeHints.fs index c7f36eec3a7..500014a8943 100644 --- a/vsintegration/src/FSharp.Editor/Hints/InlayReturnTypeHints.fs +++ b/vsintegration/src/FSharp.Editor/Hints/InlayReturnTypeHints.fs @@ -12,11 +12,11 @@ open CancellableTasks type InlayReturnTypeHints(parseFileResults: FSharpParseFileResults, symbol: FSharpMemberOrFunctionOrValue) = let getHintParts (symbolUse: FSharpSymbolUse) = - symbol.GetReturnTypeLayout symbolUse.DisplayContext + symbol.GetReturnTypeRichText symbolUse.DisplayContext |> Option.map (fun typeInfo -> [ TaggedText(TextTag.Text, ": ") - yield! typeInfo |> Array.toList + yield! typeInfo.Parts |> Array.toList TaggedText(TextTag.Space, " ") ]) diff --git a/vsintegration/src/FSharp.Editor/Hints/InlayTypeHints.fs b/vsintegration/src/FSharp.Editor/Hints/InlayTypeHints.fs index c5504ef104a..4ffe778fb18 100644 --- a/vsintegration/src/FSharp.Editor/Hints/InlayTypeHints.fs +++ b/vsintegration/src/FSharp.Editor/Hints/InlayTypeHints.fs @@ -14,10 +14,10 @@ type InlayTypeHints(parseResults: FSharpParseFileResults, symbol: FSharpMemberOr let getHintParts (symbol: FSharpMemberOrFunctionOrValue) (symbolUse: FSharpSymbolUse) = - match symbol.GetReturnTypeLayout symbolUse.DisplayContext with + match symbol.GetReturnTypeRichText symbolUse.DisplayContext with | Some typeInfo -> let colon = TaggedText(TextTag.Text, ": ") - colon :: (typeInfo |> Array.toList) + colon :: (typeInfo.Parts |> Array.toList) // not sure when this can happen | None -> [] diff --git a/vsintegration/src/FSharp.Editor/QuickInfo/Views.fs b/vsintegration/src/FSharp.Editor/QuickInfo/Views.fs index 146c7d7dfcb..9a398237d7b 100644 --- a/vsintegration/src/FSharp.Editor/QuickInfo/Views.fs +++ b/vsintegration/src/FSharp.Editor/QuickInfo/Views.fs @@ -45,6 +45,7 @@ module internal QuickInfoViewProvider = | TextTag.Operator -> ClassificationTypeNames.Operator | TextTag.StringLiteral -> ClassificationTypeNames.StringLiteral | TextTag.Punctuation -> ClassificationTypeNames.Punctuation + | TextTag.UnresolvedName | TextTag.UnknownEntity | TextTag.Text -> ClassificationTypeNames.Text diff --git a/vsintegration/src/FSharp.LanguageService/Intellisense.fs b/vsintegration/src/FSharp.LanguageService/Intellisense.fs index ef24af9b979..6f11b4a4314 100644 --- a/vsintegration/src/FSharp.LanguageService/Intellisense.fs +++ b/vsintegration/src/FSharp.LanguageService/Intellisense.fs @@ -24,8 +24,6 @@ open FSharp.Compiler.Tokenization module internal TaggedText = let appendTo (sb: System.Text.StringBuilder) (t: TaggedText) = sb.Append t.Text |> ignore - let toString (tts: TaggedText[]) = - tts |> Array.map (fun tt -> tt.Text) |> String.concat "" // Note: DEPRECATED CODE ONLY ACTIVE IN UNIT TESTING VIA "UNROSLYNIZED" UNIT TESTS. // @@ -80,12 +78,12 @@ type internal FSharpMethodListForAMethodTip_DEPRECATED(documentationBuilder: IDo buf.ToString() ) - override x.GetReturnTypeText(methodIndex) = safe methodIndex "" (fun m -> m.ReturnTypeText |> TaggedText.toString) + override x.GetReturnTypeText(methodIndex) = safe methodIndex "" (fun m -> m.ReturnTypeText.Text) override x.GetParameterCount(methodIndex) = safe methodIndex 0 (fun m -> getParameters(m).Length) override x.GetParameterInfo(methodIndex, parameterIndex, nameOut, displayOut, descriptionOut) = - let name,display = safe methodIndex ("","") (fun m -> let p = getParameters(m).[parameterIndex] in p.ParameterName, TaggedText.toString p.Display ) + let name,display = safe methodIndex ("","") (fun m -> let p = getParameters(m).[parameterIndex] in p.ParameterName, p.Display.Text ) nameOut <- name displayOut <- display diff --git a/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs b/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs index bcf60c275ca..93e1a530248 100644 --- a/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs +++ b/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs @@ -15,11 +15,6 @@ open FSharp.Compiler.Syntax open FSharp.Compiler.Text open FSharp.Compiler.Text.TaggedText -[] -module internal Utils2 = - let taggedTextToString (tts: TaggedText[]) = - tts |> Array.map (fun tt -> tt.Text) |> String.concat "" - type internal ITaggedTextCollector_DEPRECATED = abstract Add: text: TaggedText -> unit abstract EndsWithLineBreak: bool @@ -157,9 +152,9 @@ module internal XmlDocumentation = addSeparatorIfNecessary add if showText then let AppendOverload (item :ToolTipElementData) = - if taggedTextToString item.MainDescription <> "" then + if item.MainDescription.Text <> "" then if not textCollector.IsEmpty then textCollector.Add TaggedText.lineBreak - item.MainDescription |> Seq.iter textCollector.Add + item.MainDescription.Parts |> Seq.iter textCollector.Add AppendOverload(overloads.[0]) if len >= 2 then AppendOverload(overloads.[1]) @@ -174,7 +169,7 @@ module internal XmlDocumentation = item0.Remarks |> Option.iter (fun r -> textCollector.Add TaggedText.lineBreak - r |> Seq.iter textCollector.Add |> ignore) + r.Parts |> Seq.iter textCollector.Add |> ignore) AppendXmlComment_DEPRECATED(documentationProvider, xmlCollector, item0.XmlDoc, showExceptions, showParameters, item0.ParamName) diff --git a/vsintegration/tests/FSharp.Editor.Tests/QuickInfoProviderTests.fs b/vsintegration/tests/FSharp.Editor.Tests/QuickInfoProviderTests.fs index 18cff0490e9..09137e8a57a 100644 --- a/vsintegration/tests/FSharp.Editor.Tests/QuickInfoProviderTests.fs +++ b/vsintegration/tests/FSharp.Editor.Tests/QuickInfoProviderTests.fs @@ -43,7 +43,7 @@ module QuickInfoProviderTests = function | ToolTipElement.None -> Empty | ToolTipElement.Group(xs) -> - let descriptions = xs |> List.map (fun item -> item.MainDescription) + let descriptions = xs |> List.map (fun item -> item.MainDescription.Parts) let descriptionTexts = descriptions @@ -51,7 +51,8 @@ module QuickInfoProviderTests = let descriptionText = descriptionTexts |> Array.concat |> String.concat "" - let remarks = xs |> List.choose (fun item -> item.Remarks) + let remarks = + xs |> List.choose (fun item -> item.Remarks |> Option.map (fun r -> r.Parts)) let remarkTexts = remarks |> Array.concat |> Array.map (fun taggedText -> taggedText.Text) @@ -61,7 +62,9 @@ module QuickInfoProviderTests = | [] -> "" | _ -> "\n" + String.concat "" remarkTexts) - let tps = xs |> List.collect (fun item -> item.TypeMapping) + let tps = + xs + |> List.collect (fun item -> item.TypeMapping |> List.map (fun tp -> tp.Parts)) let tpTexts = tps |> List.map (fun x -> x |> Array.map (fun y -> y.Text) |> String.concat "") From 29718dd942497eb4e0753777e8a8e104c9abf6e3 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 12 Aug 2026 14:03:32 +0200 Subject: [PATCH 23/55] Avoid per-instance lock object in InterruptibleLazy and DelayInitArrayMap (#20088) * Avoid per-instance lock object in InterruptibleLazy and DelayInitArrayMap Both types allocated a dedicated `syncObj = obj()` for their one-time initialisation. These instances are internal and never locked externally, and there are enough of them (one per lazy IL member, per ILTypeDefs / ILMethodDefs, etc.) that the extra bare System.Object adds up to tens of MB on a large project. Lock on `this` instead and drop the field. Measured on a single-file FCS check against a project with ~486 references: bare System.Object instances dropped from ~1,000,000 to ~29,000 (~-22 MB). --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + src/Compiler/Utilities/illib.fs | 16 ++++++---------- src/Compiler/Utilities/illib.fsi | 1 + 3 files changed, 8 insertions(+), 10 deletions(-) diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index c01d034d0f6..e11e34a5c88 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -133,6 +133,7 @@ * Parser: recover on unfinished abstract members ([PR #20070](https://github.com/dotnet/fsharp/pull/20070)) * Fix #5795: Allow attributes defined in a `module rec` / `namespace rec` scope to be used on union cases, record fields, and generic type parameters of types in the same recursive scope. ([Issue #5795](https://github.com/dotnet/fsharp/issues/5795), [PR #19744](https://github.com/dotnet/fsharp/pull/19744)) * Import: Don't walk non-F# assemblies when labelling trait constraint sources (PR [#20090](https://github.com/dotnet/fsharp/pull/20090)) +* Avoid per-instance lock object in InterruptibleLazy and DelayInitArrayMap (PR [#20088](https://github.com/dotnet/fsharp/pull/20088)) ### Added diff --git a/src/Compiler/Utilities/illib.fs b/src/Compiler/Utilities/illib.fs index 87434b07720..0b8d51be0a3 100644 --- a/src/Compiler/Utilities/illib.fs +++ b/src/Compiler/Utilities/illib.fs @@ -15,8 +15,6 @@ open FSharp.Compiler.Caches [] type InterruptibleLazy<'T> private (value, valueFactory: unit -> 'T) = - let syncObj = obj () - [] // TODO nullness - this is boxed to obj because of an attribute targets bug fixed in main, but not yet shipped (needs shipped 8.0.400) let mutable valueFactory: objnull = valueFactory @@ -34,7 +32,7 @@ type InterruptibleLazy<'T> private (value, valueFactory: unit -> 'T) = match valueFactory with | null -> value | _ -> - Monitor.Enter(syncObj) + Monitor.Enter(this) try match valueFactory with @@ -44,7 +42,7 @@ type InterruptibleLazy<'T> private (value, valueFactory: unit -> 'T) = value <- (valueFactory |> unbox 'T>) () valueFactory <- Unchecked.defaultof<_> finally - Monitor.Exit(syncObj) + Monitor.Exit(this) value @@ -151,8 +149,6 @@ module internal PervasiveAutoOpens = [] type DelayInitArrayMap<'T, 'TDictKey, 'TDictValue>(f: unit -> 'T[]) = - let syncObj = obj () - let mutable arrayStore: (_ array | null) = null let mutable dictStore: (_ | null) = null @@ -162,7 +158,7 @@ type DelayInitArrayMap<'T, 'TDictKey, 'TDictValue>(f: unit -> 'T[]) = match arrayStore with | NonNull value -> value | _ -> - Monitor.Enter(syncObj) + Monitor.Enter(this) try match arrayStore with @@ -174,14 +170,14 @@ type DelayInitArrayMap<'T, 'TDictKey, 'TDictValue>(f: unit -> 'T[]) = func <- Unchecked.defaultof<_> freshArray finally - Monitor.Exit(syncObj) + Monitor.Exit(this) member this.GetDictionary() = match dictStore with | NonNull value -> value | _ -> let array = this.GetArray() - Monitor.Enter(syncObj) + Monitor.Enter(this) try match dictStore with @@ -191,7 +187,7 @@ type DelayInitArrayMap<'T, 'TDictKey, 'TDictValue>(f: unit -> 'T[]) = dictStore <- dict dict finally - Monitor.Exit(syncObj) + Monitor.Exit(this) abstract CreateDictionary: 'T[] -> IDictionary<'TDictKey, 'TDictValue> diff --git a/src/Compiler/Utilities/illib.fsi b/src/Compiler/Utilities/illib.fsi index 629ed64537f..12d56533449 100644 --- a/src/Compiler/Utilities/illib.fsi +++ b/src/Compiler/Utilities/illib.fsi @@ -8,6 +8,7 @@ open System.Collections.Concurrent open System.Collections.Generic open System.Runtime.CompilerServices +/// Do not lock on these objects. [] type InterruptibleLazy<'T> = new: valueFactory: (unit -> 'T) -> InterruptibleLazy<'T> From ffa6ef193665e8a03c00b71b394a4fc72c686255 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Wed, 12 Aug 2026 14:44:37 +0200 Subject: [PATCH 24/55] Regression matrix: build unmodified repos against local FSharp.Core (#20240) --- .github/agents/compiler-perf-investigator.md | 2 +- UseLocalCompiler.Directory.Build.props | 46 +++-- UseLocalCompiler.Directory.Build.targets | 11 ++ azure-pipelines-PR.yml | 22 ++- docs/regression-testing-pipeline.md | 53 ++---- eng/scripts/BuildWithLocalFSharp.fsx | 118 +++++++++++++ .../PrepareRepoForRegressionTesting.fsx | 110 ------------ eng/templates/regression-test-jobs.yml | 163 ++++-------------- .../InProcess/SolutionExplorerInProcess.cs | 1 + 9 files changed, 231 insertions(+), 295 deletions(-) create mode 100644 UseLocalCompiler.Directory.Build.targets create mode 100644 eng/scripts/BuildWithLocalFSharp.fsx delete mode 100644 eng/scripts/PrepareRepoForRegressionTesting.fsx diff --git a/.github/agents/compiler-perf-investigator.md b/.github/agents/compiler-perf-investigator.md index 716821d5ae9..5ad3c9477d0 100644 --- a/.github/agents/compiler-perf-investigator.md +++ b/.github/agents/compiler-perf-investigator.md @@ -40,7 +40,7 @@ These are **general investigation instructions** for this agent, a template for ### 1. Preparation - **Setup:** Clone/generate repo/snippet/etc. - **Clear old config:** Remove `global.json` unless needed. -- **Prepare local compiler:** Use `PrepareRepoForRegressionTesting.fsx` and absolute env paths. +- **Prepare local compiler:** Build via `dotnet fsi /eng/scripts/BuildWithLocalFSharp.fsx --build-script ''` (sets the local-compiler + FSharp.Core shim env). ### 2. Experiment Matrix diff --git a/UseLocalCompiler.Directory.Build.props b/UseLocalCompiler.Directory.Build.props index 8bd796bfe90..6cfa1da98bc 100644 --- a/UseLocalCompiler.Directory.Build.props +++ b/UseLocalCompiler.Directory.Build.props @@ -7,39 +7,51 @@ False - Release + $(MSBuildThisFileDirectory) + - $(MSBuildThisFileDirectory) - - true + + true $([System.IO.Path]::GetDirectoryName($(DOTNET_HOST_PATH))) $([System.IO.Path]::GetFileName($(DOTNET_HOST_PATH))) - - $(LocalFSharpCompilerPath)/artifacts/bin/fsc/$(LocalFSharpCompilerConfiguration)/$(FSharpNetCoreProductTargetFramework)/fsc.dll - $(LocalFSharpCompilerPath)/artifacts/bin/fsc/$(LocalFSharpCompilerConfiguration)/$(FSharpNetCoreProductTargetFramework)/fsc.dll - False True - - - $(LocalFSharpCompilerPath)/artifacts/bin/fsc/$(LocalFSharpCompilerConfiguration)/$(FSharpNetCoreProductTargetFramework) + $(LocalFSharpBuildBinPath)/fsc.dll + $(LocalFSharpBuildBinPath)/fsc.dll $(LocalFSharpBuildBinPath)/FSharp.Build.dll $(LocalFSharpBuildBinPath)/Microsoft.FSharp.Targets $(LocalFSharpBuildBinPath)/Microsoft.FSharp.NetSdk.props $(LocalFSharpBuildBinPath)/Microsoft.FSharp.NetSdk.targets $(LocalFSharpBuildBinPath)/Microsoft.FSharp.Overrides.NetSdk.targets + + $(OtherFlags) --nowarn:75 --times + + + + + $(RegressionLocalCoreVersion) + true + <_FSharpCoreLibraryPacksFolder>$([MSBuild]::ValueOrDefault('$(RegressionLocalCorePackagesDir)', '$(MSBuildThisFileDirectory)library-packs')) - + + + + + + + true + + diff --git a/UseLocalCompiler.Directory.Build.targets b/UseLocalCompiler.Directory.Build.targets new file mode 100644 index 00000000000..0779e90aa02 --- /dev/null +++ b/UseLocalCompiler.Directory.Build.targets @@ -0,0 +1,11 @@ + + + + + + + + + diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index 65f45277382..ff6f4603975 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -583,13 +583,19 @@ stages: condition: succeeded() - pwsh: | - # Stage UseLocalCompiler props and TargetFrameworks.props together + # Stage the props and the locally built FSharp.Core so regression jobs restore it the SDK way. + # Arcade packs FSharp.Core into a `Shipping` leaf whose parent varies by layout, so search for it. $stagingDir = "$(Build.SourcesDirectory)/UseLocalCompilerPropsStaging" - New-Item -ItemType Directory -Force -Path $stagingDir | Out-Null + $packsDir = Join-Path $stagingDir "library-packs" + New-Item -ItemType Directory -Force -Path $packsDir | Out-Null Copy-Item "$(Build.SourcesDirectory)/UseLocalCompiler.Directory.Build.props" -Destination $stagingDir Copy-Item "$(Build.SourcesDirectory)/eng/TargetFrameworks.props" -Destination $stagingDir + $core = Get-ChildItem "$(Build.SourcesDirectory)/artifacts/packages/Release" -Recurse -Filter "FSharp.Core.*.nupkg" | + Where-Object { $_.Name -notlike "*.symbols.nupkg" -and $_.Directory.Name -eq "Shipping" } | Select-Object -First 1 + if (-not $core) { Write-Host "##[error]FSharp.Core.*.nupkg not found under artifacts/packages/Release/**/Shipping"; exit 1 } + Copy-Item $core.FullName -Destination $packsDir Write-Host "Staged files for UseLocalCompilerProps artifact:" - Get-ChildItem $stagingDir -Name + Get-ChildItem $stagingDir -Recurse -Name displayName: Stage UseLocalCompiler props files - task: PublishPipelineArtifact@1 @@ -749,6 +755,7 @@ stages: commit: bbe2dec4d0379b5d7d0480997858c30d442fbb42 buildScript: dotnet build -bl displayName: UMX_Slow_Repro + expectLocalCore: true - repo: fsprojects/FSharpPlus commit: f614035b75922aba41ed6a36c2fc986a2171d2b8 buildScript: build.cmd @@ -763,6 +770,7 @@ stages: commit: 2648efe buildScript: dotnet build tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj -c Release -bl displayName: FsharpPlus_NET10_Build_Lib_Tests + expectLocalCore: true # remove this before merging - repo: fsprojects/FSharpPlus commit: 2648efe @@ -814,10 +822,18 @@ stages: commit: 6ddc28d46f81447eacb241b96e16ce693b210c96 buildScript: dotnet build Prime.sln --configuration Release displayName: Prime_Build + expectLocalCore: true - repo: bryanedds/Nu commit: e81e00a464b9d35d272f61708a1a0bfbf487b6d5 buildScript: dotnet build Nu.sln --configuration Release displayName: Nu_Build + expectLocalCore: true + # Explicit FSharp.Core PackageReference mixed with one implicit test project; the trigger for #20059 (Lanayx/Oxpecker#20065). + - repo: Lanayx/Oxpecker + commit: cb7e4b83e3f2aba7ded46b17a36d1aea8c13c292 + buildScript: dotnet build Oxpecker.slnx -c Release + displayName: Oxpecker_Build + expectLocalCore: true # Design-time provider packaging oracle. Pin d8aba70 (pre-workaround base of FSharp.Data.GraphQL#583): # it uses the bare IsFSharpDesignTimeProvider gesture, so the client pack drops the provider without this fix. # Linux-only: the $PWD local feed and the grep content assertion need bash. (nupkg entry names are stored diff --git a/docs/regression-testing-pipeline.md b/docs/regression-testing-pipeline.md index 5e3013bfad5..7c0518f06ea 100644 --- a/docs/regression-testing-pipeline.md +++ b/docs/regression-testing-pipeline.md @@ -25,8 +25,8 @@ The regression testing logic is implemented as a reusable Azure DevOps template 1. **Build F# Compiler**: The `EndToEndBuildTests` job builds the F# compiler and publishes required artifacts 2. **Matrix Execution**: For each library in the test matrix (running in parallel): - Checkout the third-party repository at a specific commit - - Install appropriate .NET SDK version using the repository's `global.json` - - Setup `Directory.Build.props` to import `UseLocalCompiler.Directory.Build.props` + - Pin `global.json` to the exact SDK that built the local compiler + - Inject `UseLocalCompiler.Directory.Build.props` via `CustomAfterDirectoryBuildProps` - Build the library using its standard build script - Publish MSBuild binary logs for analysis 3. **Report Results**: Success/failure status is reported with build logs for diagnosis @@ -68,8 +68,9 @@ To add a new library to the test matrix, update the template invocation in `azur Each test matrix entry requires: - **repo**: GitHub repository in `owner/name` format - **commit**: Specific commit SHA for reproducible results -- **buildScript**: Build script to execute (e.g., `build.cmd`, `build.sh`) +- **buildScript**: Build command to execute — a `dotnet ...` command or a script file (`build.cmd`/`build.sh`); `;;` separates commands run sequentially, fail-fast - **displayName**: Human-readable name for the job +- **expectLocalCore** (optional): set `true` when the repo has projects that take the implicit `FSharp.Core`; the job then fails unless the locally built FSharp.Core is actually restored — a tripwire for a silently broken shim ## Pipeline Configuration @@ -82,10 +83,10 @@ Regression tests run automatically as part of PR builds when: ### Build Environment -- **OS**: Windows (using `$(WindowsMachineQueueName)`) +- **OS**: Windows by default (`$(WindowsMachineQueueName)`); matrix entries can override to Linux. The scripts are OS-agnostic - **Pool**: Standard public build pool (`$(DncEngPublicBuildPool)`) -- **Timeout**: 60 minutes per regression test job -- **.NET SDK**: Automatically detects and installs SDK version from each repository's `global.json` +- **Timeout**: 120 minutes per regression test job +- **.NET SDK**: Each test repo's `global.json` is pinned to the SDK that built the local compiler, so `fsc.dll` and its host runtime line up ### Artifacts @@ -108,26 +109,19 @@ When a regression test fails: ### Local Testing -To test a library locally with your F# compiler build: +To reproduce a regression locally, on any OS, without editing the library: -1. Build the F# compiler: `.\Build.cmd -c Release -pack` - -2. In the third-party library directory, create a `Directory.Build.props`: - ```xml - - - +1. Build the compiler and pack FSharp.Core in your `dotnet/fsharp` checkout: `./build.sh -c Release -pack` (`Build.cmd` on Windows). +2. Clone the library at the failing commit and build it against your local build: ``` - -3. Update the `LocalFSharpCompilerPath` in `UseLocalCompiler.Directory.Build.props` to point to your F# repository. - -4. Set environment variables: - ```cmd - set LoadLocalFSharpBuild=true - set LocalFSharpCompilerConfiguration=Release + git clone --recursive https://github.com//.git TestRepo + cd TestRepo && git checkout + # If TestRepo's global.json pins a different SDK, align sdk.version with /global.json + # (allowPrerelease: true, rollForward: disable) — the clone is disposable, as in CI. + dotnet fsi /eng/scripts/BuildWithLocalFSharp.fsx --build-script '' ``` -5. Run the library's build script. +`BuildWithLocalFSharp.fsx` runs the same command CI runs, from the current directory, without touching the repo's sources. Add `--verify` to fail unless every project consumes the local FSharp.Core; the script header lists the other options. Because the local package keeps a fixed `-dev` version, the script evicts it from the global NuGet cache before each run so a rebuild is never served stale; pass `--nuget-packages ` to use an isolated cache when running several builds concurrently or against a repo that redirects its packages folder. ## Best Practices @@ -148,20 +142,7 @@ To test a library locally with your F# compiler build: ### UseLocalCompiler.Directory.Build.props -This MSBuild props file configures projects to use the locally built F# compiler instead of the SDK version. Key settings: - -- `LocalFSharpCompilerPath`: Points to the F# compiler artifacts -- `DotnetFscCompilerPath`: Path to the fsc.dll compiler -- `DisableImplicitFSharpCoreReference`: Ensures local FSharp.Core is used - -### Path Handling - -The pipeline dynamically updates paths in the props file using PowerShell: -```powershell -$content -replace 'LocalFSharpCompilerPath.*MSBuildThisFileDirectory.*', 'LocalFSharpCompilerPath>$(Pipeline.Workspace)/FSharpCompiler<' -``` - -This ensures the correct path is used in the Azure DevOps environment. +This MSBuild props file redirects projects to the locally built F# compiler (and, for the matrix, the locally built FSharp.Core) instead of the SDK version. It is organised into gates so it can be injected into unmodified repos as well as imported directly by in-repo tests — see the `Gate 1/2/3` comments in the file. Its companion `UseLocalCompiler.Directory.Build.targets` is injected via `CustomAfterDirectoryBuildTargets` (after the target repo's project body) so the local FSharp.Core version wins over the repo's own reference, whether implicit, an explicit `PackageReference Include`, a `PackageReference Update`, or a central `PackageVersion` (Central Package Management). ## Future Enhancements diff --git a/eng/scripts/BuildWithLocalFSharp.fsx b/eng/scripts/BuildWithLocalFSharp.fsx new file mode 100644 index 00000000000..d01aaeca138 --- /dev/null +++ b/eng/scripts/BuildWithLocalFSharp.fsx @@ -0,0 +1,118 @@ +// Build an unmodified repo with this checkout's F# compiler and FSharp.Core, on any OS (needs only the .NET SDK). +// dotnet fsi /eng/scripts/BuildWithLocalFSharp.fsx --build-script "dotnet build MySolution.sln" +// Prerequisite: build this checkout with `-c Release -pack`. + +open System +open System.IO +open System.Diagnostics + +let fail (msg: string) : 'a = eprintfn "ERROR: %s" msg; exit 1 + +let opts = System.Collections.Generic.Dictionary(StringComparer.OrdinalIgnoreCase) + +let rec parseArgs = function + | (key: string) :: value :: rest when key.StartsWith "--" && not (value.StartsWith "--") -> + opts.[key.Substring 2] <- value + parseArgs rest + | key :: rest when key.StartsWith "--" -> + opts.[key.Substring 2] <- "true" + parseArgs rest + | _ :: rest -> parseArgs rest + | [] -> () + +fsi.CommandLineArgs |> Array.tail |> Array.toList |> parseArgs + +let tryOpt k = match opts.TryGetValue k with | true, v -> Some v | _ -> None +let opt k d = defaultArg (tryOpt k) d + +let fsharpRoot = opt "fsharp-root" (Path.GetFullPath(Path.Combine(__SOURCE_DIRECTORY__, "..", ".."))) +let configuration = opt "configuration" "Release" +let compilerPath = opt "compiler-path" fsharpRoot +let props = opt "props" (Path.Combine(fsharpRoot, "UseLocalCompiler.Directory.Build.props")) +let targets = opt "targets" (Path.Combine(fsharpRoot, "UseLocalCompiler.Directory.Build.targets")) +let corePackagesDir = opt "core-packages-dir" (Path.Combine(compilerPath, "artifacts", "packages", configuration)) +let repoDir = opt "repo-dir" (Directory.GetCurrentDirectory()) +let buildScript = match tryOpt "build-script" with Some s -> s | None -> fail "--build-script is required" +let verify = (tryOpt "verify").IsSome + +if not (File.Exists props) then fail (sprintf "props file not found: %s" props) +if not (File.Exists targets) then fail (sprintf "targets file not found: %s" targets) +if not (Directory.Exists corePackagesDir) then + fail (sprintf "FSharp.Core package folder not found: %s (build the compiler with `-c %s -pack`)" corePackagesDir configuration) + +let nupkg = + // Arcade routes FSharp.Core to a `Shipping` leaf that varies by layout (Release/Shipping locally, + // Dependency/Shipping on CI), so search recursively and prefer that folder, then newest. + Directory.GetFiles(corePackagesDir, "FSharp.Core.*.nupkg", SearchOption.AllDirectories) + |> Array.filter (fun f -> not (f.EndsWith(".symbols.nupkg", StringComparison.OrdinalIgnoreCase))) + |> Array.sortByDescending (fun f -> Path.GetFileName(Path.GetDirectoryName f) = "Shipping", File.GetLastWriteTimeUtc f) + |> Array.tryHead + |> Option.defaultWith (fun () -> fail (sprintf "no FSharp.Core.*.nupkg under %s" corePackagesDir)) + +let version = Path.GetFileNameWithoutExtension(nupkg).Substring("FSharp.Core.".Length) + +let setEnv k v = Environment.SetEnvironmentVariable(k, v) +setEnv "LoadLocalFSharpBuild" "True" +setEnv "LocalFSharpCompilerPath" compilerPath +setEnv "LocalFSharpCompilerConfiguration" configuration +setEnv "CustomAfterDirectoryBuildProps" props +setEnv "CustomAfterDirectoryBuildTargets" targets +setEnv "RegressionLocalCore" "true" +setEnv "RegressionLocalCoreVersion" version +setEnv "RegressionLocalCorePackagesDir" corePackagesDir +tryOpt "nuget-packages" |> Option.iter (setEnv "NUGET_PACKAGES") + +// NuGet caches by id+version, so a repacked same-version local FSharp.Core would be served stale; evict it first. +let globalPackages = + match Environment.GetEnvironmentVariable "NUGET_PACKAGES" with + | null | "" -> Path.Combine(Environment.GetFolderPath Environment.SpecialFolder.UserProfile, ".nuget", "packages") + | p -> p +let cachedCore = Path.Combine(globalPackages, "fsharp.core", version) +if Directory.Exists cachedCore then + try Directory.Delete(cachedCore, true) + with e -> eprintfn "WARN: could not evict cached %s: %s" cachedCore e.Message + +printfn "Local F# compiler: %s (%s)" compilerPath configuration +printfn "Local FSharp.Core: %s from %s" version corePackagesDir + +let run (command: string) = + let psi = ProcessStartInfo(WorkingDirectory = repoDir, UseShellExecute = false) + let launch = + if OperatingSystem.IsWindows() then + psi.FileName <- "cmd.exe" + psi.ArgumentList.Add "/c" + if command.StartsWith("dotnet", StringComparison.OrdinalIgnoreCase) then command else ".\\" + command + else + psi.FileName <- "/bin/bash" + psi.ArgumentList.Add "-c" + // Escape bare ';' so MSBuild's `-t:Build;Test` stays one argument, and run non-dotnet scripts + // through bash instead of `chmod +x` so the checked-out repo is never modified. + let escaped = command.Replace(";", "\\;") + if command.StartsWith("dotnet", StringComparison.OrdinalIgnoreCase) then escaped else "bash " + escaped + psi.ArgumentList.Add launch + printfn "==> %s" command + use p = Process.Start psi + p.WaitForExit() + p.ExitCode + +for cmd in buildScript.Split([| ";;" |], StringSplitOptions.RemoveEmptyEntries ||| StringSplitOptions.TrimEntries) do + let code = run cmd + if code <> 0 then fail (sprintf "build command failed with exit code %d" code) + +if verify then + // Fail if any project resolved a non-local FSharp.Core; match the exact quoted identity so a longer + // prerelease can't satisfy a prefix. + let rx = System.Text.RegularExpressions.Regex("\"FSharp\\.Core/([^\"]+)\"") + let options = EnumerationOptions(RecurseSubdirectories = true, IgnoreInaccessible = true) + let mutable usedLocal = false + let others = System.Collections.Generic.SortedSet() + for f in Directory.EnumerateFiles(repoDir, "project.assets.json", options) do + let text = try File.ReadAllText f with _ -> "" + for m in rx.Matches text do + if m.Groups.[1].Value = version then usedLocal <- true + else others.Add m.Groups.[1].Value |> ignore + if others.Count > 0 then + fail (sprintf "expected local FSharp.Core %s but some projects resolved: %s" version (String.Join(", ", others))) + if not usedLocal then + fail (sprintf "expected local FSharp.Core %s in project.assets.json but found none; built against a different FSharp.Core" version) + printfn "Verified: local FSharp.Core %s was consumed." version diff --git a/eng/scripts/PrepareRepoForRegressionTesting.fsx b/eng/scripts/PrepareRepoForRegressionTesting.fsx deleted file mode 100644 index e1df77bcb45..00000000000 --- a/eng/scripts/PrepareRepoForRegressionTesting.fsx +++ /dev/null @@ -1,110 +0,0 @@ -/// Script to inject UseLocalCompiler.Directory.Build.props import into a third-party repository's Directory.Build.props -/// Usage: dotnet fsi PrepareRepoForRegressionTesting.fsx - -open System -open System.IO -open System.Xml - -let propsFilePath = "Directory.Build.props" - -let useLocalCompilerPropsPath = - let args = Environment.GetCommandLineArgs() - // When running with dotnet fsi, args are: [0]=dotnet; [1]=fsi.dll; [2]=script.fsx; [3...]=args - let scriptArgs = args |> Array.skipWhile (fun a -> not (a.EndsWith(".fsx"))) |> Array.skip 1 - if scriptArgs.Length > 0 then - scriptArgs.[0] - else - failwith "Usage: dotnet fsi PrepareRepoForRegressionTesting.fsx " - -printfn "PrepareRepoForRegressionTesting.fsx" -printfn "===================================" -printfn "UseLocalCompiler props path: %s" useLocalCompilerPropsPath - -if not (File.Exists(useLocalCompilerPropsPath)) then - failwithf "UseLocalCompiler.Directory.Build.props not found at: %s" useLocalCompilerPropsPath - -printfn "✓ UseLocalCompiler.Directory.Build.props found" - -let absolutePropsPath = - Path.GetFullPath(useLocalCompilerPropsPath).Replace("\\", "/") -printfn "Absolute path: %s" absolutePropsPath - -if File.Exists(propsFilePath) then - printfn "Directory.Build.props exists, modifying it..." - - let doc = XmlDocument() - doc.PreserveWhitespace <- true - doc.Load(propsFilePath) - - let projectElement = doc.SelectSingleNode("/Project") - if isNull projectElement then - failwith "Could not find Project element in Directory.Build.props" - - let xpath = "//Import[contains(@Project, 'UseLocalCompiler.Directory.Build.props')]" - let existingImport = doc.SelectSingleNode(xpath) - - if isNull existingImport then - let importElement = doc.CreateElement("Import") - importElement.SetAttribute("Project", absolutePropsPath) - - if projectElement.HasChildNodes then - projectElement.InsertBefore(importElement, projectElement.FirstChild) |> ignore - else - projectElement.AppendChild(importElement) |> ignore - - let newline = doc.CreateTextNode("\n ") - projectElement.InsertAfter(newline, importElement) |> ignore - - doc.Save(propsFilePath) - printfn "✓ Added UseLocalCompiler import to Directory.Build.props" - else - printfn "✓ UseLocalCompiler import already exists" - - let otherFlagsWithTimes = doc.SelectSingleNode("//OtherFlags[contains(text(), '--times')]") - - if isNull otherFlagsWithTimes then - let propertyGroup = doc.CreateElement("PropertyGroup") - let otherFlags = doc.CreateElement("OtherFlags") - otherFlags.InnerText <- "$(OtherFlags) --nowarn:75 --times" - propertyGroup.AppendChild(otherFlags) |> ignore - - let importNode = doc.SelectSingleNode(xpath) - - // PreserveWhitespace=true causes XML DOM to keep text nodes (newlines/indentation) between elements; - // skip past the whitespace text node after the import to position the PropertyGroup correctly - let nodeAfterImport = - if not (isNull importNode) && not (isNull importNode.NextSibling) && importNode.NextSibling.NodeType = XmlNodeType.Text then - importNode.NextSibling - else - null - - if not (isNull nodeAfterImport) then - projectElement.InsertAfter(propertyGroup, nodeAfterImport) |> ignore - else - projectElement.InsertAfter(propertyGroup, importNode) |> ignore - - let newlineAfter = doc.CreateTextNode("\n ") - projectElement.InsertAfter(newlineAfter, propertyGroup) |> ignore - - doc.Save(propsFilePath) - printfn "✓ Added --times flag to OtherFlags" - else - if not (otherFlagsWithTimes.InnerText.Contains("--nowarn:75")) then - otherFlagsWithTimes.InnerText <- otherFlagsWithTimes.InnerText.Replace("--times", "--nowarn:75 --times") - doc.Save(propsFilePath) - printfn "✓ Added --nowarn:75 to existing OtherFlags" - else - printfn "✓ --times and --nowarn:75 already exist in OtherFlags" -else - printfn "Directory.Build.props does not exist, creating it..." - let newContent = sprintf "\n \n \n $(OtherFlags) --nowarn:75 --times\n \n\n" absolutePropsPath - File.WriteAllText(propsFilePath, newContent) - printfn "✓ Created Directory.Build.props with UseLocalCompiler import and --times flag" - -printfn "" -printfn "Final Directory.Build.props content:" -printfn "-----------------------------------" -let content = File.ReadAllText(propsFilePath) -printfn "%s" content -printfn "-----------------------------------" -printfn "✓ Repository prepared for regression testing" diff --git a/eng/templates/regression-test-jobs.yml b/eng/templates/regression-test-jobs.yml index ba7a3c19dab..829debeb3f4 100644 --- a/eng/templates/regression-test-jobs.yml +++ b/eng/templates/regression-test-jobs.yml @@ -65,41 +65,20 @@ jobs: Write-Host "Successfully checked out ${{ item.repo }} at commit ${{ item.commit }}" git log -1 --oneline - + Write-Host "Repository structure:" Get-ChildItem -Name - - $buildScript = '${{ item.buildScript }}' - # Support ';;' separator for multiple commands — validate each command's script file - $commands = $buildScript -split ';;' | ForEach-Object { $_.Trim() } | Where-Object { $_ } - foreach ($cmd in $commands) { - if ($cmd -like "dotnet*") { - Write-Host "Built-in dotnet command, skipping file check: $cmd" - } else { - $scriptFile = ($cmd -split ' ', 2)[0] - Write-Host "Verifying build script exists: $scriptFile" - if (Test-Path $scriptFile) { - Write-Host "Build script found: $scriptFile" - } else { - Write-Host "Build script not found: $scriptFile" - Write-Host "Available files in root:" - Get-ChildItem - exit 1 - } - } - } displayName: Checkout ${{ item.displayName }} at specific commit - pwsh: | Set-Location $(Pipeline.Workspace)/TestRepo - Write-Host "Removing global.json to use latest SDK..." - if (Test-Path "global.json") { - Remove-Item "global.json" -Force - Write-Host "global.json removed" - } else { - Write-Host "No global.json found" - } - displayName: Remove global.json to use latest SDK + # Pin the test repo to the exact SDK that built the compiler (allowPrerelease + rollForward:disable) so its + # F# SDK targets and the runtime that runs the local fsc.dll line up, with no silent fallback. + $sdk = (Get-Content "$(Build.SourcesDirectory)/global.json" | ConvertFrom-Json).sdk.version + @{ sdk = @{ version = $sdk; allowPrerelease = $true; rollForward = "disable" } } | ConvertTo-Json | Set-Content "global.json" + Write-Host "Pinned test repo to SDK $sdk" + Get-Content "global.json" + displayName: Pin global.json to compiler SDK for ${{ item.displayName }} - task: UseDotNet@2 displayName: Install .NET SDK 8.0.x for ${{ item.displayName }} @@ -145,7 +124,7 @@ jobs: # into the regression test's .dotnet so fsc.dll can find the runtime. # Tries default feed first, then ci.dot.net/public (same fallback as eng/common). - pwsh: | - $v = (Get-Content "$(Build.SourcesDirectory)/global.json" | ConvertFrom-Json).tools.dotnet + $v = (Get-Content "$(Build.SourcesDirectory)/global.json" | ConvertFrom-Json).sdk.version $d = "$(Pipeline.Workspace)/TestRepo/.dotnet" $u = "https://builds.dotnet.microsoft.com/dotnet/scripts/v1" if ($IsWindows) { @@ -161,19 +140,6 @@ jobs: bash "$d/dotnet-install.sh" --version $v --install-dir $d --skip-non-versioned-files --azure-feed "https://ci.dot.net/public" } displayName: Install compiler SDK for ${{ item.displayName }} - continueOnError: true - - - pwsh: | - Set-Location $(Pipeline.Workspace)/TestRepo - - Write-Host "Running PrepareRepoForRegressionTesting.fsx..." - dotnet fsi $(Build.SourcesDirectory)/eng/scripts/PrepareRepoForRegressionTesting.fsx "$(Pipeline.Workspace)/Props/UseLocalCompiler.Directory.Build.props" - - if ($LASTEXITCODE -ne 0) { - Write-Host "Failed to prepare repository for regression testing" - exit 1 - } - displayName: Setup local compiler configuration for ${{ item.displayName }} - pwsh: | Set-Location $(Pipeline.Workspace)/TestRepo @@ -187,17 +153,17 @@ jobs: Write-Host "" Write-Host "F# Compiler artifacts available:" $productTfm = (dotnet msbuild "$(Pipeline.Workspace)/Props/TargetFrameworks.props" --getProperty:FSharpNetCoreProductTargetFramework).Trim() - Get-ChildItem "$(Pipeline.Workspace)/FSharpCompiler/bin/fsc/Release/$productTfm" -Name -ErrorAction SilentlyContinue + Get-ChildItem "$(Pipeline.Workspace)/FSharpCompiler/artifacts/bin/fsc/Release/$productTfm" -Name -ErrorAction SilentlyContinue Write-Host "" Write-Host "F# Core available:" - if (Test-Path "$(Pipeline.Workspace)/FSharpCompiler/bin/FSharp.Core/Release/netstandard2.0/FSharp.Core.dll") { + if (Test-Path "$(Pipeline.Workspace)/FSharpCompiler/artifacts/bin/FSharp.Core/Release/netstandard2.0/FSharp.Core.dll") { Write-Host "FSharp.Core.dll found" } else { Write-Host "FSharp.Core.dll not found" } Write-Host "" - Write-Host "Directory.Build.props content:" - Get-Content "Directory.Build.props" + Write-Host "Directory.Build.props content (none if injected via CustomAfterDirectoryBuildProps):" + Get-Content "Directory.Build.props" -ErrorAction SilentlyContinue Write-Host "" Write-Host "===========================================" displayName: Report build environment for ${{ item.displayName }} @@ -216,14 +182,6 @@ jobs: - pwsh: | Set-Location $(Pipeline.Workspace)/TestRepo - Write-Host "============================================" - Write-Host "Starting build for ${{ item.displayName }}" - Write-Host "Repository: ${{ item.repo }}" - Write-Host "Commit: ${{ item.commit }}" - Write-Host "Build Script: ${{ item.buildScript }}" - Write-Host "============================================" - Write-Host "" - $errorLogPath = "$(Pipeline.Workspace)/build-errors.log" $fullLogPath = "$(Pipeline.Workspace)/build-full.log" @@ -242,62 +200,24 @@ jobs: } } - function Run-Command { - param([string]$cmd) - if ($cmd -like "dotnet*") { - Write-Host "Executing built-in command: $cmd" - if ($IsWindows) { - cmd /c $cmd 2>&1 | Tee-Object -FilePath $fullLogPath -Append | ForEach-Object { - Process-BuildOutput $_ - } - } else { - # Escape semicolons for bash -c to prevent them being treated as command separators - $escapedCmd = $cmd -replace ';', '\;' - bash -c "$escapedCmd" 2>&1 | Tee-Object -FilePath $fullLogPath -Append | ForEach-Object { - Process-BuildOutput $_ - } - } - } elseif ($IsWindows) { - Write-Host "Executing file-based script: $cmd" - cmd /c ".\$cmd" 2>&1 | Tee-Object -FilePath $fullLogPath -Append | ForEach-Object { - Process-BuildOutput $_ - } - } else { - Write-Host "Executing file-based script: $cmd" - $scriptFile = ($cmd -split ' ', 2)[0] - chmod +x "$scriptFile" - bash -c "./$cmd" 2>&1 | Tee-Object -FilePath $fullLogPath -Append | ForEach-Object { - Process-BuildOutput $_ - } - } - return $LASTEXITCODE - } + # Build logic lives in the fsx so a failure reproduces with the same one command, no pipeline required. + $fsxArgs = @( + "$(Build.SourcesDirectory)/eng/scripts/BuildWithLocalFSharp.fsx", + '--compiler-path', "$(Pipeline.Workspace)/FSharpCompiler", + '--props', "$(Pipeline.Workspace)/Props/UseLocalCompiler.Directory.Build.props", + '--core-packages-dir', "$(Pipeline.Workspace)/Props/library-packs", + '--nuget-packages', "$(Pipeline.Workspace)/.nuget-packages", + '--build-script', '${{ item.buildScript }}' + ) + if ('${{ item.expectLocalCore }}' -eq 'True') { $fsxArgs += '--verify' } - # Support ';;' separator for multiple commands - $commands = ('${{ item.buildScript }}' -split ';;') | ForEach-Object { $_.Trim() } | Where-Object { $_ } - - foreach ($cmd in $commands) { - $exitCode = Run-Command $cmd - if ($exitCode -ne 0) { - Write-Host "" - Write-Host "============================================" - Write-Host "Command failed: $cmd" - Write-Host "Exit code: $exitCode" - Write-Host "============================================" - exit $exitCode - } + dotnet fsi @fsxArgs 2>&1 | Tee-Object -FilePath $fullLogPath -Append | ForEach-Object { Process-BuildOutput $_ } + $code = $LASTEXITCODE + if ($code -ne 0) { + Write-Host "##[error]Build failed for ${{ item.displayName }} (exit code $code)" + exit $code } - - Write-Host "" - Write-Host "============================================" - Write-Host "Build completed for ${{ item.displayName }}" - Write-Host "Exit code: 0" - Write-Host "============================================" displayName: Build ${{ item.displayName }} with local F# compiler - env: - LocalFSharpCompilerPath: $(Pipeline.Workspace)/FSharpCompiler - LoadLocalFSharpBuild: 'True' - LocalFSharpCompilerConfiguration: Release timeoutInMinutes: 120 - pwsh: | @@ -417,27 +337,14 @@ jobs: } Write-Host "" - Write-Host "##[section]LOCAL REPRODUCTION STEPS (from fsharp repo root):" - Write-Host "# 1. Build the F# compiler" - Write-Host "./build.sh -c Release" - Write-Host "" - Write-Host "# 2. Clone and checkout the failing library" - Write-Host "cd .." + $verifyFlag = if ('${{ item.expectLocalCore }}' -eq 'True') { ' --verify' } else { '' } + Write-Host "##[section]LOCAL REPRODUCTION (any OS; FSHARP_REPO = your dotnet/fsharp checkout built with build.sh/Build.cmd -c Release -pack):" Write-Host "git clone --recursive https://github.com/${{ item.repo }}.git TestRepo" - Write-Host "cd TestRepo" - Write-Host "git checkout ${{ item.commit }}" - Write-Host "git submodule update --init --recursive" - Write-Host "rm -f global.json" - Write-Host "" - Write-Host "# 3. Prepare the repo for local compiler" - Write-Host "dotnet fsi ../fsharp/eng/scripts/PrepareRepoForRegressionTesting.fsx `"../fsharp/UseLocalCompiler.Directory.Build.props`"" - Write-Host "" - Write-Host "# 4. Build with local compiler" - Write-Host "export LocalFSharpCompilerPath=`$PWD/../fsharp" - Write-Host "export LoadLocalFSharpBuild=True" - Write-Host "export LocalFSharpCompilerConfiguration=Release" - Write-Host "${{ item.buildScript }}" - + Write-Host "cd TestRepo; git checkout ${{ item.commit }}; git submodule update --init --recursive" + Write-Host 'BUILD_COMMAND: ${{ item.buildScript }}' + Write-Host "dotnet fsi FSHARP_REPO/eng/scripts/BuildWithLocalFSharp.fsx$verifyFlag --build-script ''" + Write-Host "# If TestRepo/global.json pins a different SDK, align sdk.version to your compiler SDK (rollForward: disable); add --nuget-packages to isolate restore." + Write-Host "##vso[task.logissue type=error;sourcepath=azure-pipelines-PR.yml]Regression test failed: ${{ item.displayName }}" } Write-Host "============================================" diff --git a/vsintegration/tests/FSharp.Editor.IntegrationTests/InProcess/SolutionExplorerInProcess.cs b/vsintegration/tests/FSharp.Editor.IntegrationTests/InProcess/SolutionExplorerInProcess.cs index 43743484e96..7b330eddc6f 100644 --- a/vsintegration/tests/FSharp.Editor.IntegrationTests/InProcess/SolutionExplorerInProcess.cs +++ b/vsintegration/tests/FSharp.Editor.IntegrationTests/InProcess/SolutionExplorerInProcess.cs @@ -60,6 +60,7 @@ private static string CreateStandaloneProjectFile() return $@" + True Debug {RepoRoot} From d3fab443a1cde90f68d9a272e7e776959936a84c Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 12 Aug 2026 21:39:06 +0200 Subject: [PATCH 25/55] IL: add ILPreNamespace, make ILPreTypeDef creation lazy (#20092) * IL: add ILPreNamespace, make ILPreTypeDef creation lazy --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + src/Compiler/AbstractIL/il.fs | 381 +++++++++- src/Compiler/AbstractIL/il.fsi | 73 +- src/Compiler/AbstractIL/ilread.fs | 49 +- src/Compiler/Checking/NameResolution.fs | 3 +- src/Compiler/Checking/import.fs | 167 ++--- src/Compiler/Driver/StaticLinking.fs | 2 + src/Compiler/TypedTree/TypedTree.fs | 13 +- src/Compiler/Utilities/illib.fs | 26 + src/Compiler/Utilities/illib.fsi | 10 + ...iler.Service.SurfaceArea.netstandard20.bsl | 19 +- .../FSharp.Compiler.Service.Tests.fsproj | 1 + .../ModuleReaderCancellationTests.fs | 150 +++- .../ModuleReaderNamespaceTests.fs | 676 ++++++++++++++++++ .../FSharp.Compiler.Benchmarks.fsproj | 1 + .../NamespaceImportBenchmarks.fs | 454 ++++++++++++ .../CompilerServiceBenchmarks/Program.fs | 28 +- .../CompilerServiceBenchmarks/README.md | 20 + 18 files changed, 1884 insertions(+), 190 deletions(-) create mode 100644 tests/FSharp.Compiler.Service.Tests/ModuleReaderNamespaceTests.fs create mode 100644 tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/NamespaceImportBenchmarks.fs diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index e11e34a5c88..38dd2d65b0a 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -162,6 +162,7 @@ * Support for the `` XML documentation tag: at compile time, documentation is copied from an external XML file selected by an XPath query and emitted into the generated documentation file. `` remains unsupported. ([Issue #19175](https://github.com/dotnet/fsharp/issues/19175), [PR #19186](https://github.com/dotnet/fsharp/pull/19186)) * Expand `` at tooling time. In IDE tooltips, completion, and signature help, documentation is inherited from base classes, interfaces, overridden members, and constructors (matched by parameter signature). The FCS Symbols API (`FSharpSymbol.XmlDoc`) additionally resolves explicit `cref` targets, but does not expand constructor inheritance. The compiler emits the tag verbatim into generated XML documentation files, matching C#; `` is not implemented. ([Issue #19175](https://github.com/dotnet/fsharp/issues/19175), [PR #19188](https://github.com/dotnet/fsharp/pull/19188)) * Add symbol and type highlighting to F# diagnostics ([PR #20097](https://github.com/dotnet/fsharp/pull/20097)) +* IL: add `ILPreNamespace`, make `ILPreTypeDef` creation lazy ([PR #20092](https://github.com/dotnet/fsharp/pull/20092)) ### Improved diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index 8321f88127f..0aa4e76ecf4 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -2967,23 +2967,90 @@ type ILTypeDef override x.ToString() = "type " + x.Name -and [] ILTypeDefs(f: unit -> ILPreTypeDef[]) = - inherit DelayInitArrayMap(f) +and [] ILTypeDefs + ( + f: unit -> ILPreTypeDef[], + // Plain fields rather than a lazy: there is one ILTypeDefs per read type and per namespace level. + fNamespaces: unit -> ILPreNamespace[] + ) = + inherit DelayInitArrayMap(f) + + [] + let mutable namespacesStore: (ILPreNamespace array | null) = null + + let mutable fNamespaces = fNamespaces + + new(f: unit -> ILPreTypeDef[]) = ILTypeDefs(f, Unchecked.defaultof<_>) override this.CreateDictionary(arr) = let t = Dictionary(arr.Length, HashIdentity.Structural) for pre in arr do - let key = pre.Namespace, pre.Name - t[key] <- pre + t[pre.Name] <- pre ReadOnlyDictionary t + member private this.RealiseNamespaces() = + Monitor.Enter this + + try + match namespacesStore with + | NonNull nss -> nss + | _ -> + let nss = + match box fNamespaces with + | null -> Array.empty + | _ -> fNamespaces () + + namespacesStore <- nss + fNamespaces <- Unchecked.defaultof<_> + nss + finally + Monitor.Exit this + + member this.AsArrayOfPreNamespaces() = + match namespacesStore with + | NonNull nss -> nss + | _ -> this.RealiseNamespaces() + + member x.AllPreTypeDefs() = + [| + yield! x.GetArray() + for ns: ILPreNamespace in x.AsArrayOfPreNamespaces() do + yield! ns.AllPreTypeDefs() + |] + + member x.TryFindPreTypeDef(ns: string list, n: string) = + match ns with + | [] -> + match x.GetDictionary().TryGetValue n with + | true, pre -> Some pre + | _ -> None + | head :: rest -> + match x.AsArrayOfPreNamespaces() |> Array.tryFind (fun ns -> ns.Name = head) with + | Some(ns: ILPreNamespace) -> ns.TryFindPreTypeDef(rest, n) + | None -> None + + member private x.TryFindPreTypeDefOfWholeName(nm: string) = + let ns, n = splitILTypeName nm + + match x.TryFindPreTypeDef(ns, n) with + | Some _ as res -> res + | None -> + match ns with + | [] -> None + | _ -> + // Probing an ungrouped level's whole names only once the walk has failed leaves a grouped + // level's types unforced. + match x.GetDictionary().TryGetValue nm with + | true, pre -> Some pre + | _ -> None + member x.AsArray() = - [| for pre in x.GetArray() -> pre.GetTypeDef() |] + [| for pre in x.AllPreTypeDefs() -> pre.GetTypeDef() |] member x.AsList() = - [ for pre in x.GetArray() -> pre.GetTypeDef() ] + [ for pre in x.AllPreTypeDefs() -> pre.GetTypeDef() ] interface IEnumerable with member x.GetEnumerator() = @@ -2991,43 +3058,142 @@ and [] ILTypeDefs(f: unit -> ILPreTypeDef[]) = interface IEnumerable with member x.GetEnumerator() = - (seq { for pre in x.GetArray() -> pre.GetTypeDef() }).GetEnumerator() + (seq { for pre in x.AllPreTypeDefs() -> pre.GetTypeDef() }).GetEnumerator() member x.AsArrayOfPreTypeDefs() = x.GetArray() member x.FindByName nm = - let ns, n = splitILTypeName nm - x.GetDictionary().[(ns, n)].GetTypeDef() + match x.TryFindPreTypeDefOfWholeName nm with + | Some pre -> pre.GetTypeDef() + | None -> raise (KeyNotFoundException(nm)) member x.ExistsByName nm = - let ns, n = splitILTypeName nm - x.GetDictionary().ContainsKey((ns, n)) + x.TryFindPreTypeDefOfWholeName nm |> Option.isSome and [] ILPreTypeDef = - abstract Namespace: string list abstract Name: string abstract GetTypeDef: unit -> ILTypeDef +/// Plain fields rather than lazies: there is one of these per namespace of every assembly read, and one +/// that nothing looks inside stays a single object holding three nulls. +and [] ILPreNamespace(name: string) = + + [] + let mutable types: (ILPreTypeDef array | null) = null + + [] + let mutable namespaces: (ILPreNamespace array | null) = null + + // Only a namespace someone looks a type up in ever builds one. + [] + let mutable typesByName: (IDictionary | null) = null + + member _.Name = name + + abstract ComputeTypes: unit -> ILPreTypeDef[] + + abstract ComputeNamespaces: unit -> ILPreNamespace[] + + member private this.RealiseTypes() = + Monitor.Enter this + + try + match types with + | NonNull ts -> ts + | _ -> + let ts = this.ComputeTypes() + types <- ts + ts + finally + Monitor.Exit this + + member private this.RealiseNamespaces() = + Monitor.Enter this + + try + match namespaces with + | NonNull nss -> nss + | _ -> + let nss = this.ComputeNamespaces() + namespaces <- nss + nss + finally + Monitor.Exit this + + member this.GetTypes() = + match types with + | NonNull ts -> ts + | _ -> this.RealiseTypes() + + member this.GetNamespaces() = + match namespaces with + | NonNull nss -> nss + | _ -> this.RealiseNamespaces() + + member private this.GetTypesByName() = + match typesByName with + | NonNull d -> d + | _ -> + let d = Dictionary(HashIdentity.Structural) + + for pre in this.GetTypes() do + d[pre.Name] <- pre + + let d = ReadOnlyDictionary d :> IDictionary<_, _> + typesByName <- d + d + + member this.TryFindPreTypeDef(ns: string list, n: string) = + match ns with + | [] -> + match this.GetTypesByName().TryGetValue n with + | true, pre -> Some pre + | _ -> None + | head :: rest -> + // Levels are narrow - 86% of the framework's have one child - so scanning beats a dictionary. + match this.GetNamespaces() |> Array.tryFind (fun ns -> ns.Name = head) with + | Some ns -> ns.TryFindPreTypeDef(rest, n) + | None -> None + + member this.AllPreTypeDefs() = + [| + yield! this.GetTypes() + for ns in this.GetNamespaces() do + yield! ns.AllPreTypeDefs() + |] + /// This is a memory-critical class. Very many of these objects get allocated and held to represent the contents of .NET assemblies. -and [] ILPreTypeDefImpl(nameSpace: string list, name: string, metadataIndex: int32, storage: ILTypeDefStored) = - let stored = - lazy - match storage with - | ILTypeDefStored.Given td -> td - | ILTypeDefStored.Computed f -> f () - | ILTypeDefStored.Reader f -> f metadataIndex +/// +/// Two threads racing on the name both resolve it: they get equal strings, so no lock is needed. +and [] ILPreTypeDefImpl(nameIdx: int32, metadataIndex: int32, storage: ILTypeDefStored) = + inherit DelayInitValue() + + [] + let mutable name: (string | null) = null + + override _.Compute() = + match storage with + | ILTypeDefStored.Reader(getTypeDef, _) -> getTypeDef metadataIndex interface ILPreTypeDef with - member _.Namespace = nameSpace - member _.Name = name - member x.GetTypeDef() = stored.Value + member _.Name = + match name with + | NonNull n -> n + | _ -> + let n = + match storage with + | ILTypeDefStored.Reader(_, getName) -> getName nameIdx + + name <- n + n + + member this.GetTypeDef() = this.Value -and ILTypeDefStored = - | Given of ILTypeDef - | Reader of (int32 -> ILTypeDef) - | Computed of (unit -> ILTypeDef) +/// Every type a reader reads shares these, so nameIdx is all a pre-type-def holds to name itself. +and ILTypeDefStored = Reader of getTypeDef: (int32 -> ILTypeDef) * getName: (int32 -> string) -let mkILTypeDefReader f = ILTypeDefStored.Reader f +let mkILTypeDefReader (getTypeDef, getName) = + ILTypeDefStored.Reader(getTypeDef, getName) type ILNestedExportedType = { @@ -3414,24 +3580,165 @@ let mkRefForNestedILTypeDef scope (enc: ILTypeDef list, td: ILTypeDef) = // Operations on type tables. // -------------------------------------------------------------------- -let mkILPreTypeDef (td: ILTypeDef) = - let ns, n = splitILTypeName td.Name - ILPreTypeDefImpl(ns, n, NoMetadataIdx, ILTypeDefStored.Given td) :> ILPreTypeDef +let mkILPreTypeDefRead (nameIdx, metadataIndex, f) = + ILPreTypeDefImpl(nameIdx, metadataIndex, f) :> ILPreTypeDef + +/// A type def already in hand. Named whole: the tables built out of these are not grouped by namespace. +[] +type private ILPreTypeDefGiven(td: ILTypeDef) = + interface ILPreTypeDef with + member _.Name = td.Name + member _.GetTypeDef() = td + +let private mkILPreTypeDefGiven (td: ILTypeDef) = ILPreTypeDefGiven td :> ILPreTypeDef + +/// A class rather than an object expression: there is one of these per namespace of every assembly read. +[] +type private ILPreNamespaceImpl(name: string, types: unit -> ILPreTypeDef[], namespaces: unit -> ILPreNamespace[]) = + inherit ILPreNamespace(name) + + override _.ComputeTypes() = types () + override _.ComputeNamespaces() = namespaces () + +let mkILPreNamespaceComputed (name, types, namespaces) = + ILPreNamespaceImpl(name, types, namespaces) :> ILPreNamespace + +/// A level names a child once: one named by both sources becomes a single child, not two entities of the +/// same name. +let rec private mergePreNamespaces (grouped: ILPreNamespace[]) (supplied: ILPreNamespace[]) = + if Array.isEmpty supplied then + // Grouping never produces two children of one name, so this is the whole answer. + grouped + else + let merged = ResizeArray grouped + + for ns in supplied do + match merged.FindIndex(fun (other: ILPreNamespace) -> other.Name = ns.Name) with + | -1 -> merged.Add ns + | i -> merged[i] <- combinePreNamespaces merged[i] ns + + merged.ToArray() + +and private combinePreNamespaces (a: ILPreNamespace) (b: ILPreNamespace) = + mkILPreNamespaceComputed ( + a.Name, + (fun () -> Array.append (a.GetTypes()) (b.GetTypes())), + (fun () -> mergePreNamespaces (a.GetNamespaces()) (b.GetNamespaces())) + ) + +let inline private namespaceOfEntry (entries: struct (string list * ILPreTypeDef)[]) i = + let struct (ns, _) = entries[i] + ns + +/// Order entries so each namespace is one contiguous run, its own types ahead of its children, both in +/// first-seen order - which merges a namespace split across the source. Every level is then a range of this +/// one array: descending costs a node, never a copy. +let private groupEntriesByNamespace (entries: struct (string list * ILPreTypeDef)[]) = + // A level whose types all sit in it needs no ordering. + if entries |> Array.forall (fun (struct (ns, _)) -> List.isEmpty ns) then + entries + else + let grouped = ResizeArray entries.Length + + let rec fill (level: ResizeArray) depth = + let heads = ResizeArray() + let buckets = Dictionary>() + + for entry in level do + let struct (ns, _) = entry + + if List.length ns = depth then + grouped.Add entry + else + let head = List.item depth ns + + match buckets.TryGetValue head with + | true, bucket -> bucket.Add entry + | _ -> + let bucket = ResizeArray() + heads.Add head + buckets[head] <- bucket + bucket.Add entry + + for head in heads do + fill buckets[head] (depth + 1) + + fill (ResizeArray entries) 0 + grouped.ToArray() + +/// A namespace as a range of the grouped array: one that is never imported stays a single object. +[] +type private ILPreNamespaceOfRange(name: string, entries: struct (string list * ILPreTypeDef)[], lo: int, hi: int, depth: int) = + inherit ILPreNamespace(name) + + /// Grouping put the level's own types at the front of its range. + static member Types(entries: struct (string list * ILPreTypeDef)[], lo, hi, depth) = + let mutable count = 0 -let mkILPreTypeDefComputed (ns, n, f) = - ILPreTypeDefImpl(ns, n, NoMetadataIdx, ILTypeDefStored.Computed f) :> ILPreTypeDef + while lo + count < hi && List.length (namespaceOfEntry entries (lo + count)) = depth do + count <- count + 1 -let mkILPreTypeDefRead (ns, n, idx, f) = - ILPreTypeDefImpl(ns, n, idx, f) :> ILPreTypeDef + Array.init count (fun i -> + let struct (_, pre) = entries[lo + i] + pre) + + static member Namespaces(entries: struct (string list * ILPreTypeDef)[], lo, hi, depth) = + let mutable i = lo + + while i < hi && List.length (namespaceOfEntry entries i) = depth do + i <- i + 1 + + let children = ResizeArray() + + while i < hi do + let name = List.item depth (namespaceOfEntry entries i) + let start = i + + while i < hi && List.item depth (namespaceOfEntry entries i) = name do + i <- i + 1 + + children.Add(ILPreNamespaceOfRange(name, entries, start, i, depth + 1) :> ILPreNamespace) + + children.ToArray() + + override _.ComputeTypes() = + ILPreNamespaceOfRange.Types(entries, lo, hi, depth) + + override _.ComputeNamespaces() = + ILPreNamespaceOfRange.Namespaces(entries, lo, hi, depth) + +let mkILTypeDefsComputed f = ILTypeDefs f + +let mkILTypeDefsOfNamespace (preNamespace: ILPreNamespace) = + ILTypeDefs(preNamespace.GetTypes, preNamespace.GetNamespaces) + +let mkILTypeDefsGroupedComputed (types: unit -> struct (string list * ILPreTypeDef)[]) (namespaces: unit -> ILPreNamespace[]) = + // Grouping runs once per table, on whichever half of the top level is asked for first. + let entries = InterruptibleLazy(fun () -> groupEntriesByNamespace (types ())) + + let getTypes () = + let entries = entries.Value + ILPreNamespaceOfRange.Types(entries, 0, entries.Length, 0) + + let getNamespaces () = + let entries = entries.Value + mergePreNamespaces (ILPreNamespaceOfRange.Namespaces(entries, 0, entries.Length, 0)) (namespaces ()) + + ILTypeDefs(getTypes, getNamespaces) let addILTypeDef td (tdefs: ILTypeDefs) = - ILTypeDefs(fun () -> [| yield mkILPreTypeDef td; yield! tdefs.AsArrayOfPreTypeDefs() |]) + ILTypeDefs( + (fun () -> [| yield mkILPreTypeDefGiven td; yield! tdefs.AsArrayOfPreTypeDefs() |]), + (fun () -> tdefs.AsArrayOfPreNamespaces()) + ) +/// Ungrouped: flattening has to give these back in the order they were built in, which is the TypeDef +/// order of the module being written. let mkILTypeDefsFromArray (l: ILTypeDef[]) = - ILTypeDefs(fun () -> Array.map mkILPreTypeDef l) + ILTypeDefs(fun () -> Array.map mkILPreTypeDefGiven l) let mkILTypeDefs l = mkILTypeDefsFromArray (Array.ofList l) -let mkILTypeDefsComputed f = ILTypeDefs f + let emptyILTypeDefs = mkILTypeDefsFromArray [||] let emptyILInterfaceImpls = InterruptibleLazy.FromValue([]) diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi index 82626b68337..8e82bd176fb 100644 --- a/src/Compiler/AbstractIL/il.fsi +++ b/src/Compiler/AbstractIL/il.fsi @@ -1523,10 +1523,11 @@ type ILTypeDefAccess = | Private | Nested of ILMemberAccess -/// Tables of named type definitions. +/// One namespace level: the types declared in it, and its child namespaces. A reader is grouped into this +/// shape on the way in; types already in hand stay one level, so that flattening keeps their order. [] type ILTypeDefs = - inherit DelayInitArrayMap + inherit DelayInitArrayMap interface IEnumerable @@ -1534,13 +1535,19 @@ type ILTypeDefs = member internal AsList: unit -> ILTypeDef list - /// Get some information about the type defs, but do not force the read of the type defs themselves. + /// Forces neither the type defs nor the child namespaces. member internal AsArrayOfPreTypeDefs: unit -> ILPreTypeDef[] - /// Calls to FindByName will result in all the ILPreTypeDefs being read. + /// Forces neither the children's contents nor this level's types. + member internal AsArrayOfPreNamespaces: unit -> ILPreNamespace[] + + /// Forces the whole subtree. + member internal AllPreTypeDefs: unit -> ILPreTypeDef[] + + /// Descends only into the type's own namespace. Raises KeyNotFoundException if not found. member internal FindByName: string -> ILTypeDef - /// Calls to ExistsByName will result in all the ILPreTypeDefs being read. + /// Descends only into the type's own namespace. member internal ExistsByName: string -> bool [] @@ -1694,22 +1701,54 @@ type ILTypeDef = /// This information has to be "Goldilocks" - not too much, not too little, just right. [] type ILPreTypeDef = - abstract Namespace: string list abstract Name: string /// Realise the actual full typedef abstract GetTypeDef: unit -> ILTypeDef -[] +/// One namespace of a type table, read only once something looks inside it. Inherit this to back a +/// namespace with your own store; see also mkILPreNamespaceComputed. +[] +type ILPreNamespace = + new: name: string -> ILPreNamespace + + member Name: string + + /// Called at most once. + abstract ComputeTypes: unit -> ILPreTypeDef[] + + /// Called at most once, and independently of the types: importing a level's types must not read its + /// children, nor the other way round. + abstract ComputeNamespaces: unit -> ILPreNamespace[] + + /// Forces neither the children nor anything deeper. + member GetTypes: unit -> ILPreTypeDef[] + + /// Realised independently of the types. + member GetNamespaces: unit -> ILPreNamespace[] + + /// Descends only into the namespace on the type's path, so unrelated ones are never realised. + member internal TryFindPreTypeDef: ns: string list * n: string -> ILPreTypeDef option + + /// Forces the whole subtree. + member internal AllPreTypeDefs: unit -> ILPreTypeDef[] + +[] type internal ILPreTypeDefImpl = + inherit DelayInitValue + interface ILPreTypeDef [] type internal ILTypeDefStored -val internal mkILPreTypeDef: ILTypeDef -> ILPreTypeDef -val internal mkILPreTypeDefComputed: string list * string * (unit -> ILTypeDef) -> ILPreTypeDef -val internal mkILPreTypeDefRead: string list * string * int32 * ILTypeDefStored -> ILPreTypeDef -val internal mkILTypeDefReader: (int32 -> ILTypeDef) -> ILTypeDefStored +/// The name is read on demand, so grouping by namespace never touches the string heap for a namespace +/// nobody imports. +val internal mkILPreTypeDefRead: nameIdx: int32 * metadataIndex: int32 * ILTypeDefStored -> ILPreTypeDef + +val mkILPreNamespaceComputed: + name: string * types: (unit -> ILPreTypeDef[]) * namespaces: (unit -> ILPreNamespace[]) -> ILPreNamespace + +val internal mkILTypeDefReader: getTypeDef: (int32 -> ILTypeDef) * getName: (int32 -> string) -> ILTypeDefStored [] type ILNestedExportedTypes = @@ -2370,8 +2409,20 @@ val emptyILTypeDefs: ILTypeDefs /// /// Note that individual type definitions may contain further delays /// in their method, field and other tables. +/// +/// The types all sit in this one namespace; a store that knows its namespaces inherits +/// ILPreNamespace instead. val mkILTypeDefsComputed: (unit -> ILPreTypeDef[]) -> ILTypeDefs +/// A level as a type table, for where one is needed: a module's own level, and a type's nested types. +val mkILTypeDefsOfNamespace: ILPreNamespace -> ILTypeDefs + +/// For a store with no namespace structure to hand - a metadata table in row order, say. Each type comes +/// with its namespace path below this level ([] for the level's own types); those are grouped into children +/// on demand, in first-seen order, with a split namespace becoming one child. +val mkILTypeDefsGroupedComputed: + types: (unit -> struct (string list * ILPreTypeDef)[]) -> namespaces: (unit -> ILPreNamespace[]) -> ILTypeDefs + val internal addILTypeDef: ILTypeDef -> ILTypeDefs -> ILTypeDefs val internal mkTypeForwarder: diff --git a/src/Compiler/AbstractIL/ilread.fs b/src/Compiler/AbstractIL/ilread.fs index 09fc311367a..0ccdd9cf35c 100644 --- a/src/Compiler/AbstractIL/ilread.fs +++ b/src/Compiler/AbstractIL/ilread.fs @@ -1888,7 +1888,7 @@ let rec seekReadModule (ctxt: ILMetadataReader) canReduceMemory (pectxtEager: PE MetadataIndex = idx Name = ilModuleName NativeResources = nativeResources - TypeDefs = mkILTypeDefsComputed (fun () -> seekReadTopTypeDefs ctxt) + TypeDefs = mkILTypeDefsGroupedComputed (fun () -> seekReadTopTypeDefEntries ctxt) (fun () -> Array.empty) SubSystemFlags = int32 subsys IsILOnly = ilOnly SubsystemVersion = subsysversion @@ -2055,14 +2055,6 @@ and seekIsTopTypeDefOfIdx ctxt idx = let flags, _, _, _, _, _ = seekReadTypeDefRow ctxt idx isTopTypeDef flags -and readBlobHeapAsSplitTypeName ctxt (nameIdx, namespaceIdx) = - let name = readStringHeap ctxt nameIdx - let nspace = readStringHeapOption ctxt namespaceIdx - - match nspace with - | Some nspace -> splitNamespace nspace, name - | None -> [], name - and readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) = let name = readStringHeap ctxt nameIdx let nspace = readStringHeapOption ctxt namespaceIdx @@ -2082,18 +2074,8 @@ and seekReadTypeDefRowWithExtents ctxt (idx: int) = let info = seekReadTypeDefRow ctxt idx info, seekReadTypeDefRowExtents ctxt info idx -and seekReadPreTypeDef ctxt toponly (idx: int) = - let flags, nameIdx, namespaceIdx, _, _, _ = seekReadTypeDefRow ctxt idx - - if toponly && not (isTopTypeDef flags) then - None - else - let ns, n = readBlobHeapAsSplitTypeName ctxt (nameIdx, namespaceIdx) - // Return the ILPreTypeDef - Some(mkILPreTypeDefRead (ns, n, idx, ctxt.typeDefReader)) - and typeDefReader ctxtH : ILTypeDefStored = - mkILTypeDefReader (fun idx -> + let getTypeDef idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() // Re-read so as not to save all these in the lazy closure - this suspension ctxt.is the largest @@ -2231,14 +2213,25 @@ and typeDefReader ctxtH : ILTypeDefStored = additionalFlags = additionalFlags, customAttrsStored = ILAttributesStored.CreateReader(idx, ctxt.customAttrsReaderFn_TypeDef), metadataIndex = idx - )) + ) + + let getName nameIdx = readStringHeap (getHole ctxtH) nameIdx -and seekReadTopTypeDefs (ctxt: ILMetadataReader) = + mkILTypeDefReader (getTypeDef, getName) + +// Only namespaces are read here; a name is left to its pre-type-def, so un-imported ones cost nothing. +and seekReadTopTypeDefEntries (ctxt: ILMetadataReader) = [| for i = 1 to ctxt.getNumRows TableNames.TypeDef do - match seekReadPreTypeDef ctxt true i with - | None -> () - | Some td -> yield td + let flags, nameIdx, namespaceIdx, _, _, _ = seekReadTypeDefRow ctxt i + + if isTopTypeDef flags then + let ns = + match readStringHeapOption ctxt namespaceIdx with + | Some nspace -> splitNamespace nspace + | None -> [] + + yield struct (ns, mkILPreTypeDefRead (nameIdx, i, ctxt.typeDefReader)) |] and seekReadNestedTypeDefs (ctxt: ILMetadataReader) tidx = @@ -2246,11 +2239,11 @@ and seekReadNestedTypeDefs (ctxt: ILMetadataReader) tidx = let nestedIdxs = seekReadIndexedRows (ctxt.getNumRows TableNames.Nested, seekReadNestedRow ctxt, snd, simpleIndexCompare tidx, false, fst) + // Nested types carry no namespace in metadata. [| for i in nestedIdxs do - match seekReadPreTypeDef ctxt false i with - | None -> () - | Some td -> yield td + let _, nameIdx, _, _, _, _ = seekReadTypeDefRow ctxt i + yield mkILPreTypeDefRead (nameIdx, i, ctxt.typeDefReader) |]) and seekReadInterfaceImpls (ctxt: ILMetadataReader) mdv numTypars tidx = diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 7c66ef1799e..b93d9e416b2 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -1500,7 +1500,8 @@ let rec AddModuleOrNamespaceRefsToNameEnv g amap m root ad nenv (modrefs: Module let nenv = (nenv, modrefs) ||> List.fold (fun nenv modref -> - if modref.IsModule && EntityHasWellKnownAttribute g WellKnownEntityAttributes.AutoOpenAttribute modref.Deref then + // Check attributes before forcing the type reading. + if EntityHasWellKnownAttribute g WellKnownEntityAttributes.AutoOpenAttribute modref.Deref && modref.IsModule then AddModuleOrNamespaceContentsToNameEnv g amap ad m false nenv modref else nenv) diff --git a/src/Compiler/Checking/import.fs b/src/Compiler/Checking/import.fs index e4e18fb4abf..fb8c1efee05 100644 --- a/src/Compiler/Checking/import.fs +++ b/src/Compiler/Checking/import.fs @@ -246,16 +246,22 @@ module Nullness = { DirectAttributes: AttributesFromIL Fallback : NullableContextSource} with + // Not ValueOption.orElseWith: it is not inline, so each call allocated a closure per member. member this.GetFlags(g:TcGlobals) = - let fallback = this.Fallback - this.DirectAttributes.GetNullable(g) - |> ValueOption.orElseWith(fun () -> - match fallback with - | FromClass attrs -> attrs.GetNullableContext(g) - | FromMethodAndClass(methodCtx,classCtx) -> - methodCtx.GetNullableContext(g) - |> ValueOption.orElseWith (fun () -> classCtx.GetNullableContext(g))) - |> ValueOption.defaultValue arrayWithByte0 + match this.DirectAttributes.GetNullable(g) with + | ValueSome flags -> flags + | ValueNone -> + let fromContext = + match this.Fallback with + | FromClass attrs -> attrs.GetNullableContext(g) + | FromMethodAndClass(methodCtx,classCtx) -> + match methodCtx.GetNullableContext(g) with + | ValueSome flags -> ValueSome flags + | ValueNone -> classCtx.GetNullableContext(g) + + match fromContext with + | ValueSome flags -> flags + | ValueNone -> arrayWithByte0 static member Empty = let emptyFromIL = AttributesFromIL(0,ILAttributesStored.CreateGiven(ILAttributes.Empty)) {DirectAttributes = emptyFromIL; Fallback = FromClass(emptyFromIL)} @@ -677,93 +683,66 @@ let ImportILGenericParameters amap m scoref tinst (nullableFallback:Nullness.Nul tp.SetConstraints constraints) tps -/// Given a list of items each keyed by an ordered list of keys, apply 'nodef' to the each group -/// with the same leading key. Apply 'tipf' to the elements where the keylist is empty, and return -/// the overall results. Used to bucket types, so System.Char and System.Collections.Generic.List -/// both get initially bucketed under 'System'. -let multisetDiscriminateAndMap nodef tipf (items: ('Key list * 'Value) list) = - // Find all the items with an empty key list and call 'tipf' - let tips = - [ for keylist, v in items do - match keylist with - | [] -> yield tipf v - | _ -> () ] - - // Find all the items with a non-empty key list. Bucket them together by - // the first key. For each bucket, call 'nodef' on that head key and the bucket. - let nodes = - let buckets = Dictionary<_, _>(10) - for keylist, v in items do - match keylist with - | [] -> () - | key :: rest -> - buckets[key] <- - match buckets.TryGetValue key with - | true, b -> (rest, v) :: b - | _ -> [rest, v] - - [ for KeyValue(key, items) in buckets -> nodef key items ] - - tips @ nodes +/// Most IL types have no type parameters, so they share this instead of each allocating a lazy and closure. +let private noTypars = LazyWithContext.NotLazy [] /// Import an IL type definition as a new F# TAST Entity node. let rec ImportILTypeDef amap m scoref (cpath: CompilationPath) enc nm (tdef: ILTypeDef) = - let lazyModuleOrNamespaceTypeForNestedTypes = - InterruptibleLazy(fun _ -> - let cpath = cpath.NestedCompPath nm ModuleOrType - ImportILTypeDefs amap m scoref cpath (enc@[tdef]) tdef.NestedTypes + let moduleOrNamespaceTypeForNestedTypes = + MaybeLazy.Lazy( + // Captures tdef, not its nested types: the closure holds nothing the entity doesn't already keep. + InterruptibleLazy(fun _ -> + let cpath = cpath.NestedCompPath nm ModuleOrType + ImportILTypeDefs amap m scoref cpath (enc@[tdef]) tdef.NestedTypes + ) ) - let nullableFallback = Nullness.FromClass(Nullness.AttributesFromIL(tdef.MetadataIndex,tdef.CustomAttrsStored)) + let typars = + match tdef.GenericParams with + | [] -> noTypars + | gps -> + let nullableFallback = Nullness.FromClass(Nullness.AttributesFromIL(tdef.MetadataIndex,tdef.CustomAttrsStored)) + + // The read of the type parameters may fail to resolve types. Entity.Typars forces + // entity_typars with entity_range, so the range used here is always the import-time + // range 'm' passed to NewILTycon below — never a caller's ad-hoc source range. + // Make sure we reraise the original exception one occurs - see findOriginalException. + LazyWithContext.Create( + (fun m -> ImportILGenericParameters amap m scoref [] nullableFallback gps), + findOriginalException + ) // Add the type itself. Construct.NewILTycon (Some cpath) (nm, m) - // The read of the type parameters may fail to resolve types. Entity.Typars forces - // entity_typars with entity_range, so the range used here is always the import-time - // range 'm' passed to NewILTycon above — never a caller's ad-hoc source range. - // Make sure we reraise the original exception one occurs - see findOriginalException. - (LazyWithContext.Create( - (fun m -> ImportILGenericParameters amap m scoref [] nullableFallback tdef.GenericParams), - findOriginalException - )) + typars (scoref, enc, tdef) - (MaybeLazy.Lazy lazyModuleOrNamespaceTypeForNestedTypes) + moduleOrNamespaceTypeForNestedTypes -/// Import a list of (possibly nested) IL types as a new ModuleOrNamespaceType node -/// containing new entities, bucketing by namespace along the way. -and ImportILTypeDefList amap m (cpath: CompilationPath) enc items = - // Split into the ones with namespaces and without. Add the ones with namespaces in buckets. - // That is, discriminate based in the first element of the namespace list (e.g. "System") - // and, for each bag, fold-in a lazy computation to add the types under that bag . - // - // nodef - called for each bucket, where 'n' is the head element of the namespace used - // as a key in the discrimination, tgs is the remaining descriptors. We create an entity for 'n'. - // - // tipf - called if there are no namespace items left to discriminate on. - let entities = - items - |> multisetDiscriminateAndMap - (fun n tgs -> - let modty = InterruptibleLazy(fun _ -> ImportILTypeDefList amap m (cpath.NestedCompPath n (Namespace true)) enc tgs) - Construct.NewModuleOrNamespace (Some cpath) taccessPublic (mkSynId m n) XmlDoc.Empty [] (MaybeLazy.Lazy modty)) - (fun (n, info: InterruptibleLazy<_>) -> - let (scoref2, lazyTypeDef: ILPreTypeDef) = info.Force() - ImportILTypeDef amap m scoref2 cpath enc n (lazyTypeDef.GetTypeDef())) +/// Import one namespace level as a ModuleOrNamespaceType. +and ImportILTypeDefsOfLevel amap m scoref (cpath: CompilationPath) enc (types: ILPreTypeDef[]) (namespaces: ILPreNamespace[]) = + let typeEntities = + [ for pre in types -> ImportILTypeDef amap m scoref cpath enc pre.Name (pre.GetTypeDef()) ] + + let namespaceEntities = + [ for preNamespace in namespaces do + let childCPath = cpath.NestedCompPath preNamespace.Name (Namespace true) + + // Each half is read once, so a child level needs no table of its own. + let modty = + InterruptibleLazy(fun _ -> + ImportILTypeDefsOfLevel amap m scoref childCPath enc (preNamespace.GetTypes()) (preNamespace.GetNamespaces())) + + Construct.NewModuleOrNamespace (Some cpath) taccessPublic (mkSynId m preNamespace.Name) XmlDoc.Empty [] (MaybeLazy.Lazy modty) ] let kind = match enc with [] -> Namespace true | _ -> ModuleOrType - Construct.NewModuleOrNamespaceType kind entities [] + Construct.NewModuleOrNamespaceType kind (typeEntities @ namespaceEntities) [] -/// Import a table of IL types as a ModuleOrNamespaceType. -/// -and ImportILTypeDefs amap m scoref cpath enc (tdefs: ILTypeDefs) = - // We be very careful not to force a read of the type defs here - tdefs.AsArrayOfPreTypeDefs() - |> Array.map (fun pre -> (pre.Namespace, (pre.Name, notlazy(scoref, pre)))) - |> Array.toList - |> ImportILTypeDefList amap m cpath enc +and ImportILTypeDefs amap m scoref (cpath: CompilationPath) enc (tdefs: ILTypeDefs) = + // We be very careful not to force a read of the type defs or of the child namespaces' contents here + ImportILTypeDefsOfLevel amap m scoref cpath enc (tdefs.AsArrayOfPreTypeDefs()) (tdefs.AsArrayOfPreNamespaces()) /// Import the main type definitions in an IL assembly. /// @@ -780,22 +759,22 @@ let ImportILAssemblyExportedType amap m auxModLoader (scoref: ILScopeRef) (expor [] else let ns, n = splitILTypeName exportedType.Name - let info = - InterruptibleLazy (fun _ -> - match - (try + + let pre = + { new ILPreTypeDef with + member _.Name = n + + member _.GetTypeDef() = + try let modul = auxModLoader exportedType.ScopeRef - let ptd = mkILPreTypeDefComputed (ns, n, (fun () -> modul.TypeDefs.FindByName exportedType.Name)) - Some ptd - with :? KeyNotFoundException -> None) - with - | None -> - error(Error(FSComp.SR.impReferenceToDllRequiredByAssembly(RichText.mkText exportedType.ScopeRef.QualifiedName, RichText.mkText scoref.QualifiedName, RichText.ofQualifiedTypeName exportedType.Name), m)) - | Some preTypeDef -> - scoref, preTypeDef - ) + modul.TypeDefs.FindByName exportedType.Name + with :? KeyNotFoundException -> + error(Error(FSComp.SR.impReferenceToDllRequiredByAssembly(RichText.mkText exportedType.ScopeRef.QualifiedName, RichText.mkText scoref.QualifiedName, RichText.ofQualifiedTypeName exportedType.Name), m)) } + + // A one-entry table: grouping turns the type's namespace into the entity chain. + let tdefs = mkILTypeDefsGroupedComputed (fun () -> [| struct (ns, pre) |]) (fun () -> Array.empty) - [ ImportILTypeDefList amap m (CompPath(scoref, SyntaxAccess.Unknown, [])) [] [(ns, (n, info))] ] + [ ImportILTypeDefs amap m scoref (CompPath(scoref, SyntaxAccess.Unknown, [])) [] tdefs ] /// Import the "exported types" table for multi-module assemblies. let ImportILAssemblyExportedTypes amap m auxModLoader scoref (exportedTypes: ILExportedTypesAndForwarders) = diff --git a/src/Compiler/Driver/StaticLinking.fs b/src/Compiler/Driver/StaticLinking.fs index ebc8287b974..7379423579e 100644 --- a/src/Compiler/Driver/StaticLinking.fs +++ b/src/Compiler/Driver/StaticLinking.fs @@ -214,7 +214,9 @@ let StaticLinkILModules let topTypeDefs, normalTypeDefs = moduls |> List.map (fun m -> + // Type defs come grouped by namespace, which is not the TypeDef row order. Emit them as read. m.TypeDefs.AsList() + |> List.sortBy (fun td -> td.MetadataIndex) |> List.partition (fun td -> isTypeNameForGlobalFunctions td.Name)) |> List.unzip diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 78a07c081c1..236a4a9b798 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -905,8 +905,12 @@ type Entity = member x.IsFSharpException = match x.ExceptionInfo with TExnNone -> false | _ -> true /// Demangle the module name, if FSharpModuleWithSuffix is used - member x.DemangledModuleOrNamespaceName = - CompilationPath.DemangleEntityName x.LogicalName x.ModuleOrNamespaceType.ModuleOrNamespaceKind + member x.DemangledModuleOrNamespaceName = + // Check the suffix before reading the entity contents. + if x.LogicalName.EndsWithOrdinal FSharpModuleSuffix then + CompilationPath.DemangleEntityName x.LogicalName x.ModuleOrNamespaceType.ModuleOrNamespaceKind + else + x.LogicalName /// Get the type parameters for an entity that is a type declaration, otherwise return the empty list. /// @@ -6208,8 +6212,9 @@ type Construct() = ModuleOrNamespaceType(mkind, QueueList.ofList vals, QueueList.ofList tycons) /// Create a new node for an empty module or namespace contents - static member NewEmptyModuleOrNamespaceType mkind = - Construct.NewModuleOrNamespaceType mkind [] [] + static member NewEmptyModuleOrNamespaceType mkind = + // Not via NewModuleOrNamespaceType: QueueList.ofList would build two more objects to hold nothing. + ModuleOrNamespaceType(mkind, QueueList.Empty, QueueList.Empty) static member NewEmptyFSharpTyconData kind = { fsobjmodel_cases = Construct.MakeUnionCases [] diff --git a/src/Compiler/Utilities/illib.fs b/src/Compiler/Utilities/illib.fs index 0b8d51be0a3..a5d44c12bdd 100644 --- a/src/Compiler/Utilities/illib.fs +++ b/src/Compiler/Utilities/illib.fs @@ -191,6 +191,32 @@ type DelayInitArrayMap<'T, 'TDictKey, 'TDictValue>(f: unit -> 'T[]) = abstract CreateDictionary: 'T[] -> IDictionary<'TDictKey, 'TDictValue> +[] +type DelayInitValue<'T when 'T: not null and 'T: not struct>() = + // Locks the instance and stores in place: a sync object or a lazy would add an object per value. + [] + let mutable value: objnull = null + + abstract Compute: unit -> 'T + + member private this.Realise() = + Monitor.Enter this + + try + match value with + | null -> + let computed = this.Compute() + value <- box computed + computed + | v -> unbox<'T> v + finally + Monitor.Exit this + + member this.Value = + match value with + | null -> this.Realise() + | v -> unbox<'T> v + //------------------------------------------------------------------------- // Library: projections //------------------------------------------------------------------------ diff --git a/src/Compiler/Utilities/illib.fsi b/src/Compiler/Utilities/illib.fsi index 12d56533449..a4bba551042 100644 --- a/src/Compiler/Utilities/illib.fsi +++ b/src/Compiler/Utilities/illib.fsi @@ -86,6 +86,16 @@ type DelayInitArrayMap<'T, 'TDictKey, 'TDictValue> = abstract CreateDictionary: 'T[] -> IDictionary<'TDictKey, 'TDictValue> +/// Computes a value once, in place: an unforced value costs one object rather than a lazy plus its closure. +[] +type internal DelayInitValue<'T when 'T: not null and 'T: not struct> = + new: unit -> DelayInitValue<'T> + + member Value: 'T + + /// Called at most once, under the instance's lock. An exception is not cached: the next access retries. + abstract Compute: unit -> 'T + module internal Order = val orderBy: p: ('T -> 'U) -> IComparer<'T> when 'U: comparison and 'T: not null and 'T: not struct diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl index bff5dd54c5d..055808bf332 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl @@ -1263,9 +1263,14 @@ FSharp.Compiler.AbstractIL.IL+ILPlatform: Int32 CompareTo(System.Object, System. FSharp.Compiler.AbstractIL.IL+ILPlatform: Int32 GetHashCode() FSharp.Compiler.AbstractIL.IL+ILPlatform: Int32 GetHashCode(System.Collections.IEqualityComparer) FSharp.Compiler.AbstractIL.IL+ILPlatform: System.String ToString() +FSharp.Compiler.AbstractIL.IL+ILPreNamespace: ILPreNamespace[] ComputeNamespaces() +FSharp.Compiler.AbstractIL.IL+ILPreNamespace: ILPreNamespace[] GetNamespaces() +FSharp.Compiler.AbstractIL.IL+ILPreNamespace: ILPreTypeDef[] ComputeTypes() +FSharp.Compiler.AbstractIL.IL+ILPreNamespace: ILPreTypeDef[] GetTypes() +FSharp.Compiler.AbstractIL.IL+ILPreNamespace: System.String Name +FSharp.Compiler.AbstractIL.IL+ILPreNamespace: System.String get_Name() +FSharp.Compiler.AbstractIL.IL+ILPreNamespace: Void .ctor(System.String) FSharp.Compiler.AbstractIL.IL+ILPreTypeDef: ILTypeDef GetTypeDef() -FSharp.Compiler.AbstractIL.IL+ILPreTypeDef: Microsoft.FSharp.Collections.FSharpList`1[System.String] Namespace -FSharp.Compiler.AbstractIL.IL+ILPreTypeDef: Microsoft.FSharp.Collections.FSharpList`1[System.String] get_Namespace() FSharp.Compiler.AbstractIL.IL+ILPreTypeDef: System.String Name FSharp.Compiler.AbstractIL.IL+ILPreTypeDef: System.String get_Name() FSharp.Compiler.AbstractIL.IL+ILPropertyDef: Boolean IsRTSpecialName @@ -1652,7 +1657,7 @@ FSharp.Compiler.AbstractIL.IL+ILTypeDefLayout: Int32 GetHashCode(System.Collecti FSharp.Compiler.AbstractIL.IL+ILTypeDefLayout: Int32 Tag FSharp.Compiler.AbstractIL.IL+ILTypeDefLayout: Int32 get_Tag() FSharp.Compiler.AbstractIL.IL+ILTypeDefLayout: System.String ToString() -FSharp.Compiler.AbstractIL.IL+ILTypeDefs: System.Collections.Generic.IDictionary`2[System.Tuple`2[Microsoft.FSharp.Collections.FSharpList`1[System.String],System.String],FSharp.Compiler.AbstractIL.IL+ILPreTypeDef] CreateDictionary(ILPreTypeDef[]) +FSharp.Compiler.AbstractIL.IL+ILTypeDefs: System.Collections.Generic.IDictionary`2[System.String,FSharp.Compiler.AbstractIL.IL+ILPreTypeDef] CreateDictionary(ILPreTypeDef[]) FSharp.Compiler.AbstractIL.IL+ILTypeInit+Tags: Int32 BeforeField FSharp.Compiler.AbstractIL.IL+ILTypeInit+Tags: Int32 OnAny FSharp.Compiler.AbstractIL.IL+ILTypeInit: Boolean Equals(ILTypeInit) @@ -1893,6 +1898,7 @@ FSharp.Compiler.AbstractIL.IL: FSharp.Compiler.AbstractIL.IL+ILNestedExportedTyp FSharp.Compiler.AbstractIL.IL: FSharp.Compiler.AbstractIL.IL+ILNestedExportedTypes FSharp.Compiler.AbstractIL.IL: FSharp.Compiler.AbstractIL.IL+ILParameter FSharp.Compiler.AbstractIL.IL: FSharp.Compiler.AbstractIL.IL+ILPlatform +FSharp.Compiler.AbstractIL.IL: FSharp.Compiler.AbstractIL.IL+ILPreNamespace FSharp.Compiler.AbstractIL.IL: FSharp.Compiler.AbstractIL.IL+ILPreTypeDef FSharp.Compiler.AbstractIL.IL: FSharp.Compiler.AbstractIL.IL+ILPropertyDef FSharp.Compiler.AbstractIL.IL: FSharp.Compiler.AbstractIL.IL+ILPropertyDefs @@ -1945,6 +1951,7 @@ FSharp.Compiler.AbstractIL.IL: ILMethodImplDefs mkILMethodImpls(Microsoft.FSharp FSharp.Compiler.AbstractIL.IL: ILMethodImplDefs mkILMethodImplsLazy(System.Lazy`1[Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.AbstractIL.IL+ILMethodImplDef]]) FSharp.Compiler.AbstractIL.IL: ILModuleDef mkILSimpleModule(System.String, System.String, Boolean, System.Tuple`2[System.Int32,System.Int32], Boolean, ILTypeDefs, Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.String], Int32, ILExportedTypesAndForwarders, System.String) FSharp.Compiler.AbstractIL.IL: ILNestedExportedTypes mkILNestedExportedTypes(Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.AbstractIL.IL+ILNestedExportedType]) +FSharp.Compiler.AbstractIL.IL: ILPreNamespace mkILPreNamespaceComputed(System.String, Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,FSharp.Compiler.AbstractIL.IL+ILPreTypeDef[]], Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,FSharp.Compiler.AbstractIL.IL+ILPreNamespace[]]) FSharp.Compiler.AbstractIL.IL: ILPropertyDefs emptyILProperties FSharp.Compiler.AbstractIL.IL: ILPropertyDefs get_emptyILProperties() FSharp.Compiler.AbstractIL.IL: ILPropertyDefs mkILProperties(Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.AbstractIL.IL+ILPropertyDef]) @@ -1961,6 +1968,8 @@ FSharp.Compiler.AbstractIL.IL: ILTypeDefs get_emptyILTypeDefs() FSharp.Compiler.AbstractIL.IL: ILTypeDefs mkILTypeDefs(Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.AbstractIL.IL+ILTypeDef]) FSharp.Compiler.AbstractIL.IL: ILTypeDefs mkILTypeDefsComputed(Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,FSharp.Compiler.AbstractIL.IL+ILPreTypeDef[]]) FSharp.Compiler.AbstractIL.IL: ILTypeDefs mkILTypeDefsFromArray(ILTypeDef[]) +FSharp.Compiler.AbstractIL.IL: ILTypeDefs mkILTypeDefsGroupedComputed(Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,System.ValueTuple`2[Microsoft.FSharp.Collections.FSharpList`1[System.String],FSharp.Compiler.AbstractIL.IL+ILPreTypeDef][]], Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,FSharp.Compiler.AbstractIL.IL+ILPreNamespace[]]) +FSharp.Compiler.AbstractIL.IL: ILTypeDefs mkILTypeDefsOfNamespace(ILPreNamespace) FSharp.Compiler.AbstractIL.IL: Int32 NoMetadataIdx FSharp.Compiler.AbstractIL.IL: Int32 get_NoMetadataIdx() FSharp.Compiler.AbstractIL.IL: Internal.Utilities.Library.InterruptibleLazy`1[Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.AbstractIL.IL+InterfaceImpl]] emptyILInterfaceImpls @@ -5654,6 +5663,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean EventIsStandard FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean HasGetterMethod FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean HasSetterMethod FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean HasSignatureFile +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsPropertyAccessor FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsActivePattern FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsBaseValue FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsCompilerGenerated @@ -5676,7 +5686,6 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsModuleValueOrMe FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsMutable FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsOverrideOrExplicitInterfaceImplementation FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsProperty -FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsPropertyAccessor FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsPropertyGetterMethod FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsPropertySetterMethod FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsRefCell @@ -5690,6 +5699,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_EventIsStanda FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_HasGetterMethod() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_HasSetterMethod() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_HasSignatureFile() +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsPropertyAccessor() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsActivePattern() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsBaseValue() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsCompilerGenerated() @@ -5712,7 +5722,6 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsModuleValue FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsMutable() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsOverrideOrExplicitInterfaceImplementation() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsProperty() -FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsPropertyAccessor() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsPropertyGetterMethod() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsPropertySetterMethod() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsRefCell() diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj index ab32f769df7..2e53400e325 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj @@ -34,6 +34,7 @@ + diff --git a/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs b/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs index b05e8f5864e..473a503ba13 100644 --- a/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs @@ -10,6 +10,7 @@ open FSharp.Compiler open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILBinaryReader open FSharp.Compiler.CodeAnalysis +open FSharp.Compiler.Diagnostics open FSharp.Compiler.Text open FSharp.Test.Assert open Internal.Utilities.Library @@ -124,17 +125,17 @@ type PreTypeDef(data: PreTypeDefData) = interface ILPreTypeDef with member x.Name = data.Name - member x.Namespace = data.Namespace member x.GetTypeDef() = getTypeDef () -let createPreTypeDefs typeData = +// Entries for a reader with no namespace structure of its own. +let createPreTypeDefs typeData : struct (string list * ILPreTypeDef)[] = typeData |> Array.ofList - |> Array.map (fun data -> PreTypeDef data :> ILPreTypeDef) + |> Array.map (fun data -> struct (data.Namespace, PreTypeDef data :> ILPreTypeDef)) -let referenceReaderProject getPreTypeDefs (cancelOnModuleAccess: bool) (options: FSharpProjectOptions) = - let reader = new ModuleReader("Reference", mkILTypeDefsComputed getPreTypeDefs, cancelOnModuleAccess) +let referenceReaderProjectWithTypeDefs (typeDefs: ILTypeDefs) (cancelOnModuleAccess: bool) (options: FSharpProjectOptions) = + let reader = new ModuleReader("Reference", typeDefs, cancelOnModuleAccess) let project = FSharpReferencedProject.ILModuleReference( reader.Path, (fun _ -> reader.Timestamp), (fun _ -> reader) @@ -142,6 +143,10 @@ let referenceReaderProject getPreTypeDefs (cancelOnModuleAccess: bool) (options: { options with ReferencedProjects = [| project |]; OtherOptions = Array.append options.OtherOptions [| $"-r:{reader.Path}"|] } +let referenceReaderProject getPreTypeDefs (cancelOnModuleAccess: bool) (options: FSharpProjectOptions) = + let typeDefs = mkILTypeDefsGroupedComputed getPreTypeDefs (fun () -> Array.empty) + referenceReaderProjectWithTypeDefs typeDefs cancelOnModuleAccess options + let parseAndCheck path source options = cts <- new CancellationTokenSource() wasCancelled <- false @@ -211,8 +216,7 @@ let ``Type defs 01 - assembly import`` () = | None -> failwith "Expecting results" -// can only be run explicitly -[] +[] let ``Type defs 02 - assembly import`` () = let source = source1 @@ -300,3 +304,135 @@ let ``Module def 01 - assembly import`` () = |> shouldEqual [| "No constructors are available for the type 'T'" |] | None -> failwith "Expecting results" + + +// A namespace split across the metadata must merge into one on import, in metadata order. Synthetic, +// since Roslyn can't emit a genuinely split namespace. +let private splitNamespaceTypes = + [ { Name = "T1"; Namespace = ["Ns1"; "Ns2"]; HasCtor = false; CancelOnImport = false } + { Name = "T2"; Namespace = ["Ns1"]; HasCtor = false; CancelOnImport = false } + { Name = "T3"; Namespace = ["Ns1"; "Ns2"]; HasCtor = false; CancelOnImport = false } ] + +[] +let ``Split namespace - both fragments merge and are accessible`` () = + // Both T1 and T3, though split by Ns1.T2 in the metadata. + let source = """ +module Module + +open Ns1 +open Ns1.Ns2 + +let _f1 (x: T1) = x +let _f2 (x: T2) = x +let _f3 (x: T3) = x +""" + let getPreTypeDefs _ = createPreTypeDefs splitNamespaceTypes + let path, options = mkTestFileAndOptions [||] + let options = referenceReaderProject getPreTypeDefs false options + + match parseAndCheck path source options with + | Some results -> + results.Diagnostics + |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error) + |> Array.map _.Message + |> shouldEqual [||] + | None -> failwith "Expecting results" + +let private referencedAssembly (options: FSharpProjectOptions) = + let results = checker.ParseAndCheckProject(options) |> Async.RunSynchronously + + results.ProjectContext.GetReferencedAssemblies() + |> List.find (fun a -> a.SimpleName.StartsWith "Reference") + +/// The imported types in entity order, each as "Namespace.Path.TypeName". +let private importedTypeOrder (options: FSharpProjectOptions) = + (referencedAssembly options).Contents.Entities + |> Seq.map (fun e -> if e.AccessPath = "global" then e.DisplayName else $"{e.AccessPath}.{e.DisplayName}") + |> List.ofSeq + +[] +let ``Split namespace - import order is preserved`` () = + let getPreTypeDefs _ = createPreTypeDefs splitNamespaceTypes + let _, options = mkTestFileAndOptions [||] + let options = referenceReaderProject getPreTypeDefs false options + + // Depth-first, T1 before T3 despite the split. Matches the old import for this shape by coincidence + // of its depths - see the ordering tests below. + (referencedAssembly options).Contents.Entities + |> Seq.map (fun e -> e.DisplayName, e.AccessPath) + |> List.ofSeq + |> shouldEqual [ "T2", "Ns1"; "T1", "Ns1.Ns2"; "T3", "Ns1.Ns2" ] + + +// ---- Entity order ------------------------------------------------------------------------------ +// +// Depths 0-3 with siblings at each - enough to pin sibling order at every depth for both reader shapes. +let private orderedTypes = + [ "G0", [] + "G1", [] + "A1", [ "N1" ] + "B1", [ "N1" ] + "A2", [ "N1"; "N2" ] + "B2", [ "N1"; "N2" ] + "A3", [ "N1"; "N2"; "N3" ] + "B3", [ "N1"; "N2"; "N3" ] + "PA", [ "N1"; "P" ] + "QA", [ "N1"; "Q" ] + "C1", [ "M1" ] ] + +let private mkTypeData (name, ns) = + { Name = name; Namespace = ns; HasCtor = false; CancelOnImport = false } + +/// Metadata order at every depth, types before child namespaces. +/// +/// A deliberate change: the old import reversed siblings once per namespace component consumed, so its +/// order alternated with depth. A grouped tree reverses a type once whatever its depth and a flat table +/// once per component, so metadata order is the only one both shapes can agree on - hence one list here. +let private expectedOrder = + [ "G0" + "G1" + "N1.A1" + "N1.B1" + "N1.N2.A2" + "N1.N2.B2" + "N1.N2.N3.A3" + "N1.N2.N3.B3" + "N1.P.PA" + "N1.Q.QA" + "M1.C1" ] + +/// The same types as a hand-built tree: what a reader whose own store knows its namespaces hands over. +let rec private mkPreNamespace name depth (types: (string * string list) list) = + let ownTypes, nested = types |> List.partition (fun (_, ns) -> List.length ns = depth) + + mkILPreNamespaceComputed( + name, + (fun () -> [| for t in ownTypes -> PreTypeDef(mkTypeData t) :> ILPreTypeDef |]), + (fun () -> + [| for name, group in List.groupBy (fun (_, ns) -> List.item depth ns) nested -> + mkPreNamespace name (depth + 1) group |]) + ) + +let private mkNamespaceTree depth types = + mkILTypeDefsOfNamespace (mkPreNamespace "" depth types) + +[] +let ``Import order - grouped entries keep metadata order at every depth`` () = + // Namespaced entries grouped by the reader: what a metadata table, FSI and static linking produce. + let typeDefs = + mkILTypeDefsGroupedComputed + (fun () -> createPreTypeDefs (List.map mkTypeData orderedTypes)) + (fun () -> Array.empty) + + let _, options = mkTestFileAndOptions [||] + let options = referenceReaderProjectWithTypeDefs typeDefs false options + + importedTypeOrder options |> shouldEqual expectedOrder + +[] +let ``Import order - a hand-built namespace tree imports the same`` () = + // The two ways of handing over the same types must import identically. + let _, options = mkTestFileAndOptions [||] + let options = referenceReaderProjectWithTypeDefs (mkNamespaceTree 0 orderedTypes) false options + + importedTypeOrder options |> shouldEqual expectedOrder diff --git a/tests/FSharp.Compiler.Service.Tests/ModuleReaderNamespaceTests.fs b/tests/FSharp.Compiler.Service.Tests/ModuleReaderNamespaceTests.fs new file mode 100644 index 00000000000..233c7ed0647 --- /dev/null +++ b/tests/FSharp.Compiler.Service.Tests/ModuleReaderNamespaceTests.fs @@ -0,0 +1,676 @@ +module FSharp.Compiler.Service.Tests.ModuleReaderNamespaceTests + +open System.Collections.Generic +open System.Reflection +open System.Text +open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.AbstractIL.ILBinaryReader +open FSharp.Compiler.Diagnostics +open FSharp.Compiler.Service.Tests.Common +// The synthetic ILModuleReader harness (ModuleReader, referenceReaderProjectWithTypeDefs). +open FSharp.Compiler.Service.Tests.ModuleReaderCancellationTests +open FSharp.Test.Compiler +open FSharp.Test.Assert +open Xunit + +// How ILPreTypeDef / ILPreNamespace are created when reading metadata: only imported namespaces should +// realise their pre-type-defs. Roslyn can't emit a genuinely split namespace, so C# is used only for the +// realistic-shape test and split order is asserted with synthetic arrays. + +let private dumpTree (sortSiblings: bool) (typeDefs: ILTypeDefs) : string = + let sb = StringBuilder() + + let rec go (indent: int) (types: ILPreTypeDef[]) (namespaces: ILPreNamespace[]) = + let pad = String.replicate indent " " + + let typeNames = + [ for pre in types do + // Skip the always-present pseudo-type. + if pre.Name <> "" then yield pre.Name ] + for name in (if sortSiblings then List.sort typeNames else typeNames) do + sb.AppendLine($"{pad}{name}") |> ignore + + let namespaces = List.ofArray namespaces + let namespaces = if sortSiblings then List.sortBy (fun (ns: ILPreNamespace) -> ns.Name) namespaces else namespaces + for ns in namespaces do + sb.AppendLine($"{pad}{ns.Name}/") |> ignore + go (indent + 1) (ns.GetTypes()) (ns.GetNamespaces()) + + sb.AppendLine("global") |> ignore + go 1 (typeDefs.AsArrayOfPreTypeDefs()) (typeDefs.AsArrayOfPreNamespaces()) + sb.ToString().Replace("\r\n", "\n").TrimEnd('\n') + + +// ---- Synthetic pre-type-defs (control the exact metadata order) -------------------------------- + +/// Carries only the simple name; the namespace lives in the containing table. +let private mkPreTypeDef (name: string) : ILPreTypeDef = + { new ILPreTypeDef with + member _.Name = name + member _.GetTypeDef() = + ILTypeDef(name, TypeAttributes.Public, ILTypeDefLayout.Auto, [], [], None, + mkILMethods [], mkILTypeDefs [], mkILFields [], emptyILMethodImpls, mkILEvents [], + mkILProperties [], emptyILSecurityDecls, emptyILCustomAttrsStored) } + +let private entryOf (fullName: string) : struct (string list * ILPreTypeDef) = + let ns, name = splitILTypeName fullName + struct (ns, mkPreTypeDef name) + +/// Full type names, in order, through the production grouping. +let private mkGroupedTypeDefs (fullNames: string list) : ILTypeDefs = + mkILTypeDefsGroupedComputed (fun () -> [| for n in fullNames -> entryOf n |]) (fun () -> Array.empty) + +/// Wrap the type defs so that reading either half of any namespace records its full path in `forced`. +let private trackNamespaceForcing (forced: HashSet) (typeDefs: ILTypeDefs) : ILTypeDefs = + let rec track (path: string) (ns: ILPreNamespace) = + let childPath (child: ILPreNamespace) = + if path = "" then child.Name else $"{path}.{child.Name}" + + mkILPreNamespaceComputed( + ns.Name, + (fun () -> + forced.Add path |> ignore + ns.GetTypes()), + (fun () -> + forced.Add path |> ignore + [| for child in ns.GetNamespaces() -> track (childPath child) child |]) + ) + + // The level itself is the table handed in; only the namespaces below it are tracked. + mkILTypeDefsOfNamespace ( + mkILPreNamespaceComputed( + "", + (fun () -> typeDefs.AsArrayOfPreTypeDefs()), + (fun () -> [| for ns in typeDefs.AsArrayOfPreNamespaces() -> track ns.Name ns |]) + ) + ) + + +[] +let ``Grouping - split namespace preserves metadata order`` () = + // Ns1 is split in the metadata: Ns1.T1, then Ns2.T2, then back to Ns1.T3. + let typeDefs = mkGroupedTypeDefs [ "Ns1.T1"; "Ns2.T2"; "Ns1.T3" ] + + // Ns1 must come before Ns2 (first-seen), and within Ns1 the members keep order: T1 then T3. + dumpTree false typeDefs |> shouldEqual ( + "global\n" + + " Ns1/\n" + + " T1\n" + + " T3\n" + + " Ns2/\n" + + " T2" + ) + + +[] +let ``Grouping - nested namespaces and global types`` () = + let typeDefs = + mkGroupedTypeDefs [ "Type1"; "Namespace1.Type2"; "Namespace2.Inner.Type4"; "Namespace2.Type3" ] + + dumpTree false typeDefs |> shouldEqual ( + "global\n" + + " Type1\n" + + " Namespace1/\n" + + " Type2\n" + + " Namespace2/\n" + + " Type3\n" + + " Inner/\n" + + " Type4" + ) + + +[] +let ``Grouping - flat compat members flatten across namespaces`` () = + let typeDefs = mkGroupedTypeDefs [ "Type1"; "Ns1.T1"; "Ns2.T2"; "Ns1.T3" ] + + // AllPreTypeDefs flattens the whole subtree (local types first, then per-namespace in order). + typeDefs.AllPreTypeDefs() |> Array.map _.Name |> shouldEqual [| "Type1"; "T1"; "T3"; "T2" |] + + typeDefs.ExistsByName "Ns1.T3" |> shouldEqual true + typeDefs.ExistsByName "Ns2.T2" |> shouldEqual true + typeDefs.ExistsByName "Missing" |> shouldEqual false + (typeDefs.FindByName "Ns1.T1").Name |> shouldEqual "T1" + + +[] +let ``Grouping - namespaces are realised lazily`` () = + let forced = HashSet() + + let typeDefs = + trackNamespaceForcing forced (mkGroupedTypeDefs [ "Type1"; "Ns1.T1"; "Ns2.Inner.T2" ]) + + // Reading global-namespace types and enumerating child namespaces must not force any contents. + typeDefs.AsArrayOfPreTypeDefs() |> Array.map _.Name |> shouldEqual [| "Type1" |] + typeDefs.AsArrayOfPreNamespaces() |> Array.map _.Name |> shouldEqual [| "Ns1"; "Ns2" |] + forced.Count |> shouldEqual 0 + + // Importing a single namespace forces only that one (not its siblings, not deeper levels). + let ns1 = typeDefs.AsArrayOfPreNamespaces() |> Array.find (fun ns -> ns.Name = "Ns1") + ns1.GetTypes() |> Array.map _.Name |> shouldEqual [| "T1" |] + forced.Contains "Ns1" |> shouldEqual true + forced.Contains "Ns2" |> shouldEqual false + forced.Contains "Ns2.Inner" |> shouldEqual false + + +[] +let ``Grouping - un-imported namespaces never have their type names read`` () = + // Grouping needs an entry's namespace, never its name - and a name is a string-heap read for the + // metadata reader. + let read = HashSet() + + let entry (fullName: string) : struct (string list * ILPreTypeDef) = + let ns, name = splitILTypeName fullName + + let pre = + { new ILPreTypeDef with + member _.Name = + read.Add fullName |> ignore + name + + member _.GetTypeDef() = (mkPreTypeDef name).GetTypeDef() } + + struct (ns, pre) + + let typeDefs = + mkILTypeDefsGroupedComputed + (fun () -> [| entry "Type1"; entry "Ns1.T1"; entry "Ns2.Inner.T2" |]) + (fun () -> Array.empty) + + // Child namespaces are named by the grouping, not by the types in them, so enumerating reads nothing. + typeDefs.AsArrayOfPreNamespaces() |> Array.map _.Name |> shouldEqual [| "Ns1"; "Ns2" |] + read |> shouldEqual (HashSet()) + + typeDefs.AsArrayOfPreTypeDefs() |> Array.map _.Name |> shouldEqual [| "Type1" |] + read |> shouldEqual (HashSet [ "Type1" ]) + + // Importing Ns1 reads only Ns1's; Ns2's remain untouched. + let ns1 = typeDefs.AsArrayOfPreNamespaces() |> Array.find (fun ns -> ns.Name = "Ns1") + ns1.GetTypes() |> Array.map _.Name |> shouldEqual [| "T1" |] + read |> shouldEqual (HashSet [ "Type1"; "Ns1.T1" ]) + + +[] +let ``Lookup - by name works for a deeply nested namespace`` () = + let typeDefs = + mkILTypeDefsGroupedComputed (fun () -> [| entryOf "Ns1.Ns2.T"; entryOf "GlobalType" |]) (fun () -> Array.empty) + + typeDefs.ExistsByName "Ns1.Ns2.T" |> shouldEqual true + typeDefs.ExistsByName "GlobalType" |> shouldEqual true + typeDefs.ExistsByName "Ns1.T" |> shouldEqual false + (typeDefs.FindByName "Ns1.Ns2.T").Name |> shouldEqual "T" + + +[] +let ``Lookup - by name descends only into the relevant namespace`` () = + let forced = HashSet() + let typeDefs = trackNamespaceForcing forced (mkGroupedTypeDefs [ "Ns1.T1"; "Ns2.Inner.T2" ]) + + // Finding a type descends only into the namespaces on its path, not its siblings. + typeDefs.ExistsByName "Ns2.Inner.T2" |> shouldEqual true + forced.Contains "Ns2" |> shouldEqual true + forced.Contains "Ns2.Inner" |> shouldEqual true + forced.Contains "Ns1" |> shouldEqual false + + // A miss under an existing namespace does not force siblings either. + typeDefs.ExistsByName "Ns2.Nope" |> shouldEqual false + forced.Contains "Ns1" |> shouldEqual false + + +[] +let ``Lookup - FindByName reports the missing type name`` () = + let typeDefs = mkGroupedTypeDefs [ "Ns1.T1" ] + + Assert.Throws(fun () -> typeDefs.FindByName "Ns1.Missing" |> ignore).Message + |> shouldEqual "Ns1.Missing" + + +[] +let ``Mixed level - a namespace named by both an entry and a pre-namespace becomes one child`` () = + // Children from BOTH grouped entries and supplied pre-namespaces, sharing a name: they must be one + // child at every depth, so an importer never sees two namespaces of one name. + let ns2 = + mkILPreNamespaceComputed("Ns2", (fun () -> [| mkPreTypeDef "TDeepSupplied" |]), (fun () -> Array.empty)) + + let ns1 = + mkILPreNamespaceComputed("Ns1", (fun () -> [| mkPreTypeDef "TSupplied" |]), (fun () -> [| ns2 |])) + + let typeDefs = + mkILTypeDefsGroupedComputed + (fun () -> + [| struct ([ "Ns1" ], mkPreTypeDef "TGrouped") + struct ([ "Ns1"; "Ns2" ], mkPreTypeDef "TDeepGrouped") |]) + (fun () -> [| ns1 |]) + + typeDefs.AsArrayOfPreNamespaces() |> Array.map _.Name |> shouldEqual [| "Ns1" |] + + typeDefs.ExistsByName "Ns1.TGrouped" |> shouldEqual true + typeDefs.ExistsByName "Ns1.TSupplied" |> shouldEqual true + typeDefs.ExistsByName "Ns1.Ns2.TDeepGrouped" |> shouldEqual true + typeDefs.ExistsByName "Ns1.Ns2.TDeepSupplied" |> shouldEqual true + typeDefs.ExistsByName "Ns1.Missing" |> shouldEqual false + + // Flattening a merged child takes the grouped side first, then the supplied one. + typeDefs.AllPreTypeDefs() + |> Array.map _.Name + |> shouldEqual [| "TGrouped"; "TSupplied"; "TDeepGrouped"; "TDeepSupplied" |] + + +[] +let ``Duplicate namespace nodes - two supplied children of one name merge`` () = + let mkNs name typeName = + mkILPreNamespaceComputed(name, (fun () -> [| mkPreTypeDef typeName |]), (fun () -> Array.empty)) + + let typeDefs = + mkILTypeDefsGroupedComputed (fun () -> [||]) (fun () -> [| mkNs "Ns" "First"; mkNs "Ns" "Second" |]) + + typeDefs.AsArrayOfPreNamespaces() |> Array.map _.Name |> shouldEqual [| "Ns" |] + typeDefs.ExistsByName "Ns.First" |> shouldEqual true + typeDefs.ExistsByName "Ns.Second" |> shouldEqual true + typeDefs.AllPreTypeDefs() |> Array.map _.Name |> shouldEqual [| "First"; "Second" |] + + typeDefs.AllPreTypeDefs() |> Array.map _.Name |> shouldEqual [| "First"; "Second" |] + + +// ---- C# realistic-shape path (reads real metadata via ILModuleReader) -------------------------- + +let private readCSharpModule (source: string) : ILModuleDef = + let dllPath = + CSharp source + |> withName "NamespaceReaderTest" + |> compile + |> shouldSucceed + |> fun result -> + match result.OutputPath with + | Some path -> path + | None -> failwith "Expected an output path from the C# compilation" + + let options = + { pdbDirPath = None + reduceMemoryUsage = ReduceMemoryFlag.Yes + metadataOnly = MetadataOnlyFlag.Yes + tryGetMetadataSnapshot = (fun _ -> None) } + + (OpenILModuleReader dllPath options).ILModuleDef + + +[] +let ``Grouping - reader groups real metadata into namespaces (C#)`` () = + let source = """ +public class Type1 { } +namespace Namespace1 { public class Type2 { } } +namespace Namespace2 { public class Type3 { } } +namespace Namespace2.Inner { public class Type4 { } } +""" + + // Sibling order is normalised: Roslyn does not preserve source order across namespaces. + dumpTree true (readCSharpModule source).TypeDefs |> shouldEqual ( + "global\n" + + " Type1\n" + + " Namespace1/\n" + + " Type2\n" + + " Namespace2/\n" + + " Type3\n" + + " Inner/\n" + + " Type4" + ) + + +[] +let ``Nested types - live under their declaring type, not as namespaces (C#)`` () = + let source = """ +namespace Ns { public class Outer { public class Inner { public class Innermost { } } } } +""" + + let moduleDef = readCSharpModule source + + // The tree only exposes namespaces and top-level types: nested types are not namespaces. + dumpTree true moduleDef.TypeDefs |> shouldEqual ( + "global\n" + + " Ns/\n" + + " Outer" + ) + + // Nested types are reachable through their declaring type's NestedTypes, keyed by simple name. + let outer = moduleDef.TypeDefs.FindByName "Ns.Outer" + outer.NestedTypes.AsArray() |> Array.map (fun td -> td.Name) |> shouldEqual [| "Inner" |] + outer.NestedTypes.AsArrayOfPreNamespaces() |> shouldEqual [||] + + let inner = outer.NestedTypes.FindByName "Inner" + inner.NestedTypes.AsArray() |> Array.map (fun td -> td.Name) |> shouldEqual [| "Innermost" |] + + +[] +let ``Nested types - grouping keeps them under the declaring type`` () = + // A top-level type in a namespace, carrying a nested type in its (namespace-free) NestedTypes. + let inner = + ILTypeDef("Inner", TypeAttributes.NestedPublic, ILTypeDefLayout.Auto, [], [], None, + mkILMethods [], mkILTypeDefs [], mkILFields [], emptyILMethodImpls, mkILEvents [], + mkILProperties [], emptyILSecurityDecls, emptyILCustomAttrsStored) + + let outer : ILPreTypeDef = + { new ILPreTypeDef with + member _.Name = "Outer" + member _.GetTypeDef() = + ILTypeDef("Outer", TypeAttributes.Public, ILTypeDefLayout.Auto, [], [], None, + mkILMethods [], mkILTypeDefs [ inner ], mkILFields [], emptyILMethodImpls, mkILEvents [], + mkILProperties [], emptyILSecurityDecls, emptyILCustomAttrsStored) } + + let typeDefs = mkILTypeDefsGroupedComputed (fun () -> [| struct ([ "Ns" ], outer) |]) (fun () -> Array.empty) + + // Outer sits in namespace Ns; Inner is not a top-level type or namespace. + dumpTree false typeDefs |> shouldEqual ( + "global\n" + + " Ns/\n" + + " Outer" + ) + + let ns: ILPreNamespace = typeDefs.AsArrayOfPreNamespaces() |> Array.exactlyOne + let outerPre = ns.GetTypes() |> Array.exactlyOne + outerPre.GetTypeDef().NestedTypes.AsArray() |> Array.map (fun td -> td.Name) |> shouldEqual [| "Inner" |] + + +// ---- End-to-end: what checking a file actually reads out of a reference ------------------------ +// +// The tests above pin the reader API in isolation. These pin the guarantee it exists for: checking a file +// must pull only the namespaces it names. The regression is easy to introduce far from the reader - +// anything that walks a CCU's whole ModuleOrNamespaceType realises every namespace of it, as +// addConstraintSources did. + +/// A type to put in the synthetic reference assembly. +type private TypeShape = + { Name: string + Namespace: string list + /// Names of the types nested in it (leaves themselves). + Nested: string list + /// Full name of a base type in the same assembly. + Extends: string option } + +let private shape name ns = + { Name = name; Namespace = ns; Nested = []; Extends = None } + +let private fullName ns name = String.concat "." (ns @ [ name ]) + +/// Resolved by simple name against the project's references, so System.Object can be named. +let private systemRuntimeScopeRef = + ILScopeRef.Assembly(ILAssemblyRef.Create("System.Runtime", None, None, false, None, None)) + +/// What a check pulled out of the reference, by full type name ("Ns.T", nested as "Ns.T+Inner"). +type private ReadLog() = + member val TypeDefs = HashSet() + member val Members = HashSet() + member val NestedTypes = HashSet() + member val CustomAttrs = HashSet() + +let private sorted (names: HashSet) = List.ofSeq names |> List.sort + +/// Records reading its type def, and each part of it read afterwards. +/// +/// `ilName` follows the reader: a top-level type def carries its full name while the pre-type-def carries +/// the simple one, and a nested type def carries the simple name. Import rebuilds a nested type's +/// ILTypeRef from its declaring type def's name, so a simple name there resolves in the wrong namespace. +let rec private trackedPreTypeDefWith + (log: ReadLog) + (attributes: TypeAttributes) + (ilName: string) + (path: string) + (ty: TypeShape) + : ILPreTypeDef = + let methods = + mkILMethodsComputed (fun () -> + log.Members.Add path |> ignore + [||]) + + let nested = + mkILTypeDefsComputed (fun () -> + log.NestedTypes.Add path |> ignore + + [| for name in ty.Nested -> + trackedPreTypeDefWith log TypeAttributes.NestedPublic name $"{path}+{name}" (shape name []) |]) + + let customAttrs = + ILAttributesStored.CreateReader( + 0, + fun _ -> + log.CustomAttrs.Add path |> ignore + [||] + ) + + // Without a base type a member lookup has no hierarchy to walk and simply fails. + let extends = + let scope, name = + match ty.Extends with + | Some name -> ILScopeRef.Local, name + | None -> systemRuntimeScopeRef, "System.Object" + + Some(mkILBoxedType (mkILNonGenericTySpec (mkILTyRef (scope, name)))) + + // One instance, as a real reader hands out: import holds on to the one it was given. + let typeDef = + ILTypeDef(ilName, attributes, ILTypeDefLayout.Auto, [], [], extends, + methods, nested, mkILFields [], emptyILMethodImpls, mkILEvents [], + mkILProperties [], emptyILSecurityDecls, customAttrs) + + { new ILPreTypeDef with + member _.Name = ty.Name + + member _.GetTypeDef() = + log.TypeDefs.Add path |> ignore + typeDef } + +let private trackedPreTypeDef log (ty: TypeShape) = + let path = fullName ty.Namespace ty.Name + trackedPreTypeDefWith log TypeAttributes.Public path path ty + +/// Check `source` against a reference assembly built from `shapes`, and report what it read. +let private checkAgainstReference (shapes: TypeShape list) (source: string) = + let log = ReadLog() + + let typeDefs = + mkILTypeDefsGroupedComputed (fun () -> [| for s in shapes -> struct (s.Namespace, trackedPreTypeDef log s) |]) (fun () -> + Array.empty) + + let path, options = mkTestFileAndOptions [||] + let options = referenceReaderProjectWithTypeDefs typeDefs false options + + let _, results = parseAndCheckFile path source options + + results.Diagnostics + |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error) + |> Array.map _.Message + |> shouldEqual [||] + + log + +/// Types at several namespace depths, with a sibling at each and a nested type in Ns1.A. +let private referenceShapes = + [ shape "G" [] + { shape "A" [ "Ns1" ] with Nested = [ "Inner" ] } + shape "B" [ "Ns1" ] + shape "D" [ "Ns1"; "Deep" ] + shape "X" [ "Ns2" ] ] + +let private useNs1A = """ +module Module + +let f (x: Ns1.A) = x +""" + +[] +let ``Laziness - checking a file reads only the namespaces it names`` () = + let log = checkAgainstReference referenceShapes useNs1A + + // Import granularity is the namespace level, not the type, so Ns1.B and G come along. What matters is + // that the levels off the path - Ns1.Deep and Ns2 - are never read. + sorted log.TypeDefs |> shouldEqual [ "G"; "Ns1.A"; "Ns1.B" ] + +[] +let ``Laziness - checking a file reads no type name of an un-named namespace`` () = + let log = ReadLog() + let read = HashSet() + + // The isolated test above pins that grouping never reads a name; this pins that it survives a check. + let typeDefs = + mkILTypeDefsGroupedComputed + (fun () -> + [| for s in referenceShapes -> + let path = fullName s.Namespace s.Name + let pre = trackedPreTypeDef log s + + let tracked = + { new ILPreTypeDef with + member _.Name = + read.Add path |> ignore + pre.Name + + member _.GetTypeDef() = pre.GetTypeDef() } + + struct (s.Namespace, tracked) |]) + (fun () -> Array.empty) + + let path, options = mkTestFileAndOptions [||] + let options = referenceReaderProjectWithTypeDefs typeDefs false options + parseAndCheckFile path useNs1A options |> ignore + + sorted read |> shouldEqual [ "G"; "Ns1.A"; "Ns1.B" ] + sorted log.TypeDefs |> shouldEqual [ "G"; "Ns1.A"; "Ns1.B" ] + +[] +let ``Laziness - importing a type reads neither its members nor its nested types`` () = + let log = checkAgainstReference referenceShapes useNs1A + + // Reading a type def is the whole cost of importing it: what is inside stays behind its own lazies. + sorted log.Members |> shouldEqual [] + sorted log.NestedTypes |> shouldEqual [] + +[] +let ``Laziness - attributes are read for the types brought into scope, not for all imported ones`` () = + let log = checkAgainstReference referenceShapes useNs1A + + // Attributes are read when a type enters the name environment or a use of it is resolved. Ns1.B is + // imported alongside Ns1.A but never enters scope. + sorted log.CustomAttrs |> shouldEqual [ "G"; "Ns1.A" ] + +[] +let ``Laziness - a nested type is read only once it is named`` () = + let source = """ +module Module + +let f (x: Ns1.A.Inner) = x +""" + let log = checkAgainstReference referenceShapes source + + // Naming the nested type forces its declaring type's nested table - and only that one. + sorted log.NestedTypes |> shouldEqual [ "Ns1.A" ] + sorted log.TypeDefs |> shouldEqual [ "G"; "Ns1.A"; "Ns1.A+Inner"; "Ns1.B" ] + sorted log.Members |> shouldEqual [] + +[] +let ``Laziness - opening a namespace does not read its child namespaces`` () = + let source = """ +module Module + +open Ns1 + +let f (x: A) = x +""" + let log = checkAgainstReference referenceShapes source + + // An open imports the namespace's own types, so Ns1.Deep must stay untouched. + sorted log.TypeDefs |> shouldEqual [ "G"; "Ns1.A"; "Ns1.B" ] + + // An open brings every type of Ns1 into scope, so it reads all their attributes - bounded by Ns1. + sorted log.CustomAttrs |> shouldEqual [ "G"; "Ns1.A"; "Ns1.B" ] + +[] +let ``Laziness - a deep type reads only the levels on its path`` () = + let source = """ +module Module + +let f (x: Ns1.Deep.D) = x +""" + let log = checkAgainstReference referenceShapes source + + // Ns1 is on the path so its own types come too; Ns2 is not. + sorted log.TypeDefs |> shouldEqual [ "G"; "Ns1.A"; "Ns1.B"; "Ns1.Deep.D" ] + +[] +let ``Laziness - a reference nothing names reads only its root level`` () = + let source = """ +module Module + +let x = 1 +""" + let log = checkAgainstReference referenceShapes source + + // The floor: the initial name resolution environment names each reference's root namespaces. + sorted log.TypeDefs |> shouldEqual [ "G" ] + +let private withBaseTypeShapes = + [ { shape "A" [ "Ns1" ] with Extends = Some "Ns2.Base" } + shape "Base" [ "Ns2" ] + shape "X" [ "Ns2" ] + shape "D" [ "Ns1"; "Deep" ] ] + +[] +let ``Laziness - the base type of an imported type is not read`` () = + let log = checkAgainstReference withBaseTypeShapes useNs1A + + // Importing Ns1.A only records its base type as an ILType; nothing here needs the hierarchy, so Ns2 + // stays unread - and with no global type, even the root level costs nothing. + sorted log.TypeDefs |> shouldEqual [ "Ns1.A" ] + +[] +let ``Laziness - a member lookup reads the base type's namespace`` () = + let source = """ +module Module + +let f (x: Ns1.A) = x.ToString() +""" + let log = checkAgainstReference withBaseTypeShapes source + + // A member lookup walks the hierarchy, so the base type is imported, realising its namespace level. + sorted log.TypeDefs |> shouldEqual [ "Ns1.A"; "Ns2.Base"; "Ns2.X" ] + sorted log.Members |> shouldEqual [ "Ns1.A"; "Ns2.Base" ] + + +// ---- Row indices let a flattened read module be put back into metadata order ------------------- + +/// The full names of a module's top-level types, in raw metadata TypeDef table order. +let private metadataTypeDefOrder (path: string) = + use fs = System.IO.File.OpenRead path + use pe = new System.Reflection.PortableExecutable.PEReader(fs) + let md = System.Reflection.Metadata.PEReaderExtensions.GetMetadataReader pe + + [ for handle in md.TypeDefinitions do + let td: System.Reflection.Metadata.TypeDefinition = md.GetTypeDefinition handle + // Nested types have their own rows; ILTypeDefs only holds top-level ones. + if td.GetDeclaringType().IsNil then + let ns = md.GetString td.Namespace + let name = md.GetString td.Name + yield (if ns = "" then name else ns + "." + name) ] + +[] +let ``Reading - sorting a flattened module by row index gives the metadata TypeDef order`` () = + // Flattening walks namespace by namespace, so it does not reproduce the TypeDef table order - a + // namespace can be split across it. Consumers needing the reader's order sort by MetadataIndex, as + // static linking does. FSharp.Core is the subject because F# routinely splits a namespace; Roslyn doesn't. + let path = typeof.Assembly.Location + let metadataOrder = metadataTypeDefOrder path + + let options = + { pdbDirPath = None + reduceMemoryUsage = ReduceMemoryFlag.Yes + metadataOnly = MetadataOnlyFlag.Yes + tryGetMetadataSnapshot = (fun _ -> None) } + + let moduleDef = (OpenILModuleReader path options).ILModuleDef + let typeDefs = moduleDef.TypeDefs.AsList() + + // ILTypeDef.Name for a top-level type read from metadata is the full "Namespace.Name". + // Every row is there, but the namespace walk hands them back in a different order. + let names = typeDefs |> List.map _.Name + List.sort names |> shouldEqual (List.sort metadataOrder) + Assert.True(names <> metadataOrder, "flattening happened to match row order, so the sort below proves nothing") + + // List.sortBy is stable, so row indices alone restore the order the rows were read in. + typeDefs |> List.sortBy (fun td -> td.MetadataIndex) |> List.map _.Name |> shouldEqual metadataOrder diff --git a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/FSharp.Compiler.Benchmarks.fsproj b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/FSharp.Compiler.Benchmarks.fsproj index d23efc28b99..5251526efa2 100644 --- a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/FSharp.Compiler.Benchmarks.fsproj +++ b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/FSharp.Compiler.Benchmarks.fsproj @@ -14,6 +14,7 @@ + diff --git a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/NamespaceImportBenchmarks.fs b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/NamespaceImportBenchmarks.fs new file mode 100644 index 00000000000..37660b40ed0 --- /dev/null +++ b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/NamespaceImportBenchmarks.fs @@ -0,0 +1,454 @@ +namespace FSharp.Compiler.Benchmarks + +open System +open System.IO +open FSharp.Compiler.CodeAnalysis +open FSharp.Compiler.Diagnostics +open FSharp.Compiler.Text +open FSharp.Compiler.AbstractIL.ILBinaryReader +open BenchmarkDotNet.Attributes +open FSharp.Benchmarks.Common.Categories + +// Importing an assembly should realise only the namespaces the code touches, so a project referencing +// large assemblies but opening a couple of namespaces should read and retain less. Only non-F# assemblies +// take this path: F# ones are unpickled from FSharpSignatureData. Narrow opens one namespace, Wide many - +// Wide is the control that should stay flat. +[] +module private NamespaceImportHelpers = + + let narrowSource = + """module Bench.Narrow +open System +let s: String = String.Empty +let sb = StringComparer.Ordinal""" + + let wideSource = + """module Bench.Wide +open System +open System.Collections +open System.Collections.Generic +open System.Diagnostics +open System.Globalization +open System.IO +open System.Reflection +open System.Runtime.InteropServices +open System.Text +open System.Threading +open System.Threading.Tasks +let s: String = String.Empty +let l = List() +let d = Dictionary() +let sb = StringBuilder() +let ci = CultureInfo.InvariantCulture +let ms = new MemoryStream()""" + + /// Script options: the full framework referenced, so there are many namespaces to (not) realise. + let getScriptOptions (checker: FSharpChecker) (fileName: string) (source: string) = + let options, diagnostics = + checker.GetProjectOptionsFromScript(fileName, SourceText.ofString source, assumeDotNetFramework = false, useSdkRefs = true) + |> Async.RunSynchronously + if diagnostics |> List.exists (fun (d: FSharpDiagnostic) -> d.Severity = FSharpDiagnosticSeverity.Error) then + failwithf "script options had errors: %A" diagnostics + options + + let check (checker: FSharpChecker) (fileName: string) (source: string) (options: FSharpProjectOptions) = + let _, answer = + checker.ParseAndCheckFileInProject(fileName, 0, SourceText.ofString source, options) + |> Async.RunSynchronously + match answer with + | FSharpCheckFileAnswer.Aborted -> failwith "check aborted" + | FSharpCheckFileAnswer.Succeeded results -> + let errors = results.Diagnostics |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error) + if errors.Length > 0 then failwithf "check had errors: %A" errors + answer + + /// Empty reader cache and a fresh checker, so the namespace trees are built from scratch. + let coldCheck (fileName: string) (source: string) (options: FSharpProjectOptions) = + ClearAllILModuleReaderCache() + let checker = FSharpChecker.Create(projectCacheSize = 200) + check checker fileName source options |> ignore + checker + + let consoleAppSource = + """module Program +open System +[] +let main argv = + Console.WriteLine("Hello, World!") + let sum = [ 1 .. 10 ] |> List.map (fun x -> x * x) |> List.sum + Console.WriteLine(sum) + 0""" + + let buildConsoleAppArgv (checker: FSharpChecker) (extraArgs: string list) = + let dir = Path.Combine(Path.GetTempPath(), "fcsConsoleAppBench") + Directory.CreateDirectory(dir) |> ignore + let sourceFile = Path.Combine(dir, "Program.fs") + File.WriteAllText(sourceFile, consoleAppSource) + let outFile = Path.Combine(dir, "Program.exe") + let options = getScriptOptions checker (Path.Combine(dir, "resolve.fsx")) "let x = 1" + let refs = options.OtherOptions |> Array.filter (fun o -> o.StartsWith "-r:") + [| yield "fsc.dll" + yield! refs + yield "--noframework" + yield "--target:exe" + yield "--optimize+" + yield "--out:" + outFile + yield! extraArgs + yield sourceFile |] + +/// Cold type-check: allocation here counts the namespace trees built for un-opened namespaces. +[] +[] +type NamespaceImportStartupBenchmarks() = + + let narrowFile = "narrow.fsx" + let wideFile = "wide.fsx" + let mutable narrowOptions = Unchecked.defaultof + let mutable wideOptions = Unchecked.defaultof + + [] + member _.Setup() = + // Resolving script references is unrelated to what we measure; do it once. + let checker = FSharpChecker.Create() + narrowOptions <- getScriptOptions checker narrowFile narrowSource + wideOptions <- getScriptOptions checker wideFile wideSource + + [] + member _.NarrowImport() = + coldCheck narrowFile narrowSource narrowOptions |> ignore + + [] + member _.WideImport() = + coldCheck wideFile wideSource wideOptions |> ignore + + [] + member _.Cleanup() = ClearAllILModuleReaderCache() + +/// End-to-end compile of a console app: the realistic workload driving reference reading. Each iteration +/// starts with a cleared reader cache. +[] +[] +type ConsoleAppCompileBenchmarks() = + + let mutable checker = Unchecked.defaultof + let mutable argv = Array.empty + + [] + member _.Setup() = + checker <- FSharpChecker.Create() + argv <- buildConsoleAppArgv checker [] + + [] + member _.CompileConsoleApp() = + let diagnostics, exnOpt = checker.Compile(argv) |> Async.RunSynchronously + match exnOpt with + | Some e -> raise e + | None -> + let errors = diagnostics |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error) + if errors.Length > 0 then failwithf "compile had errors: %A" errors + + [] + member _.Cleanup() = ClearAllILModuleReaderCache() + +/// Per-phase breakdown of the console-app compile via `--times`, to see the effect on the import phase. +/// +/// Not a BDN benchmark: run from Program.fs with the `times` argument. +module TimesProbe = + + let run () = + let checker = FSharpChecker.Create() + // Warm up JIT and reference resolution. + checker.Compile(buildConsoleAppArgv checker []) |> Async.RunSynchronously |> ignore + + for i in 1..3 do + ClearAllILModuleReaderCache() + printfn "===== compile %d (--times) =====" i + let argv = buildConsoleAppArgv checker [ "--times" ] + let _, exnOpt = checker.Compile(argv) |> Async.RunSynchronously + exnOpt |> Option.iter raise + +/// Cold compile of a real, large project from a captured fsc response file - the "many large references, +/// import a subset" workload. MemoryDiagnoser can't take a runtime file, so this is a standalone probe. +/// +/// Run from Program.fs: `compile-project ` - the project dir becomes the +/// working directory so the response file's relative paths resolve. +module CompileProjectProbe = + + let private forceGC () = + GC.Collect(2, GCCollectionMode.Forced, blocking = true) + GC.WaitForPendingFinalizers() + GC.Collect(2, GCCollectionMode.Forced, blocking = true) + + let run (responseFile: string) (projectDir: string) = + Environment.CurrentDirectory <- projectDir + let argv = + File.ReadAllLines responseFile + |> Array.filter (fun l -> l.Trim().Length > 0) + let checker = FSharpChecker.Create() + + let compile () = + let diagnostics, exnOpt = checker.Compile(argv) |> Async.RunSynchronously + exnOpt |> Option.iter raise + diagnostics |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error) |> Array.length + + printfn "Compiling %d args (%d refs); warming up..." + argv.Length (argv |> Array.filter (fun a -> a.StartsWith "-r:") |> Array.length) + let errs = compile () + printfn "warm-up done (%d errors)" errs + + for i in 1..3 do + ClearAllILModuleReaderCache() + forceGC () + let before = GC.GetTotalAllocatedBytes true + let sw = System.Diagnostics.Stopwatch.StartNew() + let errs = compile () + sw.Stop() + let allocated = GC.GetTotalAllocatedBytes true - before + printfn "run %d: %6.0f ms | allocated %8.1f MB | %d errors" + i sw.Elapsed.TotalMilliseconds (float allocated / 1024.0 / 1024.0) errs + + // What a long-lived process keeps alive. Isolated as the heap drop when the cache is cleared, so + // it excludes JIT / checker / GC noise. + let mb (b: int64) = float b / 1024.0 / 1024.0 + for i in 1..3 do + ClearAllILModuleReaderCache() + forceGC () + let baseHeap = GC.GetTotalMemory true + compile () |> ignore + forceGC () + let withCache = GC.GetTotalMemory true + ClearAllILModuleReaderCache() + forceGC () + let afterClear = GC.GetTotalMemory true + printfn "retain %d: reader-cache holds %7.1f MB | total post-compile %7.1f MB (base %6.1f, withCache %6.1f, afterClear %6.1f)" + i (mb (withCache - afterClear)) (mb (withCache - baseHeap)) (mb baseHeap) (mb withCache) (mb afterClear) + +/// Retained memory for a real project: keeps ParseAndCheckProject's results alive so the imported +/// structures stay on the heap, as an IDE holding a project's analysis does. +/// +/// Run from Program.fs: `retain-project `. +module RetainProjectProbe = + + let private forceGC () = + GC.Collect(2, GCCollectionMode.Forced, blocking = true) + GC.WaitForPendingFinalizers() + GC.Collect(2, GCCollectionMode.Forced, blocking = true) + + let run (responseFile: string) (projectDir: string) = + Environment.CurrentDirectory <- projectDir + let lines = + File.ReadAllLines responseFile + |> Array.filter (fun l -> l.Trim().Length > 0) + // Kept in response-file order: signature files must precede their implementations. + let sources = + lines + |> Array.filter (fun l -> (l.EndsWith ".fs" || l.EndsWith ".fsi") && not (l.StartsWith "-")) + let otherOptions = + lines |> Array.filter (fun l -> + l <> "fsc.dll" && not (l.StartsWith "-o:") && not (Array.contains l sources)) + + let options: FSharpProjectOptions = + { ProjectFileName = Path.Combine(projectDir, "FSharp.Common.fsproj") + ProjectId = None + SourceFiles = sources + OtherOptions = otherOptions + ReferencedProjects = [||] + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = false + LoadTime = System.DateTime(2020, 1, 1) + UnresolvedReferences = None + OriginalLoadReferences = [] + Stamp = None } + + let mb (b: int64) = float b / 1024.0 / 1024.0 + printfn "ParseAndCheckProject: %d sources, %d refs" + sources.Length (otherOptions |> Array.filter (fun o -> o.StartsWith "-r:") |> Array.length) + + // One measurement per process: FSharpChecker's static caches contaminate a second sample. + ClearAllILModuleReaderCache() + let checker = FSharpChecker.Create(projectCacheSize = 0) + forceGC () + let baseHeap = GC.GetTotalMemory true + let results = checker.ParseAndCheckProject(options) |> Async.RunSynchronously + let errs = results.Diagnostics |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error) |> Array.length + forceGC () + let held = GC.GetTotalMemory true + // Keep the imported structures alive across the measurement. + GC.KeepAlive results + GC.KeepAlive checker + printfn "analysis holds %7.1f MB (base %6.1f -> held %6.1f) | %d errors" + (mb (held - baseHeap)) (mb baseHeap) (mb held) errs + +/// Single-file check in a real project - the IDE hot path - holding the analysis alive so an external heap +/// dump can attribute retained memory per type. +/// +/// Run from Program.fs: `check-file `. Prints its PID and +/// sleeps, so `dotnet-gcdump collect -p ` can run. +module CheckFileProbe = + + let private forceGC () = + GC.Collect(2, GCCollectionMode.Forced, blocking = true) + GC.WaitForPendingFinalizers() + GC.Collect(2, GCCollectionMode.Forced, blocking = true) + + let run (responseFile: string) (projectDir: string) (fileToCheck: string) = + Environment.CurrentDirectory <- projectDir + let lines = File.ReadAllLines responseFile |> Array.filter (fun l -> l.Trim().Length > 0) + let sources = lines |> Array.filter (fun l -> l.EndsWith ".fs" && not (l.StartsWith "-")) + let otherOptions = + lines |> Array.filter (fun l -> + l <> "fsc.dll" && not (l.StartsWith "-o:") && not (Array.contains l sources)) + + let options: FSharpProjectOptions = + { ProjectFileName = Path.Combine(projectDir, "FSharp.Common.fsproj") + ProjectId = None + SourceFiles = sources + OtherOptions = otherOptions + ReferencedProjects = [||] + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = false + LoadTime = System.DateTime(2020, 1, 1) + OriginalLoadReferences = [] + UnresolvedReferences = None + Stamp = None } + + // Keeps the incremental builder, and so the imported assemblies, alive. + let checker = FSharpChecker.Create(projectCacheSize = 1) + ClearAllILModuleReaderCache() + let source = SourceText.ofString (File.ReadAllText fileToCheck) + let _, answer = checker.ParseAndCheckFileInProject(fileToCheck, 0, source, options) |> Async.RunSynchronously + let errs = + match answer with + | FSharpCheckFileAnswer.Aborted -> failwith "check aborted" + | FSharpCheckFileAnswer.Succeeded r -> + r.Diagnostics |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error) |> Array.length + + forceGC () + let held = GC.GetTotalMemory true + let pid = System.Diagnostics.Process.GetCurrentProcess().Id + printfn "checked %s (%d errors)" (Path.GetFileName fileToCheck) errs + printfn "PID %d retained %.1f MB" pid (float held / 1024.0 / 1024.0) + printfn "READY_FOR_DUMP" + Console.Out.Flush() + + // Hold everything rooted while the external dump is collected. + System.Threading.Thread.Sleep(180000) + GC.KeepAlive answer + GC.KeepAlive checker + +/// Retained memory after a cold check: MemoryDiagnoser measures allocation during an op, not what +/// survives, and what survives is the point. +/// +/// Not a BDN benchmark: run from Program.fs with the `retained-memory` argument. +module RetainedMemoryProbe = + + let private forceGC () = + GC.Collect(2, GCCollectionMode.Forced, blocking = true) + GC.WaitForPendingFinalizers() + GC.Collect(2, GCCollectionMode.Forced, blocking = true) + + let private measureOne label fileName source = + ClearAllILModuleReaderCache() + let setupChecker = FSharpChecker.Create() + let options = getScriptOptions setupChecker fileName source + + // Baseline before any assembly namespaces are read. + ClearAllILModuleReaderCache() + let checker = FSharpChecker.Create(projectCacheSize = 200) + forceGC () + let before = GC.GetTotalMemory(true) + let allocatedBefore = GC.GetTotalAllocatedBytes true + + let answer = check checker fileName source options + + let allocated = GC.GetTotalAllocatedBytes true - allocatedBefore + forceGC () + let after = GC.GetTotalMemory(true) + // Keep the check's output alive, else the delta is meaningless. + GC.KeepAlive answer + GC.KeepAlive checker + printfn "%-8s retained: %10.2f KB allocated: %10.2f KB (before %10.2f KB, after %10.2f KB)" + label (float (after - before) / 1024.0) (float allocated / 1024.0) (float before / 1024.0) (float after / 1024.0) + + /// Forces every type and namespace of every reference, isolating the reader's per-object cost from + /// anything the type-checker does with it. + let private measureReadAll () = + // Implementation assemblies, not reference ones: these hold real type bodies. + let refs = + Directory.GetFiles(System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory(), "*.dll") + + let readerOptions = + { pdbDirPath = None + reduceMemoryUsage = ReduceMemoryFlag.Yes + metadataOnly = MetadataOnlyFlag.Yes + tryGetMetadataSnapshot = fun _ -> None } + + ClearAllILModuleReaderCache() + forceGC () + let before = GC.GetTotalMemory true + let allocatedBefore = GC.GetTotalAllocatedBytes true + + let readers = ResizeArray() + let mutable typeCount = 0 + + let rec forceTypeDefs (tdefs: FSharp.Compiler.AbstractIL.IL.ILTypeDefs) = + for tdef in tdefs do + typeCount <- typeCount + 1 + forceTypeDefs tdef.NestedTypes + + for r in refs do + let reader = OpenILModuleReader r readerOptions + readers.Add reader + forceTypeDefs reader.ILModuleDef.TypeDefs + + let allocated = GC.GetTotalAllocatedBytes true - allocatedBefore + forceGC () + let after = GC.GetTotalMemory true + GC.KeepAlive readers + printfn "%-8s retained: %10.2f KB allocated: %10.2f KB (%d assemblies, %d type defs)" + "ReadAll" (float (after - before) / 1024.0) (float allocated / 1024.0) refs.Length typeCount + + /// Forces the import of every entity of every reference, isolating the IL-to-TAST cost. + let private measureImportAll () = + let fileName = "importall.fsx" + let setupChecker = FSharpChecker.Create() + let options = getScriptOptions setupChecker fileName narrowSource + + ClearAllILModuleReaderCache() + let checker = FSharpChecker.Create(projectCacheSize = 200) + forceGC () + let before = GC.GetTotalMemory true + let allocatedBefore = GC.GetTotalAllocatedBytes true + + let answer = check checker fileName narrowSource options + + let results = + match answer with + | FSharpCheckFileAnswer.Succeeded results -> results + | FSharpCheckFileAnswer.Aborted -> failwith "check aborted" + + let mutable entityCount = 0 + + let rec walk (entity: FSharp.Compiler.Symbols.FSharpEntity) = + entityCount <- entityCount + 1 + for nested in entity.NestedEntities do + walk nested + + for asm in results.ProjectContext.GetReferencedAssemblies() do + for entity in asm.Contents.Entities do + walk entity + + let allocated = GC.GetTotalAllocatedBytes true - allocatedBefore + forceGC () + let after = GC.GetTotalMemory true + GC.KeepAlive answer + GC.KeepAlive checker + printfn "%-8s retained: %10.2f KB allocated: %10.2f KB (%d entities)" + "ImportAll" (float (after - before) / 1024.0) (float allocated / 1024.0) entityCount + + let run () = + printfn "Retained-memory probe (lower is better; compare across branches):" + measureOne "Narrow" "narrow.fsx" narrowSource + measureOne "Wide" "wide.fsx" wideSource + measureReadAll () + measureImportAll () diff --git a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/Program.fs b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/Program.fs index c0883da14e9..d89d5da8f6d 100644 --- a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/Program.fs +++ b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/Program.fs @@ -4,6 +4,28 @@ open BenchmarkDotNet.Configs [] let main args = - let cfg = ManualConfig.Create(DefaultConfig.Instance).WithOptions(ConfigOptions.DisableOptimizationsValidator) - BenchmarkSwitcher.FromAssembly(typeof.Assembly).Run(args,cfg) |> ignore - 0 + match args with + // Standalone retained-memory probe (not a BDN benchmark); see RetainedMemoryProbe for why. + | [| "retained-memory" |] -> + RetainedMemoryProbe.run () + 0 + // Per-phase compile breakdown via the compiler's --times flag; see TimesProbe. + | [| "times" |] -> + TimesProbe.run () + 0 + // Compile a real project from a captured fsc response file; see CompileProjectProbe. + | [| "compile-project"; responseFile; projectDir |] -> + CompileProjectProbe.run responseFile projectDir + 0 + // Deterministic retained memory of a real project's analysis held live; see RetainProjectProbe. + | [| "retain-project"; responseFile; projectDir |] -> + RetainProjectProbe.run responseFile projectDir + 0 + // Single-file check then hold alive for an external heap dump; see CheckFileProbe. + | [| "check-file"; responseFile; projectDir; fileToCheck |] -> + CheckFileProbe.run responseFile projectDir fileToCheck + 0 + | _ -> + let cfg = ManualConfig.Create(DefaultConfig.Instance).WithOptions(ConfigOptions.DisableOptimizationsValidator) + BenchmarkSwitcher.FromAssembly(typeof.Assembly).Run(args,cfg) |> ignore + 0 diff --git a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/README.md b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/README.md index 1b574ec1b56..15e2d57422d 100644 --- a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/README.md +++ b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/README.md @@ -13,6 +13,26 @@ Running all benchmarks: Running a specific benchmark: ```dotnet run -c Release --filter *ParsingCheckExpressionsFs*``` +## Namespace-import benchmarks (lazy ILPreNamespace) + +`NamespaceImportBenchmarks.fs` measures the effect of lazy namespace reading in the IL reader: a project +that references large **non-F#** assemblies (the BCL) but opens only a few namespaces should read and +retain less. F# assemblies are unpickled and do not exercise this path. + +Startup time + transient allocation (BDN, `MemoryDiagnoser`): +```dotnet run -c Release --filter *NamespaceImportStartup*``` +`NarrowImport` opens one namespace (where laziness should pay off); `WideImport` opens many (control — +should stay flat). Compare the `Mean` and `Allocated` columns across `main` and this branch. + +Retained (live-heap) memory — MemoryDiagnoser only sees allocation *during* an op, not what survives, so +this is a separate standalone probe: +```dotnet run -c Release -- retained-memory``` +It prints retained KB for Narrow and Wide. The win is un-opened namespaces never being *retained*, so +compare `Narrow` retained across `main` and this branch (and Narrow-vs-Wide within a branch). + +To compare branches: build + run on `main`, note the numbers, `git checkout il-pre-namespace`, rebuild +and re-run, diff. (The `BenchmarkComparison/` project automates historical before/after runs if preferred.) + ## Sample results | Method | Job | UnrollFactor | Mean | Error | StdDev | Median | Gen 0 | Gen 1 | Gen 2 | Allocated | From 1e94cc5f61bf880b9ec0ecf5df2fe003983da8a0 Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Thu, 13 Aug 2026 14:38:31 +0100 Subject: [PATCH 26/55] feat(Async): Add exception-unwrapping Await (#19785) --- azure-pipelines-PR.yml | 15 +- .../.FSharp.Compiler.Service/11.0.100.md | 1 + docs/release-notes/.FSharp.Core/11.0.100.md | 1 + src/Compiler/Checking/ConstraintSolver.fs | 15 +- src/FSharp.Core/async.fs | 123 +++- src/FSharp.Core/async.fsi | 266 ++++++++- .../ByrefSafetyAnalysis.fs | 2 +- .../IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs | 63 +++ .../Tooltip/TooltipTests.Types.fs | 8 +- ...p.Core.SurfaceArea.netstandard20.debug.bsl | 4 + ...Core.SurfaceArea.netstandard20.release.bsl | 4 + ...p.Core.SurfaceArea.netstandard21.debug.bsl | 6 + ...Core.SurfaceArea.netstandard21.release.bsl | 6 + .../Microsoft.FSharp.Control/AsyncType.fs | 534 +++++++++++++++--- .../FSharp.Core/XmlDocumentationValidation.fs | 70 ++- 15 files changed, 948 insertions(+), 170 deletions(-) diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index ff6f4603975..6b831af89e6 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -757,35 +757,34 @@ stages: displayName: UMX_Slow_Repro expectLocalCore: true - repo: fsprojects/FSharpPlus - commit: f614035b75922aba41ed6a36c2fc986a2171d2b8 + commit: f42f81885111c652b08218e0880c264447ae56e4 buildScript: build.cmd displayName: FSharpPlus_Windows - repo: fsprojects/FSharpPlus - commit: f614035b75922aba41ed6a36c2fc986a2171d2b8 + commit: f42f81885111c652b08218e0880c264447ae56e4 buildScript: build.sh displayName: FSharpPlus_Linux useVmImage: $(LinuxMachineQueueName) usePool: $(DncEngPublicBuildPool) - repo: fsprojects/FSharpPlus - commit: 2648efe + commit: f42f81885111c652b08218e0880c264447ae56e4 buildScript: dotnet build tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj -c Release -bl displayName: FsharpPlus_NET10_Build_Lib_Tests expectLocalCore: true - # remove this before merging - repo: fsprojects/FSharpPlus - commit: 2648efe + commit: f42f81885111c652b08218e0880c264447ae56e4 buildScript: dotnet msbuild build.proj -t:Build;Test -bl displayName: FsharpPlus_NET10_Test_Debug - repo: fsprojects/FSharpPlus - commit: 2648efe + commit: f42f81885111c652b08218e0880c264447ae56e4 buildScript: dotnet msbuild build.proj -t:Build;Test -p:Configuration=Release -bl displayName: FsharpPlus_NET10_Test_Release - repo: fsprojects/FSharpPlus - commit: 2648efe + commit: f42f81885111c652b08218e0880c264447ae56e4 buildScript: dotnet msbuild build.proj -t:Build;AllDocs -bl displayName: FsharpPlus_NET10_Docs - repo: fsprojects/FSharpPlus - commit: 2648efe + commit: f42f81885111c652b08218e0880c264447ae56e4 buildScript: build.sh displayName: FsharpPlus_Net10_Linux useVmImage: $(LinuxMachineQueueName) diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index 38dd2d65b0a..abbf3304ee1 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -1,5 +1,6 @@ ### Fixed +* Fix recursive inline SRTP resolution being truncated by one currying level (e.g. FSharpPlus `memoizeN`), a regression from the function-domain unification order change in [PR #15181](https://github.com/dotnet/fsharp/pull/15181); the contravariant domain now keeps the inference variable that still carries the pending member constraint. ([PR #20247](https://github.com/dotnet/fsharp/pull/20247)) * Fix incorrect `StructLayout(Size = 1)` emission for data-less struct unions where the compiler-generated tag field makes the actual runtime size larger. ([PR #19759](https://github.com/dotnet/fsharp/pull/19759)) * Fix FS0750 "This construct may only be used within computation expressions" incorrectly raised for `let!`/`use!`/`do!` appearing in the right-hand side of a plain `let` binding inside a computation expression. The right-hand side is now desugared as a nested computation of the same builder whose result is bound with `let!`, keeping its bindings correctly scoped. ([Issue #19457](https://github.com/dotnet/fsharp/issues/19457), [PR #19868](https://github.com/dotnet/fsharp/pull/19868)) * Stop leaking a `System.Diagnostics.Metrics.MeterListener` per `Cache` in DEBUG builds. Each cache created a `CacheMetrics.CacheMetricsListener` (which starts a `MeterListener` registered in the process-global metrics registry) and never disposed it, so listeners accumulated for the lifetime of the process. Because every cache hit/miss/add published to all registered listeners, the per-operation cost grew linearly with the number of leaked listeners, so repeated checks (and Debug FCS test runs) slowed down over time. The per-cache `CacheMetricsListener` and the per-instance `cacheId` tag are removed; `DebugDisplay` and tests now read the existing name-aggregated stats populated by the single `ListenToAll` listener, so no per-cache listener is created and no per-operation cost is added. ([PR #19995](https://github.com/dotnet/fsharp/pull/19995)) diff --git a/docs/release-notes/.FSharp.Core/11.0.100.md b/docs/release-notes/.FSharp.Core/11.0.100.md index 6904710cc82..884146bc4e4 100644 --- a/docs/release-notes/.FSharp.Core/11.0.100.md +++ b/docs/release-notes/.FSharp.Core/11.0.100.md @@ -7,6 +7,7 @@ ### Added +* Add `Async.Await`, mirroring `Async.AwaitTask` semantics, but elides egregious `AggregateException` wrapping. Includes `ValueTask` support, and a SRTP-based overload accepting any Task-like value that supports the `GetAwaiter` protocol. ([Language Suggestion #840](https://github.com/fsharp/fslang-suggestions/issues/840), [PR #19785](https://github.com/dotnet/fsharp/pull/19785)) * `Async.RunSynchronouslyImmediate`: runs work on the calling thread until the first asynchronous suspension (as opposed to `RunSynchronously`, which immediately offloads if not on a background and/or threadpool thread). ([Issue #1042](https://github.com/fsharp/fslang-suggestions/issues/1042), [PR #19804](https://github.com/dotnet/fsharp/pull/19804)) * Added modules for `Async`, `Task` and `ValueTask` with consistent `result`, `map`, `bind`, `ignore`, `catchWith`, `catch`, and `empty` functions ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) * Added conversion functions `Task.ofValueTask` and `ValueTask.ofTask`. ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index f8ece244530..dc57f3e973c 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -1500,7 +1500,20 @@ and SolveFunTypeEqn csenv ndeep m2 trace cxsln domainTy1 domainTy2 rangeTy1 rang trackErrors { let g = csenv.g let domainTy2 = reqTyForArgumentNullnessInference g domainTy1 domainTy2 - do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln domainTy2 domainTy1 + // Keep an inference variable that still carries an unsolved SRTP constraint as the + // unification representative: if the required domain absorbs it, the pending recursive + // trait resolution is merged away and recursive SRTP specialization is truncated by one + // currying level. This restores the forward domain order that nullness PR #15181 reversed, + // but only for that case; skipped under MatchingOnly, where only the left type variable may + // be solved (see SolveTypeEqualsType). + let inline isUnsolvedTraitTypar ty = + match tryDestTyparTy g ty with + | ValueSome tp -> tp |> HasConstraint (function TyparConstraint.MayResolveMember(traitInfo, _) -> traitInfo.Solution.IsNone | _ -> false) + | _ -> false + if not csenv.MatchingOnly && isUnsolvedTraitTypar domainTy2 && not (isUnsolvedTraitTypar domainTy1) then + do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln domainTy1 domainTy2 + else + do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln domainTy2 domainTy1 return! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln rangeTy1 rangeTy2 } diff --git a/src/FSharp.Core/async.fs b/src/FSharp.Core/async.fs index 73c004b4260..e73dc4aa230 100644 --- a/src/FSharp.Core/async.fs +++ b/src/FSharp.Core/async.fs @@ -13,6 +13,7 @@ open System.Runtime.ExceptionServices open System.Threading open System.Threading.Tasks open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Control open Microsoft.FSharp.Collections @@ -1203,16 +1204,30 @@ module AsyncPrimitives = task + // Used by Async.Await path to elide egregious AggregateException wrapping + [] + let UnwrapExn (exn: AggregateException) = + if exn.InnerExceptions.Count = 1 then + exn.InnerExceptions[0] + else + exn + // Call the appropriate continuation on completion of a task [] - let OnTaskCompleted (completedTask: Task<'T>) (ctxt: AsyncActivation<'T>) = + let OnTaskCompleted unwrap (completedTask: Task<'T>) (ctxt: AsyncActivation<'T>) = assert completedTask.IsCompleted if completedTask.IsCanceled then let edi = ExceptionDispatchInfo.Capture(TaskCanceledException completedTask) ctxt.econt edi elif completedTask.IsFaulted then - let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception + let e = + if unwrap then + UnwrapExn completedTask.Exception + else + completedTask.Exception + + let edi = ExceptionDispatchInfo.RestoreOrCapture e ctxt.econt edi else ctxt.cont completedTask.Result @@ -1222,14 +1237,20 @@ module AsyncPrimitives = // the overall async (they may be governed by different cancellation tokens, or // the task may not have a cancellation token at all). [] - let OnUnitTaskCompleted (completedTask: Task) (ctxt: AsyncActivation) = + let OnUnitTaskCompleted unwrap (completedTask: Task) (ctxt: AsyncActivation) = assert completedTask.IsCompleted if completedTask.IsCanceled then let edi = ExceptionDispatchInfo.Capture(TaskCanceledException(completedTask)) ctxt.econt edi elif completedTask.IsFaulted then - let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception + let e = + if unwrap then + UnwrapExn completedTask.Exception + else + completedTask.Exception + + let edi = ExceptionDispatchInfo.RestoreOrCapture e ctxt.econt edi else ctxt.cont () @@ -1239,10 +1260,10 @@ module AsyncPrimitives = // completing the task. This will install a new trampoline on that thread and continue the // execution of the async there. [] - let AttachContinuationToTask (task: Task<'T>) (ctxt: AsyncActivation<'T>) = + let AttachContinuationToTask unwrap (task: Task<'T>) (ctxt: AsyncActivation<'T>) = task.ContinueWith( Action>(fun completedTask -> - ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> OnTaskCompleted completedTask ctxt) + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> OnTaskCompleted unwrap completedTask ctxt) |> unfake), TaskContinuationOptions.ExecuteSynchronously ) @@ -1254,16 +1275,36 @@ module AsyncPrimitives = // completing the task. This will install a new trampoline on that thread and continue the // execution of the async there. [] - let AttachContinuationToUnitTask (task: Task) (ctxt: AsyncActivation) = + let AttachContinuationToUnitTask unwrap (task: Task) (ctxt: AsyncActivation) = task.ContinueWith( Action(fun completedTask -> - ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> OnUnitTaskCompleted completedTask ctxt) + ctxt.trampolineHolder.ExecuteWithTrampoline(fun () -> OnUnitTaskCompleted unwrap completedTask ctxt) |> unfake), TaskContinuationOptions.ExecuteSynchronously ) |> ignore |> fake + let AwaitTask unwrap (task: Task<'T>) = + MakeAsyncWithCancelCheck(fun ctxt -> + if task.IsCompleted then + // Run synchronously without installing new trampoline + OnTaskCompleted unwrap task ctxt + else + // Continue asynchronously, via syncContext if necessary, installing new trampoline + let ctxt = DelimitSyncContext ctxt + ctxt.ProtectCode(fun () -> AttachContinuationToTask unwrap task ctxt)) + + let AwaitUnitTask unwrap (task: Task) = + MakeAsyncWithCancelCheck(fun ctxt -> + if task.IsCompleted then + // Continue synchronously without installing new trampoline + OnUnitTaskCompleted unwrap task ctxt + else + // Continue asynchronously, via syncContext if necessary, installing new trampoline + let ctxt = DelimitSyncContext ctxt + ctxt.ProtectCode(fun () -> AttachContinuationToUnitTask unwrap task ctxt)) + /// Removes a registration places on a cancellation token let DisposeCancellationRegistration (registration: byref) = match registration with @@ -2202,24 +2243,58 @@ type Async = CreateWhenCancelledAsync compensation computation static member AwaitTask(task: Task<'T>) : Async<'T> = - MakeAsyncWithCancelCheck(fun ctxt -> - if task.IsCompleted then - // Run synchronously without installing new trampoline - OnTaskCompleted task ctxt - else - // Continue asynchronously, via syncContext if necessary, installing new trampoline - let ctxt = DelimitSyncContext ctxt - ctxt.ProtectCode(fun () -> AttachContinuationToTask task ctxt)) + AwaitTask false task static member AwaitTask(task: Task) : Async = - MakeAsyncWithCancelCheck(fun ctxt -> - if task.IsCompleted then - // Continue synchronously without installing new trampoline - OnUnitTaskCompleted task ctxt - else - // Continue asynchronously, via syncContext if necessary, installing new trampoline - let ctxt = DelimitSyncContext ctxt - ctxt.ProtectCode(fun () -> AttachContinuationToUnitTask task ctxt)) + AwaitUnitTask false task + + static member Await(task: Task<'T>) : Async<'T> = + AwaitTask true task + + static member Await(task: Task) : Async = + AwaitUnitTask true task + +#if NETSTANDARD2_1 + static member Await(task: ValueTask<'T>) : Async<'T> = + if task.IsCompletedSuccessfully then + CreateReturnAsync(task.GetAwaiter().GetResult()) + else + AwaitTask true (task.AsTask()) + + static member Await(task: ValueTask) : Async = + if task.IsCompletedSuccessfully then + CreateReturnAsync(task.GetAwaiter().GetResult()) + else + AwaitUnitTask true (task.AsTask()) +#endif + +module AsyncTaskLikeExtensions = + + type Async with + + [] + static member inline Await< ^TaskLike, ^Awaiter, 'T + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'T)> + (task: ^TaskLike) + : Async<'T> = + Async.FromContinuations(fun (cont, econt, _ccont) -> + let mutable awaiter = (^TaskLike: (member GetAwaiter: unit -> ^Awaiter) task) + + if (^Awaiter: (member get_IsCompleted: unit -> bool) awaiter) then + try + cont ((^Awaiter: (member GetResult: unit -> 'T) awaiter)) + with e -> + econt e + else + (awaiter :> ICriticalNotifyCompletion) + .OnCompleted(fun () -> + try + cont ((^Awaiter: (member GetResult: unit -> 'T) awaiter)) + with e -> + econt e)) module CommonExtensions = diff --git a/src/FSharp.Core/async.fsi b/src/FSharp.Core/async.fsi index 1af0fab84db..2171f75164a 100644 --- a/src/FSharp.Core/async.fsi +++ b/src/FSharp.Core/async.fsi @@ -5,9 +5,11 @@ namespace Microsoft.FSharp.Control open System open System.Threading open System.Threading.Tasks + open System.Runtime.CompilerServices open System.Runtime.ExceptionServices open Microsoft.FSharp.Core + open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Control open Microsoft.FSharp.Collections @@ -776,47 +778,210 @@ namespace Microsoft.FSharp.Control /// static member AwaitIAsyncResult: iar: IAsyncResult * ?millisecondsTimeout:int -> Async - /// Return an asynchronous computation that will wait for the given task to complete and return - /// its result. - /// + /// Creates an asynchronous computation that will wait asynchronously for the given task to complete, returning + /// its result. Note exceptions are wrapped in ; for new + /// code, prefer Async.Await, which surfaces single exceptions directly. /// The task to await. - /// - /// If an exception occurs in the asynchronous computation then an exception is re-raised by this - /// function. - /// - /// If the task is cancelled then is raised. Note + /// If the task is canceled then is raised. Note /// that the task may be governed by a different cancellation token to the overall async computation /// where the AwaitTask occurs. In practice you should normally start the task with the /// cancellation token returned by let! ct = Async.CancellationToken, and catch - /// any at the point where the + /// any at the point where the /// overall async is started. /// - /// /// Awaiting Results - /// - /// + /// + /// + /// let t = Task.Run(fun () -> invalidOp "test"; 42) + /// async { + /// try + /// let! _ = Async.AwaitTask t + /// () + /// with + /// | :? System.InvalidOperationException -> + /// printfn "unreachable" // will not match: exception is wrapped in AggregateException + /// | :? System.AggregateException as e -> + /// printfn $"Caught: {e.InnerException.Message}" + /// } |> Async.RunSynchronously + /// + /// Prints Caught: test. The InvalidOperationException branch is not reached because + /// exceptions from tasks are always wrapped in . Contrast with Async.Await. + /// static member AwaitTask: task: Task<'T> -> Async<'T> - /// Return an asynchronous computation that will wait for the given task to complete and return - /// its result. - /// + /// Creates an asynchronous computation that will wait asynchronously for the given task to complete. + /// Note exceptions are wrapped in ; for new + /// code, prefer Async.Await, which surfaces single exceptions directly. /// The task to await. - /// - /// If an exception occurs in the asynchronous computation then an exception is re-raised by this - /// function. - /// - /// If the task is cancelled then is raised. Note + /// If the task is canceled then is raised. Note /// that the task may be governed by a different cancellation token to the overall async computation /// where the AwaitTask occurs. In practice you should normally start the task with the /// cancellation token returned by let! ct = Async.CancellationToken, and catch - /// any at the point where the + /// any at the point where the /// overall async is started. /// + /// Awaiting Results + /// + /// + /// let t = Task.Run(fun () -> invalidOp "test") + /// async { + /// try + /// do! Async.AwaitTask t + /// with + /// | :? System.InvalidOperationException -> + /// printfn "unreachable" // will not match: exception is wrapped in AggregateException + /// | :? System.AggregateException as e -> + /// printfn $"Caught: {e.InnerException.Message}" + /// } |> Async.RunSynchronously + /// + /// Prints Caught: test. The InvalidOperationException branch is not reached because + /// exceptions from tasks are always wrapped in . Contrast with Async.Await. + /// + static member AwaitTask: task: Task -> Async + + /// Creates an asynchronous computation that will wait for the given task to complete and return + /// its result. + /// + /// The task to await. + /// + /// + ///

Exceptions are surfaced directly: a task faulted with a single exception raises that + /// exception; only s carrying multiple inner exceptions are + /// re-raised as-is. For the legacy behavior of uniformly presenting the raw underlying + /// , use Async.AwaitTask.

+ /// + ///

If the task is canceled then is raised.

+ /// + ///

Note the task may be governed by a different cancellation token than the overall async computation; + /// typically tasks should be wired to the ambient cancellation token obtained via + /// let! ct = Async.CancellationToken, catching + /// where the overall async is started.

+ /// /// /// Awaiting Results /// - /// - static member AwaitTask: task: Task -> Async + /// + /// + /// let t = Task.Run(fun () -> invalidOp "test"; 42) + /// async { + /// try + /// let! _ = Async.Await t + /// () + /// with + /// | :? System.InvalidOperationException as e -> + /// printfn $"Caught: {e.Message}" + /// | :? System.AggregateException -> + /// printfn "unreachable" // will not match: single exception is unwrapped + /// } |> Async.RunSynchronously + /// + /// Prints Caught: test. The AggregateException branch is not reached because a + /// single-inner exception is unwrapped. Contrast with Async.AwaitTask. + /// + static member Await: task: Task<'T> -> Async<'T> + + /// Creates an asynchronous computation that will wait for the given task to complete. + /// The task to await. + /// + ///

Exceptions are surfaced directly: a task faulted with a single exception raises that + /// exception; only s carrying multiple inner exceptions are + /// re-raised as-is. For the legacy behavior of uniformly presenting the raw underlying + /// , use Async.AwaitTask.

+ /// + ///

If the task is canceled then is raised.

+ /// + ///

Note the task may be governed by a different cancellation token than the overall async computation; + /// typically tasks should be wired to the ambient cancellation token obtained via + /// let! ct = Async.CancellationToken, catching + /// where the overall async is started.

+ /// + /// Awaiting Results + /// + /// + /// let t = Task.Run(fun () -> invalidOp "test") + /// async { + /// try + /// do! Async.Await t + /// with + /// | :? System.InvalidOperationException as e -> + /// printfn $"Caught: {e.Message}" + /// | :? System.AggregateException -> + /// printfn "unreachable" // will not match: single exception is unwrapped + /// } |> Async.RunSynchronously + /// + /// Prints Caught: test. The AggregateException branch is not reached because a + /// single-inner exception is unwrapped. Contrast with Async.AwaitTask. + /// + static member Await: task: Task -> Async + +#if NETSTANDARD2_1 + /// Creates an asynchronous computation that will wait for the given ValueTask to complete and return + /// its result. + /// The ValueTask to await. + /// + ///

Exceptions are surfaced directly: a task faulted with a single exception raises that + /// exception; only s carrying multiple inner exceptions are + /// re-raised as-is. For the legacy behavior of uniformly presenting the raw underlying + /// , use Async.AwaitTask.

+ /// + ///

If the task is canceled then is raised.

+ /// + ///

Note the task may be governed by a different cancellation token than the overall async computation; + /// typically tasks should be wired to the ambient cancellation token obtained via + /// let! ct = Async.CancellationToken, catching + /// where the overall async is started.

+ /// + /// Awaiting Results + /// + /// + /// let vt = ValueTask<int>(Task.Run(fun () -> invalidOp "test"; 42)) + /// async { + /// try + /// let! _ = Async.Await vt + /// () + /// with + /// | :? System.InvalidOperationException as e -> + /// printfn $"Caught: {e.Message}" + /// | :? System.AggregateException -> + /// printfn "unreachable" // will not match: single exception is unwrapped + /// } |> Async.RunSynchronously + /// + /// Prints Caught: test. + /// + static member Await: task: ValueTask<'T> -> Async<'T> + + /// Creates an asynchronous computation that will wait for the given ValueTask to complete. + /// The ValueTask to await. + /// + ///

Exceptions are surfaced directly: a task faulted with a single exception raises that + /// exception; only s carrying multiple inner exceptions are + /// re-raised as-is. For the legacy behavior of uniformly presenting the raw underlying + /// , use Async.AwaitTask.

+ /// + ///

If the task is canceled then is raised.

+ /// + ///

Note the task may be governed by a different cancellation token than the overall async computation; + /// typically tasks should be wired to the ambient cancellation token obtained via + /// let! ct = Async.CancellationToken, catching + /// where the overall async is started.

+ /// + /// Awaiting Results + /// + /// + /// let vt = ValueTask(Task.Run(fun () -> invalidOp "test")) + /// async { + /// try + /// do! Async.Await vt + /// with + /// | :? System.InvalidOperationException as e -> + /// printfn $"Caught: {e.Message}" + /// | :? System.AggregateException -> + /// printfn "unreachable" // will not match: single exception is unwrapped + /// } |> Async.RunSynchronously + /// + /// Prints Caught: test. + /// + static member Await: task: ValueTask -> Async +#endif /// /// Creates an asynchronous computation that will sleep for the given time. This is scheduled @@ -1110,6 +1275,61 @@ namespace Microsoft.FSharp.Control computation:Async<'T> * ?cancellationToken:CancellationToken-> Task<'T> + /// A module of extension members providing support for awaiting any task-like value via the GetAwaiter pattern. + /// + /// Awaiting Results + [] + module AsyncTaskLikeExtensions = + + type Async with + + /// Creates an asynchronous computation that will wait for the given task-like value to complete and return + /// its result. + /// The task-like value to await. + ///

The value must satisfy the GetAwaiter pattern: it must have a GetAwaiter() method + /// returning an awaiter implementing + /// with IsCompleted and GetResult() members.

+ ///

Exceptions thrown by GetResult() are propagated directly.

+ ///

Unlike the +#if NETSTANDARD2_1 + /// and +#endif + /// overloads, an carrying multiple inner exceptions is not preserved: + /// the first inner exception surfaces (standard GetResult() semantics).

+ ///

This overload uses statically resolved type parameters (SRTP) so it can accept any task-like type. +#if NETSTANDARD2_1 + /// The specific overloads for , , + /// and +#else + /// The specific overloads for and +#endif + /// are preferred when the argument type is known.

+ /// + /// Awaiting Results + /// + /// + /// // A minimal custom task-like type + /// type MyTask<'T>(task: System.Threading.Tasks.Task<'T>) = + /// member _.GetAwaiter() = task.GetAwaiter() + /// + /// let myTask = MyTask(System.Threading.Tasks.Task.FromResult 42) + /// async { + /// let! result = Async.Await myTask + /// printfn $"Result: {result}" + /// } |> Async.RunSynchronously + /// + /// Prints Result: 42. + /// + // NOTE Aside from being a catch-all to cover the GetAwaiter pattern, + // On netstandard2.0, this overload also covers ValueTask and ValueTask<'T>. + [] + static member inline Await< ^TaskLike, ^Awaiter, 'T> : + task: ^TaskLike -> Async<'T> + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'T) + /// The F# compiler emits references to this type to implement F# async expressions. /// /// Async Internals diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/InferenceProcedures/ByrefSafetyAnalysis/ByrefSafetyAnalysis.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/InferenceProcedures/ByrefSafetyAnalysis/ByrefSafetyAnalysis.fs index 40d511a028b..32f18bfb19f 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/InferenceProcedures/ByrefSafetyAnalysis/ByrefSafetyAnalysis.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/InferenceProcedures/ByrefSafetyAnalysis/ByrefSafetyAnalysis.fs @@ -1000,7 +1000,7 @@ type outref<'T> with |> shouldSucceed #endif -#if NETSTANDARD2_1_OR_GREATER +#if NETCOREAPP [] let``E_TopLevelByref_fs`` compilation = compilation diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/Types/TypeConstraints/IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/Types/TypeConstraints/IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs index fb6c648ca49..3de8d80d947 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/Types/TypeConstraints/IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/Types/TypeConstraints/IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs @@ -1970,6 +1970,69 @@ let resultInt: int = call 42 if resultFloat <> 0.0 then failwith $"Expected 0.0 but got {resultFloat}" if resultDecimal <> 0M then failwith $"Expected 0M but got {resultDecimal}" if resultInt <> 0 then failwith $"Expected 0 but got {resultInt}" +""" + |> asExe + |> compileAndRun + |> shouldSucceed + + // Recursive inline SRTP resolution must not be truncated by one currying level (regression from + // the domain-order reversal in nullness PR #15181). + [] + let ``Recursive inline SRTP memoization specializes at every currying depth`` () = + FSharp """ +module Test +open System.Collections.Concurrent + +type Default1 = class end + +[] +type MemoizationKeyWrapper<'a> = MemoizationKeyWrapper of 'a + +type MemoizeN = + inherit Default1 + static member getOrAdd (cd: ConcurrentDictionary,'b>) (f: 'a -> 'b) k = + cd.GetOrAdd (MemoizationKeyWrapper k, (fun (MemoizationKeyWrapper x) -> x) >> f) + +let inline memoizeN (f: ^F) : ^F = + let inline call_2 (a: ^MemoizeN, b: ^b) = ((^MemoizeN or ^b) : (static member MemoizeN : ^MemoizeN * 'b -> _ ) (a, b)) + call_2 (Unchecked.defaultof, Unchecked.defaultof< ^F >) f + +type MemoizeN with + static member MemoizeN (_: Default1, _: 'a -> 'b) = MemoizeN.getOrAdd (ConcurrentDictionary ()) + static member inline MemoizeN (_: MemoizeN, _:'t -> 'a -> 'b) = MemoizeN.getOrAdd (ConcurrentDictionary ()) << (<<) memoizeN + +let effs = ResizeArray () +let sum3 a (b:int) c = effs.Add "sum3"; a + b + c +let msum3 = memoizeN sum3 +msum3 1 2 3 |> ignore +msum3 1 2 3 |> ignore +if effs.Count <> 1 then failwith $"depth-3 memoization ran the function {effs.Count} times, expected 1" + +let effs2 = ResizeArray () +let sum2 (a:int) (b:int) = effs2.Add "sum2"; a + b +let msum2 = memoizeN sum2 +msum2 1 1 |> ignore +msum2 1 1 |> ignore +if effs2.Count <> 1 then failwith $"depth-2 memoization ran the function {effs2.Count} times, expected 1" +""" + |> asExe + |> compileAndRun + |> shouldSucceed + + // Guards the `not csenv.MatchingOnly` gate of the SolveFunTypeEqn SRTP fix (mirrors the same + // guard in SolveTypeEqualsType): an SRTP-constrained argument must not disturb overload + // candidate selection, else the lambda's type is left uninferred (FS0072). + [] + let ``SRTP argument does not disturb overload resolution during MatchingOnly`` () = + FSharp """ +module Test +let inline dbl x = x + x +type K = + static member M(g: int -> int, f: string -> int) = f "a" + static member M(g: System.DateTime -> System.DateTime, f: System.DateTime -> int) = 0 + +let r = K.M(dbl, fun v -> v.Length) +if r <> 1 then failwith $"Expected 1 but got {r}" """ |> asExe |> compileAndRun diff --git a/tests/FSharp.Compiler.Service.Tests/Tooltip/TooltipTests.Types.fs b/tests/FSharp.Compiler.Service.Tests/Tooltip/TooltipTests.Types.fs index e875a276073..1a669b7980b 100644 --- a/tests/FSharp.Compiler.Service.Tests/Tooltip/TooltipTests.Types.fs +++ b/tests/FSharp.Compiler.Service.Tests/Tooltip/TooltipTests.Types.fs @@ -45,8 +45,12 @@ y.M() [] let ``QuickInfoForTypesWithHiddenRepresentation`` () = let signatureListing = - "type Async =\n static member AsBeginEnd: computation: ('Arg -> Async<'T>) -> ('Arg * AsyncCallback * objnull -> IAsyncResult) * (IAsyncResult -> 'T) * (IAsyncResult -> unit)\n static member AwaitEvent: event: IEvent<'Del,'T> * ?cancelAction: (unit -> unit) -> Async<'T> (requires delegate and 'Del :> Delegate and 'Del: not null)\n static member AwaitIAsyncResult: iar: IAsyncResult * ?millisecondsTimeout: int -> Async\n static member AwaitTask: task: Task<'T> -> Async<'T> + 1 overload\n static member AwaitWaitHandle: waitHandle: WaitHandle * ?millisecondsTimeout: int -> Async\n static member CancelDefaultToken: unit -> unit\n static member Catch: computation: Async<'T> -> Async>\n static member Choice: computations: Async<'T option> seq -> Async<'T option>\n static member FromBeginEnd: beginAction: (AsyncCallback * objnull -> IAsyncResult) * endAction: (IAsyncResult -> 'T) * ?cancelAction: (unit -> unit) -> Async<'T> + 3 overloads\n static member FromContinuations: callback: (('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) -> Async<'T>\n ..." - + "type Async =\n static member AsBeginEnd: computation: ('Arg -> Async<'T>) -> ('Arg * AsyncCallback * objnull -> IAsyncResult) * (IAsyncResult -> 'T) * (IAsyncResult -> unit)\n static member Await: task: Task<'T> -> Async<'T> + 3 overloads\n static member AwaitEvent: event: IEvent<'Del,'T> * ?cancelAction: (unit -> unit) -> Async<'T> (requires delegate and 'Del :> Delegate and 'Del: not null)\n static member AwaitIAsyncResult: iar: IAsyncResult * ?millisecondsTimeout: int -> Async\n static member AwaitTask: task: Task<'T> -> Async<'T> + 1 overload\n static member AwaitWaitHandle: waitHandle: WaitHandle * ?millisecondsTimeout: int -> Async\n static member CancelDefaultToken: unit -> unit\n static member Catch: computation: Async<'T> -> Async>\n static member Choice: computations: Async<'T option> seq -> Async<'T option>\n static member FromBeginEnd: beginAction: (AsyncCallback * objnull -> IAsyncResult) * endAction: (IAsyncResult -> 'T) * ?cancelAction: (unit -> unit) -> Async<'T> + 3 overloads\n ..." +#if !NETCOREAPP + // on netstandard2.0, Await doesn't have ValueTask overloads + |> _.Replace("static member Await: task: Task<'T> -> Async<'T> + 3 overloads", + "static member Await: task: Task<'T> -> Async<'T> + 1 overload") +#endif assertTooltipContainsInOrder [ signatureListing; "Full name: Microsoft.FSharp.Control.Async" ] (markAtEndOfMarker "let x = Async.AsBeginEnd\n1" "Asyn") diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl index 175102ee368..1f6241a57e3 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl @@ -631,6 +631,8 @@ Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn I Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn TryFinally[T](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn TryWith[T](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.FSharpAsync`1[T] MakeAsync[T](Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Control.AsyncActivation`1[T],Microsoft.FSharp.Control.AsyncReturn]) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], TTaskLike) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static[TTaskLike,TAwaiter,T](TTaskLike) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.CommonExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncWrite(System.IO.Stream, Byte[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) @@ -650,6 +652,7 @@ Microsoft.FSharp.Control.EventModule: Void Add[T,TDel](Microsoft.FSharp.Core.FSh Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Control.FSharpAsync`1[T]] StartChild[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpChoice`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpOption`1[T]] Choice[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpOption`1[T]]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Await(System.Threading.Tasks.Task) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AwaitTask(System.Threading.Tasks.Task) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(Int32) @@ -667,6 +670,7 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[] Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[]] Parallel[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[]] Sequential[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] AwaitEvent[TDel,T](Microsoft.FSharp.Control.IEvent`2[TDel,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Await[T](System.Threading.Tasks.Task`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] AwaitTask[T](System.Threading.Tasks.Task`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,TArg3,T](TArg1, TArg2, TArg3, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`5[TArg1,TArg2,TArg3,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,T](TArg1, TArg2, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`4[TArg1,TArg2,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl index cdf68c2d1ef..0b025a942de 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl @@ -631,6 +631,8 @@ Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn I Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn TryFinally[T](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn TryWith[T](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.FSharpAsync`1[T] MakeAsync[T](Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Control.AsyncActivation`1[T],Microsoft.FSharp.Control.AsyncReturn]) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], TTaskLike) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static[TTaskLike,TAwaiter,T](TTaskLike) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.CommonExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncWrite(System.IO.Stream, Byte[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) @@ -650,6 +652,7 @@ Microsoft.FSharp.Control.EventModule: Void Add[T,TDel](Microsoft.FSharp.Core.FSh Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Control.FSharpAsync`1[T]] StartChild[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpChoice`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpOption`1[T]] Choice[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpOption`1[T]]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Await(System.Threading.Tasks.Task) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AwaitTask(System.Threading.Tasks.Task) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(Int32) @@ -667,6 +670,7 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[] Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[]] Parallel[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[]] Sequential[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] AwaitEvent[TDel,T](Microsoft.FSharp.Control.IEvent`2[TDel,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Await[T](System.Threading.Tasks.Task`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] AwaitTask[T](System.Threading.Tasks.Task`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,TArg3,T](TArg1, TArg2, TArg3, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`5[TArg1,TArg2,TArg3,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,T](TArg1, TArg2, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`4[TArg1,TArg2,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl index cac5fe9d0ef..9496d1dfe2b 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl @@ -633,6 +633,8 @@ Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn I Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn TryFinally[T](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn TryWith[T](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.FSharpAsync`1[T] MakeAsync[T](Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Control.AsyncActivation`1[T],Microsoft.FSharp.Control.AsyncReturn]) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], TTaskLike) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static[TTaskLike,TAwaiter,T](TTaskLike) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.CommonExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncWrite(System.IO.Stream, Byte[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) @@ -652,6 +654,8 @@ Microsoft.FSharp.Control.EventModule: Void Add[T,TDel](Microsoft.FSharp.Core.FSh Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Control.FSharpAsync`1[T]] StartChild[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpChoice`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpOption`1[T]] Choice[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpOption`1[T]]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Await(System.Threading.Tasks.Task) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Await(System.Threading.Tasks.ValueTask) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AwaitTask(System.Threading.Tasks.Task) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(Int32) @@ -669,6 +673,8 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[] Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[]] Parallel[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[]] Sequential[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] AwaitEvent[TDel,T](Microsoft.FSharp.Control.IEvent`2[TDel,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Await[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Await[T](System.Threading.Tasks.ValueTask`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] AwaitTask[T](System.Threading.Tasks.Task`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,TArg3,T](TArg1, TArg2, TArg3, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`5[TArg1,TArg2,TArg3,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,T](TArg1, TArg2, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`4[TArg1,TArg2,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl index 537095d9e10..b1a377ea33b 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl @@ -633,6 +633,8 @@ Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn I Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn TryFinally[T](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn TryWith[T](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]]) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.FSharpAsync`1[T] MakeAsync[T](Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Control.AsyncActivation`1[T],Microsoft.FSharp.Control.AsyncReturn]) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], TTaskLike) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static[TTaskLike,TAwaiter,T](TTaskLike) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.CommonExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncWrite(System.IO.Stream, Byte[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) @@ -652,6 +654,8 @@ Microsoft.FSharp.Control.EventModule: Void Add[T,TDel](Microsoft.FSharp.Core.FSh Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Control.FSharpAsync`1[T]] StartChild[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpChoice`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpOption`1[T]] Choice[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpOption`1[T]]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Await(System.Threading.Tasks.Task) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Await(System.Threading.Tasks.ValueTask) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AwaitTask(System.Threading.Tasks.Task) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(Int32) @@ -669,6 +673,8 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[] Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[]] Parallel[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T[]] Sequential[T](System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] AwaitEvent[TDel,T](Microsoft.FSharp.Control.IEvent`2[TDel,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Await[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Await[T](System.Threading.Tasks.ValueTask`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] AwaitTask[T](System.Threading.Tasks.Task`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,TArg3,T](TArg1, TArg2, TArg3, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`5[TArg1,TArg2,TArg3,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,T](TArg1, TArg2, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`4[TArg1,TArg2,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs index 571a4250175..2ce61e65968 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs @@ -220,14 +220,14 @@ type AsyncType() = | _ -> reraise() Assert.True (tcs.Task.IsCompleted, "Task is not completed") - [] - member _.RunSynchronouslyCancellationWithDelayedResult () = + [] + member _.RunSynchronouslyCancellationWithDelayedResult(newAwait: bool) = let cts = new CancellationTokenSource() let tcs = TaskCompletionSource() let _ = cts.Token.Register(fun () -> tcs.SetResult 42) let a = async { - cts.CancelAfter (100) - let! result = tcs.Task |> Async.AwaitTask + cts.CancelAfter(100) + let! result = tcs.Task |> if newAwait then Async.Await else Async.AwaitTask return result } let cancelled = @@ -367,127 +367,127 @@ type AsyncType() = Assert.True(t.IsCanceled) Assert.True(cancelled) - [] - member _.TaskAsyncValue () = + [] + member _.TaskAsyncValue(newAwait: bool) = let s = "Test" use t = Task.Factory.StartNew(Func<_>(fun () -> s)) let a = async { - let! s1 = Async.AwaitTask(t) - return s = s1 - } - Async.RunSynchronously(a) |> Assert.True + let! s1 = t |> if newAwait then Async.Await else Async.AwaitTask + return s = s1 + } + let ok = Async.RunSynchronously a + Assert.True ok - [] - member _.AwaitTaskCancellation () = - let test() = async { - let tcs = new System.Threading.Tasks.TaskCompletionSource() + [] + member _.AwaitTaskCancellation(newAwait: bool) = + let a = async { + let tcs = System.Threading.Tasks.TaskCompletionSource() tcs.SetCanceled() try - do! Async.AwaitTask tcs.Task + do! tcs.Task |> if newAwait then Async.Await else Async.AwaitTask return false - with :? System.OperationCanceledException -> return true + with :? OperationCanceledException -> return true } - - Async.RunSynchronously(test()) |> Assert.True + let ok = Async.RunSynchronously a + Assert.True ok [] member _.AwaitCompletedTask() = - let test() = async { + let a = async { let threadIdBefore = Thread.CurrentThread.ManagedThreadId do! Async.AwaitTask Task.CompletedTask let threadIdAfter = Thread.CurrentThread.ManagedThreadId return threadIdBefore = threadIdAfter } + let ok = Async.RunSynchronously a + Assert.True ok - Async.RunSynchronously(test()) |> Assert.True - - [] - member _.AwaitTaskCancellationUntyped () = - let test() = async { - let tcs = new System.Threading.Tasks.TaskCompletionSource() + [] + member _.AwaitTaskCancellationUntyped(newAwait: bool) = + let a = async { + let tcs = System.Threading.Tasks.TaskCompletionSource() tcs.SetCanceled() try - do! Async.AwaitTask (tcs.Task :> Task) + do! tcs.Task :> Task |> if newAwait then Async.Await else Async.AwaitTask return false - with :? System.OperationCanceledException -> return true + with :? OperationCanceledException -> return true } + let ok = Async.RunSynchronously a + Assert.True ok - Async.RunSynchronously(test()) |> Assert.True - - [] - member _.TaskAsyncValueException () = + [] + member _.TaskAsyncValueException(newAwait: bool) = use t = Task.Factory.StartNew(Func(fun () -> raise <| Exception())) let a = async { - try - let! v = Async.AwaitTask(t) - return false - with e -> return true - } - Async.RunSynchronously(a) |> Assert.True + try let! v = t |> if newAwait then Async.Await else Async.AwaitTask + return false + with e -> return true + } + let ok = Async.RunSynchronously a + Assert.True ok - [] - member _.TaskAsyncValueCancellation () = + [] + member _.TaskAsyncValueCancellation(newAwait: bool) = use ewh = new ManualResetEvent(false) let cts = new CancellationTokenSource() let token = cts.Token use t : Task = Task.Factory.StartNew(Func(fun () -> while not token.IsCancellationRequested do ()), token) let cancelled = ref true - let a = - async { - try - use! _holder = Async.OnCancel(fun _ -> ewh.Set() |> ignore) - let! v = Async.AwaitTask(t) - return v - // AwaitTask raises TaskCanceledException when it is canceled, it is a valid result of this test - with - :? TaskCanceledException -> - ewh.Set() |> ignore // this is ok - } + let a = async { + try + use! _holder = Async.OnCancel(fun _ -> ewh.Set() |> ignore) + let! v = t |> if newAwait then Async.Await else Async.AwaitTask + return v + // A canceled task yields TaskCanceledException via the exception continuation + with + :? TaskCanceledException -> + ewh.Set() |> ignore // this is ok + } let t1 = Async.StartAsTask a cts.Cancel() ewh.WaitOne(10000) |> ignore // Don't leave unobserved background tasks, because they can crash the test run. t1.Wait() - [] - member _.NonGenericTaskAsyncValue () = + [] + member _.NonGenericTaskAsyncValue(newAwait: bool) = let mutable hasBeenCalled = false use t = Task.Factory.StartNew(Action(fun () -> hasBeenCalled <- true)) let a = async { - do! Async.AwaitTask(t) - return true - } - let result = Async.RunSynchronously(a) - (hasBeenCalled && result) |> Assert.True + do! t |> if newAwait then Async.Await else Async.AwaitTask + return true + } + let ok = Async.RunSynchronously a + Assert.True(hasBeenCalled && ok) - [] - member _.NonGenericTaskAsyncValueException () = + [] + member _.NonGenericTaskAsyncValueException(newAwait: bool) = use t = Task.Factory.StartNew(Action(fun () -> raise <| Exception())) let a = async { - try - let! v = Async.AwaitTask(t) - return false - with e -> return true - } - Async.RunSynchronously(a) |> Assert.True + try + let! v = t |> if newAwait then Async.Await else Async.AwaitTask + return false + with e -> return true + } + let ok = Async.RunSynchronously a + Assert.True ok - [] - member _.NonGenericTaskAsyncValueCancellation () = + [] + member _.NonGenericTaskAsyncValueCancellation(newAwait: bool) = use ewh = new ManualResetEvent(false) let cts = new CancellationTokenSource() let token = cts.Token use t = Task.Factory.StartNew(Action(fun () -> while not token.IsCancellationRequested do ()), token) - let a = - async { - try - use! _holder = Async.OnCancel(fun _ -> ewh.Set() |> ignore) - let! v = Async.AwaitTask(t) - return v - // AwaitTask raises TaskCanceledException when it is canceled, it is a valid result of this test - with - :? TaskCanceledException -> - ewh.Set() |> ignore // this is ok - } + let a = async { + try + use! _holder = Async.OnCancel(fun _ -> ewh.Set() |> ignore) + let! v = t |> if newAwait then Async.Await else Async.AwaitTask + return v + // A canceled task yields TaskCanceledException via the exception continuation + with + :? TaskCanceledException -> + ewh.Set() |> ignore // this is ok + } let t1 = Async.StartAsTask a cts.Cancel() ewh.WaitOne(10000) |> ignore @@ -510,19 +510,383 @@ type AsyncType() = ewh.Wait(10000) |> ignore Assert.False hasThrown - [] - member _.NoStackOverflowOnRecursion() = - + [] + member _.NoStackOverflowOnRecursion(newAwait: bool) = let mutable hasThrown = false let rec loop (x: int) = async { - do! Task.CompletedTask |> Async.AwaitTask + do! Task.CompletedTask |> if newAwait then Async.Await else Async.AwaitTask Console.WriteLine (if x = 10000 then failwith "finish" else x) return! loop(x+1) } - try - Async.RunSynchronously (loop 0) - hasThrown <- false + try Async.RunSynchronously (loop 0) + hasThrown <- false with Failure "finish" -> hasThrown <- true Assert.True hasThrown + + // Both AwaitTask and Await ignore the ambient cancellation token while waiting + // (Same goes for the typed variants) + [] + member _.``Both AwaitTask and Await ignore ambient cancellation while waiting``(newAwait) = + let cts = new CancellationTokenSource() + let tcs = TaskCompletionSource() // task that never completes + let res = TaskCompletionSource() + + let a = async { + try do! tcs.Task |> if newAwait then Async.Await else Async.AwaitTask + res.TrySetResult true |> ignore + with _ -> res.TrySetResult false |> ignore + } + + Async.Start(a, cts.Token) + // NOTE we only cancel during the Await/AwaitTask - the initial check would throw if we canceled before the Start() + cts.CancelAfter 100 + + // AwaitTask should NOT honor the ambient CT trigger + let taskCompleted = res.Task.Wait 500 + Assert.False(taskCompleted, "Await/AwaitTask should not have responded to ambient CT cancellation") + tcs.TrySetResult() |> ignore // clean up + res.Task.Wait() + + (* When an AggregateException has multiple inner exceptions, Await and AwaitTask behave identically *) + + [] + member _.``Await and AwaitTask(Task<'T>) valid AggregateException is surfaced``(newAwait) = + let tcs = TaskCompletionSource() + tcs.SetException [ ArgumentException "a" :> exn; InvalidOperationException "b" :> exn ] + let a = async { + try + let! _ = tcs.Task |> if newAwait then Async.Await else Async.AwaitTask + return false + with :? AggregateException as ae -> return ae.InnerExceptions.Count = 2 + } + let ok = Async.RunSynchronously a + Assert.True ok + + [] + member _.``Await and AwaitTask(Task) valid AggregateException is surfaced``(newAwait) = + let tcs = TaskCompletionSource() + tcs.SetException [| ArgumentException "a" :> exn; InvalidOperationException "b" |] + let a = async { + try + do! tcs.Task |> if newAwait then Async.Await else Async.AwaitTask + return false + with :? AggregateException as ae -> return ae.InnerExceptions.Count = 2 + } + let ok = Async.RunSynchronously a + Assert.True ok + + (* Async.Await behavioral differences + + The following tests demonstrate where Async.Await deliberately differs from Async.AwaitTask *) + + // Async.AwaitTask(Task) surfaces the wrapping AggregateException ... + [] + member _.``AwaitTask(Task) egregious AggregateException is unchanged``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let a = async { + try do! Async.AwaitTask tcs.Task + return false + with :? AggregateException -> return true + } + let ok = Async.RunSynchronously a + Assert.True ok + + // ... whereas Async.Await(Task) surfaces the inner exception directly. + [] + member _.``Await(Task) egregious AggregateException is unwrapped``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let a = async { + try do! Async.Await tcs.Task + return false + with :? ArgumentException as ae -> return ae.Message = "original" + } + let ok = Async.RunSynchronously a + Assert.True ok + + // Async.AwaitTask(Task<'T>) surfaces the wrapping AggregateException ... + [] + member _.``AwaitTask(Task<'T>) egregious AggregateException is unchanged``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let a = async { + try let! _ = Async.AwaitTask tcs.Task + return false + with :? AggregateException -> return true + } + let ok = Async.RunSynchronously a + Assert.True ok + + // ... whereas Async.Await(Task<'T>) surfaces the inner exception directly. + [] + member _.``Await(Task<'T>) egregious AggregateException is unwrapped``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let a = async { + try let! _ = Async.Await tcs.Task + return false + with :? ArgumentException as ae -> return ae.Message = "original" + } + let ok = Async.RunSynchronously a + Assert.True ok + + (* Await(Task/Task<'T>) overloads happy path *) + + [] + member _.``Await(Task<'T>) happy path``() = + let a = async { + let! v = Async.Await(System.Threading.Tasks.Task.FromResult(42)) + return v = 42 + } + let ok = Async.RunSynchronously a + Assert.True ok + + [] + member _.``Await(Task) happy path``() = + let a = async { + do! Async.Await(System.Threading.Tasks.Task.CompletedTask) + return true + } + let ok = Async.RunSynchronously a + Assert.True ok + +#if !NETFRAMEWORK + (* Await(ValueTask and ValueTask<'T>) overloads coverage of mainline behaviors *) + + [] + member _.``Await(ValueTask) happy path``() = + let a = async { + do! Async.Await(ValueTask()) + return true + } + let ok = Async.RunSynchronously a + Assert.True ok + + [] + member _.``Await(ValueTask<'T>) happy path``() = + let a = async { + let! v = Async.Await(ValueTask(42)) + return v = 42 + } + let ok = Async.RunSynchronously a + Assert.True ok + + [] + member _.``Await(ValueTask) exception unwraps``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let task = ValueTask(tcs.Task :> Task) + let a = async { + try do! Async.Await task + return false + with :? ArgumentException as ae -> return ae.Message = "original" + } + let ok = Async.RunSynchronously a + Assert.True ok + + [] + member _.``Await(ValueTask<'T>) exception unwraps``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let a = async { + try let! _ = Async.Await(ValueTask(tcs.Task)) + return false + with :? ArgumentException as ae -> return ae.Message = "original" + } + let ok = Async.RunSynchronously a + Assert.True ok +#endif + +[] +module AsyncTaskLikeAwaitTests = + + // Minimal custom task-like type wrapping Task<'T> + type MyTask<'T>(inner: Task<'T>) = + member _.GetAwaiter() = inner.GetAwaiter() + + // Minimal custom unit-returning task-like + type MyUnitTask(inner: Task) = + member _.GetAwaiter() = inner.GetAwaiter() + + [] + let ``Await(task-like) happy path with result``() = + let result = + async { + let! v = Async.Await(MyTask(Task.FromResult 99)) + return v + } + |> Async.RunSynchronously + Assert.Equal(99, result) + + [] + let ``Await(task-like) happy path unit``() = + async { + do! Async.Await(MyUnitTask(Task.CompletedTask)) + } + |> Async.RunSynchronously + + [] + let ``Await(task-like) deferred completion``() = + let tcs = TaskCompletionSource() + let t = + async { + let! v = Async.Await(MyTask(tcs.Task)) + return v + } + |> Async.StartAsTask + Assert.False(t.IsCompleted, "Should not be done before TCS is set") + tcs.SetResult 7 + t.Wait(TimeSpan.FromSeconds 5.0) |> ignore + Assert.Equal(7, t.Result) + + [] + let ``Await(task-like) deferred completion preserves AsyncLocal ExecutionContext``() = + let asyncLocal = AsyncLocal() + let tcs = TaskCompletionSource() + + let t = + Async.StartImmediateAsTask(async { + asyncLocal.Value <- "trace-id" + do! Async.Await(MyUnitTask(tcs.Task)) + return asyncLocal.Value // should yield trace-id, *unless ExecutionContext did not propagate* + }) + Assert.False(t.IsCompleted, "Should not be done before TCS is set") + + // This should not pollute the continuation observed + asyncLocal.Value <- "root-context" + let completion = + Task.Run(fun () -> + asyncLocal.Value <- "completing-context" // if ExecutionContext is not propagated correctly to the continuation, it will see this + tcs.SetResult()) + + Assert.True(completion.Wait(TimeSpan.FromSeconds 5.), "Completion task hung?") + Assert.True(t.Wait(TimeSpan.FromSeconds 5.), "Awaited subject task hung?") + Assert.Equal("trace-id", t.Result) // Validate the chaining worked correctly + Assert.Equal("root-context", asyncLocal.Value) // Root level context should be preserved + + [] + let ``Await(task-like) exception propagation``() = + let tcs = TaskCompletionSource() + let a = + async { + try let! _ = Async.Await(MyTask(tcs.Task)) + return false + with :? InvalidOperationException as e -> + return e.Message = "boom" + } + tcs.SetException(InvalidOperationException "boom") + let ok = Async.RunSynchronously a + Assert.True ok + + [] + let ``Await(YieldAwaitable) yields and resumes``() = + // Task.Yield() returns a YieldAwaitable which is a struct — exercises the struct-awaiter path. + let mutable before, after = false, false + async { + before <- true + do! Async.Await(Task.Yield()) + after <- true + } + |> Async.RunSynchronously + Assert.True(before && after) + + [] + let ``Await(ConfiguredTaskAwaitable) from ConfigureAwait``() = + // task.ConfigureAwait(false) returns a ConfiguredTaskAwaitable — a common real-world task-like. + let result = + async { + let! v = Async.Await(Task.FromResult(42).ConfigureAwait(false)) + return v + } + |> Async.RunSynchronously + Assert.Equal(42, result) + +[] +module AsyncAwaitStackTraceTests = + + open System.Runtime.CompilerServices + + // Minimal wrapper to route through the SRTP overload instead of the specific Task<'T> overload. + // Task<'T>, Task, ValueTask<'T>, and ValueTask all have higher-priority intrinsic overloads. + type TaskWrapper<'T>(inner: Task<'T>) = + member _.GetAwaiter() = inner.GetAwaiter() + + // Plain function — provides a stable named frame at the outermost throw site. + [] + let throwAtLevel1 () : unit = invalidOp "boom" + + // Level-1 task: thin wrapper around the direct throw. + [] + let level1Task () : Task = task { throwAtLevel1 () } + + // Level-2 task: introduces a real async await boundary between levels 1 and 2. + [] + let level2Task () : Task = task { do! level1Task () } + + // Run via StartImmediateAsTask + .Wait() and return the inner exception. + // Using StartImmediateAsTask (not RunSynchronously) ensures that the async-layer + // exception machinery goes through TaskCompletionSource.SetException, which preserves + // the stack trace rather than rethrowing synchronously and potentially truncating it. + let runAndCaptureException (computation: Async) : exn = + // TODO swap in usage of Async.RunSynchronouslyImmediate + let t = Async.StartImmediateAsTask computation + let ae = Assert.Throws(fun () -> t.Wait()) + ae.InnerException + + // Template assertion: levels 1 and 2 must be traceable in the stack trace + // regardless of which Async.Await overload is used. + let checkTrace totalCount (e: exn) = + let trace = e.StackTrace + // stacktrace should be relatively compact and not bloat the logs, so unconditionally print it to save time analyzing regressions + printfn "EDI trace ====" + printfn "%s" trace + printfn "==== EDI trace" + Assert.NotNull(trace) + Assert.Contains("throwAtLevel1", trace) + Assert.Contains("level1Task", trace) + Assert.Contains("level2Task", trace) +#if !NETFRAMEWORK // downlevel has interstitial layers we are not seeking to characterize at this point + Assert.Equal(totalCount, trace.Split('\n').Length) +#endif + + // --- Tests per overload --- + // The common skeleton is: build a 3-level chain (throwAtLevel1 → level1Task → level2Task), + // wrap the outermost level in an async block using Async.Await, run via + // StartImmediateAsTask + .Wait(), and assert on the resulting exception's stack trace. + + [] + let ``Await Task-of-T: all three levels visible in stack trace`` () = + let e = runAndCaptureException (async { do! Async.Await(level2Task()) }) + checkTrace 3 e + + [] + let ``Await Task (non-generic): all three levels visible in stack trace`` () = + let e = runAndCaptureException (async { do! Async.Await(level2Task() :> Task) }) + checkTrace 3 e + // Same behavior as the Task<'T> overload — see comment there. + +#if !NETFRAMEWORK + [] + let ``Await ValueTask-of-T: all three levels visible in stack trace`` () = + // For a faulted ValueTask, IsCompletedSuccessfully is false; the overload falls + // through to AwaitTask, which takes the same path as the specific Task<'T> overload. + let e = runAndCaptureException (async { do! Async.Await(ValueTask(level2Task())) }) + checkTrace 3 e + + [] + let ``Await ValueTask (non-generic): all three levels visible in stack trace`` () = + // Same as ValueTask<'T>: falls through to AwaitUnitTask for the non-successfully-completed case. + let e = runAndCaptureException (async { do! Async.Await(ValueTask(level2Task() :> Task)) }) + + checkTrace 3 e +#endif + + [] + let ``Await task-like via SRTP overload: all three levels visible in stack trace`` () = + let e = runAndCaptureException (async { do! Async.Await(TaskWrapper(level2Task())) }) + + // 4 instead of 3 as current impl has an outer "at FSharp.Core.UnitTests.Control.AsyncAwaitStackTraceTests.e@836-9.Invoke(Tuple`3 tupledArg) + checkTrace 4 e \ No newline at end of file diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/XmlDocumentationValidation.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/XmlDocumentationValidation.fs index 3010ef7e95f..434ecf28c59 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/XmlDocumentationValidation.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/XmlDocumentationValidation.fs @@ -4,37 +4,55 @@ module FSharp.Core.UnitTests.XmlDocumentationValidation open System open System.IO -open System.Text.RegularExpressions open System.Xml open Xunit +let isConditionalDirectiveLine (trimmedLine: string) = + trimmedLine.StartsWith("#if") + || trimmedLine.StartsWith("#else") + || trimmedLine.StartsWith("#elif") + || trimmedLine.StartsWith("#endif") + /// Extracts XML documentation blocks from F# signature files let extractXmlDocBlocks (content: string) = - // Regex to match XML documentation comments (/// followed by XML content) - let xmlDocPattern = @"^\s*///\s*(.*)$" - let regex = Regex(xmlDocPattern, RegexOptions.Multiline) - - let lines = content.Split([|'\n'; '\r'|], StringSplitOptions.RemoveEmptyEntries) - let mutable xmlBlocks = [] - let mutable currentBlock = [] - let mutable lineNumber = 0 - - for line in lines do - lineNumber <- lineNumber + 1 - let trimmedLine = line.Trim() - if trimmedLine.StartsWith("///") then - let xmlContent = trimmedLine.Substring(3).Trim() - currentBlock <- (xmlContent, lineNumber) :: currentBlock - else - if not (List.isEmpty currentBlock) then - xmlBlocks <- List.rev currentBlock :: xmlBlocks - currentBlock <- [] - - // Don't forget the last block if file ends with XML comments - if not (List.isEmpty currentBlock) then - xmlBlocks <- List.rev currentBlock :: xmlBlocks - - List.rev xmlBlocks + seq { + let currentBlock = ResizeArray<_>() + let tryFlushCurrentBlock () = + if currentBlock.Count > 0 then + let block = currentBlock |> Seq.toList + currentBlock.Clear() + Some block + else + None + + use reader = new StringReader(content) + let mutable lineNumber = 0 + let mutable line = reader.ReadLine() + + while not (isNull line) do + lineNumber <- lineNumber + 1 + let trimmed = line.Trim() + + if trimmed.StartsWith("///") then + let xmlContent = trimmed.Substring(3).Trim() + if not (String.IsNullOrWhiteSpace xmlContent) then + currentBlock.Add((xmlContent, lineNumber)) + elif isConditionalDirectiveLine trimmed || trimmed.Length = 0 then + // Keep the current XML documentation block open across conditional directives and blank lines + // Handles docs that have internal #if/#else/#endif guards within xmldoc blocks to cover TFM variations. + () + else + match tryFlushCurrentBlock () with + | Some block -> yield block + | None -> () + + line <- reader.ReadLine() + + // Don't forget the last block if file ends with XML comments + match tryFlushCurrentBlock () with + | Some block -> yield block + | None -> () + } /// Validates that XML content is well-formed let validateXmlBlock (xmlLines: (string * int) list) = From 6ac056a5ee3d3dc2ff11b83b2ee09c4e6eacfdd8 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Thu, 13 Aug 2026 15:42:48 +0200 Subject: [PATCH 27/55] IL: fix leaking binary view (#20250) --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + src/Compiler/AbstractIL/ilread.fs | 6 +- .../FSharp.Compiler.Service.Tests.fsproj | 1 + .../ILBinaryReaderMemoryTests.fs | 67 +++++++++++++++++++ 4 files changed, 73 insertions(+), 2 deletions(-) create mode 100644 tests/FSharp.Compiler.Service.Tests/ILBinaryReaderMemoryTests.fs diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index abbf3304ee1..d8f9a8c937c 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -135,6 +135,7 @@ * Fix #5795: Allow attributes defined in a `module rec` / `namespace rec` scope to be used on union cases, record fields, and generic type parameters of types in the same recursive scope. ([Issue #5795](https://github.com/dotnet/fsharp/issues/5795), [PR #19744](https://github.com/dotnet/fsharp/pull/19744)) * Import: Don't walk non-F# assemblies when labelling trait constraint sources (PR [#20090](https://github.com/dotnet/fsharp/pull/20090)) * Avoid per-instance lock object in InterruptibleLazy and DelayInitArrayMap (PR [#20088](https://github.com/dotnet/fsharp/pull/20088)) +* IL: fix leaking binary view ([PR #20250](https://github.com/dotnet/fsharp/pull/20250)) ### Added diff --git a/src/Compiler/AbstractIL/ilread.fs b/src/Compiler/AbstractIL/ilread.fs index 0ccdd9cf35c..ddf0a7d7778 100644 --- a/src/Compiler/AbstractIL/ilread.fs +++ b/src/Compiler/AbstractIL/ilread.fs @@ -2190,7 +2190,7 @@ and typeDefReader ctxtH : ILTypeDefStored = let fdefs = seekReadFields ctxt (numTypars, hasLayout) fieldsIdx endFieldsIdx let nested = seekReadNestedTypeDefs ctxt idx - let impls = seekReadInterfaceImpls ctxt mdv numTypars idx + let impls = seekReadInterfaceImpls ctxt numTypars idx let mimpls = seekReadMethodImpls ctxt numTypars idx let props = seekReadProperties ctxt numTypars idx @@ -2246,8 +2246,10 @@ and seekReadNestedTypeDefs (ctxt: ILMetadataReader) tidx = yield mkILPreTypeDefRead (nameIdx, i, ctxt.typeDefReader) |]) -and seekReadInterfaceImpls (ctxt: ILMetadataReader) mdv numTypars tidx = +and seekReadInterfaceImpls (ctxt: ILMetadataReader) numTypars tidx = InterruptibleLazy(fun () -> + let mdv = ctxt.mdfile.GetView() + seekReadIndexedRows ( ctxt.getNumRows TableNames.InterfaceImpl, id, diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj index 2e53400e325..7130f40e785 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj @@ -35,6 +35,7 @@ + diff --git a/tests/FSharp.Compiler.Service.Tests/ILBinaryReaderMemoryTests.fs b/tests/FSharp.Compiler.Service.Tests/ILBinaryReaderMemoryTests.fs new file mode 100644 index 00000000000..d7e82347ffc --- /dev/null +++ b/tests/FSharp.Compiler.Service.Tests/ILBinaryReaderMemoryTests.fs @@ -0,0 +1,67 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +module FSharp.Compiler.Service.Tests.ILBinaryReaderMemoryTests + +open System +open System.Collections.Generic +open System.IO +open System.Reflection +open FSharp.Compiler.AbstractIL.ILBinaryReader +open FSharp.Compiler.IO +open Xunit + +let private instanceFields = + BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic + +let rec private allFields (ty: Type | null) = + match ty with + | Null -> Seq.empty + | NonNull ty -> Seq.append (ty.GetFields instanceFields) (allFields ty.BaseType) + +/// The metadata of a stable file is held weakly (see `WeakByteFile`) so that it can be dropped under memory +/// pressure and re-read on demand. Capturing a view over it, for example in a lazy value, defeats that. +/// Weakly held data is not reported: a weak reference has no field pointing to its target. +let private assertDoesNotRetainMetadata (root: obj) = + let visited = HashSet(HashIdentity.Reference) + let queue = Queue() + + let enqueue path (value: objnull) = + match value with + | NonNull value when not (value.GetType().IsPrimitive) && visited.Add value -> queue.Enqueue(value, path) + | _ -> () + + enqueue (root.GetType().Name) root + + while queue.Count > 0 do + match queue.Dequeue() with + | (:? ByteMemory), path -> failwith $"The metadata view is retained by: {path}" + | (:? Array as array), path -> array |> Seq.cast |> Seq.iteri (fun i o -> enqueue $"{path}[{i}]" o) + | value, path -> + for field in allFields (value.GetType()) do + enqueue $"{path}.{field.Name}" (field.GetValue value) + +let private readerOptions = + { + pdbDirPath = None + reduceMemoryUsage = ReduceMemoryFlag.Yes + metadataOnly = MetadataOnlyFlag.Yes + tryGetMetadataSnapshot = fun _ -> None + } + +[] +let ``Reading type defs does not retain the metadata view`` () = + // The bytes are only held weakly for files that look stable, which is decided by location (`IsStableFileHeuristic`). + let directory = + Path.Combine(FileSystem.GetTempPathShim(), "packages", Guid.NewGuid().ToString()) + |> FileSystem.DirectoryCreateShim + + let path = Path.Combine(directory, "TestAssembly.dll") + FileSystem.CopyShim(typeof.Assembly.Location, path, false) + + try + let reader = OpenILModuleReader path readerOptions + + // The lazily read parts of the type defs, such as the interface impls, are left unforced on purpose. + assertDoesNotRetainMetadata (reader.ILModuleDef.TypeDefs.AsArray()) + finally + FileSystem.FileDeleteShim path + FileSystem.DirectoryDeleteShim directory From e09605cdcf4e98fc1380a052b11694dcd8d747a7 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Thu, 13 Aug 2026 17:20:35 +0200 Subject: [PATCH 28/55] IL: use empty tables for members when possible (#20249) --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + src/Compiler/AbstractIL/ilread.fs | 174 +++++++++--------- 2 files changed, 89 insertions(+), 86 deletions(-) diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index d8f9a8c937c..cdb8195a13e 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -165,6 +165,7 @@ * Expand `` at tooling time. In IDE tooltips, completion, and signature help, documentation is inherited from base classes, interfaces, overridden members, and constructors (matched by parameter signature). The FCS Symbols API (`FSharpSymbol.XmlDoc`) additionally resolves explicit `cref` targets, but does not expand constructor inheritance. The compiler emits the tag verbatim into generated XML documentation files, matching C#; `` is not implemented. ([Issue #19175](https://github.com/dotnet/fsharp/issues/19175), [PR #19188](https://github.com/dotnet/fsharp/pull/19188)) * Add symbol and type highlighting to F# diagnostics ([PR #20097](https://github.com/dotnet/fsharp/pull/20097)) * IL: add `ILPreNamespace`, make `ILPreTypeDef` creation lazy ([PR #20092](https://github.com/dotnet/fsharp/pull/20092)) +* IL: use empty tables for members when possible ([PR #20249](https://github.com/dotnet/fsharp/pull/20249)) ### Improved diff --git a/src/Compiler/AbstractIL/ilread.fs b/src/Compiler/AbstractIL/ilread.fs index ddf0a7d7778..bc31548cbdd 100644 --- a/src/Compiler/AbstractIL/ilread.fs +++ b/src/Compiler/AbstractIL/ilread.fs @@ -1542,6 +1542,26 @@ let seekReadMethodImplRow (ctxt: ILMetadataReader) mdv idx = let mdeclIdx = seekReadMethodDefOrRefIdx ctxt mdv &addr (tidx, mbodyIdx, mdeclIdx) +/// Rows of a table keyed by type def in its first column: at most one per type in EventMap and +/// PropertyMap, pointing at its member range, and the overrides themselves in MethodImpl. Called per +/// type def rather than when the table it feeds is forced, so the types with no rows - most of them - +/// can share the empty table. +let seekReadRowRangeForTypeDef (ctxt: ILMetadataReader) mdv (table: TableName) tidx = + let searcher = + { new ISeekReadIndexedRowReader with + member _.GetRow(i, rowIndex) = rowIndex <- i + member _.GetKey(rowIndex) = rowIndex + + member _.CompareKey(rowIndex) = + let mutable addr = ctxt.rowAddr table rowIndex + let rowTidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr + simpleIndexCompare tidx rowTidx + + member _.ConvertRow(rowIndex) = rowIndex + } + + seekReadIndexedRowsRange (ctxt.getNumRows table) true searcher + /// Read Table ILModuleRef. let seekReadModuleRefRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.ModuleRef idx @@ -2192,9 +2212,9 @@ and typeDefReader ctxtH : ILTypeDefStored = let impls = seekReadInterfaceImpls ctxt numTypars idx - let mimpls = seekReadMethodImpls ctxt numTypars idx - let props = seekReadProperties ctxt numTypars idx - let events = seekReadEvents ctxt numTypars idx + let mimpls = seekReadMethodImpls ctxt mdv numTypars idx + let props = seekReadProperties ctxt mdv numTypars idx + let events = seekReadEvents ctxt mdv numTypars idx ILTypeDef( name = nm, @@ -2546,26 +2566,30 @@ and seekReadField ctxt mdv (numTypars, hasLayout) (idx: int) = ) and seekReadFields (ctxt: ILMetadataReader) (numTypars, hasLayout) fidx1 fidx2 = - mkILFieldsLazy ( - InterruptibleLazy(fun _ -> - let mdv = ctxt.mdfile.GetView() + if fidx1 <= 0 || fidx2 <= fidx1 then + emptyILFields + else + mkILFieldsLazy ( + InterruptibleLazy(fun _ -> + let mdv = ctxt.mdfile.GetView() - [ - if fidx1 > 0 then + [ for i = fidx1 to fidx2 - 1 do yield seekReadField ctxt mdv (numTypars, hasLayout) i - ]) - ) + ]) + ) and seekReadMethods (ctxt: ILMetadataReader) numTypars midx1 midx2 = - mkILMethodsComputed (fun () -> - let mdv = ctxt.mdfile.GetView() + if midx1 <= 0 || midx2 <= midx1 then + emptyILMethods + else + mkILMethodsComputed (fun () -> + let mdv = ctxt.mdfile.GetView() - [| - if midx1 > 0 then + [| for i = midx1 to midx2 - 1 do yield seekReadMethod ctxt mdv numTypars i - |]) + |]) and sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr = let struct (n, sigptr) = sigptrGetZInt32 bytes sigptr @@ -3112,40 +3136,37 @@ and seekReadParamExtras (ctxt: ILMetadataReader) mdv (retRes: byref, p MetadataIndex = idx } -and seekReadMethodImpls (ctxt: ILMetadataReader) numTypars tidx = - mkILMethodImplsLazy ( - lazy - let mdv = ctxt.mdfile.GetView() +and seekReadMethodImpls (ctxt: ILMetadataReader) mdv numTypars tidx = + let startIdx, endIdx = + seekReadRowRangeForTypeDef ctxt mdv TableNames.MethodImpl tidx - let mimpls = - seekReadIndexedRows ( - ctxt.getNumRows TableNames.MethodImpl, - id, - id, - (fun i -> - let mutable addr = ctxt.rowAddr TableNames.MethodImpl i - let _tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr - simpleIndexCompare tidx _tidx), - isSorted ctxt TableNames.MethodImpl, - seekReadMethodImplRow ctxt mdv - ) + if startIdx <= 0 || endIdx < startIdx then + emptyILMethodImpls + else + mkILMethodImplsLazy ( + lazy + let mdv = ctxt.mdfile.GetView() - mimpls - |> List.map (fun (_, b, c) -> - { - OverrideBy = - let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = - seekReadMethodDefOrRefNoVarargs ctxt numTypars b + [ + for i in startIdx..endIdx do + let _, b, c = seekReadMethodImplRow ctxt mdv i + + yield + { + OverrideBy = + let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMethodDefOrRefNoVarargs ctxt numTypars b - mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) - Overrides = - let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = - seekReadMethodDefOrRefNoVarargs ctxt numTypars c + mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) + Overrides = + let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMethodDefOrRefNoVarargs ctxt numTypars c - let mspec = mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) - OverridesSpec(mspec.MethodRef, mspec.DeclaringType) - }) - ) + let mspec = mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) + OverridesSpec(mspec.MethodRef, mspec.DeclaringType) + } + ] + ) and seekReadMultipleMethodSemantics (ctxt: ILMetadataReader) (flags, id) = seekReadIndexedRows ( @@ -3191,27 +3212,17 @@ and seekReadEvent ctxt mdv numTypars idx = metadataIndex = idx ) -(* REVIEW: can substantially reduce numbers of EventMap and PropertyMap reads by first checking if the whole table mdv sorted according to ILTypeDef tokens and then doing a binary chop *) -and seekReadEvents (ctxt: ILMetadataReader) numTypars tidx = - mkILEventsLazy ( - InterruptibleLazy(fun _ -> - let mdv = ctxt.mdfile.GetView() +and seekReadEvents (ctxt: ILMetadataReader) mdv numTypars tidx = + let rowNum, _ = seekReadRowRangeForTypeDef ctxt mdv TableNames.EventMap tidx + + if rowNum <= 0 then + emptyILEvents + else + mkILEventsLazy ( + InterruptibleLazy(fun _ -> + let mdv = ctxt.mdfile.GetView() + let _, beginEventIdx = seekReadEventMapRow ctxt mdv rowNum - match - seekReadOptionalIndexedRow ( - ctxt.getNumRows TableNames.EventMap, - id, - id, - (fun i -> - let mutable addr = ctxt.rowAddr TableNames.EventMap i - let _tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr - simpleIndexCompare tidx _tidx), - false, - (fun i -> i, seekReadEventMapRow ctxt mdv i |> snd) - ) - with - | None -> [] - | Some(rowNum, beginEventIdx) -> let endEventIdx = if rowNum >= ctxt.getNumRows TableNames.EventMap then ctxt.getNumRows TableNames.Event + 1 @@ -3224,7 +3235,7 @@ and seekReadEvents (ctxt: ILMetadataReader) numTypars tidx = for i in beginEventIdx .. endEventIdx - 1 do yield seekReadEvent ctxt mdv numTypars i ]) - ) + ) and seekReadProperty ctxt mdv numTypars idx = let flags, nameIdx, typIdx = seekReadPropertyRow ctxt mdv idx @@ -3262,26 +3273,17 @@ and seekReadProperty ctxt mdv numTypars idx = metadataIndex = idx ) -and seekReadProperties (ctxt: ILMetadataReader) numTypars tidx = - mkILPropertiesLazy ( - InterruptibleLazy(fun _ -> - let mdv = ctxt.mdfile.GetView() +and seekReadProperties (ctxt: ILMetadataReader) mdv numTypars tidx = + let rowNum, _ = seekReadRowRangeForTypeDef ctxt mdv TableNames.PropertyMap tidx + + if rowNum <= 0 then + emptyILProperties + else + mkILPropertiesLazy ( + InterruptibleLazy(fun _ -> + let mdv = ctxt.mdfile.GetView() + let _, beginPropIdx = seekReadPropertyMapRow ctxt mdv rowNum - match - seekReadOptionalIndexedRow ( - ctxt.getNumRows TableNames.PropertyMap, - id, - id, - (fun i -> - let mutable addr = ctxt.rowAddr TableNames.PropertyMap i - let _tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr - simpleIndexCompare tidx _tidx), - false, - (fun i -> i, seekReadPropertyMapRow ctxt mdv i |> snd) - ) - with - | None -> [] - | Some(rowNum, beginPropIdx) -> let endPropIdx = if rowNum >= ctxt.getNumRows TableNames.PropertyMap then ctxt.getNumRows TableNames.Property + 1 @@ -3294,7 +3296,7 @@ and seekReadProperties (ctxt: ILMetadataReader) numTypars tidx = for i in beginPropIdx .. endPropIdx - 1 do yield seekReadProperty ctxt mdv numTypars i ]) - ) + ) and customAttrsReaderFn ctxtH tag : int32 -> ILAttribute[] = fun idx -> From 5d6e4dcabe53433706d2d406149a6ea4d8268908 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 13 Aug 2026 17:30:53 +0200 Subject: [PATCH 29/55] Add regression test: #14454, IAsyncDisposable use in task CE in FSI (#20251) --- .../Scripting/Interactive.fs | 23 +++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/Scripting/Interactive.fs b/tests/FSharp.Compiler.ComponentTests/Scripting/Interactive.fs index 7bca2ea2691..cb797572366 100644 --- a/tests/FSharp.Compiler.ComponentTests/Scripting/Interactive.fs +++ b/tests/FSharp.Compiler.ComponentTests/Scripting/Interactive.fs @@ -358,3 +358,26 @@ asm.GetCustomAttributes(typeof, false) | Result.Error ex -> raise ex Assert.Equal(1, flags.Length) + + // https://github.com/dotnet/fsharp/issues/14454 + [] + let ``Issue 14454 - IAsyncDisposable use in task CE`` () = + Fsx + """ +open System +open System.Threading.Tasks + +let asyncDisposable = + { new IAsyncDisposable with + member _.DisposeAsync() = ValueTask() } + +let t = + task { + use d = asyncDisposable + return () + } + +t.Wait() + """ + |> eval + |> shouldSucceed From 0640920463534599d2bb6b479bc67662f79515f0 Mon Sep 17 00:00:00 2001 From: Copilot <198982749+Copilot@users.noreply.github.com> Date: Thu, 13 Aug 2026 17:37:34 +0200 Subject: [PATCH 30/55] Teach compiler driver to ignore unknown warning codes (#20246) --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + src/Compiler/Driver/CompilerOptions.fs | 17 ++++++++--------- .../CompilerDirectives/NonStringArgs.fs | 8 ++++++++ 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index cdb8195a13e..7dd68964cb3 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -173,6 +173,7 @@ * Direct delegate construction ([PR ##19993](https://github.com/dotnet/fsharp/pull/19993)) ### Changed +* The `--warnaserror` option now ignores unrecognized diagnostic identifiers in warning lists while still applying recognized F# warning codes. ([PR #20246](https://github.com/dotnet/fsharp/pull/20246)) * Improvements in error and warning messages: new error FS3885 when `let!`/`use!` is the final expression in a computation expression; new warning FS3886 when a list literal contains a single tuple element (likely missing `;` separator); improved wording for FS0003, FS0025, FS0039, FS0072, FS0247, FS0597, FS0670, FS3082, and SRTP operator-not-in-scope hints. ([PR #19398](https://github.com/dotnet/fsharp/pull/19398)) * Exception field serialization (`GetObjectData` and field-restoring constructor) is now gated behind `langversion:11` (`LanguageFeature.ExceptionFieldSerializationSupport`). With langversion ≤10, exception codegen is unchanged from pre-#19342 behavior. ([PR #19746](https://github.com/dotnet/fsharp/pull/19746)) diff --git a/src/Compiler/Driver/CompilerOptions.fs b/src/Compiler/Driver/CompilerOptions.fs index 48574325813..bf6e72f0d95 100644 --- a/src/Compiler/Driver/CompilerOptions.fs +++ b/src/Compiler/Driver/CompilerOptions.fs @@ -791,14 +791,6 @@ let inputFileFlagsFsi (tcConfigB: TcConfigBuilder) = //--------------------------------- let errorsAndWarningsFlags (tcConfigB: TcConfigBuilder) = - let trimFS (s: string) = - if s.StartsWithOrdinal "FS" then s.Substring 2 else s - - let trimFStoInt (s: string) = - match Int32.TryParse(trimFS s) with - | true, n -> Some n - | false, _ -> None - [ CompilerOption( "warnaserror", @@ -816,7 +808,14 @@ let errorsAndWarningsFlags (tcConfigB: TcConfigBuilder) = "warnaserror", tagWarnList, OptionStringListSwitch(fun n switch -> - match trimFStoInt n with + match + GetWarningNumber( + rangeCmdArgs, + WarningDescription.String n, + tcConfigB.langVersion, + WarningNumberSource.CommandLineOption + ) + with | Some n -> let options = tcConfigB.diagnosticsOptions diff --git a/tests/FSharp.Compiler.ComponentTests/CompilerDirectives/NonStringArgs.fs b/tests/FSharp.Compiler.ComponentTests/CompilerDirectives/NonStringArgs.fs index a8b275ab3d5..47e5e5109b9 100644 --- a/tests/FSharp.Compiler.ComponentTests/CompilerDirectives/NonStringArgs.fs +++ b/tests/FSharp.Compiler.ComponentTests/CompilerDirectives/NonStringArgs.fs @@ -143,6 +143,14 @@ match None with None -> () // creates FS0025 - ignored due to flag (Warning 988, Line 3, Col 3, Line 3, Col 3, "Main module of program is empty: nothing will happen when it is run") ] + [] + let ``--warnaserror ignores unknown diagnostic identifiers`` () = + FSharp """ "" """ + |> withOptions ["--warnaserror:NU1605;FS20"] + |> typecheck + |> shouldFail + |> withErrorCode 20 + [] [] From d26c842f3de53b6084d53f25d0b1789d5d8ebaa8 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Thu, 13 Aug 2026 17:38:16 +0200 Subject: [PATCH 31/55] Remove always-on RelaxWhitespace language feature flag (#20226) --- src/Compiler/FSComp.txt | 1 - src/Compiler/Facilities/LanguageFeatures.fs | 5 ----- src/Compiler/Facilities/LanguageFeatures.fsi | 1 - src/Compiler/SyntaxTree/LexFilter.fs | 1 - src/Compiler/xlf/FSComp.txt.cs.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.de.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.es.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.fr.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.it.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.ja.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.ko.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.pl.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.ru.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.tr.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 5 ----- src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 5 ----- 17 files changed, 73 deletions(-) diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 429d2e9695c..ff21c378132 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1564,7 +1564,6 @@ optsAlwaysInline,"Always inline 'inline' functions" nativeResourceFormatError,"Stream does not begin with a null resource and is not in '.RES' format." nativeResourceHeaderMalformed,"Resource header beginning at offset %s is malformed." formatDashItem," - %s" -featureRelaxWhitespace,"whitespace relaxation" featureNameOf,"nameof" featureDotlessFloat32Literal,"dotless float32 literal" featurePackageManagement,"package management" diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index 99f223d1b05..aa455f3acb3 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -16,7 +16,6 @@ module internal FSharp.Compiler.Features [] type LanguageFeature = - | RelaxWhitespace | RelaxWhitespace2 | NameOf | DotlessFloat32Literal @@ -147,9 +146,6 @@ type LanguageVersion(versionText, ?disabledFeaturesArray: LanguageFeature array) static let features = dict [ - // F# 4.7 - LanguageFeature.RelaxWhitespace, languageVersion47 - // F# 5.0 LanguageFeature.FixedIndexSlice3d4d, languageVersion50 LanguageFeature.DotlessFloat32Literal, languageVersion50 @@ -357,7 +353,6 @@ type LanguageVersion(versionText, ?disabledFeaturesArray: LanguageFeature array) /// Get a string name for the given feature. static member GetFeatureString feature = match feature with - | LanguageFeature.RelaxWhitespace -> FSComp.SR.featureRelaxWhitespace () | LanguageFeature.RelaxWhitespace2 -> FSComp.SR.featureRelaxWhitespace2 () | LanguageFeature.NameOf -> FSComp.SR.featureNameOf () | LanguageFeature.DotlessFloat32Literal -> FSComp.SR.featureDotlessFloat32Literal () diff --git a/src/Compiler/Facilities/LanguageFeatures.fsi b/src/Compiler/Facilities/LanguageFeatures.fsi index 161af34ada8..0c06da92e29 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fsi +++ b/src/Compiler/Facilities/LanguageFeatures.fsi @@ -6,7 +6,6 @@ module internal FSharp.Compiler.Features /// LanguageFeature enumeration [] type LanguageFeature = - | RelaxWhitespace | RelaxWhitespace2 | NameOf | DotlessFloat32Literal diff --git a/src/Compiler/SyntaxTree/LexFilter.fs b/src/Compiler/SyntaxTree/LexFilter.fs index 6ee9560058c..ff8aa8c649e 100644 --- a/src/Compiler/SyntaxTree/LexFilter.fs +++ b/src/Compiler/SyntaxTree/LexFilter.fs @@ -964,7 +964,6 @@ type LexFilterImpl ( | _, CtxtSeqBlock _ :: CtxtParen(LPAREN, _) :: (CtxtMemberHead _ as limitCtxt) :: _ // 'static member P with get() = ' limited by 'static', likewise others | _, CtxtWithAsLet _ :: (CtxtMemberHead _ as limitCtxt) :: _ - when lexbuf.SupportsFeature LanguageFeature.RelaxWhitespace -> PositionWithColumn(limitCtxt.StartPos, limitCtxt.StartCol + 1) // REVIEW: document these diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index d71b3646c8d..b898e7a3800 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -632,11 +632,6 @@ informační zprávy související s referenčními buňkami - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 relaxace whitespace v2 diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index 0d9544eb119..589a35f5a6e 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -632,11 +632,6 @@ Informationsmeldungen im Zusammenhang mit Bezugszellen - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 whitespace relaxation v2 diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 74c3429cc6b..222b0f9cdd7 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -632,11 +632,6 @@ mensajes informativos relacionados con las celdas de referencia - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 relajación de espacios en blanco v2 diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 72133297e57..e433626190b 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -632,11 +632,6 @@ messages d’information liés aux cellules de référence - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 relaxation des espaces blancs v2 diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 5d314986629..7eba9c9e86e 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -632,11 +632,6 @@ messaggi informativi relativi alle celle di riferimento - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 uso meno restrittivo degli spazi vuoti v2 diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index 80c7433ba7c..59421c85192 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -632,11 +632,6 @@ 参照セルに関連する情報メッセージ - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 whitespace relaxation v2 diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 6e233678849..e03116ac48f 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -632,11 +632,6 @@ 참조 셀과 관련된 정보 메시지 - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 공백 relaxation v2 diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index 84926fbc1ab..ef606df18a1 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -632,11 +632,6 @@ komunikaty informacyjne związane z odwołaniami do komórek - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 łagodzenie odstępów wer 2 diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index b3069949b5e..6c94d5d189d 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -632,11 +632,6 @@ mensagens informativas relacionadas a células de referência - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 relaxamento de espaço em branco v2 diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index db7328a54d1..fc9b54f939f 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -632,11 +632,6 @@ информационные сообщения, связанные с ссылочными ячейками - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 смягчение требований по использованию пробелов, версия 2 diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index fb4f4641816..5fa7d66e43b 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -632,11 +632,6 @@ başvuru hücreleriyle ilgili bilgi mesajları - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 boşluk ilişkilendirme v2 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index c6c6ae4aa01..ae8bab0bac3 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -632,11 +632,6 @@ 与引用单元格相关的信息性消息 - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 空格放空 v2 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 2e61b8fe454..02b9a8f2b88 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -632,11 +632,6 @@ 與參考儲存格相關的資訊訊息 - - whitespace relaxation - whitespace relaxation - - whitespace relaxation v2 空格鍵放鬆 v2 From 699959510a225be7cfb3029509d8fce1ab9e5e57 Mon Sep 17 00:00:00 2001 From: "dotnet-maestro[bot]" <42748379+dotnet-maestro[bot]@users.noreply.github.com> Date: Thu, 13 Aug 2026 17:50:34 +0200 Subject: [PATCH 32/55] [main] Update dependencies from dotnet/msbuild (#20073) * Update dependencies from https://github.com/dotnet/msbuild build 20260721.8 On relative base path root Microsoft.Build , Microsoft.Build.Framework , Microsoft.Build.Tasks.Core , Microsoft.Build.Utilities.Core From Version 18.10.0-1.26370.18 -> To Version 18.10.0-1.26371.8 * Pin MSBuild at 18.10.0-1.26370.18 (last net10.0-compatible build) The 18.10.0-1.26371.x MSBuild builds dropped their net10.0 assets (they now ship net11.0 + net472 only). This repo's product target framework is net10.0, so: - The package's TFM-support check turns into a build error (doesn't support net10.0). - More importantly, there is no net10.0 runtime asset, so the bootstrap fsc (and fsi) fail at runtime with a silent exit 1 when the legacy MSBuild reference resolver tries to load Microsoft.Build.Utilities.Core, breaking the FSharp.Core compilation and thus the whole build. The net11.0 assemblies cannot be cleanly deployed to a net10.0 app (NuGet won't select them as runtime assets and manual deployment isn't reflected in deps.json), so the update cannot be consumed until the product moves to net11.0 or MSBuild restores net10.0 assets. Pin the dependencies at the last good build to keep CI green and stop the incompatible builds from re-flowing. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> * Pin MessagePack to patched 2.5.302 in CLaSP Framework Proxy to fix NU1902/NU1903 audit The Proxy project transitively pulls MessagePack (via Microsoft.CommonLanguageServerProtocol.Framework) and some restore environments resolve the vulnerable 2.5.108 (< 2.5.301 patched line), tripping NuGetAudit warnings-as-errors on every Windows job that builds VisualFSharp.slnx. Mirror the existing FSharp.Compiler.LanguageServer pin with a direct reference at 2.5.302. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> * Re-trigger CI: Linux leg hit an agent OOM/hang (exit 137, 0 test failures) The FSharp.Compiler.ComponentTests Linux run reported 'Free memory lower than 5% (95.06% used)' then hung ~47 min before SIGKILL (exit 137) with succeeded:5971 failed:0. This is a transient CI-agent out-of-memory flake, unrelated to the MessagePack pin (a Windows VS-only project not built on Linux). Empty commit to re-run the pipeline. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> * Fix merge: use CPM-style package references in CLaSP Framework Proxy csproj The merge of origin/main duplicated PackageReference items (NU1504) and kept Version attributes incompatible with Central Package Management (NU1008). Main migrated this project to CPM; versions are now defined centrally in eng/Packages.props (CLaSP 4.13.0-3.24579.1, MessagePack 2.5.302, Threading override 17.12.21). Restore now succeeds. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> * Re-trigger CI (flaky DependencyManager timeout test) Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --------- Co-authored-by: dotnet-maestro[bot] Co-authored-by: Copilot Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- eng/Version.Details.props | 11 ++++++----- eng/Version.Details.xml | 20 ++++++++++++-------- 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/eng/Version.Details.props b/eng/Version.Details.props index bb9666a824b..64c56630211 100644 --- a/eng/Version.Details.props +++ b/eng/Version.Details.props @@ -7,11 +7,12 @@ This file should be imported by eng/Versions.props 11.0.0-beta.26369.1 - - 18.10.0-preview-26357-08 - 18.10.0-preview-26357-08 - 18.10.0-preview-26357-08 - 18.10.0-preview-26357-08 + + 18.10.0-1.26370.18 + 18.10.0-1.26370.18 + 18.10.0-1.26370.18 + 18.10.0-1.26370.18 1.0.0-prerelease.26407.1 1.0.0-prerelease.26407.1 diff --git a/eng/Version.Details.xml b/eng/Version.Details.xml index 5cda2d7a661..15aaf7819b4 100644 --- a/eng/Version.Details.xml +++ b/eng/Version.Details.xml @@ -2,21 +2,25 @@ - + + https://github.com/dotnet/msbuild - 746aeb090c9e2bcedc398751370da862014ebf7a + eae54023463db15e9a9081f35a959c9162797643 - + https://github.com/dotnet/msbuild - 746aeb090c9e2bcedc398751370da862014ebf7a + eae54023463db15e9a9081f35a959c9162797643 - + https://github.com/dotnet/msbuild - 746aeb090c9e2bcedc398751370da862014ebf7a + eae54023463db15e9a9081f35a959c9162797643 - + https://github.com/dotnet/msbuild - 746aeb090c9e2bcedc398751370da862014ebf7a + eae54023463db15e9a9081f35a959c9162797643 https://github.com/dotnet/roslyn From 90767c77e9c1bcc0a0ea8e4db389416c077fc804 Mon Sep 17 00:00:00 2001 From: "dotnet-maestro[bot]" <42748379+dotnet-maestro[bot]@users.noreply.github.com> Date: Thu, 13 Aug 2026 17:51:48 +0200 Subject: [PATCH 33/55] [main] Source code updates from dotnet/dotnet (#20252) * Backflow from https://github.com/dotnet/dotnet / 7cdb217 build 326717 Diff: https://github.com/dotnet/dotnet/compare/7fb8cef14d9ae6bd729b04638f88d00f1ba7eb99..7cdb217445905f3342bbb0266a4497b9a014389a From: https://github.com/dotnet/dotnet/commit/7fb8cef14d9ae6bd729b04638f88d00f1ba7eb99 To: https://github.com/dotnet/dotnet/commit/7cdb217445905f3342bbb0266a4497b9a014389a [[ commit created by automation ]] * Update dependencies from build 326717 No dependency updates to commit [[ commit created by automation ]] --------- Co-authored-by: dotnet-maestro[bot] --- eng/Build.ps1 | 5 +++++ eng/Version.Details.xml | 2 +- eng/build.sh | 12 ++++++++++++ 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/eng/Build.ps1 b/eng/Build.ps1 index ad397df6acb..3578b641a4d 100644 --- a/eng/Build.ps1 +++ b/eng/Build.ps1 @@ -45,6 +45,8 @@ param ( [switch]$procdump, [switch]$deployExtensions, [switch]$prepareMachine, + [bool][Alias('mt')]$msbuildMultiThreaded = $false, + [bool]$nodeReuse = $false, [switch]$useGlobalNuGetCache = $true, [switch]$dontUseGlobalNuGetCache = $false, [switch]$warnAsError = $true, @@ -78,6 +80,7 @@ param ( Set-StrictMode -version 2.0 $ErrorActionPreference = "Stop" + $BuildCategory = "" $BuildMessage = "" @@ -140,6 +143,8 @@ function Print-Usage() { Write-Host " -msbuildEngine Msbuild engine to use to run build ('dotnet', 'vs', or unspecified)." Write-Host " -procdump Monitor test runs with procdump" Write-Host " -prepareMachine Prepare machine for CI run, clean up processes after build" + Write-Host " -msbuildMultiThreaded Sets MSBuild's multi-threaded mode, i.e. the -mt switch ('1' or '0') (short: -mt)" + Write-Host " -nodeReuse Sets nodereuse msbuild parameter ('1' or '0')" Write-Host " -dontUseGlobalNuGetCache Do not use the global NuGet cache" Write-Host " -noVisualStudio Only build fsc and fsi as .NET Core applications. No Visual Studio required. '-configuration', '-verbosity', '-norestore', '-rebuild' are supported." Write-Host " -productBuild Build the repository in product-build mode." diff --git a/eng/Version.Details.xml b/eng/Version.Details.xml index 15aaf7819b4..02c6cafa04f 100644 --- a/eng/Version.Details.xml +++ b/eng/Version.Details.xml @@ -1,6 +1,6 @@ - + $(NetCurrent) + + $(NetCurrent) + + + TargetFramework=netstandard2.1 + + + 10) --> $([System.Text.RegularExpressions.Regex]::Replace('$(FSharpNetCoreProductTargetFramework)', '^net(\d+)\.0$', '$1')) + + + net10.0 diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index c9bc8c203d3..999a26f683a 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -6833,7 +6833,7 @@ and GenSequenceExpr let cloref = IlxClosureRef(ilCloTypeRef, ilCloLambdas, ilCloAllFreeVars) let ilxCloSpec = - IlxClosureSpec.Create(cloref, GenGenericArgs m eenvouter.tyenv cloFreeTyvars, false) + IlxClosureSpec.Create(cloref, GenGenericArgs cenv m eenvouter.tyenv cloFreeTyvars, false) let formalClospec = IlxClosureSpec.Create(cloref, mkILFormalGenericArgs 0 ilCloGenericParams, false) @@ -7075,8 +7075,10 @@ and GenStaticDelegateClosureTypeDefs and GenGenericParams cenv eenv tps = tps |> DropErasedTypars |> List.map (GenGenericParam cenv eenv) -and GenGenericArgs m (tyenv: TypeReprEnv) tps = - tps |> DropErasedTypars |> List.map (fun c -> (mkILTyvarTy tyenv[c, m])) +and GenGenericArgs cenv m (tyenv: TypeReprEnv) tps = + tps + |> DropErasedTypars + |> List.map (fun tp -> GenType cenv m tyenv (mkTyparTy tp)) /// Generate a local type function contract class and implementation and GenClosureAsLocalTypeFunction cenv (cgbuf: CodeGenBuffer) eenv thisVars expr m = @@ -7476,7 +7478,7 @@ and GetIlxClosureInfo cenv m boxity isLocalTypeFunc canUseStaticField thisVars e /// Compute the contract if it is a local type function let ilCloGenericFormals = GenGenericParams cenv eenvinner cloFreeTyvars - let ilCloGenericActuals = GenGenericArgs m eenvouter.tyenv cloFreeTyvars + let ilCloGenericActuals = GenGenericArgs cenv m eenvouter.tyenv cloFreeTyvars let useStaticField = canUseStaticField && (ilCloAllFreeVars.Length = 0) @@ -7784,7 +7786,7 @@ and GenDelegateExpr cenv cgbuf eenvouter expr (TObjExprMethod(slotsig, _attribs, CountClosure() // Push the constructor for the delegee - let ctxtGenericArgsForDelegee = GenGenericArgs m eenvouter.tyenv cloFreeTyvars + let ctxtGenericArgsForDelegee = GenGenericArgs cenv m eenvouter.tyenv cloFreeTyvars if useStaticClosure then GenUnit cenv eenvouter m cgbuf diff --git a/src/FSharp.Core/FSharp.Core.fsproj b/src/FSharp.Core/FSharp.Core.fsproj index 565fab62a04..be193aa3bbb 100644 --- a/src/FSharp.Core/FSharp.Core.fsproj +++ b/src/FSharp.Core/FSharp.Core.fsproj @@ -5,7 +5,7 @@ Library netstandard2.0 - netstandard2.0;netstandard2.1 + netstandard2.0;netstandard2.1;$(FSharpCoreShippedNetTargetFramework) $(NoWarn);75 $(NoWarn);1204 true @@ -36,6 +36,11 @@ Debug;Release;Proto + + + + + $(OtherFlags) --realsig- diff --git a/src/FSharp.Core/FSharp.Core.nuspec b/src/FSharp.Core/FSharp.Core.nuspec index cc7e5316ac6..a32a54e5382 100644 --- a/src/FSharp.Core/FSharp.Core.nuspec +++ b/src/FSharp.Core/FSharp.Core.nuspec @@ -6,6 +6,7 @@ + @@ -22,5 +23,11 @@ + + + + + + diff --git a/src/FSharp.Core/Query.fs b/src/FSharp.Core/Query.fs index 715894dd34a..61e2d2906db 100644 --- a/src/FSharp.Core/Query.fs +++ b/src/FSharp.Core/Query.fs @@ -107,7 +107,7 @@ type QueryBuilder() = member _.Head (source: QuerySource<'T, 'Q>) = Enumerable.First source.Source - member _.Nth (source: QuerySource<'T, 'Q>, index) = + member _.Nth (source: QuerySource<'T, 'Q>, index: int) = Enumerable.ElementAt (source.Source, index) member _.Skip (source: QuerySource<'T, 'Q>, count) : QuerySource<'T, 'Q> = @@ -116,7 +116,7 @@ type QueryBuilder() = member _.SkipWhile (source: QuerySource<'T, 'Q>, predicate) : QuerySource<'T, 'Q> = QuerySource (Enumerable.SkipWhile (source.Source, Func<_, _>(predicate))) - member _.Take (source: QuerySource<'T, 'Q>, count) : QuerySource<'T, 'Q> = + member _.Take (source: QuerySource<'T, 'Q>, count: int) : QuerySource<'T, 'Q> = QuerySource (Enumerable.Take (source.Source, count)) member _.TakeWhile (source: QuerySource<'T, 'Q>, predicate) : QuerySource<'T, 'Q> = @@ -246,7 +246,7 @@ type QueryBuilder() = QuerySource (Enumerable.GroupJoin(outerSource.Source, innerSource.Source, Func<_, _>(outerKeySelector), Func<_, _>(innerKeySelector), Func<_, _, _>(resultSelector))) member _.LeftOuterJoin (outerSource: QuerySource<_, 'Q>, innerSource: QuerySource<_, 'Q>, outerKeySelector, innerKeySelector, resultSelector: _ -> seq<_> -> _) : QuerySource<_, 'Q> = - QuerySource (Enumerable.GroupJoin(outerSource.Source, innerSource.Source, Func<_, _>(outerKeySelector), Func<_, _>(innerKeySelector), Func<_, _, _>(fun x g -> resultSelector x (g.DefaultIfEmpty())))) + QuerySource (Enumerable.GroupJoin(outerSource.Source, innerSource.Source, Func<_, _>(outerKeySelector), Func<_, _>(innerKeySelector), Func<_, _, _>(fun x (g: seq<_>) -> resultSelector x (g.DefaultIfEmpty())))) member _.RunQueryAsValue (q: Quotations.Expr<'T>) : 'T = ForwardDeclarations.Query.Execute q @@ -475,8 +475,8 @@ module Query = MakeOrCallContainsOrElementAt FQ FE let MakeElementAt, CallElementAt = - let FQ = methodhandleof (fun (x, y) -> Queryable.ElementAt(x, y)) - let FE = methodhandleof (fun (x, y) -> Enumerable.ElementAt(x, y)) + let FQ = methodhandleof (fun (x, y) -> Queryable.ElementAt(x, (y: int))) + let FE = methodhandleof (fun (x, y) -> Enumerable.ElementAt(x, (y: int))) MakeOrCallContainsOrElementAt FQ FE let MakeOrCallMinByOrMaxBy FQ FE = @@ -886,8 +886,8 @@ module Query = let MakeTake = MakeSkipOrTake - (methodhandleof (fun (x, y) -> Queryable.Take (x, y))) - (methodhandleof (fun (x, y) -> Enumerable.Take (x, y))) + (methodhandleof (fun (x, y) -> Queryable.Take (x, (y: int)))) + (methodhandleof (fun (x, y) -> Enumerable.Take (x, (y: int)))) let MakeSkipWhile = GenMakeSkipWhileOrTakeWhile diff --git a/src/FSharp.Core/async.fs b/src/FSharp.Core/async.fs index e73dc4aa230..caff822709c 100644 --- a/src/FSharp.Core/async.fs +++ b/src/FSharp.Core/async.fs @@ -2254,7 +2254,7 @@ type Async = static member Await(task: Task) : Async = AwaitUnitTask true task -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET static member Await(task: ValueTask<'T>) : Async<'T> = if task.IsCompletedSuccessfully then CreateReturnAsync(task.GetAwaiter().GetResult()) diff --git a/src/FSharp.Core/async.fsi b/src/FSharp.Core/async.fsi index 2171f75164a..e0631dc4cad 100644 --- a/src/FSharp.Core/async.fsi +++ b/src/FSharp.Core/async.fsi @@ -913,7 +913,7 @@ namespace Microsoft.FSharp.Control /// static member Await: task: Task -> Async -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET /// Creates an asynchronous computation that will wait for the given ValueTask to complete and return /// its result. /// The ValueTask to await. @@ -1291,13 +1291,13 @@ namespace Microsoft.FSharp.Control /// with IsCompleted and GetResult() members.

///

Exceptions thrown by GetResult() are propagated directly.

///

Unlike the -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET /// and #endif /// overloads, an carrying multiple inner exceptions is not preserved: /// the first inner exception surfaces (standard GetResult() semantics).

///

This overload uses statically resolved type parameters (SRTP) so it can accept any task-like type. -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET /// The specific overloads for , , /// and #else @@ -1931,4 +1931,3 @@ namespace Microsoft.FSharp.Control /// [] val empty: Async - diff --git a/src/FSharp.Core/local.fs b/src/FSharp.Core/local.fs index 16654a06257..c365f9e5bdb 100644 --- a/src/FSharp.Core/local.fs +++ b/src/FSharp.Core/local.fs @@ -10,17 +10,17 @@ module internal DetailedExceptions = open Microsoft.FSharp.Core /// takes an argument, a formatting string, a param array to splice into the formatting string - let inline invalidArgFmt (arg:string) (format:string) paramArray = + let inline invalidArgFmt (arg:string) (format:string) (paramArray: obj[]) = let msg = String.Format (format, paramArray) raise (ArgumentException(msg, arg)) /// takes an argument, a formatting string, a param array to splice into the formatting string - let inline invalidArgOutOfRangeFmt (arg:string) (format:string) paramArray = + let inline invalidArgOutOfRangeFmt (arg:string) (format:string) (paramArray: obj[]) = let msg = String.Format (format, paramArray) raise (ArgumentOutOfRangeException(arg, msg)) /// takes a formatting string and a param array to splice into the formatting string - let inline invalidOpFmt (format:string) paramArray = + let inline invalidOpFmt (format:string) (paramArray: obj[]) = let msg = String.Format (format, paramArray) raise (InvalidOperationException(msg)) diff --git a/src/FSharp.Core/prim-types.fs b/src/FSharp.Core/prim-types.fs index 036ba49ce48..5ee0a4e2ff8 100644 --- a/src/FSharp.Core/prim-types.fs +++ b/src/FSharp.Core/prim-types.fs @@ -443,13 +443,14 @@ namespace System.Diagnostics.CodeAnalysis member this.DynamicallyAccessedMembersAttribute(memberTypes: DynamicallyAccessedMemberTypes) = this.MemberTypes <- memberTypes +#endif + namespace Microsoft.FSharp.Core open System open System.Collections open System.Collections.Generic open System.Globalization open System.Reflection - #endif [] type float<[] 'Measure> = float [] type float32<[] 'Measure> = float32 @@ -4096,6 +4097,7 @@ namespace Microsoft.FSharp.Core and 'T voption = ValueOption<'T> // These attributes only exist in .NET 8 and up. +#if !NET8_0_OR_GREATER namespace System.Runtime.CompilerServices open System open Microsoft.FSharp.Core @@ -4111,6 +4113,7 @@ namespace System.Runtime.CompilerServices [] type internal ScopedRefAttribute () = inherit Attribute () +#endif namespace Microsoft.FSharp.Collections @@ -4128,7 +4131,7 @@ namespace Microsoft.FSharp.Collections open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions open Microsoft.FSharp.Core.BasicInlinedOperations -#if NETSTANDARD2_1_OR_GREATER +#if NETSTANDARD2_1_OR_GREATER || NET [, "Create")>] #endif [] @@ -4156,7 +4159,7 @@ namespace Microsoft.FSharp.Collections and 'T list = List<'T> -#if NETSTANDARD2_1_OR_GREATER +#if NETSTANDARD2_1_OR_GREATER || NET and [] type SupportsWhenTEnum = class end +#if !NET5_0_OR_GREATER namespace System.Diagnostics.CodeAnalysis open System @@ -1047,6 +1048,8 @@ namespace System.Diagnostics.CodeAnalysis new: DynamicallyAccessedMemberTypes -> DynamicallyAccessedMembersAttribute member MemberTypes: DynamicallyAccessedMemberTypes +#endif + namespace Microsoft.FSharp.Core open System @@ -2606,6 +2609,7 @@ namespace Microsoft.FSharp.Core | Error of ErrorValue:'TError // These attributes only exist in .NET 8 and up. +#if !NET8_0_OR_GREATER namespace System.Runtime.CompilerServices open System open Microsoft.FSharp.Core @@ -2637,6 +2641,7 @@ namespace System.Runtime.CompilerServices type internal ScopedRefAttribute = inherit Attribute new: unit -> ScopedRefAttribute +#endif namespace Microsoft.FSharp.Collections @@ -2654,7 +2659,7 @@ namespace Microsoft.FSharp.Collections /// /// /// -#if NETSTANDARD2_1_OR_GREATER +#if NETSTANDARD2_1_OR_GREATER || NET [, "Create")>] #endif [] @@ -2730,7 +2735,7 @@ namespace Microsoft.FSharp.Collections /// and 'T list = List<'T> -#if NETSTANDARD2_1_OR_GREATER +#if NETSTANDARD2_1_OR_GREATER || NET ///

Contains methods for compiler use related to lists. and [ add comparer k acc) empty l -#if NETSTANDARD2_1_OR_GREATER +#if NETSTANDARD2_1_OR_GREATER || NET [, "Create")>] #endif [] @@ -1097,7 +1097,7 @@ type Set<[] 'T when 'T: comparison>(comparer: IComparer<' .Append("; ... ]") .ToString() -#if NETSTANDARD2_1_OR_GREATER +#if NETSTANDARD2_1_OR_GREATER || NET and [See the module for further operations on sets. /// /// All members of this class are thread-safe and may be used concurrently from multiple threads. -#if NETSTANDARD2_1_OR_GREATER +#if NETSTANDARD2_1_OR_GREATER || NET [, "Create")>] #endif [] @@ -263,7 +263,7 @@ type Set<[] 'T when 'T: comparison> = interface System.Collections.IStructuralEquatable interface IReadOnlyCollection<'T> -#if NETSTANDARD2_1_OR_GREATER +#if NETSTANDARD2_1_OR_GREATER || NET /// Contains methods for compiler use related to sets. and [, body: 'T -> TaskCode<'TOverall, unit>) : TaskCode<'TOverall, unit> = ResumableCode.For(sequence, body) -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET member inline internal this.TryFinallyAsync (body: TaskCode<'TOverall, 'T>, compensation: unit -> ValueTask) : TaskCode<'TOverall, 'T> = @@ -788,13 +788,13 @@ module Task = let catch (task: Task<'T>) : Task> = task |> map Ok |> catchWith Error -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET [] let inline ofValueTask (valueTask: ValueTask<'T>) : Task<'T> = valueTask.AsTask() #endif -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET [] [] module ValueTask = diff --git a/src/FSharp.Core/tasks.fsi b/src/FSharp.Core/tasks.fsi index a4e6806d824..f948c5a7044 100644 --- a/src/FSharp.Core/tasks.fsi +++ b/src/FSharp.Core/tasks.fsi @@ -93,7 +93,7 @@ type TaskBuilderBase = member inline TryWith: body: TaskCode<'TOverall, 'T> * catch: (exn -> TaskCode<'TOverall, 'T>) -> TaskCode<'TOverall, 'T> -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET /// /// Specifies a unit of task code which binds to the resource implementing IAsyncDisposable and disposes it asynchronously /// @@ -582,7 +582,7 @@ module Task = [] val empty: Task -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET /// Converts a to a . /// /// The input value task. @@ -600,7 +600,7 @@ module Task = val inline ofValueTask: valueTask: ValueTask<'T> -> Task<'T> #endif -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET /// Contains camelCase module-level functions for computations. /// /// Async Programming diff --git a/src/Microsoft.FSharp.Compiler/Microsoft.FSharp.Compiler.fsproj b/src/Microsoft.FSharp.Compiler/Microsoft.FSharp.Compiler.fsproj index ec0704c0cf1..f31891bc587 100644 --- a/src/Microsoft.FSharp.Compiler/Microsoft.FSharp.Compiler.fsproj +++ b/src/Microsoft.FSharp.Compiler/Microsoft.FSharp.Compiler.fsproj @@ -45,7 +45,7 @@ TargetFrameworks=netstandard2.0 - TargetFrameworks=netstandard2.1;netstandard2.0 + TargetFrameworks=netstandard2.1;netstandard2.0;$(FSharpCoreShippedNetTargetFramework) TargetFrameworks=netstandard2.0 diff --git a/tests/AheadOfTime/NetPackage/VerifyNetPackage.fsx b/tests/AheadOfTime/NetPackage/VerifyNetPackage.fsx new file mode 100644 index 00000000000..9e04522daa3 --- /dev/null +++ b/tests/AheadOfTime/NetPackage/VerifyNetPackage.fsx @@ -0,0 +1,69 @@ +open System +open System.IO +open System.IO.Compression +open System.Text.RegularExpressions + +let fail message = + eprintfn "Package verification failed: %s" message + exit 1 + +let requireExactlyOne description items = + match Array.ofSeq items with + | [| item |] -> item + | items -> fail $"{description}: expected exactly one, found {items.Length}" + +let packagesRoot = + match fsi.CommandLineArgs with + | [| _; path |] -> Path.GetFullPath path + | _ -> fail "expected the artifacts/packages directory" + +let packagePath = + Directory.EnumerateFiles(packagesRoot, "FSharp.Core.*.nupkg", SearchOption.AllDirectories) + |> Seq.filter (fun path -> + DirectoryInfo(Path.GetDirectoryName path).Name = "Shipping" + && not (Path.GetFileName(path).EndsWith(".symbols.nupkg", StringComparison.Ordinal))) + |> requireExactlyOne "FSharp.Core package" + +let package = ZipFile.OpenRead packagePath + +let entries = + package.Entries + |> Seq.map (fun entry -> entry.FullName, entry) + |> Map.ofSeq + +let netTfm = + entries.Keys + |> Seq.choose (fun path -> + let matched = Regex.Match(path, "^lib/(net\\d+\\.0)/FSharp\\.Core\\.dll$") + if matched.Success then Some matched.Groups[1].Value else None) + |> Seq.distinct + |> requireExactlyOne "versioned net target" + +let requireNonEmpty path = + match entries.TryFind path with + | Some entry when entry.Length > 0L -> () + | Some _ -> fail $"{path} is empty" + | None -> fail $"{path} is missing" + +for tfm in [ "netstandard2.0"; "netstandard2.1"; netTfm ] do + requireNonEmpty $"lib/{tfm}/FSharp.Core.dll" + requireNonEmpty $"lib/{tfm}/FSharp.Core.xml" + +let satellites tfm = + entries + |> Seq.choose (fun (KeyValue(path, entry)) -> + let matched = Regex.Match(path, $"^lib/{Regex.Escape tfm}/([^/]+)/FSharp\\.Core\\.resources\\.dll$") + if matched.Success then Some(matched.Groups[1].Value, entry) else None) + |> Map.ofSeq + +let referenceSatellites = satellites "netstandard2.1" +let netSatellites = satellites netTfm + +if referenceSatellites.IsEmpty || Set.ofSeq referenceSatellites.Keys <> Set.ofSeq netSatellites.Keys then + fail $"{netTfm} satellite assemblies do not match netstandard2.1" + +netSatellites.Values +|> Seq.iter (fun entry -> if entry.Length = 0L then fail $"{entry.FullName} is empty") + +package.Dispose() +printfn "Verified %s with %s assets." (Path.GetFileName packagePath) netTfm diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj index 7130f40e785..e043d8554ad 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj @@ -213,6 +213,12 @@ TargetFramework=netstandard2.0 + + + TargetFramework=netstandard2.1 + diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj b/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj index faf41f04322..6850edff337 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj @@ -98,8 +98,18 @@ - + + TargetFramework=$(FSharpCoreShippedNetTargetFramework) + + + + + diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs index b3b40724a81..6791e0ffc07 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs @@ -302,13 +302,14 @@ module TaskModuleFunctionsTests = Assert.Equal((), t.Result) -#if NETSTANDARD2_1 +#if NETSTANDARD2_1 || NET [] let ``Task.ofValueTask converts ValueTask`` () = let vt = ValueTask(42) let t = Task.ofValueTask vt Assert.Equal(42, t.Result) + [] let ``Task.ofValueTask converts faulted ValueTask`` () = let vt = ValueTask(Task.FromException(Exception "boom")) let t = Task.ofValueTask vt diff --git a/tests/FSharp.Core.UnitTests/SurfaceArea.fs b/tests/FSharp.Core.UnitTests/SurfaceArea.fs index 8adf6e5f512..c52b1fba19f 100644 --- a/tests/FSharp.Core.UnitTests/SurfaceArea.fs +++ b/tests/FSharp.Core.UnitTests/SurfaceArea.fs @@ -4,6 +4,7 @@ namespace FSharp.Core.UnitTests.Portable.SurfaceArea open Xunit open System.IO +open System.Reflection open FSharp.Test type SurfaceAreaTest() = @@ -18,13 +19,10 @@ type SurfaceAreaTest() = // Linux/macOS: // export TEST_UPDATE_BSL=1 [] - member this.VerifySurfaceAreaFSharpCore () : unit = + member _.VerifySurfaceAreaFSharpCore () : unit = let platform = // We are testing the surface area of the FSharp.Core assembly. -// NETCOREAPP builds with netstandard2.1 -// Net472 builds with netstandard1.0 -// #if NETCOREAPP "netstandard21" #else @@ -38,4 +36,27 @@ type SurfaceAreaTest() = #endif let assembly = typeof.Assembly let baseline = Path.Combine(__SOURCE_DIRECTORY__, $"FSharp.Core.SurfaceArea.{platform}.{flavor}.bsl") +#if NETCOREAPP + SurfaceArea.verifyIgnoringAssemblyReferences assembly baseline +#else + SurfaceArea.verify assembly baseline +#endif + +#if NETCOREAPP + [] + member _.VerifyNetStandard21SurfaceAreaFSharpCore () : unit = +#if DEBUG + let configuration = "Debug" + let flavor = "debug" +#else + let configuration = "Release" + let flavor = "release" +#endif + let assemblyPath = + Path.Combine(__SOURCE_DIRECTORY__, "..", "..", "artifacts", "bin", "FSharp.Core", configuration, "netstandard2.1", "FSharp.Core.dll") + |> Path.GetFullPath + + let assembly = Assembly.LoadFile assemblyPath + let baseline = Path.Combine(__SOURCE_DIRECTORY__, $"FSharp.Core.SurfaceArea.netstandard21.{flavor}.bsl") SurfaceArea.verify assembly baseline +#endif diff --git a/tests/FSharp.Test.Utilities/SurfaceArea.fs b/tests/FSharp.Test.Utilities/SurfaceArea.fs index 7e60103175b..8b6e6c90748 100644 --- a/tests/FSharp.Test.Utilities/SurfaceArea.fs +++ b/tests/FSharp.Test.Utilities/SurfaceArea.fs @@ -42,19 +42,24 @@ module FSharp.Test.SurfaceArea |] assembly, actual - // verify public surface area matches expected, handles baseline update when TEST_UPDATE_BSL is set - let verify assembly baselinePath : unit = + let private verifyWith updateBaseline lineFilter assembly baselinePath : unit = let normalize (s:string) = Regex.Replace(s, "(\\r\\n|\\n|\\r)+", Environment.NewLine).Trim() let asm, actualNotNormalized = getSurfaceAreaForAssembly (assembly) - let actual = - actualNotNormalized + + let render lines = + lines |> Seq.map normalize |> Seq.filter (String.IsNullOrWhiteSpace >> not) + |> Seq.filter lineFilter |> Seq.sort |> String.concat Environment.NewLine + let actual = render actualNotNormalized + let compare fileContent produced = - match Assert.shouldBeSameMultilineStringSets (normalize fileContent) produced with + let expected = Regex.Split(fileContent, "\\r\\n|\\n|\\r") |> render + + match Assert.shouldBeSameMultilineStringSets expected produced with | None -> None | Some diff -> Some $"""Assembly: %A{asm} @@ -64,4 +69,16 @@ module FSharp.Test.SurfaceArea {diff}""" - checkBaselineWith compare actual baselinePath + if updateBaseline then + checkBaselineWith compare actual baselinePath + else + match compare (File.ReadAllText baselinePath) actual with + | None -> () + | Some diff -> failwith diff + + // verify public surface area matches expected, handles baseline update when TEST_UPDATE_BSL is set + let verify assembly baselinePath : unit = + verifyWith true (fun _ -> true) assembly baselinePath + + let verifyIgnoringAssemblyReferences assembly baselinePath : unit = + verifyWith false (fun line -> not (line.StartsWith("! AssemblyReference:", StringComparison.Ordinal))) assembly baselinePath diff --git a/tests/ILVerify/ilverify.ps1 b/tests/ILVerify/ilverify.ps1 index c870bbcf3d5..70e331b06c3 100644 --- a/tests/ILVerify/ilverify.ps1 +++ b/tests/ILVerify/ilverify.ps1 @@ -55,12 +55,13 @@ $env:PublishWindowsPdb = "false" [string] $default_tfm = "netstandard2.0" # Read product TFM from centralized source of truth via MSBuild [string] $product_tfm = (& (Join-Path $repo_path "eng/common/dotnet.ps1") msbuild (Join-Path $repo_path "eng/TargetFrameworks.props") --getProperty:FSharpNetCoreProductTargetFramework).Trim() +[string] $fsharp_core_net_tfm = (& (Join-Path $repo_path "eng/common/dotnet.ps1") msbuild (Join-Path $repo_path "eng/TargetFrameworks.props") --getProperty:FSharpCoreShippedNetTargetFramework).Trim() [string] $artifacts_bin_path = Join-Path (Join-Path $repo_path "artifacts") "bin" # List projects to verify, with TFMs $projects = @{ - "FSharp.Core" = @($default_tfm, "netstandard2.1") + "FSharp.Core" = @($default_tfm, "netstandard2.1", $fsharp_core_net_tfm) "FSharp.Compiler.Service" = @($default_tfm, $product_tfm) } diff --git a/tests/ILVerify/ilverify_FSharp.Core_Debug_netcoreapp.bsl b/tests/ILVerify/ilverify_FSharp.Core_Debug_netcoreapp.bsl new file mode 100644 index 00000000000..e69de29bb2d diff --git a/tests/ILVerify/ilverify_FSharp.Core_Release_netcoreapp.bsl b/tests/ILVerify/ilverify_FSharp.Core_Release_netcoreapp.bsl new file mode 100644 index 00000000000..e69de29bb2d From 492d417754af3d7ecf8efe7439a90234e6e54d40 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Mon, 17 Aug 2026 12:47:47 +0200 Subject: [PATCH 36/55] Add nullness regression test for recursive inline SRTP memoization (#20247) --- .../IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs | 39 +++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/Types/TypeConstraints/IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/Types/TypeConstraints/IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs index 3de8d80d947..0000b06f571 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/Types/TypeConstraints/IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/Types/TypeConstraints/IWSAMsAndSRTPs/IWSAMsAndSRTPsTests.fs @@ -2037,3 +2037,42 @@ if r <> 1 then failwith $"Expected 1 but got {r}" |> asExe |> compileAndRun |> shouldSucceed + + // The domain-order fix keeps the SRTP typar as the unification representative, so a nullable + // argument annotation survives the recursive specialization and nullness inference stays intact + // under --checknulls+ (no lost or spurious warning, no internal error). + [] + let ``Recursive inline SRTP memoization preserves nullable argument inference under checknulls`` () = + FSharp """ +module Test +open System.Collections.Concurrent + +type Default1 = class end + +[] +type MemoizationKeyWrapper<'a> = MemoizationKeyWrapper of 'a + +type MemoizeN = + inherit Default1 + static member getOrAdd (cd: ConcurrentDictionary,'b>) (f: 'a -> 'b) k = + cd.GetOrAdd (MemoizationKeyWrapper k, (fun (MemoizationKeyWrapper x) -> x) >> f) + +let inline memoizeN (f: ^F) : ^F = + let inline call_2 (a: ^MemoizeN, b: ^b) = ((^MemoizeN or ^b) : (static member MemoizeN : ^MemoizeN * 'b -> _ ) (a, b)) + call_2 (Unchecked.defaultof, Unchecked.defaultof< ^F >) f + +type MemoizeN with + static member MemoizeN (_: Default1, _: 'a -> 'b) = MemoizeN.getOrAdd (ConcurrentDictionary ()) + static member inline MemoizeN (_: MemoizeN, _:'t -> 'a -> 'b) = MemoizeN.getOrAdd (ConcurrentDictionary ()) << (<<) memoizeN + +let lookup (prefix: int) (index: int) (s: string | null) = s.Length + prefix + index +let mlookup = memoizeN lookup +mlookup 1 2 "abc" |> ignore +""" + |> withLangVersion "preview" + |> withCheckNulls + |> withWarnOn 3261 + |> compile + |> withDiagnostics [ + Warning 3261, Line 23, Col 60, Line 23, Col 61, "Nullness warning: Possible dereference of a null value when accessing member 'Length' on the nullable value 's' of type 'string | null'." + ] From f8287a1da193f2f75c0567ee75ac0711fa1c4307 Mon Sep 17 00:00:00 2001 From: Bozhidar Batsov Date: Tue, 18 Aug 2026 11:01:07 +0200 Subject: [PATCH 37/55] Add generic print and println functions to FSharp.Core (#19265) * Add generic print and printn functions to FSharp.Core Add inline `print: 'T -> unit` and `printn: 'T -> unit` to ExtraTopLevelOperators. These use the existing `string` function for conversion (InvariantCulture for IFormattable, .ToString() fallback) and write to Console.Out. RFC FS-1125 --- .fantomasignore | 1 + docs/release-notes/.FSharp.Core/11.0.100.md | 2 + src/FSharp.Core/fslib-extra-pervasives.fs | 17 ++++ src/FSharp.Core/fslib-extra-pervasives.fsi | 27 +++++ .../EmittedIL/PrintFunction.fs | 98 +++++++++++++++++++ .../FSharp.Compiler.ComponentTests.fsproj | 1 + ...p.Core.SurfaceArea.netstandard20.debug.bsl | 2 + ...Core.SurfaceArea.netstandard20.release.bsl | 2 + ...p.Core.SurfaceArea.netstandard21.debug.bsl | 2 + ...Core.SurfaceArea.netstandard21.release.bsl | 2 + .../FSharp.Core.UnitTests.fsproj | 1 + .../Microsoft.FSharp.Core/PrintTests.fs | 76 ++++++++++++++ 12 files changed, 231 insertions(+) create mode 100644 tests/FSharp.Compiler.ComponentTests/EmittedIL/PrintFunction.fs create mode 100644 tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Core/PrintTests.fs diff --git a/.fantomasignore b/.fantomasignore index 1b373a01b2e..fff0a1b9cbc 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -75,6 +75,7 @@ src/Compiler/SyntaxTree/LexFilter.fs src/FSharp.Core/array2.fs src/FSharp.Core/array3.fs +src/FSharp.Core/fslib-extra-pervasives.fs src/FSharp.Core/Linq.fs src/FSharp.Core/local.fs src/FSharp.Core/nativeptr.fs diff --git a/docs/release-notes/.FSharp.Core/11.0.100.md b/docs/release-notes/.FSharp.Core/11.0.100.md index c896ddb5aa8..24d65094f16 100644 --- a/docs/release-notes/.FSharp.Core/11.0.100.md +++ b/docs/release-notes/.FSharp.Core/11.0.100.md @@ -5,8 +5,10 @@ * Move `Async.StartChild` to the "Starting Async Computations" docs category alongside `Async.StartChildAsTask`. ([Issue #19667](https://github.com/dotnet/fsharp/issues/19667)) * Add `InlineIfLambda` to `Array.init` ([PR #19869](https://github.com/dotnet/fsharp/pull/19869)) + ### Added +* Added generic `print` and `printn` functions (`'T -> unit`) to `ExtraTopLevelOperators` for simple value printing to stdout. ([RFC FS-1125](https://github.com/fsharp/fslang-design/blob/main/RFCs/FS-1125-print-printn-functions.md), [PR #19265](https://github.com/dotnet/fsharp/pull/19265)) * Ship `FSharp.Core` with an additional `net10.0` target framework (next to `netstandard2.0` and `netstandard2.1`). The `net`-TFM assembly is public-surface-identical to the `netstandard2.1` one; the target version is a pinned, deliberately advanced knob. ([PR #20229](https://github.com/dotnet/fsharp/pull/20229)) * Add `Async.Await`, mirroring `Async.AwaitTask` semantics, but elides egregious `AggregateException` wrapping. Includes `ValueTask` support, and a SRTP-based overload accepting any Task-like value that supports the `GetAwaiter` protocol. ([Language Suggestion #840](https://github.com/fsharp/fslang-suggestions/issues/840), [PR #19785](https://github.com/dotnet/fsharp/pull/19785)) * `Async.RunSynchronouslyImmediate`: runs work on the calling thread until the first asynchronous suspension (as opposed to `RunSynchronously`, which immediately offloads if not on a background and/or threadpool thread). ([Issue #1042](https://github.com/fsharp/fslang-suggestions/issues/1042), [PR #19804](https://github.com/dotnet/fsharp/pull/19804)) diff --git a/src/FSharp.Core/fslib-extra-pervasives.fs b/src/FSharp.Core/fslib-extra-pervasives.fs index 924f057b7e1..4dd4250843d 100644 --- a/src/FSharp.Core/fslib-extra-pervasives.fs +++ b/src/FSharp.Core/fslib-extra-pervasives.fs @@ -277,6 +277,23 @@ module ExtraTopLevelOperators = let eprintfn format = Printf.eprintfn format + [] + let inline print (value: 'T) = + Console.Out.Write(string value) + // Culture-independent types can bypass 'string' and use TextWriter overloads directly. + // Numeric types must go through 'string' to ensure InvariantCulture formatting, + // since TextWriter.Write(int/float/...) uses the writer's FormatProvider (CurrentCulture). + when 'T : string = Console.Out.Write((# "" value : string #)) + when 'T : char = Console.Out.Write((# "" value : char #)) + when 'T : bool = Console.Out.Write((# "" value : bool #)) + + [] + let inline printn (value: 'T) = + Console.Out.WriteLine(string value) + when 'T : string = Console.Out.WriteLine((# "" value : string #)) + when 'T : char = Console.Out.WriteLine((# "" value : char #)) + when 'T : bool = Console.Out.WriteLine((# "" value : bool #)) + [] let async = AsyncBuilder() diff --git a/src/FSharp.Core/fslib-extra-pervasives.fsi b/src/FSharp.Core/fslib-extra-pervasives.fsi index dff6b2e68d1..878b62547c5 100644 --- a/src/FSharp.Core/fslib-extra-pervasives.fsi +++ b/src/FSharp.Core/fslib-extra-pervasives.fsi @@ -56,6 +56,33 @@ module ExtraTopLevelOperators = [] val eprintfn: format: Printf.TextWriterFormat<'T> -> 'T + /// Converts the value to a string using the string operator and writes it to the standard output. + /// + /// The value to print. + /// + /// + /// + /// print "Hello, " + /// print "World!" + /// // output: Hello, World! + /// + /// + [] + val inline print: value: 'T -> unit + + /// Converts the value to a string using the string operator and writes it to the standard output, followed by a newline. + /// + /// The value to print. + /// + /// + /// + /// printn "Hello, World!" + /// // output: Hello, World! + /// + /// + [] + val inline printn: value: 'T -> unit + /// Print to a string using the given format. /// /// The formatter. diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/PrintFunction.fs b/tests/FSharp.Compiler.ComponentTests/EmittedIL/PrintFunction.fs new file mode 100644 index 00000000000..16db7328cac --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/PrintFunction.fs @@ -0,0 +1,98 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace EmittedIL + +open Xunit +open FSharp.Test.Compiler + +module PrintFunction = + + [] + let ``print with int specializes to Int32 ToString with InvariantCulture``() = + FSharp """ +module PrintInt + +let printInt () = print 42 + """ + |> withOptimize + |> compile + |> shouldSucceed + |> verifyIL [ + """call class [netstandard]System.IO.TextWriter [netstandard]System.Console::get_Out()""" + """call class [netstandard]System.Globalization.CultureInfo [netstandard]System.Globalization.CultureInfo::get_InvariantCulture()""" + """call instance string [netstandard]System.Int32::ToString(string,""" + """callvirt instance void [netstandard]System.IO.TextWriter::Write(string)"""] + + [] + let ``printn with int specializes to Int32 ToString with InvariantCulture``() = + FSharp """ +module PrintnInt + +let printnInt () = printn 42 + """ + |> withOptimize + |> compile + |> shouldSucceed + |> verifyIL [ + """call class [netstandard]System.IO.TextWriter [netstandard]System.Console::get_Out()""" + """call class [netstandard]System.Globalization.CultureInfo [netstandard]System.Globalization.CultureInfo::get_InvariantCulture()""" + """call instance string [netstandard]System.Int32::ToString(string,""" + """callvirt instance void [netstandard]System.IO.TextWriter::WriteLine(string)"""] + + [] + let ``print with string calls Write directly``() = + FSharp """ +module PrintString + +let printStr () = print "hello" + """ + |> withOptimize + |> compile + |> shouldSucceed + |> verifyIL [ + """call class [netstandard]System.IO.TextWriter [netstandard]System.Console::get_Out()""" + """callvirt instance void [netstandard]System.IO.TextWriter::Write(string)"""] + + [] + let ``print with char calls Write char overload``() = + FSharp """ +module PrintChar + +let printChar () = print 'A' + """ + |> withOptimize + |> compile + |> shouldSucceed + |> verifyIL [ + """call class [netstandard]System.IO.TextWriter [netstandard]System.Console::get_Out()""" + """callvirt instance void [netstandard]System.IO.TextWriter::Write(char)"""] + + [] + let ``print with bool calls Write bool overload``() = + FSharp """ +module PrintBool + +let printBool () = print true + """ + |> withOptimize + |> compile + |> shouldSucceed + |> verifyIL [ + """call class [netstandard]System.IO.TextWriter [netstandard]System.Console::get_Out()""" + """callvirt instance void [netstandard]System.IO.TextWriter::Write(bool)"""] + + [] + let ``printn with float specializes to Double ToString with InvariantCulture``() = + FSharp """ +module PrintnFloat + +let printnFloat () = printn 3.14 + """ + |> withOptimize + |> compile + |> shouldSucceed + |> verifyIL [ + """call class [netstandard]System.IO.TextWriter [netstandard]System.Console::get_Out()""" + """call class [netstandard]System.Globalization.CultureInfo [netstandard]System.Globalization.CultureInfo::get_InvariantCulture()""" + """call instance string [netstandard]System.Double::ToString(string,""" + """callvirt instance void [netstandard]System.IO.TextWriter::WriteLine(string)"""] diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 194292ab223..2d033e260dc 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -241,6 +241,7 @@ + diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl index 1f6241a57e3..c1bf3c07a4e 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl @@ -1098,6 +1098,8 @@ Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToStringThenFail[T,TR Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToString[T](Microsoft.FSharp.Core.PrintfFormat`4[T,Microsoft.FSharp.Core.Unit,System.String,System.String]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToTextWriter[T](System.IO.TextWriter, Microsoft.FSharp.Core.PrintfFormat`4[T,System.IO.TextWriter,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormat[T](Microsoft.FSharp.Core.PrintfFormat`4[T,System.IO.TextWriter,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) +Microsoft.FSharp.Core.ExtraTopLevelOperators: Void PrintValue[T](T) +Microsoft.FSharp.Core.ExtraTopLevelOperators: Void PrintValueLine[T](T) Microsoft.FSharp.Core.ExtraTopLevelOperators: T SpliceExpression[T](Microsoft.FSharp.Quotations.FSharpExpr`1[T]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T SpliceUntypedExpression[T](Microsoft.FSharp.Quotations.FSharpExpr) Microsoft.FSharp.Core.ExtraTopLevelOperators: T[,] CreateArray2D[a,T](System.Collections.Generic.IEnumerable`1[a]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl index 0b025a942de..05fbc0e0b47 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl @@ -1098,6 +1098,8 @@ Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToStringThenFail[T,TR Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToString[T](Microsoft.FSharp.Core.PrintfFormat`4[T,Microsoft.FSharp.Core.Unit,System.String,System.String]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToTextWriter[T](System.IO.TextWriter, Microsoft.FSharp.Core.PrintfFormat`4[T,System.IO.TextWriter,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormat[T](Microsoft.FSharp.Core.PrintfFormat`4[T,System.IO.TextWriter,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) +Microsoft.FSharp.Core.ExtraTopLevelOperators: Void PrintValue[T](T) +Microsoft.FSharp.Core.ExtraTopLevelOperators: Void PrintValueLine[T](T) Microsoft.FSharp.Core.ExtraTopLevelOperators: T SpliceExpression[T](Microsoft.FSharp.Quotations.FSharpExpr`1[T]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T SpliceUntypedExpression[T](Microsoft.FSharp.Quotations.FSharpExpr) Microsoft.FSharp.Core.ExtraTopLevelOperators: T[,] CreateArray2D[a,T](System.Collections.Generic.IEnumerable`1[a]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl index 9496d1dfe2b..5d9110a09e3 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl @@ -1113,6 +1113,8 @@ Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToStringThenFail[T,TR Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToString[T](Microsoft.FSharp.Core.PrintfFormat`4[T,Microsoft.FSharp.Core.Unit,System.String,System.String]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToTextWriter[T](System.IO.TextWriter, Microsoft.FSharp.Core.PrintfFormat`4[T,System.IO.TextWriter,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormat[T](Microsoft.FSharp.Core.PrintfFormat`4[T,System.IO.TextWriter,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) +Microsoft.FSharp.Core.ExtraTopLevelOperators: Void PrintValue[T](T) +Microsoft.FSharp.Core.ExtraTopLevelOperators: Void PrintValueLine[T](T) Microsoft.FSharp.Core.ExtraTopLevelOperators: T SpliceExpression[T](Microsoft.FSharp.Quotations.FSharpExpr`1[T]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T SpliceUntypedExpression[T](Microsoft.FSharp.Quotations.FSharpExpr) Microsoft.FSharp.Core.ExtraTopLevelOperators: T[,] CreateArray2D[a,T](System.Collections.Generic.IEnumerable`1[a]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl index b1a377ea33b..f8a069e257c 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl @@ -1113,6 +1113,8 @@ Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToStringThenFail[T,TR Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToString[T](Microsoft.FSharp.Core.PrintfFormat`4[T,Microsoft.FSharp.Core.Unit,System.String,System.String]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormatToTextWriter[T](System.IO.TextWriter, Microsoft.FSharp.Core.PrintfFormat`4[T,System.IO.TextWriter,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T PrintFormat[T](Microsoft.FSharp.Core.PrintfFormat`4[T,System.IO.TextWriter,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]) +Microsoft.FSharp.Core.ExtraTopLevelOperators: Void PrintValue[T](T) +Microsoft.FSharp.Core.ExtraTopLevelOperators: Void PrintValueLine[T](T) Microsoft.FSharp.Core.ExtraTopLevelOperators: T SpliceExpression[T](Microsoft.FSharp.Quotations.FSharpExpr`1[T]) Microsoft.FSharp.Core.ExtraTopLevelOperators: T SpliceUntypedExpression[T](Microsoft.FSharp.Quotations.FSharpExpr) Microsoft.FSharp.Core.ExtraTopLevelOperators: T[,] CreateArray2D[a,T](System.Collections.Generic.IEnumerable`1[a]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj b/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj index 6850edff337..494509d0906 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj @@ -72,6 +72,7 @@ + diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Core/PrintTests.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Core/PrintTests.fs new file mode 100644 index 00000000000..4c5526a9524 --- /dev/null +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Core/PrintTests.fs @@ -0,0 +1,76 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +// Various tests for: +// Microsoft.FSharp.Core.ExtraTopLevelOperators.print +// Microsoft.FSharp.Core.ExtraTopLevelOperators.printn + +namespace FSharp.Core.UnitTests + +open System +open System.IO +open Xunit + +[] +type PrintTests() = + + let captureConsoleOut (f: unit -> unit) = + let oldOut = Console.Out + use sw = new StringWriter() + Console.SetOut(sw) + try + f () + sw.ToString() + finally + Console.SetOut(oldOut) + + [] + member _.``print writes string value``() = + let result = captureConsoleOut (fun () -> print "hello") + Assert.Equal("hello", result) + + [] + member _.``print writes integer value``() = + let result = captureConsoleOut (fun () -> print 42) + Assert.Equal("42", result) + + [] + member _.``print writes float with InvariantCulture``() = + let result = captureConsoleOut (fun () -> print 3.14) + Assert.Equal("3.14", result) + + [] + member _.``print writes bool value``() = + let result = captureConsoleOut (fun () -> print true) + Assert.Equal("True", result) + + [] + member _.``print writes Some value``() = + let result = captureConsoleOut (fun () -> print (Some 42)) + Assert.Equal("Some(42)", result) + + [] + member _.``print writes None value``() = + let result = captureConsoleOut (fun () -> print None) + Assert.Equal("", result) + + [] + member _.``print writes list value``() = + let result = captureConsoleOut (fun () -> print [1; 2; 3]) + Assert.Equal("[1; 2; 3]", result) + + [] + member _.``printn writes value followed by newline``() = + let result = captureConsoleOut (fun () -> printn "hello") + Assert.Equal("hello" + Environment.NewLine, result) + + [] + member _.``multiple prints concatenate``() = + let result = captureConsoleOut (fun () -> + print "Hello, " + print "World!") + Assert.Equal("Hello, World!", result) + + [] + member _.``printn writes integer with newline``() = + let result = captureConsoleOut (fun () -> printn 42) + Assert.Equal("42" + Environment.NewLine, result) From c939fe3cec3e8155c5e980dd8e09aea368050a88 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Tue, 18 Aug 2026 12:31:07 +0200 Subject: [PATCH 38/55] Unpin MSBuild deps and flow to VS 18.11 (18.11.0-1.26417.9) (#20278) The Microsoft.Build.* deps were pinned at 18.10.0-1.26370.18 to keep them on the net10.0 asset line while the product targeted net10.0. The product moved to net11.0 (#20080) before the pin landed, so the pin's own unpin condition was already met. In the VMR source-only build this pin causes prebuilts: the VMR source-builds MSBuild on the 18.11.0 line (VS 18.11 channel), so an 18.10.0 reference cannot be satisfied in-tree and leaks to an external feed, dragging its net10 System.* transitive closure with it. Unpin the four Microsoft.Build.* deps and let the existing msbuild -> fsharp VS 18.11 subscription flow the coherent build (darc update-dependencies), and bump the CPM runtime floor 10.0.9 -> 10.0.10 since net11 MSBuild 18.11 pulls System.Collections.Immutable / System.Reflection.Metadata / Security.Cryptography.Xml at >= 10.0.10. VS 18.11 is the same channel the VMR (main and release/11.0.1xx) consumes MSBuild from, restoring coherency and removing the prebuilts. Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> Copilot-Session: 3a3d99e1-5b05-409a-afd5-c8d9676360f4 --- azure-pipelines-PR.yml | 2 +- eng/Version.Details.props | 11 +++++------ eng/Version.Details.xml | 20 ++++++++------------ eng/Versions.props | 8 ++++---- 4 files changed, 18 insertions(+), 23 deletions(-) diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index ae2ceb05d6c..bac84adeb5b 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -559,7 +559,7 @@ stages: steps: - checkout: self clean: true - - script: .\Build.cmd -c Release -pack + - script: .\Build.cmd -ci -c Release -pack env: NativeToolsOnMachine: true - script: .\eng\common\dotnet.cmd fsi .\tests\AheadOfTime\NetPackage\VerifyNetPackage.fsx -- .\artifacts\packages\Release diff --git a/eng/Version.Details.props b/eng/Version.Details.props index 64c56630211..cf2da9e5711 100644 --- a/eng/Version.Details.props +++ b/eng/Version.Details.props @@ -7,12 +7,11 @@ This file should be imported by eng/Versions.props 11.0.0-beta.26369.1 - - 18.10.0-1.26370.18 - 18.10.0-1.26370.18 - 18.10.0-1.26370.18 - 18.10.0-1.26370.18 + + 18.11.0-1.26417.9 + 18.11.0-1.26417.9 + 18.11.0-1.26417.9 + 18.11.0-1.26417.9 1.0.0-prerelease.26407.1 1.0.0-prerelease.26407.1 diff --git a/eng/Version.Details.xml b/eng/Version.Details.xml index 02c6cafa04f..82db3dfb115 100644 --- a/eng/Version.Details.xml +++ b/eng/Version.Details.xml @@ -2,25 +2,21 @@ - - + https://github.com/dotnet/msbuild - eae54023463db15e9a9081f35a959c9162797643 + 842fc358af70a4ef049ba4052dab78882af557ca - + https://github.com/dotnet/msbuild - eae54023463db15e9a9081f35a959c9162797643 + 842fc358af70a4ef049ba4052dab78882af557ca - + https://github.com/dotnet/msbuild - eae54023463db15e9a9081f35a959c9162797643 + 842fc358af70a4ef049ba4052dab78882af557ca - + https://github.com/dotnet/msbuild - eae54023463db15e9a9081f35a959c9162797643 + 842fc358af70a4ef049ba4052dab78882af557ca https://github.com/dotnet/roslyn diff --git a/eng/Versions.props b/eng/Versions.props index febf548022a..03905c8726c 100644 --- a/eng/Versions.props +++ b/eng/Versions.props @@ -89,13 +89,13 @@ 4.6.3 6.1.2 - $(SystemSecurityCryptographyXmlVersion) $(SystemCollectionsImmutableVersion) @@ -104,7 +104,7 @@ - 10.0.9 + 10.0.10 $(SystemRuntimeCentralFloorVersion) $(SystemRuntimeCentralFloorVersion) $(SystemRuntimeCentralFloorVersion) From 161c13d5b2b4dbb50d7a9b2e5d90f4a59966468e Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Tue, 18 Aug 2026 12:09:55 +0100 Subject: [PATCH 39/55] feat(Async): StartTaskImmediate (#20258) --- docs/release-notes/.FSharp.Core/11.0.100.md | 7 +- src/FSharp.Core/async.fs | 24 ++ src/FSharp.Core/async.fsi | 153 ++++++++- ...p.Core.SurfaceArea.netstandard20.debug.bsl | 4 + ...Core.SurfaceArea.netstandard20.release.bsl | 4 + ...p.Core.SurfaceArea.netstandard21.debug.bsl | 6 + ...Core.SurfaceArea.netstandard21.release.bsl | 6 + .../Microsoft.FSharp.Control/AsyncType.fs | 294 +++++++++++++----- 8 files changed, 407 insertions(+), 91 deletions(-) diff --git a/docs/release-notes/.FSharp.Core/11.0.100.md b/docs/release-notes/.FSharp.Core/11.0.100.md index 24d65094f16..7b2685aab02 100644 --- a/docs/release-notes/.FSharp.Core/11.0.100.md +++ b/docs/release-notes/.FSharp.Core/11.0.100.md @@ -11,6 +11,7 @@ * Added generic `print` and `printn` functions (`'T -> unit`) to `ExtraTopLevelOperators` for simple value printing to stdout. ([RFC FS-1125](https://github.com/fsharp/fslang-design/blob/main/RFCs/FS-1125-print-printn-functions.md), [PR #19265](https://github.com/dotnet/fsharp/pull/19265)) * Ship `FSharp.Core` with an additional `net10.0` target framework (next to `netstandard2.0` and `netstandard2.1`). The `net`-TFM assembly is public-surface-identical to the `netstandard2.1` one; the target version is a pinned, deliberately advanced knob. ([PR #20229](https://github.com/dotnet/fsharp/pull/20229)) * Add `Async.Await`, mirroring `Async.AwaitTask` semantics, but elides egregious `AggregateException` wrapping. Includes `ValueTask` support, and a SRTP-based overload accepting any Task-like value that supports the `GetAwaiter` protocol. ([Language Suggestion #840](https://github.com/fsharp/fslang-suggestions/issues/840), [PR #19785](https://github.com/dotnet/fsharp/pull/19785)) -* `Async.RunSynchronouslyImmediate`: runs work on the calling thread until the first asynchronous suspension (as opposed to `RunSynchronously`, which immediately offloads if not on a background and/or threadpool thread). ([Issue #1042](https://github.com/fsharp/fslang-suggestions/issues/1042), [PR #19804](https://github.com/dotnet/fsharp/pull/19804)) -* Added modules for `Async`, `Task` and `ValueTask` with consistent `result`, `map`, `bind`, `ignore`, `catchWith`, `catch`, and `empty` functions ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) -* Added conversion functions `Task.ofValueTask` and `ValueTask.ofTask`. ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) +* Add `Async.StartTaskImmediate`: passes the ambient `Async.CancellationToken` to a task factory, then await the result using `Async.Await` semantics. Overloads for `Task`, `Task<'T>`, `ValueTask`, `ValueTask<'T>` and task-like `.GetAwaiter()` (via SRTP). ([Language Suggestion #1284](https://github.com/fsharp/fslang-suggestions/issues/1284), [PR #20258](https://github.com/dotnet/fsharp/pull/20258)) +* Add `Async.RunSynchronouslyImmediate`: runs work on the calling thread until the first asynchronous suspension (as opposed to `RunSynchronously`, which immediately offloads if not on a background and/or threadpool thread). ([Issue #1042](https://github.com/fsharp/fslang-suggestions/issues/1042), [PR #19804](https://github.com/dotnet/fsharp/pull/19804)) +* Add modules for `Async`, `Task` and `ValueTask` with consistent `result`, `map`, `bind`, `ignore`, `catchWith`, `catch`, and `empty` functions ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) +* Add conversion functions `Task.ofValueTask` and `ValueTask.ofTask`. ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) diff --git a/src/FSharp.Core/async.fs b/src/FSharp.Core/async.fs index caff822709c..f9c5b63c522 100644 --- a/src/FSharp.Core/async.fs +++ b/src/FSharp.Core/async.fs @@ -2268,6 +2268,20 @@ type Async = AwaitUnitTask true (task.AsTask()) #endif + static member StartTaskImmediate(createTask: CancellationToken -> Task<'T>) : Async<'T> = + CreateBindAsync Async.CancellationToken (createTask >> Async.Await) + + static member StartTaskImmediate(createTask: CancellationToken -> Task) : Async = + CreateBindAsync Async.CancellationToken (createTask >> Async.Await) + +#if NETSTANDARD2_1 || NET + static member StartTaskImmediate(createTask: CancellationToken -> ValueTask<'T>) : Async<'T> = + CreateBindAsync Async.CancellationToken (createTask >> Async.Await) + + static member StartTaskImmediate(createTask: CancellationToken -> ValueTask) : Async = + CreateBindAsync Async.CancellationToken (createTask >> Async.Await) +#endif + module AsyncTaskLikeExtensions = type Async with @@ -2296,6 +2310,16 @@ module AsyncTaskLikeExtensions = with e -> econt e)) + [] + static member inline StartTaskImmediate< ^TaskLike, ^Awaiter, 'T + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'T)> + (createTask: CancellationToken -> ^TaskLike) + : Async<'T> = + CreateBindAsync Async.CancellationToken (createTask >> Async.Await) + module CommonExtensions = type System.IO.Stream with diff --git a/src/FSharp.Core/async.fsi b/src/FSharp.Core/async.fsi index e0631dc4cad..fc17d93973a 100644 --- a/src/FSharp.Core/async.fsi +++ b/src/FSharp.Core/async.fsi @@ -782,12 +782,16 @@ namespace Microsoft.FSharp.Control /// its result. Note exceptions are wrapped in ; for new /// code, prefer Async.Await, which surfaces single exceptions directly. /// The task to await. - /// If the task is canceled then is raised. Note + /// + ///

If the task is canceled then is raised. Note /// that the task may be governed by a different cancellation token to the overall async computation /// where the AwaitTask occurs. In practice you should normally start the task with the /// cancellation token returned by let! ct = Async.CancellationToken, and catch /// any at the point where the - /// overall async is started. + /// overall async is started.

+ ///

For the common case where you are running a Task within an Asynchronous Computation, + /// see StartTaskImmediate, which surfaces the ambient CancellationToken + /// so that it can be passed to the Task being started.

/// /// Awaiting Results /// @@ -813,12 +817,15 @@ namespace Microsoft.FSharp.Control /// Note exceptions are wrapped in ; for new /// code, prefer Async.Await, which surfaces single exceptions directly. /// The task to await. - /// If the task is canceled then is raised. Note + ///

If the task is canceled then is raised. Note /// that the task may be governed by a different cancellation token to the overall async computation /// where the AwaitTask occurs. In practice you should normally start the task with the /// cancellation token returned by let! ct = Async.CancellationToken, and catch /// any at the point where the - /// overall async is started. + /// overall async is started.

+ ///

For the common case where you are running a Task within an Asynchronous Computation, + /// see StartTaskImmediate, which surfaces the ambient CancellationToken + /// so that it can be passed to the Task being started.

/// /// Awaiting Results /// @@ -856,6 +863,9 @@ namespace Microsoft.FSharp.Control /// typically tasks should be wired to the ambient cancellation token obtained via /// let! ct = Async.CancellationToken, catching /// where the overall async is started.

+ ///

For the common case where you are running a Task within an Asynchronous Computation, + /// see StartTaskImmediate, which surfaces the ambient CancellationToken + /// so that it can be passed to the Task being started.

/// /// /// Awaiting Results @@ -893,6 +903,9 @@ namespace Microsoft.FSharp.Control /// typically tasks should be wired to the ambient cancellation token obtained via /// let! ct = Async.CancellationToken, catching /// where the overall async is started.

+ ///

For the common case where you are running a Task within an Asynchronous Computation, + /// see StartTaskImmediate, which surfaces the ambient CancellationToken + /// so that it can be passed to the Task being started.

/// /// Awaiting Results /// @@ -929,6 +942,9 @@ namespace Microsoft.FSharp.Control /// typically tasks should be wired to the ambient cancellation token obtained via /// let! ct = Async.CancellationToken, catching /// where the overall async is started.

+ ///

For the common case where you are running a Task within an Asynchronous Computation, + /// see StartTaskImmediate, which surfaces the ambient CancellationToken + /// so that it can be passed to the Task being started.

/// /// Awaiting Results /// @@ -963,6 +979,9 @@ namespace Microsoft.FSharp.Control /// typically tasks should be wired to the ambient cancellation token obtained via /// let! ct = Async.CancellationToken, catching /// where the overall async is started.

+ ///

For the common case where you are running a Task within an Asynchronous Computation, + /// see StartTaskImmediate, which surfaces the ambient CancellationToken + /// so that it can be passed to the Task being started.

/// /// Awaiting Results /// @@ -983,6 +1002,79 @@ namespace Microsoft.FSharp.Control static member Await: task: ValueTask -> Async #endif + /// Creates an asynchronous computation that passes the ambient Async.CancellationToken to + /// createTask, and then awaits the resulting task, returning its result. + /// + /// A function that accepts a CancellationToken and returns a Task<'T>. + /// + /// The cancellation token of the enclosing async computation is automatically passed to + /// createTask, propagating cancellation naturally to the task without requiring manual token capture. + /// + /// The resulting task is awaited using ; + /// exception unwrapping and cancellation handling are as per that overload. + /// + /// Starting Async Computations + /// + /// + /// async { + /// let! text = Async.StartTaskImmediate(fun ct -> File.ReadAllTextAsync("file.txt", ct)) + /// printfn "Content: %s" text + /// } + /// + /// + static member StartTaskImmediate: createTask: (CancellationToken -> Task<'T>) -> Async<'T> + + /// Creates an asynchronous computation that passes the ambient Async.CancellationToken to + /// createTask, and then awaits the resulting task. + /// + /// A function that accepts a CancellationToken and returns a Task. + /// + /// The cancellation token of the enclosing async computation is automatically passed to + /// createTask, propagating cancellation naturally to the task without requiring manual token capture. + /// + /// The resulting task is awaited using ; + /// exception unwrapping and cancellation handling are as per that overload. + /// + /// Starting Async Computations + /// + /// + /// async { + /// do! Async.StartTaskImmediate(fun ct -> File.WriteAllTextAsync("file.txt", "hello", ct)) + /// } + /// + /// + static member StartTaskImmediate: createTask: (CancellationToken -> Task) -> Async + +#if NETSTANDARD2_1 || NET + /// Creates an asynchronous computation that passes the ambient Async.CancellationToken to + /// createTask, and then awaits the resulting ValueTask, returning its result. + /// + /// A function that accepts a CancellationToken and returns a ValueTask<'T>. + /// + /// The cancellation token of the enclosing async computation is automatically passed to + /// createTask, propagating cancellation naturally to the task without requiring manual token capture. + /// + /// The resulting task is awaited using ; + /// exception unwrapping and cancellation handling are as per that overload. + /// + /// Starting Async Computations + static member StartTaskImmediate: createTask: (CancellationToken -> ValueTask<'T>) -> Async<'T> + + /// Creates an asynchronous computation that passes the ambient Async.CancellationToken to + /// createTask, and then awaits the resulting ValueTask. + /// + /// A function that accepts a CancellationToken and returns a ValueTask. + /// + /// The cancellation token of the enclosing async computation is automatically passed to + /// createTask, propagating cancellation naturally to the task without requiring manual token capture. + /// + /// The resulting task is awaited using ; + /// exception unwrapping and cancellation handling are as per that overload. + /// + /// Starting Async Computations + static member StartTaskImmediate: createTask: (CancellationToken -> ValueTask) -> Async + +#endif /// /// Creates an asynchronous computation that will sleep for the given time. This is scheduled /// using a System.Threading.Timer object. The operation will not block operating system threads @@ -1286,7 +1378,11 @@ namespace Microsoft.FSharp.Control /// Creates an asynchronous computation that will wait for the given task-like value to complete and return /// its result. /// The task-like value to await. - ///

The value must satisfy the GetAwaiter pattern: it must have a GetAwaiter() method + /// + ///

For the common case where you are running a Task within an Asynchronous Computation, + /// see StartTaskImmediate, which surfaces the ambient CancellationToken + /// so that it can be passed to the Task being started.

+ ///

The value must satisfy the GetAwaiter pattern: it must have a GetAwaiter() method /// returning an awaiter implementing /// with IsCompleted and GetResult() members.

///

Exceptions thrown by GetResult() are propagated directly.

@@ -1330,6 +1426,53 @@ namespace Microsoft.FSharp.Control and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> 'T) + /// Creates an asynchronous computation that passes the ambient Async.CancellationToken to + /// createTask, and then awaits the resulting task-like value. + /// + /// A function that accepts a CancellationToken and returns a task-like value + /// satisfying the GetAwaiter pattern. + /// + /// The value returned by createTask must satisfy the GetAwaiter pattern: it must have a + /// GetAwaiter() method returning an awaiter implementing + /// + /// with IsCompleted and GetResult() members. + /// + /// This overload uses statically resolved type parameters (SRTP) so it can accept factories returning + /// any task-like type, including YieldAwaitable (from Task.Yield()) and + /// ConfiguredTaskAwaitable (from task.ConfigureAwait(false)). + /// The specific overloads for , , + /// and + /// are preferred when the factory return type is known. + /// + /// Starting Async Computations + /// + /// + /// // Straightforward: factory returns Task<string>, which is handled by + /// // the specific Task<'T> overload of StartTaskImmediate (not this one). + /// let fetchPlain (url: string) = + /// Async.StartTaskImmediate(fun ct -> + /// httpClient.GetStringAsync(url, ct)) // returns Task<string> + /// + /// // Adding ConfigureAwait(false) to the mix yields a ConfiguredTaskAwaitable<string>, + /// // which has no specific overload — this SRTP overload handles it. + /// let fetchConfigured (url: string) = + /// Async.StartTaskImmediate(fun ct -> + /// httpClient.GetStringAsync(url, ct).ConfigureAwait(false)) + /// + /// async { + /// let! html = fetchConfigured "https://example.com" + /// printfn $"Downloaded {html.Length} chars" + /// } |> Async.RunSynchronouslyImmediate + /// + /// + [] + static member inline StartTaskImmediate< ^TaskLike, ^Awaiter, 'T> : + createTask: (CancellationToken -> ^TaskLike) -> Async<'T> + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'T) + /// The F# compiler emits references to this type to implement F# async expressions. /// /// Async Internals diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl index c1bf3c07a4e..4ecc7bb1236 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl @@ -633,6 +633,8 @@ Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn T Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.FSharpAsync`1[T] MakeAsync[T](Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Control.AsyncActivation`1[T],Microsoft.FSharp.Control.AsyncReturn]) Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], TTaskLike) Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static[TTaskLike,TAwaiter,T](TTaskLike) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.StartTaskImmediate.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,TTaskLike]) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.StartTaskImmediate.Static[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,TTaskLike]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.CommonExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncWrite(System.IO.Stream, Byte[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) @@ -657,6 +659,7 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Mic Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(Int32) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(System.TimeSpan) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] StartTaskImmediate(Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToContext(System.Threading.SynchronizationContext) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToNewThread() Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToThreadPool() @@ -677,6 +680,7 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,T](TArg1, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`3[TArg1,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`2[System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromContinuations[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`3[Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.Unit],Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,Microsoft.FSharp.Core.Unit],Microsoft.FSharp.Core.FSharpFunc`2[System.OperationCanceledException,Microsoft.FSharp.Core.Unit]],Microsoft.FSharp.Core.Unit]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] StartTaskImmediate[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[T]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] TryCancelled[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[System.OperationCanceledException,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Control.FSharpAsync: System.Threading.CancellationToken DefaultCancellationToken Microsoft.FSharp.Control.FSharpAsync: System.Threading.CancellationToken get_DefaultCancellationToken() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl index 05fbc0e0b47..520dd64a3b2 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl @@ -633,6 +633,8 @@ Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn T Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.FSharpAsync`1[T] MakeAsync[T](Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Control.AsyncActivation`1[T],Microsoft.FSharp.Control.AsyncReturn]) Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], TTaskLike) Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static[TTaskLike,TAwaiter,T](TTaskLike) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.StartTaskImmediate.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,TTaskLike]) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.StartTaskImmediate.Static[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,TTaskLike]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.CommonExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncWrite(System.IO.Stream, Byte[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) @@ -657,6 +659,7 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Mic Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(Int32) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(System.TimeSpan) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] StartTaskImmediate(Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToContext(System.Threading.SynchronizationContext) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToNewThread() Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToThreadPool() @@ -677,6 +680,7 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,T](TArg1, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`3[TArg1,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`2[System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromContinuations[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`3[Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.Unit],Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,Microsoft.FSharp.Core.Unit],Microsoft.FSharp.Core.FSharpFunc`2[System.OperationCanceledException,Microsoft.FSharp.Core.Unit]],Microsoft.FSharp.Core.Unit]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] StartTaskImmediate[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[T]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] TryCancelled[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[System.OperationCanceledException,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Control.FSharpAsync: System.Threading.CancellationToken DefaultCancellationToken Microsoft.FSharp.Control.FSharpAsync: System.Threading.CancellationToken get_DefaultCancellationToken() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl index 5d9110a09e3..93e339fd537 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl @@ -635,6 +635,8 @@ Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn T Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.FSharpAsync`1[T] MakeAsync[T](Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Control.AsyncActivation`1[T],Microsoft.FSharp.Control.AsyncReturn]) Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], TTaskLike) Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static[TTaskLike,TAwaiter,T](TTaskLike) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.StartTaskImmediate.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,TTaskLike]) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.StartTaskImmediate.Static[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,TTaskLike]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.CommonExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncWrite(System.IO.Stream, Byte[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) @@ -660,6 +662,8 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Mic Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(Int32) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(System.TimeSpan) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] StartTaskImmediate(Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] StartTaskImmediate(Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.ValueTask]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToContext(System.Threading.SynchronizationContext) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToNewThread() Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToThreadPool() @@ -681,6 +685,8 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,T](TArg1, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`3[TArg1,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`2[System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromContinuations[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`3[Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.Unit],Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,Microsoft.FSharp.Core.Unit],Microsoft.FSharp.Core.FSharpFunc`2[System.OperationCanceledException,Microsoft.FSharp.Core.Unit]],Microsoft.FSharp.Core.Unit]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] StartTaskImmediate[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[T]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] StartTaskImmediate[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.ValueTask`1[T]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] TryCancelled[T](Microsoft.FSharp.Control.FSharpAsync`1[T], Microsoft.FSharp.Core.FSharpFunc`2[System.OperationCanceledException,Microsoft.FSharp.Core.Unit]) Microsoft.FSharp.Control.FSharpAsync: System.Threading.CancellationToken DefaultCancellationToken Microsoft.FSharp.Control.FSharpAsync: System.Threading.CancellationToken get_DefaultCancellationToken() diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl index f8a069e257c..7e3fe8e9135 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl @@ -635,6 +635,8 @@ Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn T Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.FSharpAsync`1[T] MakeAsync[T](Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Control.AsyncActivation`1[T],Microsoft.FSharp.Control.AsyncReturn]) Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], TTaskLike) Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.Await.Static[TTaskLike,TAwaiter,T](TTaskLike) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.StartTaskImmediate.Static$W[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[TTaskLike,TAwaiter], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,T], Microsoft.FSharp.Core.FSharpFunc`2[TAwaiter,System.Boolean], Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,TTaskLike]) +Microsoft.FSharp.Control.AsyncTaskLikeExtensions: Microsoft.FSharp.Control.FSharpAsync`1[T] Async.StartTaskImmediate.Static[TTaskLike,TAwaiter,T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,TTaskLike]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.BackgroundTaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.CommonExtensions: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] AsyncWrite(System.IO.Stream, Byte[], Microsoft.FSharp.Core.FSharpOption`1[System.Int32], Microsoft.FSharp.Core.FSharpOption`1[System.Int32]) @@ -660,6 +662,8 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Mic Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(Int32) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Sleep(System.TimeSpan) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] StartTaskImmediate(Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] StartTaskImmediate(Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.ValueTask]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToContext(System.Threading.SynchronizationContext) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToNewThread() Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] SwitchToThreadPool() @@ -676,6 +680,8 @@ Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Await[T](System.Threading.Tasks.Task`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] Await[T](System.Threading.Tasks.ValueTask`1[T]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] AwaitTask[T](System.Threading.Tasks.Task`1[T]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] StartTaskImmediate[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[T]]) +Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] StartTaskImmediate[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.ValueTask`1[T]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,TArg3,T](TArg1, TArg2, TArg3, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`5[TArg1,TArg2,TArg3,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,TArg2,T](TArg1, TArg2, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`4[TArg1,TArg2,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.FSharpAsync: Microsoft.FSharp.Control.FSharpAsync`1[T] FromBeginEnd[TArg1,T](TArg1, Microsoft.FSharp.Core.FSharpFunc`2[System.Tuple`3[TArg1,System.AsyncCallback,System.Object],System.IAsyncResult], Microsoft.FSharp.Core.FSharpFunc`2[System.IAsyncResult,T], Microsoft.FSharp.Core.FSharpOption`1[Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit]]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs index 2ce61e65968..e77154860d1 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs @@ -11,7 +11,7 @@ open Xunit open System.Threading open System.Threading.Tasks -// Cancels default token. +// Test affects global state via Async.CancelDefaultToken [] module AsyncType = @@ -40,6 +40,7 @@ module AsyncType = async { return () } |> expect Success +// Multiple tests affect global state via Async.CancelDefaultToken [] type AsyncType() = @@ -54,20 +55,21 @@ type AsyncType() = let result = t.Wait(TimeSpan.FromSeconds(30.0)) Assert.True(result, "Task did not finish after waiting for 30 seconds.") - [] - member _.AsyncRunSynchronouslyReusesThreadPoolThread() = + [] + member _.AsyncRunSynchronouslyReusesThreadPoolThread(immediate) = + let run a = if immediate then Async.RunSynchronouslyImmediate(a) else Async.RunSynchronously(a) let action _ = async { return async { return Thread.CurrentThread.ManagedThreadId } - |> Async.RunSynchronously + |> run } // This test needs approximately 1000 ThreadPool threads // if Async.RunSynchronously doesn't reuse them. let usedThreads = Seq.init 1000 action |> Async.Parallel - |> Async.RunSynchronously + |> run |> Set.ofArray printfn $"RunSynchronously used {usedThreads.Count} threads. Environment.ProcessorCount is {Environment.ProcessorCount}." // Some arbitrary large number but in practice it should not use more threads than there are CPU cores. @@ -82,7 +84,7 @@ type AsyncType() = match sleepType with | "int32" -> Async.Sleep(10000000) | "timespan" -> Async.Sleep(10000000.0 |> TimeSpan.FromMilliseconds) - | unknown -> raise (NotImplementedException(unknown)) + | unknown -> failwith $"Unknown {unknown}" let mutable result = "" use cts = new CancellationTokenSource() Async.StartWithContinuations(computation, @@ -91,7 +93,7 @@ type AsyncType() = (fun _ -> result <- "Cancel"), cts.Token) cts.Cancel() - Async.Sleep(1000) |> Async.RunSynchronously + Async.Sleep(1000) |> Async.RunSynchronouslyImmediate Assert.AreEqual("Cancel", result) ) @@ -104,7 +106,7 @@ type AsyncType() = match sleepType with | "int32" -> Async.Sleep(10) | "timespan" -> Async.Sleep(10.0 |> TimeSpan.FromMilliseconds) - | unknown -> raise (NotImplementedException(unknown)) + | unknown -> failwith $"Unknown {unknown}" for i in 1..100 do let mutable result = "" use completedEvent = new ManualResetEvent(false) @@ -129,16 +131,16 @@ type AsyncType() = do! match sleepType with | "int32" -> Async.Sleep(-100) | "timespan" -> Async.Sleep(-100.0 |> TimeSpan.FromMilliseconds) - | unknown -> raise (NotImplementedException(unknown)) + | unknown -> failwith $"Unknown {unknown}" failwith "Expected ArgumentOutOfRangeException" with | :? ArgumentOutOfRangeException -> () - } |> Async.RunSynchronously + } |> Async.RunSynchronouslyImmediate [] member _.AsyncSleepInfinitely() = ignoreSynchCtx (fun () -> - let computation = Async.Sleep(System.Threading.Timeout.Infinite) + let computation = Async.Sleep(Timeout.Infinite) let result = TaskCompletionSource() use cts = new CancellationTokenSource(TimeSpan.FromSeconds(1.0)) // there's a long way from 1 sec to infinity, but it'll have to do. Async.StartWithContinuations(computation, @@ -146,7 +148,7 @@ type AsyncType() = (fun _ -> result.TrySetResult("Exception") |> ignore), (fun _ -> result.TrySetResult("Cancel") |> ignore), cts.Token) - let result = result.Task |> Async.AwaitTask |> Async.RunSynchronously + let result = result.Task |> Async.Await |> Async.RunSynchronouslyImmediate Assert.AreEqual("Cancel", result) ) @@ -156,7 +158,7 @@ type AsyncType() = let a = async { return s } let t : Task = Async.StartAsTask a waitForCompletion t - Assert.True (t.IsCompleted) + Assert.True(t.IsCompleted) Assert.AreEqual(s, t.Result) [] @@ -166,7 +168,7 @@ type AsyncType() = let doSpinloop () = while spinloop do () let a = async { asyncStarted.Set() - cts.CancelAfter (100) + cts.CancelAfter(100) doSpinloop() } @@ -179,7 +181,7 @@ type AsyncType() = // Should not finish, we don't eagerly mark the task done just because it's been signaled to cancel. try let result = t.Wait(1000) - Assert.False (result) + Assert.False(result) with :? AggregateException -> Assert.Fail "Task should not finish, yet" spinloop <- false @@ -198,8 +200,8 @@ type AsyncType() = [] member _.``AwaitTask ignores Async cancellation`` () = let cts = new CancellationTokenSource() - let tcs = new TaskCompletionSource() - let innerTcs = new TaskCompletionSource() + let tcs = TaskCompletionSource() + let innerTcs = TaskCompletionSource() let a = innerTcs.Task |> Async.AwaitTask Async.StartWithContinuations(a, tcs.SetResult, tcs.SetException, ignore >> tcs.SetCanceled, cts.Token) @@ -207,7 +209,7 @@ type AsyncType() = cts.CancelAfter(100) try let result = tcs.Task.Wait(300) - Assert.False (result) + Assert.False(result) with :? AggregateException -> Assert.Fail "Should not finish, yet" innerTcs.SetResult () @@ -232,12 +234,12 @@ type AsyncType() = let cancelled = try - Async.RunSynchronously(a, cancellationToken = cts.Token) |> ignore + Async.RunSynchronouslyImmediate(a, cancellationToken = cts.Token) |> ignore false with :? OperationCanceledException as o -> true | _ -> false - Assert.True (cancelled, "Task is not cancelled") + Assert.True(cancelled, "Task is not cancelled") [] member _.ExceptionPropagatesToTask () = @@ -251,7 +253,7 @@ type AsyncType() = t.Wait() with e -> exceptionThrown <- true - Assert.True (t.IsFaulted) + Assert.True(t.IsFaulted) Assert.True(exceptionThrown) [] @@ -268,7 +270,7 @@ type AsyncType() = try waitForCompletion t with e -> exceptionThrown <- true - Assert.True (exceptionThrown) + Assert.True(exceptionThrown) Assert.True(t.IsCanceled) [] @@ -291,7 +293,7 @@ type AsyncType() = try t.Wait() with e -> exceptionThrown <- true - Assert.True (exceptionThrown) + Assert.True(exceptionThrown) Assert.True(t.IsCanceled) Assert.True(cancelled) @@ -301,7 +303,7 @@ type AsyncType() = let a = async { return s } let t : Task = Async.StartImmediateAsTask a waitForCompletion t - Assert.True (t.IsCompleted) + Assert.True(t.IsCompleted) Assert.AreEqual(s, t.Result) [] @@ -310,7 +312,7 @@ type AsyncType() = let a = async { return s } let t = Async.StartImmediateAsTask a waitForCompletion t - Assert.True (t.IsCompleted) + Assert.True(t.IsCompleted) Assert.AreEqual(s, t.Result) @@ -325,7 +327,7 @@ type AsyncType() = t.Wait() with e -> exceptionThrown <- true - Assert.True (t.IsFaulted) + Assert.True(t.IsFaulted) Assert.True(exceptionThrown) [] @@ -340,7 +342,7 @@ type AsyncType() = try t.Wait() with e -> exceptionThrown <- true - Assert.True (exceptionThrown) + Assert.True(exceptionThrown) Assert.True(t.IsCanceled) [] @@ -363,7 +365,7 @@ type AsyncType() = try t.Wait() with e -> exceptionThrown <- true - Assert.True (exceptionThrown) + Assert.True(exceptionThrown) Assert.True(t.IsCanceled) Assert.True(cancelled) @@ -375,8 +377,7 @@ type AsyncType() = let! s1 = t |> if newAwait then Async.Await else Async.AwaitTask return s = s1 } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] member _.AwaitTaskCancellation(newAwait: bool) = @@ -388,8 +389,7 @@ type AsyncType() = return false with :? OperationCanceledException -> return true } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] member _.AwaitCompletedTask() = @@ -399,8 +399,7 @@ type AsyncType() = let threadIdAfter = Thread.CurrentThread.ManagedThreadId return threadIdBefore = threadIdAfter } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] member _.AwaitTaskCancellationUntyped(newAwait: bool) = @@ -412,8 +411,7 @@ type AsyncType() = return false with :? OperationCanceledException -> return true } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] member _.TaskAsyncValueException(newAwait: bool) = @@ -423,8 +421,7 @@ type AsyncType() = return false with e -> return true } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] member _.TaskAsyncValueCancellation(newAwait: bool) = @@ -457,7 +454,7 @@ type AsyncType() = do! t |> if newAwait then Async.Await else Async.AwaitTask return true } - let ok = Async.RunSynchronously a + let ok = Async.RunSynchronouslyImmediate a Assert.True(hasBeenCalled && ok) [] @@ -469,8 +466,7 @@ type AsyncType() = return false with e -> return true } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] member _.NonGenericTaskAsyncValueCancellation(newAwait: bool) = @@ -499,7 +495,7 @@ type AsyncType() = let cts = new CancellationTokenSource() let token = cts.Token let mutable hasThrown = false - token.Register(fun () -> ewh.Set() |> ignore) |> ignore + token.Register(fun () -> ewh.Set()) |> ignore let a = async { try while true do token.ThrowIfCancellationRequested() @@ -519,7 +515,7 @@ type AsyncType() = return! loop(x+1) } - try Async.RunSynchronously (loop 0) + try Async.RunSynchronously(loop 0) hasThrown <- false with Failure "finish" -> hasThrown <- true @@ -561,8 +557,7 @@ type AsyncType() = return false with :? AggregateException as ae -> return ae.InnerExceptions.Count = 2 } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] member _.``Await and AwaitTask(Task) valid AggregateException is surfaced``(newAwait) = @@ -574,8 +569,7 @@ type AsyncType() = return false with :? AggregateException as ae -> return ae.InnerExceptions.Count = 2 } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) (* Async.Await behavioral differences @@ -591,8 +585,7 @@ type AsyncType() = return false with :? AggregateException -> return true } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) // ... whereas Async.Await(Task) surfaces the inner exception directly. [] @@ -604,8 +597,7 @@ type AsyncType() = return false with :? ArgumentException as ae -> return ae.Message = "original" } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) // Async.AwaitTask(Task<'T>) surfaces the wrapping AggregateException ... [] @@ -617,8 +609,7 @@ type AsyncType() = return false with :? AggregateException -> return true } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) // ... whereas Async.Await(Task<'T>) surfaces the inner exception directly. [] @@ -630,28 +621,87 @@ type AsyncType() = return false with :? ArgumentException as ae -> return ae.Message = "original" } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) (* Await(Task/Task<'T>) overloads happy path *) [] member _.``Await(Task<'T>) happy path``() = let a = async { - let! v = Async.Await(System.Threading.Tasks.Task.FromResult(42)) + let! v = Async.Await(Task.FromResult(42)) return v = 42 } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] member _.``Await(Task) happy path``() = let a = async { - do! Async.Await(System.Threading.Tasks.Task.CompletedTask) + do! Async.Await(Task.CompletedTask) return true } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) + + (* StartTaskImmediate(Task/Task<'T>) *) + + [] + member _.``StartTaskImmediate(Task<'T>) flows result``() = + let a = async { + let! v = Async.StartTaskImmediate(fun _ct -> Task.result 42) + return v = 42 + } + Assert.True(Async.RunSynchronouslyImmediate a) + + [] + member _.``StartTaskImmediate(Task) happy path``() = + let mutable called = false + let a = async { + do! Async.StartTaskImmediate(fun _ct -> task { called <- true }) + } + Async.RunSynchronouslyImmediate a + Assert.True called + + [] + member _.``StartTaskImmediate flows CancellationToken``() = + let cts = new CancellationTokenSource() + let mutable capturedCt = CancellationToken.None + let a = async { + do! Async.StartTaskImmediate(fun ct -> task { capturedCt <- ct }) + } + Async.RunSynchronouslyImmediate(a, cancellationToken = cts.Token) + Assert.Equal(cts.Token, capturedCt) + + [] + member _.``StartTaskImmediate(Task<'T>) exception unwraps``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let a = async { + try let! _ = Async.StartTaskImmediate(fun _ct -> tcs.Task) + return false + with :? ArgumentException as ae -> return ae.Message = "original" + } + Assert.True(Async.RunSynchronouslyImmediate a) + + [] + member _.``StartTaskImmediate(Task) exception unwraps``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let a = async { + try do! Async.StartTaskImmediate(fun _ct -> tcs.Task :> Task) + return false + with :? ArgumentException as ae -> return ae.Message = "original" + } + Assert.True(Async.RunSynchronouslyImmediate a) + + [] + member _.``StartTaskImmediate(Task<'T>) cancellation raises TaskCanceledException``() = + let tcs = TaskCompletionSource() + tcs.SetCanceled() + let a = async { + try let! _ = Async.StartTaskImmediate(fun _ct -> tcs.Task) + return false + with :? TaskCanceledException -> return true + } + Assert.True(Async.RunSynchronouslyImmediate a) #if !NETFRAMEWORK (* Await(ValueTask and ValueTask<'T>) overloads coverage of mainline behaviors *) @@ -662,8 +712,7 @@ type AsyncType() = do! Async.Await(ValueTask()) return true } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True (Async.RunSynchronouslyImmediate a) [] member _.``Await(ValueTask<'T>) happy path``() = @@ -671,8 +720,7 @@ type AsyncType() = let! v = Async.Await(ValueTask(42)) return v = 42 } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True (Async.RunSynchronouslyImmediate a) [] member _.``Await(ValueTask) exception unwraps``() = @@ -684,8 +732,7 @@ type AsyncType() = return false with :? ArgumentException as ae -> return ae.Message = "original" } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] member _.``Await(ValueTask<'T>) exception unwraps``() = @@ -696,11 +743,51 @@ type AsyncType() = return false with :? ArgumentException as ae -> return ae.Message = "original" } - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) + + (* StartTaskImmediate(ValueTask/ValueTask<'T>) *) + + [] + member _.``StartTaskImmediate(ValueTask<'T>) flows result``() = + let a = async { + let! v = Async.StartTaskImmediate(fun _ct -> ValueTask(42)) + return v = 42 + } + Assert.True(Async.RunSynchronouslyImmediate a) + + [] + member _.``StartTaskImmediate(ValueTask) happy path``() = + let a = async { + do! Async.StartTaskImmediate(fun _ct -> ValueTask()) + return true + } + Assert.True(Async.RunSynchronouslyImmediate a) + + [] + member _.``StartTaskImmediate(ValueTask<'T>) exception unwraps``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let a = async { + try + let! _ = Async.StartTaskImmediate(fun _ct -> ValueTask(tcs.Task)) + return false + with :? ArgumentException as ae -> return ae.Message = "original" + } + Assert.True(Async.RunSynchronouslyImmediate a) + + [] + member _.``StartTaskImmediate(ValueTask) exception unwraps``() = + let tcs = TaskCompletionSource() + tcs.SetException(ArgumentException "original") + let a = async { + try + do! Async.StartTaskImmediate(fun _ct -> ValueTask(tcs.Task :> Task)) + return false + with :? ArgumentException as ae -> return ae.Message = "original" + } + Assert.True(Async.RunSynchronouslyImmediate a) #endif -[] module AsyncTaskLikeAwaitTests = // Minimal custom task-like type wrapping Task<'T> @@ -713,20 +800,20 @@ module AsyncTaskLikeAwaitTests = [] let ``Await(task-like) happy path with result``() = - let result = + let a = async { - let! v = Async.Await(MyTask(Task.FromResult 99)) + let! v = Async.Await(MyTask(Task.FromResult 42)) return v } - |> Async.RunSynchronously - Assert.Equal(99, result) + Assert.Equal(42, Async.RunSynchronouslyImmediate a) + [] let ``Await(task-like) happy path unit``() = async { do! Async.Await(MyUnitTask(Task.CompletedTask)) } - |> Async.RunSynchronously + |> Async.RunSynchronouslyImmediate [] let ``Await(task-like) deferred completion``() = @@ -778,8 +865,7 @@ module AsyncTaskLikeAwaitTests = return e.Message = "boom" } tcs.SetException(InvalidOperationException "boom") - let ok = Async.RunSynchronously a - Assert.True ok + Assert.True(Async.RunSynchronouslyImmediate a) [] let ``Await(YieldAwaitable) yields and resumes``() = @@ -790,7 +876,7 @@ module AsyncTaskLikeAwaitTests = do! Async.Await(Task.Yield()) after <- true } - |> Async.RunSynchronously + |> Async.RunSynchronouslyImmediate Assert.True(before && after) [] @@ -801,10 +887,51 @@ module AsyncTaskLikeAwaitTests = let! v = Async.Await(Task.FromResult(42).ConfigureAwait(false)) return v } - |> Async.RunSynchronously + |> Async.RunSynchronouslyImmediate Assert.Equal(42, result) -[] +module AsyncStartTaskImmediateTaskLikeTests = + + [] + let ``StartTaskImmediate(YieldAwaitable factory) yields and resumes``() = + // Task.Yield() returns a struct YieldAwaitable — exercises the struct-awaiter SRTP path. + let mutable before, after = false, false + + async { + before <- true + do! Async.StartTaskImmediate(fun _ -> Task.Yield()) + after <- true + } + |> Async.RunSynchronouslyImmediate + + Assert.True(before && after) + + [] + let ``StartTaskImmediate(ConfiguredTaskAwaitable factory) returns result``() = + // ConfigureAwait(false) returns a ConfiguredTaskAwaitable — a common real-world task-like. + let result = + async { + return! Async.StartTaskImmediate(fun _ -> Task.FromResult(42).ConfigureAwait(false)) + } + |> Async.RunSynchronouslyImmediate + + Assert.Equal(42, result) + + [] + let ``StartTaskImmediate flows CancellationToken``() = + // The factory receives the ambient cancellation token from the enclosing async. + let mutable capturedCt = CancellationToken.None + use cts = new CancellationTokenSource() + + let a = async { + do! Async.StartTaskImmediate(fun ct -> + capturedCt <- ct + Task.CompletedTask.ConfigureAwait(false)) + } + Async.RunSynchronouslyImmediate(a, cancellationToken = cts.Token) + + Assert.Equal(cts.Token, capturedCt) + module AsyncAwaitStackTraceTests = open System.Runtime.CompilerServices @@ -829,9 +956,9 @@ module AsyncAwaitStackTraceTests = // Run via StartImmediateAsTask + .Wait() and return the inner exception. // Using StartImmediateAsTask (not RunSynchronously) ensures that the async-layer // exception machinery goes through TaskCompletionSource.SetException, which preserves - // the stack trace rather than rethrowing synchronously and potentially truncating it. + // the stack trace rather than rethrowing synchronously and/or potentially truncating it. let runAndCaptureException (computation: Async) : exn = - // TODO swap in usage of Async.RunSynchronouslyImmediate + // TODO swap in usage of Async.RunSynchronouslyImmediate and add characterization of the stack trace behavior there as well let t = Async.StartImmediateAsTask computation let ae = Assert.Throws(fun () -> t.Wait()) ae.InnerException @@ -888,5 +1015,6 @@ module AsyncAwaitStackTraceTests = let ``Await task-like via SRTP overload: all three levels visible in stack trace`` () = let e = runAndCaptureException (async { do! Async.Await(TaskWrapper(level2Task())) }) - // 4 instead of 3 as current impl has an outer "at FSharp.Core.UnitTests.Control.AsyncAwaitStackTraceTests.e@836-9.Invoke(Tuple`3 tupledArg) + // 4 instead of 3 as current impl has an outer + // at FSharp.Core.UnitTests.Control.AsyncAwaitStackTraceTests.e@836-9.Invoke(Tuple`3 tupledArg) checkTrace 4 e \ No newline at end of file From 95ca5901c06afc7558c9d00e26839b470ec28816 Mon Sep 17 00:00:00 2001 From: "dotnet-maestro[bot]" <42748379+dotnet-maestro[bot]@users.noreply.github.com> Date: Tue, 18 Aug 2026 12:24:19 +0000 Subject: [PATCH 40/55] [main] Update dependencies from dotnet/roslyn (#20100) * Update dependencies from https://github.com/dotnet/roslyn build 20260729.11 On relative base path root Microsoft.CodeAnalysis , Microsoft.CodeAnalysis.Compilers , Microsoft.CodeAnalysis.CSharp , Microsoft.CodeAnalysis.EditorFeatures , Microsoft.CodeAnalysis.EditorFeatures.Text , Microsoft.CodeAnalysis.ExternalAccess.FSharp , Microsoft.CodeAnalysis.Features , Microsoft.VisualStudio.LanguageServices From Version 5.10.0-1.26365.3 -> To Version 5.11.0-1.26379.11 * Update dependencies from https://github.com/dotnet/roslyn build 20260730.4 On relative base path root Microsoft.CodeAnalysis , Microsoft.CodeAnalysis.Compilers , Microsoft.CodeAnalysis.CSharp , Microsoft.CodeAnalysis.EditorFeatures , Microsoft.CodeAnalysis.EditorFeatures.Text , Microsoft.CodeAnalysis.ExternalAccess.FSharp , Microsoft.CodeAnalysis.Features , Microsoft.VisualStudio.LanguageServices From Version 5.10.0-1.26365.3 -> To Version 5.11.0-1.26380.4 * Update dependencies from https://github.com/dotnet/roslyn build 20260731.6 On relative base path root Microsoft.CodeAnalysis , Microsoft.CodeAnalysis.Compilers , Microsoft.CodeAnalysis.CSharp , Microsoft.CodeAnalysis.EditorFeatures , Microsoft.CodeAnalysis.EditorFeatures.Text , Microsoft.CodeAnalysis.ExternalAccess.FSharp , Microsoft.CodeAnalysis.Features , Microsoft.VisualStudio.LanguageServices From Version 5.10.0-1.26365.3 -> To Version 5.11.0-1.26381.6 * Update dependencies from https://github.com/dotnet/roslyn build 20260731.12 On relative base path root Microsoft.CodeAnalysis , Microsoft.CodeAnalysis.Compilers , Microsoft.CodeAnalysis.CSharp , Microsoft.CodeAnalysis.EditorFeatures , Microsoft.CodeAnalysis.EditorFeatures.Text , Microsoft.CodeAnalysis.ExternalAccess.FSharp , Microsoft.CodeAnalysis.Features , Microsoft.VisualStudio.LanguageServices From Version 5.10.0-1.26365.3 -> To Version 5.11.0-1.26381.12 * Bump VS transitive package pins to satisfy Roslyn 5.11.0 dependencies Roslyn 5.11.0-1.26381.12 pulls newer transitive versions of Microsoft.ServiceHub.Framework (4.10.147), Microsoft.VisualStudio.RpcContracts (18.9.918), StreamJsonRpc (2.26.10) and Microsoft.VisualStudio.Threading (18.7.23) than the versions pinned in eng/Versions.props, causing NU1605 package-downgrade errors across the vsintegration projects. Bump the pins to match. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> * Update dependencies from https://github.com/dotnet/roslyn build 20260803.5 On relative base path root Microsoft.CodeAnalysis , Microsoft.CodeAnalysis.Compilers , Microsoft.CodeAnalysis.CSharp , Microsoft.CodeAnalysis.EditorFeatures , Microsoft.CodeAnalysis.EditorFeatures.Text , Microsoft.CodeAnalysis.ExternalAccess.FSharp , Microsoft.CodeAnalysis.Features , Microsoft.VisualStudio.LanguageServices From Version 5.10.0-1.26365.3 -> To Version 5.11.0-1.26403.5 * Pin transitive MessagePack to patched 2.5.302 in Framework.Proxy to fix NU1902/NU1903 Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> * Bump Microsoft.VisualStudio.Platform.VSEditor to 18.9.179 to match Text.* pulled by Roslyn 5.11 Roslyn 5.11 transitively bumps Microsoft.VisualStudio.Text.* / .Editor from 18.9.123 to 18.9.179. VSEditor stayed pinned at 18.9.123, whose implementation references IRtfBuilderServiceInternal (removed in Text.UI 18.9.179), so the VsMocks MEF catalog GetTypes() threw ReflectionTypeLoadException and all legacy VS unit tests failed. Bump VSEditor to the matching 18.9.179. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> * Skip flaky Fsx.Bug5073 tooltip test (non-deterministic #r resolution in FCS host) The test asserts #r "System" resolves specifically to the reference-assemblies folder, but name-based reference resolution in the FCS test host is non-deterministic and intermittently returns an empty tooltip - the same reason Fsx.HashR_QuickInfo.ResolveFromGAC is already skipped. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --------- Co-authored-by: dotnet-maestro[bot] Co-authored-by: Copilot Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> Co-authored-by: Tomas Grosup --- eng/Packages.props | 9 ++---- eng/Version.Details.props | 16 +++++----- eng/Version.Details.xml | 32 +++++++++---------- eng/Versions.props | 27 ++++++++-------- .../FSharp.Compiler.LanguageServer.fsproj | 3 +- vsintegration/Directory.Build.targets | 7 ++-- 6 files changed, 46 insertions(+), 48 deletions(-) diff --git a/eng/Packages.props b/eng/Packages.props index b609655af51..53cfe671d7b 100644 --- a/eng/Packages.props +++ b/eng/Packages.props @@ -38,7 +38,6 @@ - @@ -74,7 +73,6 @@ - @@ -86,7 +84,7 @@ - + @@ -95,11 +93,10 @@ - - - + + diff --git a/eng/Version.Details.props b/eng/Version.Details.props index cf2da9e5711..d92de9faf0a 100644 --- a/eng/Version.Details.props +++ b/eng/Version.Details.props @@ -19,14 +19,14 @@ This file should be imported by eng/Versions.props 1.0.0-prerelease.26407.1 1.0.0-prerelease.26407.1 - 5.10.0-1.26365.3 - 5.10.0-1.26365.3 - 5.10.0-1.26365.3 - 5.10.0-1.26365.3 - 5.10.0-1.26365.3 - 5.10.0-1.26365.3 - 5.10.0-1.26365.3 - 5.10.0-1.26365.3 + 5.11.0-1.26415.2 + 5.11.0-1.26415.2 + 5.11.0-1.26415.2 + 5.11.0-1.26415.2 + 5.11.0-1.26415.2 + 5.11.0-1.26415.2 + 5.11.0-1.26415.2 + 5.11.0-1.26415.2 10.0.8 10.0.8 diff --git a/eng/Version.Details.xml b/eng/Version.Details.xml index 82db3dfb115..0700d0ede13 100644 --- a/eng/Version.Details.xml +++ b/eng/Version.Details.xml @@ -18,37 +18,37 @@ https://github.com/dotnet/msbuild 842fc358af70a4ef049ba4052dab78882af557ca - + https://github.com/dotnet/roslyn - 3d32d464e2949f054086fbb5346e4beea0c6df56 + 0280f7f9457d50a46cd523ce0082807b5d70b236 - + https://github.com/dotnet/roslyn - 3d32d464e2949f054086fbb5346e4beea0c6df56 + 0280f7f9457d50a46cd523ce0082807b5d70b236 - + https://github.com/dotnet/roslyn - 3d32d464e2949f054086fbb5346e4beea0c6df56 + 0280f7f9457d50a46cd523ce0082807b5d70b236 - + https://github.com/dotnet/roslyn - 3d32d464e2949f054086fbb5346e4beea0c6df56 + 0280f7f9457d50a46cd523ce0082807b5d70b236 - + https://github.com/dotnet/roslyn - 3d32d464e2949f054086fbb5346e4beea0c6df56 + 0280f7f9457d50a46cd523ce0082807b5d70b236 - + https://github.com/dotnet/roslyn - 3d32d464e2949f054086fbb5346e4beea0c6df56 + 0280f7f9457d50a46cd523ce0082807b5d70b236 - + https://github.com/dotnet/roslyn - 3d32d464e2949f054086fbb5346e4beea0c6df56 + 0280f7f9457d50a46cd523ce0082807b5d70b236 - + https://github.com/dotnet/roslyn - 3d32d464e2949f054086fbb5346e4beea0c6df56 + 0280f7f9457d50a46cd523ce0082807b5d70b236 diff --git a/eng/Versions.props b/eng/Versions.props index 03905c8726c..c5e419f09a1 100644 --- a/eng/Versions.props +++ b/eng/Versions.props @@ -88,26 +88,26 @@ 4.6.1 4.6.3 6.1.2 - - + $(SystemSecurityCryptographyXmlVersion) $(SystemCollectionsImmutableVersion) $(SystemReflectionMetadataVersion) + $(SystemCompositionVersion) + $(SystemDiagnosticsDiagnosticSourceVersion) - + 10.0.10 $(SystemRuntimeCentralFloorVersion) $(SystemRuntimeCentralFloorVersion) $(SystemRuntimeCentralFloorVersion) + $(SystemRuntimeCentralFloorVersion) + $(SystemRuntimeCentralFloorVersion) @@ -117,9 +117,10 @@ 4.7.0 - - 18.9.123 + + 18.9.179 0.1.800-beta - + + diff --git a/vsintegration/Directory.Build.targets b/vsintegration/Directory.Build.targets index 9d253c24d27..8e31749d2a5 100644 --- a/vsintegration/Directory.Build.targets +++ b/vsintegration/Directory.Build.targets @@ -14,11 +14,10 @@ - + + - - - From 923796e42183ae55f32917581853c6e821eac3a5 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Tue, 18 Aug 2026 14:27:26 +0200 Subject: [PATCH 41/55] Add Unchecked.withNull for unconstrained C# nullable-generic interop (#20232) --- docs/release-notes/.FSharp.Core/11.0.100.md | 1 + src/FSharp.Core/prim-types.fs | 3 + src/FSharp.Core/prim-types.fsi | 9 +++ .../Nullness/NullableCsharpImportTests.fs | 65 ++++++++++++++++++- ...p.Core.SurfaceArea.netstandard20.debug.bsl | 1 + ...Core.SurfaceArea.netstandard20.release.bsl | 1 + ...p.Core.SurfaceArea.netstandard21.debug.bsl | 1 + ...Core.SurfaceArea.netstandard21.release.bsl | 1 + 8 files changed, 80 insertions(+), 2 deletions(-) diff --git a/docs/release-notes/.FSharp.Core/11.0.100.md b/docs/release-notes/.FSharp.Core/11.0.100.md index 7b2685aab02..d17942708c9 100644 --- a/docs/release-notes/.FSharp.Core/11.0.100.md +++ b/docs/release-notes/.FSharp.Core/11.0.100.md @@ -8,6 +8,7 @@ ### Added +* Add `Unchecked.withNull`, an interop escape hatch that re-types any `'T` to `'T | null` without the usual `not null`/`not struct` constraints, so unconstrained C# nullable-generic APIs (e.g. `T? M()`) can be implemented and consumed from F#. ([Issue #17734](https://github.com/dotnet/fsharp/issues/17734), [PR #20232](https://github.com/dotnet/fsharp/pull/20232)) * Added generic `print` and `printn` functions (`'T -> unit`) to `ExtraTopLevelOperators` for simple value printing to stdout. ([RFC FS-1125](https://github.com/fsharp/fslang-design/blob/main/RFCs/FS-1125-print-printn-functions.md), [PR #19265](https://github.com/dotnet/fsharp/pull/19265)) * Ship `FSharp.Core` with an additional `net10.0` target framework (next to `netstandard2.0` and `netstandard2.1`). The `net`-TFM assembly is public-surface-identical to the `netstandard2.1` one; the target version is a pinned, deliberately advanced knob. ([PR #20229](https://github.com/dotnet/fsharp/pull/20229)) * Add `Async.Await`, mirroring `Async.AwaitTask` semantics, but elides egregious `AggregateException` wrapping. Includes `ValueTask` support, and a SRTP-based overload accepting any Task-like value that supports the `GetAwaiter` protocol. ([Language Suggestion #840](https://github.com/fsharp/fslang-suggestions/issues/840), [PR #19785](https://github.com/dotnet/fsharp/pull/19785)) diff --git a/src/FSharp.Core/prim-types.fs b/src/FSharp.Core/prim-types.fs index 5ee0a4e2ff8..db555024f3c 100644 --- a/src/FSharp.Core/prim-types.fs +++ b/src/FSharp.Core/prim-types.fs @@ -5557,6 +5557,9 @@ namespace Microsoft.FSharp.Core [] let inline (|NonNullQuick|) (value : 'T | null when 'T : not null and 'T : not struct) = nonNull value + [] + let inline withNull (value: 'T) : 'T | null = (# "" value : 'T | null #) + module Checked = let inline (+) (x: ^T) (y: ^U) : ^V = diff --git a/src/FSharp.Core/prim-types.fsi b/src/FSharp.Core/prim-types.fsi index 5e306705ad3..5f7a6b9c5dc 100644 --- a/src/FSharp.Core/prim-types.fsi +++ b/src/FSharp.Core/prim-types.fsi @@ -5839,6 +5839,15 @@ namespace Microsoft.FSharp.Core [] val inline (|NonNullQuick|) : value: 'T | null -> 'T when 'T : not null and 'T : not struct + /// Unsafely retypes the value from 'T to ('T | null), bypassing the 'not null' and 'not struct' constraints that F# otherwise requires in order to write ('T | null). This is an unsafe operation. + /// This exists purely for interoperability with C# APIs that expose an unconstrained nullable generic, such as a method T? M<T>() or an interface member T? GetValue<T>(int index) where T has no class constraint and can therefore also be a struct. Without it such a signature cannot be implemented or consumed from F# without spurious FS3261 nullness warnings. + /// + /// It is unsafe precisely because it sidesteps those constraints. Unlike it adds no not null or not struct constraint, so the resulting ('T | null) can be formed even when 'T is a struct, where null is not a representable value: there the annotation carries no runtime meaning and is erased, and assigning null to such a location yields Unchecked.defaultof<'T> rather than a true null. Use it only to satisfy an interop signature. + /// The value. + /// The same value, retyped as ('T | null). + [] + val inline withNull<'T> : value: 'T -> 'T | null + /// A module of comparison and equality operators that are statically resolved, but which are not fully generic and do not make structural comparison. Opening this /// module may make code that relies on structural or generic comparison no longer compile. module NonStructuralComparison = diff --git a/tests/FSharp.Compiler.ComponentTests/Language/Nullness/NullableCsharpImportTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/Nullness/NullableCsharpImportTests.fs index 0284263d714..f3900c89b38 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/Nullness/NullableCsharpImportTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/Nullness/NullableCsharpImportTests.fs @@ -259,5 +259,66 @@ let theOtherOne = NullableClass.nullableImmArrayOfNotNullStrings |> shouldFail |> withDiagnostics [Error 3261, Line 7, Col 18, Line 7, Col 29, "Nullness warning: Possible dereference of a null value when accessing member 'Length' on the nullable value 'firstString' of type 'string | null'."] - - + +// https://github.com/dotnet/fsharp/issues/17734#issuecomment-5197965168 +// Implementing a C#-authored interface whose member returns an unconstrained 'T | null +// (e.g. SocketIO's IEventContext.GetValue). Writing the generic member with Unchecked.defaultof +// alone reports FS3261; withNull re-types it to the expected 'T | null without adding constraints. +[] +let ``Unchecked.withNull implements an unconstrained C# nullable generic member`` () = + let csharpLib = + CSharp """ +#nullable enable +namespace Interop { + public interface IEventContext { + T? GetValue(int index); + } +}""" |> withName "csEventContext" + |> withCSharpLanguageVersionPreview + + FSharp """module MyLibrary +open Interop + +let ctx = + { new IEventContext with + member _.GetValue<'T>(index: int) = Unchecked.withNull (Unchecked.defaultof<'T>) } +""" + |> asLibrary + |> withReferences [csharpLib] + |> withStrictNullness + |> compile + |> shouldSucceed + +[] +let ``Unchecked.withNull null assignment through generic layers is valid IL for structs`` () = + FSharp """module MyProgram +let observe (v: 'T) : objnull = + let mutable x = Unchecked.withNull v + x <- null + box x + +let forward (v: 'T) = observe v + +[] +let main _ = + System.Console.Write(sprintf "%A %b" (forward 42) (isNull (forward "hello"))) + 0 +""" + |> withStrictNullness + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "0 true" + +[] +let ``Unchecked.withNull does not allow assigning null to a concrete struct mutable`` () = + FSharp """module MyLibrary +let f () = + let mutable x = Unchecked.withNull 42 + x <- null +""" + |> asLibrary + |> withStrictNullness + |> typecheck + |> shouldFail + |> withErrorCode 43 + diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl index 4ecc7bb1236..5c26ed42a87 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl @@ -1848,6 +1848,7 @@ Microsoft.FSharp.Core.Operators+Unchecked: T DefaultOf[T]() Microsoft.FSharp.Core.Operators+Unchecked: T NonNullQuickPattern[T](T) Microsoft.FSharp.Core.Operators+Unchecked: T NonNull[T](T) Microsoft.FSharp.Core.Operators+Unchecked: T Unbox[T](System.Object) +Microsoft.FSharp.Core.Operators+Unchecked: T WithNull[T](T) Microsoft.FSharp.Core.Operators: Boolean IsNullV[T](System.Nullable`1[T]) Microsoft.FSharp.Core.Operators: Boolean IsNull[T](T) Microsoft.FSharp.Core.Operators: Boolean Not(Boolean) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl index 520dd64a3b2..ed1221c1a43 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl @@ -1848,6 +1848,7 @@ Microsoft.FSharp.Core.Operators+Unchecked: T DefaultOf[T]() Microsoft.FSharp.Core.Operators+Unchecked: T NonNullQuickPattern[T](T) Microsoft.FSharp.Core.Operators+Unchecked: T NonNull[T](T) Microsoft.FSharp.Core.Operators+Unchecked: T Unbox[T](System.Object) +Microsoft.FSharp.Core.Operators+Unchecked: T WithNull[T](T) Microsoft.FSharp.Core.Operators: Boolean IsNullV[T](System.Nullable`1[T]) Microsoft.FSharp.Core.Operators: Boolean IsNull[T](T) Microsoft.FSharp.Core.Operators: Boolean Not(Boolean) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl index 93e339fd537..94ff0a6b538 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl @@ -1865,6 +1865,7 @@ Microsoft.FSharp.Core.Operators+Unchecked: T DefaultOf[T]() Microsoft.FSharp.Core.Operators+Unchecked: T NonNullQuickPattern[T](T) Microsoft.FSharp.Core.Operators+Unchecked: T NonNull[T](T) Microsoft.FSharp.Core.Operators+Unchecked: T Unbox[T](System.Object) +Microsoft.FSharp.Core.Operators+Unchecked: T WithNull[T](T) Microsoft.FSharp.Core.Operators: Boolean IsNullV[T](System.Nullable`1[T]) Microsoft.FSharp.Core.Operators: Boolean IsNull[T](T) Microsoft.FSharp.Core.Operators: Boolean Not(Boolean) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl index 7e3fe8e9135..acb7fdf1e3f 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl @@ -1865,6 +1865,7 @@ Microsoft.FSharp.Core.Operators+Unchecked: T DefaultOf[T]() Microsoft.FSharp.Core.Operators+Unchecked: T NonNullQuickPattern[T](T) Microsoft.FSharp.Core.Operators+Unchecked: T NonNull[T](T) Microsoft.FSharp.Core.Operators+Unchecked: T Unbox[T](System.Object) +Microsoft.FSharp.Core.Operators+Unchecked: T WithNull[T](T) Microsoft.FSharp.Core.Operators: Boolean IsNullV[T](System.Nullable`1[T]) Microsoft.FSharp.Core.Operators: Boolean IsNull[T](T) Microsoft.FSharp.Core.Operators: Boolean Not(Boolean) From 732b1cdb6ef17e823c82d94e00d867a0cac7b8aa Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Wed, 19 Aug 2026 08:25:42 +0200 Subject: [PATCH 42/55] Add Chiron to the compiler regression-test matrix (#20281) Chiron's chiron-6 branch serializes through Aether 8.2.0's `inline` SRTP optics, which reproduces the SDK 10.0.400 legacy cross-assembly inline-metadata regression (#20253, fixed by #20260). The bug is runtime-only: a compiler that misreads Aether's legacy pickled inline flag drops the inline body and emits a call to the dynamic-invocation stub, so the build stays clean but System.NotSupportedException is thrown at run time. The matrix entry therefore runs Chiron's own xunit suite, filtered to the Aether Optic get/set/map tests that exercise the miscompiled path; a build-only check would pass despite the bug. Two sed edits only retarget dead frameworks (the library's net452 leg cannot restore on a current SDK; the test project targets the removed netcoreapp2.0) and change no test logic. Verified: the Optic tests fail with NotSupportedException on SDK 10.0.400, and all pass with the compiler built from main. Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> --- azure-pipelines-PR.yml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index bac84adeb5b..cffa4a128cf 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -845,3 +845,9 @@ stages: displayName: FSharpDataGraphQL_DesignTimeProvider_Packaging useVmImage: $(LinuxMachineQueueName) usePool: $(DncEngPublicBuildPool) + # Chiron (chiron-6) exercises Aether 8.2.0 inline SRTP optics, reproducing the SDK 10.0.400 legacy inline-metadata + # regression (#20253, fixed by #20260): the miscompile throws NotSupportedException at run time, so run the tests. + - repo: xyncro/chiron + commit: 94cf9db1793a1bd0e6e0b69efadcfb37368a6428 + buildScript: dotnet test tests/Chiron.Tests/Chiron.Tests.fsproj -c Release -p:AssetTargetFallback=net461 -p:RollForward=Major --filter FullyQualifiedName~Optic + displayName: Chiron_Aether_Inline_SRTP From 344602ce8acd3a8492b87749cce1166ef9073880 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Wed, 19 Aug 2026 11:07:40 +0200 Subject: [PATCH 43/55] Restore source-build overridable prop names for runtime packages (#20290) * Restore source-build overridable prop names for runtime packages The CPM central pins for the MSBuild/Roslyn-pulled dotnet/runtime packages (System.Collections.Immutable, System.Reflection.Metadata, System.Composition, System.Diagnostics.DiagnosticSource, System.Security.Cryptography.Xml) were routed through intermediate ...CentralVersion properties with a 10.0.10 floor. Source-build injects live runtime versions by overriding $(System*Version) (via PackageVersions.fsharp.props), but the renamed ...CentralVersion pins were frozen before that override and could not be set by source-build, so the floor forced 10.0.10 while source-build provided 10.0.9 -> prebuilt + downgrade. Reference $(System*Version) directly in eng/Packages.props (matching roslyn), drop the floor scaffolding, and declare the packages at 10.0.10 in Version.Details so product/PR restore satisfies MSBuild 18.11 / Roslyn 5.11 without a downgrade. Source-build overrides these to its live runtime version. --- .../EngVersioning.instructions.md | 17 +++++ docs/postmortems/README.md | 1 + ...n-sourcebuild-cpm-runtime-version-floor.md | 76 +++++++++++++++++++ eng/Packages.props | 10 +-- eng/Version.Details.props | 8 +- eng/Version.Details.xml | 8 +- eng/Versions.props | 20 ----- 7 files changed, 107 insertions(+), 33 deletions(-) create mode 100644 .github/instructions/EngVersioning.instructions.md create mode 100644 docs/postmortems/regression-sourcebuild-cpm-runtime-version-floor.md diff --git a/.github/instructions/EngVersioning.instructions.md b/.github/instructions/EngVersioning.instructions.md new file mode 100644 index 00000000000..391be9544dc --- /dev/null +++ b/.github/instructions/EngVersioning.instructions.md @@ -0,0 +1,17 @@ +--- +applyTo: + - "eng/Packages.props" + - "eng/Versions.props" + - "eng/Version.Details.xml" + - "eng/Version.Details.props" +--- + +These files feed the VMR source-build. The `System.*` dotnet/runtime packages marked *"Necessary for source-build"* in `eng/Version.Details.xml` are overridden at build time by the VMR's generated `PackageVersions.fsharp.props`, which replaces the darc-named `$(System*Version)` properties (e.g. `$(SystemCollectionsImmutableVersion)`) with the live source-built runtime version. + +Rules: + +- Consume those packages in `eng/Packages.props` through `$(System*Version)` **directly**. Never route them through a renamed or computed alias (e.g. a `$(System*CentralVersion)`) or a version floor — source-build overrides the darc-named property, and a renamed/eagerly-computed intermediate freezes the value so the override never reaches CPM, causing prebuilt packages and `NU1109` downgrades in the source-only build. +- When a transitive consumer (MSBuild, Roslyn) requires a higher minimum than the flowed baseline, raise the declared version in `eng/Version.Details.{xml,props}` instead of adding a floor. Source-build overrides it back down to the live runtime version; product/PR restore uses the declared value. +- fsharp PR/CI does **not** run the VMR source-only prebuilt gate (`SB_CentOSStream10_Online_MsftSdk_x64`), so a green PR restore does not prove source-build correctness. Reason about these edits against source-build. + +See `docs/postmortems/regression-sourcebuild-cpm-runtime-version-floor.md` for why. diff --git a/docs/postmortems/README.md b/docs/postmortems/README.md index 5fa97424857..8d3bc9a6166 100644 --- a/docs/postmortems/README.md +++ b/docs/postmortems/README.md @@ -8,3 +8,4 @@ These are referenced from [agentic instructions](../../.github/instructions/) an - [`regression-fs0229-bstream-misalignment.md`](regression-fs0229-bstream-misalignment.md) — a conditional write with an unconditional read shifted the pickle B-stream, producing `FS0229` when reading older metadata. - [`regression-legacy-inline-metadata-dynamic-invocation.md`](regression-legacy-inline-metadata-dynamic-invocation.md) — a new inline-flag case reused a serialized bit pattern that already meant "required inline" in F# 5 binaries, breaking cross-assembly SRTP at runtime. +- [`regression-sourcebuild-cpm-runtime-version-floor.md`](regression-sourcebuild-cpm-runtime-version-floor.md) — renaming the CPM runtime-package pins to computed `$(System*CentralVersion)` aliases with a floor defeated source-build's `$(System*Version)` override, causing prebuilt/`NU1109` failures in the VMR that fsharp CI could not see. diff --git a/docs/postmortems/regression-sourcebuild-cpm-runtime-version-floor.md b/docs/postmortems/regression-sourcebuild-cpm-runtime-version-floor.md new file mode 100644 index 00000000000..43b3eb8504d --- /dev/null +++ b/docs/postmortems/regression-sourcebuild-cpm-runtime-version-floor.md @@ -0,0 +1,76 @@ +# Regression: renamed CPM runtime-package pins broke VMR source-build + +## Summary + +To satisfy CPM transitive pinning, the central versions of the dotnet/runtime packages that MSBuild and Roslyn pull (`System.Collections.Immutable`, `System.Reflection.Metadata`, `System.Composition`, `System.Diagnostics.DiagnosticSource`, `System.Security.Cryptography.Xml`) were routed through computed `$(System*CentralVersion)` properties with a version floor, instead of the darc-named `$(System*Version)` properties. Source-build injects live runtime versions by overriding the darc-named properties, so the renamed, eagerly-floored pins froze at the floor value and the override never reached CPM. In the .NET 11 RC1 VMR the floor demanded `10.0.10` while source-build supplied the live `10.0.9`, producing prebuilt packages and `NU1109` downgrade errors that blocked the fsharp forward-flow (dotnet/dotnet#8413, #8414, #8415). Caught at the VMR source-only gate; it never shipped. + +## Error Manifestation + +The `VMR Source-Only Build SB_CentOSStream10_Online_MsftSdk_x64` leg failed two ways. + +Prebuilt detection: + +```text +eng/finish-source-only.proj(141,5): error : Prebuilt packages are not allowed in source-only builds. +Detected 1 prebuilt package(s): + - System.Diagnostics.DiagnosticSource.10.0.10 +``` + +And, once the floor was partially relaxed, a downgrade in `fsc`/`fsi`: + +```text +error NU1109: Detected package downgrade: System.Collections.Immutable from 10.0.10 to centrally defined 10.0.9. + fsi -> Microsoft.Build.Framework 18.11.0-1.26417.9 -> System.Collections.Immutable (>= 10.0.10) + fsi -> System.Collections.Immutable (>= 10.0.9) +``` + +fsharp's own PR/CI legs were green throughout — the failure appeared only downstream in dotnet/dotnet. + +## Root Cause + +fsharp declares these `System.*` packages in `eng/Version.Details.xml` with an empty `` and the note *"Necessary for source-build. This allows the live version of the package to be used by source-build."* When the VMR builds fsharp it passes `/p:DotNetPackageVersionPropsPath=…/PackageVersions.fsharp.props`, a generated file that **unconditionally overrides the darc-named properties** — `$(SystemCollectionsImmutableVersion)`, etc. — with the live runtime version it just source-built. Whatever CPM reads must be that exact property for the override to take effect. + +The CPM-transitive-pinning work introduced an indirection instead: + +```xml + +$(SystemCollectionsImmutableVersion) + + $(SystemRuntimeCentralFloorVersion) + +``` + +`eng/Packages.props` then pinned `Version="$(SystemCollectionsImmutableCentralVersion)"`. Two mistakes combined: + +1. **Rename.** Source-build overrides `$(SystemCollectionsImmutableVersion)`, not `$(...CentralVersion)`. The alias is a different property that source-build has no knowledge of. +2. **Eager floor.** `$(...CentralVersion)` is computed once, before arcade imports `PackageVersions.fsharp.props`, and is `max(flowed, floor)`. Even in source-build it evaluated to the floor. + +So the central pin froze at the floor (`10.0.10`). Source-build only produces the live runtime (`10.0.9`), which cannot satisfy a `10.0.10` pin from within the source tree, so restore reached an external feed → prebuilt; and where the graph also carried a `10.0.9` constraint, `NU1109` downgrade. + +The violated assumption: **a source-build "live version" package must be consumed through the exact darc-named `$(System*Version)` property; any renamed or computed intermediate silently defeats the override.** roslyn's `eng/Packages.props` does the correct thing — it references `$(SystemCollectionsImmutableVersion)` directly. + +## Why It Escaped + +fsharp's PR/CI restores are allowed to pull from nuget.org, where `10.0.10` exists. The floored pin resolved cleanly there, so every fsharp leg — including its own `Source-Build (Managed)` legs — was green. The only environment that rejects an out-of-tree package is the VMR source-**only** prebuilt gate (`SB_CentOSStream10_Online_MsftSdk_x64`), which fsharp CI does not run. The defect was therefore structurally invisible until the change forward-flowed into dotnet/dotnet, roughly a day later. + +It also recurred: the same source-build/runtime coherency was fought three times — the MSBuild pin (#20073), the CPM floor (#20084, extended by #20100), and the MSBuild unpin (#20278) — before the direct-property pattern fixed it. + +## Fix + +[#20290](https://github.com/dotnet/fsharp/pull/20290): reference `$(System*Version)` directly in `eng/Packages.props` (matching roslyn), delete the `$(...CentralVersion)`/`SystemRuntimeCentralFloorVersion` scaffolding from `eng/Versions.props`, and declare the packages at `10.0.10` in `eng/Version.Details.{xml,props}` so product/PR restore meets the MSBuild 18.11 / Roslyn 5.11 transitive minimum. In source-build, `PackageVersions.fsharp.props` overrides those same properties down to the live runtime version, so the pin always tracks what the VMR actually builds. Verified by feeding a simulated `PackageVersions.fsharp.props` through `/p:DotNetPackageVersionPropsPath`: with the fix CPM resolves the injected `10.0.9`; with the old alias it stayed frozen at `10.0.10`. + +## Timeline + +| Date (2026) | PR | Event | +| --- | --- | --- | +| 08-04 | #20084 | CPM + transitive pinning introduces `$(System*CentralVersion)` + floor (latent). | +| 08-13 | #20073 | MSBuild pinned at `18.10.0-1.26370.18` (kept net10 assets for the then-net10 product). | +| 08-18 | #20100 | Floor extended to the Roslyn-pulled `System.*` packages. | +| 08-18 | #20278 | MSBuild unpinned to `18.11` line; floor bumped to `10.0.10`, expanded to 5 packages. | +| 08-19 | dotnet/dotnet#8413/#8414/#8415 | Forward-flow source-only build fails: prebuilt `DiagnosticSource 10.0.10` + `NU1109`. | +| 08-19 | #20290 | Direct `$(System*Version)`, floor removed, declared `10.0.10`. | + +## Prevention + +`.github/instructions/EngVersioning.instructions.md` scoped to `eng/Packages.props`, `eng/Versions.props`, and `eng/Version.Details.{xml,props}` encodes the rule: consume source-build "live version" packages through the darc-named `$(System*Version)` property directly; never route them through a renamed or computed central alias/floor. When a transitive consumer (MSBuild, Roslyn) needs a higher minimum than the flowed baseline, raise the declared version in `eng/Version.Details.*` rather than adding a floor — source-build overrides it back down to the live runtime version. fsharp CI cannot reproduce the VMR source-only prebuilt gate, so these files must be reasoned about against source-build, not just a green PR restore. diff --git a/eng/Packages.props b/eng/Packages.props index 53cfe671d7b..8e3c5e1caac 100644 --- a/eng/Packages.props +++ b/eng/Packages.props @@ -94,14 +94,14 @@ - - - + + + - + - + diff --git a/eng/Version.Details.props b/eng/Version.Details.props index d92de9faf0a..ff921b4a8cb 100644 --- a/eng/Version.Details.props +++ b/eng/Version.Details.props @@ -28,10 +28,10 @@ This file should be imported by eng/Versions.props 5.11.0-1.26415.2 5.11.0-1.26415.2 - 10.0.8 - 10.0.8 - 10.0.8 - 10.0.8 + 10.0.10 + 10.0.10 + 10.0.10 + 10.0.10 10.0.10 diff --git a/eng/Version.Details.xml b/eng/Version.Details.xml index 0700d0ede13..fc0c24a12e5 100644 --- a/eng/Version.Details.xml +++ b/eng/Version.Details.xml @@ -51,25 +51,25 @@ 0280f7f9457d50a46cd523ce0082807b5d70b236 - + https://github.com/dotnet/runtime - + https://github.com/dotnet/runtime - + https://github.com/dotnet/runtime - + https://github.com/dotnet/runtime diff --git a/eng/Versions.props b/eng/Versions.props index c5e419f09a1..32cd8b7b8c9 100644 --- a/eng/Versions.props +++ b/eng/Versions.props @@ -88,26 +88,6 @@ 4.6.1 4.6.3 6.1.2 - - $(SystemSecurityCryptographyXmlVersion) - $(SystemCollectionsImmutableVersion) - $(SystemReflectionMetadataVersion) - $(SystemCompositionVersion) - $(SystemDiagnosticsDiagnosticSourceVersion) - - - - - 10.0.10 - $(SystemRuntimeCentralFloorVersion) - $(SystemRuntimeCentralFloorVersion) - $(SystemRuntimeCentralFloorVersion) - $(SystemRuntimeCentralFloorVersion) - $(SystemRuntimeCentralFloorVersion) From 1e0a6e7d0480a1b34d365caa7be00271df755c78 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 19 Aug 2026 11:33:50 +0200 Subject: [PATCH 44/55] Add regression test for #14596: type inference in task CE (#20257) Fixes https://github.com/dotnet/fsharp/issues/14596 Co-authored-by: github-actions[bot] <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- .../ConstraintSolver/TaskCETypeInference.fs | 41 +++++++++++++++++++ .../FSharp.Compiler.ComponentTests.fsproj | 1 + 2 files changed, 42 insertions(+) create mode 100644 tests/FSharp.Compiler.ComponentTests/ConstraintSolver/TaskCETypeInference.fs diff --git a/tests/FSharp.Compiler.ComponentTests/ConstraintSolver/TaskCETypeInference.fs b/tests/FSharp.Compiler.ComponentTests/ConstraintSolver/TaskCETypeInference.fs new file mode 100644 index 00000000000..a02427f567f --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/ConstraintSolver/TaskCETypeInference.fs @@ -0,0 +1,41 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Compiler.ComponentTests.ConstraintSolver + +open Xunit +open FSharp.Test.Compiler + +module TaskCETypeInference = + + // https://github.com/dotnet/fsharp/issues/14596 + [] + let ``Issue 14596 - Type inference in backgroundTask CE should not produce FS0073`` () = + FSharp + """ +module UnresolvedTypeVarBug + +type IMarker<'T> = interface end +type SomeAction<'T when 'T :> IMarker<'T>> = SomeAction of list<'T> +type Spec<'Action> = { Dummy: unit } + +open System.Threading.Tasks + +let dummyTask (_spec: Spec<'Action>) (_action: 'Action) : Task> = failwith "not implemented" + +let repro (spec: Spec>) + : Task> = + + backgroundTask { + let action = SomeAction [] + let! res = dummyTask spec action + + match res with + | Ok _ -> + return Ok () + | Error err -> + return Error err + } + """ + |> asLibrary + |> typecheck + |> shouldSucceed diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 2d033e260dc..487b1d3ace2 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -404,6 +404,7 @@ + From b413249638dd268626ad30aa88a64411016fc7ba Mon Sep 17 00:00:00 2001 From: Vladimir Shchur Date: Wed, 19 Aug 2026 02:34:18 -0700 Subject: [PATCH 45/55] Add build step for Oxpecker_Solid (#20262) --- azure-pipelines-PR.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index cffa4a128cf..2bc43bc24b2 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -835,6 +835,11 @@ stages: buildScript: dotnet build Oxpecker.slnx -c Release displayName: Oxpecker_Build expectLocalCore: true + - repo: Lanayx/Oxpecker + commit: cb7e4b83e3f2aba7ded46b17a36d1aea8c13c292 + buildScript: dotnet build Oxpecker.Solid.slnx -c Release + displayName: Oxpecker_Solid_Build + expectLocalCore: true # Design-time provider packaging oracle. Pin d8aba70 (pre-workaround base of FSharp.Data.GraphQL#583): # it uses the bare IsFSharpDesignTimeProvider gesture, so the client pack drops the provider without this fix. # Linux-only: the $PWD local feed and the grep content assertion need bash. (nupkg entry names are stored From c01bfbd46e671721501c4d68db8f8576326cf815 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 19 Aug 2026 11:45:03 +0200 Subject: [PATCH 46/55] IL: share ILCallingConv instances (#20254) * IL: share ILCallingConv instances There are only 18 combinations of ILThisConvention and ILArgConvention. Pre-create all of them and hand out the shared instance from ILCallingConv.Create, so reading a method signature no longer allocates a Callconv. The two existing statics (Instance, Static) are placed in the table too, so every use shares one instance per combination. The index is computed with explicit matches rather than by casting the union tags, so adding a case to either union is a compile error here instead of a bad index. Co-Authored-By: Claude Opus 5 (1M context) --- .../.FSharp.Compiler.Service/11.0.100.md | 5 +- src/Compiler/AbstractIL/il.fs | 48 +++++++++++++++++++ src/Compiler/AbstractIL/il.fsi | 15 ++++-- src/Compiler/AbstractIL/ilpars.fsy | 6 +-- src/Compiler/AbstractIL/ilprint.fs | 6 +-- src/Compiler/AbstractIL/ilread.fs | 2 +- src/Compiler/AbstractIL/ilreflect.fs | 6 +-- src/Compiler/AbstractIL/ilwrite.fs | 6 +-- src/Compiler/TypedTree/TypedTreePickle.fs | 6 +-- ...iler.Service.SurfaceArea.netstandard20.bsl | 18 ++++--- .../ModuleReaderCancellationTests.fs | 2 +- 11 files changed, 89 insertions(+), 31 deletions(-) diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index 9690a6c3c3d..0c576e47667 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -166,13 +166,14 @@ * Support for the `` XML documentation tag: at compile time, documentation is copied from an external XML file selected by an XPath query and emitted into the generated documentation file. `` remains unsupported. ([Issue #19175](https://github.com/dotnet/fsharp/issues/19175), [PR #19186](https://github.com/dotnet/fsharp/pull/19186)) * Expand `` at tooling time. In IDE tooltips, completion, and signature help, documentation is inherited from base classes, interfaces, overridden members, and constructors (matched by parameter signature). The FCS Symbols API (`FSharpSymbol.XmlDoc`) additionally resolves explicit `cref` targets, but does not expand constructor inheritance. The compiler emits the tag verbatim into generated XML documentation files, matching C#; `` is not implemented. ([Issue #19175](https://github.com/dotnet/fsharp/issues/19175), [PR #19188](https://github.com/dotnet/fsharp/pull/19188)) * Add symbol and type highlighting to F# diagnostics ([PR #20097](https://github.com/dotnet/fsharp/pull/20097)) -* IL: add `ILPreNamespace`, make `ILPreTypeDef` creation lazy ([PR #20092](https://github.com/dotnet/fsharp/pull/20092)) -* IL: use empty tables for members when possible ([PR #20249](https://github.com/dotnet/fsharp/pull/20249)) ### Improved * Nullness warning FS3261 on dotted method or property access (e.g. `x.Member`) now underlines the receiver expression and includes the member name and (when known) the binding name in the message. ([Issue #19658](https://github.com/dotnet/fsharp/issues/19658), [PR #19814](https://github.com/dotnet/fsharp/pull/19814)) * Direct delegate construction ([PR ##19993](https://github.com/dotnet/fsharp/pull/19993)) +* IL: add `ILPreNamespace`, make `ILPreTypeDef` creation lazy ([PR #20092](https://github.com/dotnet/fsharp/pull/20092)) +* IL: share ILCallingConv instances ([PR #20254](https://github.com/dotnet/fsharp/pull/20254)) +* IL: use empty tables for members when possible ([PR #20249](https://github.com/dotnet/fsharp/pull/20249)) ### Changed * The `--warnaserror` option now ignores unrecognized diagnostic identifiers in warning lists while still applying recognized F# warning codes. ([PR #20246](https://github.com/dotnet/fsharp/pull/20246)) diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index 0aa4e76ecf4..8b7eeb25aee 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -683,6 +683,9 @@ type ILCallingConv = static member Static = ILCallingConvStatics.Static + static member Create(thisConv, argConv) = + ILCallingConvStatics.Get(thisConv, argConv) + override x.ToString() = if x.IsStatic then "static" else "instance" @@ -693,10 +696,55 @@ and ILCallingConvStatics() = static let staticCallConv = Callconv(ILThisConvention.Static, ILArgConvention.Default) + /// Every combination, so that reading metadata never allocates a calling convention. The two + /// common ones above are placed in the table too, so all uses share one instance per combination. + static let allCallConvs = + let thisConvs = + [| + ILThisConvention.Instance + ILThisConvention.InstanceExplicit + ILThisConvention.Static + |] + + let argConvs = + [| + ILArgConvention.Default + ILArgConvention.CDecl + ILArgConvention.StdCall + ILArgConvention.ThisCall + ILArgConvention.FastCall + ILArgConvention.VarArg + |] + + Array.init (thisConvs.Length * argConvs.Length) (fun i -> + match thisConvs[i / argConvs.Length], argConvs[i % argConvs.Length] with + | ILThisConvention.Instance, ILArgConvention.Default -> instanceCallConv + | ILThisConvention.Static, ILArgConvention.Default -> staticCallConv + | thisConv, argConv -> Callconv(thisConv, argConv)) + static member Instance = instanceCallConv static member Static = staticCallConv + static member Get(thisConv, argConv) = + // Explicit, so adding a case to either union is a compile error here rather than a bad index. + let thisIdx = + match thisConv with + | ILThisConvention.Instance -> 0 + | ILThisConvention.InstanceExplicit -> 1 + | ILThisConvention.Static -> 2 + + let argIdx = + match argConv with + | ILArgConvention.Default -> 0 + | ILArgConvention.CDecl -> 1 + | ILArgConvention.StdCall -> 2 + | ILArgConvention.ThisCall -> 3 + | ILArgConvention.FastCall -> 4 + | ILArgConvention.VarArg -> 5 + + allCallConvs[thisIdx * 6 + argIdx] + type ILBoxity = | AsObject | AsValue diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi index 8e82bd176fb..aa2e7c69b2f 100644 --- a/src/Compiler/AbstractIL/il.fsi +++ b/src/Compiler/AbstractIL/il.fsi @@ -175,17 +175,22 @@ type ILThisConvention = [] type ILCallingConv = + private | Callconv of ILThisConvention * ILArgConvention - member internal IsInstance: bool - member internal IsInstanceExplicit: bool - member internal IsStatic: bool - member internal ThisConv: ILThisConvention - member internal BasicConv: ILArgConvention + member IsInstance: bool + member IsInstanceExplicit: bool + member IsStatic: bool + member ThisConv: ILThisConvention + member BasicConv: ILArgConvention static member Instance: ILCallingConv static member Static: ILCallingConv + /// Returns the shared instance for this combination. Since the representation is private and there + /// are only 18 combinations, no calling convention is ever allocated per method signature. + static member Create: ILThisConvention * ILArgConvention -> ILCallingConv + /// Array shapes. For most purposes the rank is the only thing that matters. type internal ILArrayBound = int32 option diff --git a/src/Compiler/AbstractIL/ilpars.fsy b/src/Compiler/AbstractIL/ilpars.fsy index ca06f6570be..1b5417e24be 100644 --- a/src/Compiler/AbstractIL/ilpars.fsy +++ b/src/Compiler/AbstractIL/ilpars.fsy @@ -189,11 +189,11 @@ typSpec: callConv: INSTANCE callKind - { Callconv (ILThisConvention.Instance,$2) } + { ILCallingConv.Create (ILThisConvention.Instance,$2) } | EXPLICIT callKind - { Callconv (ILThisConvention.InstanceExplicit,$2) } + { ILCallingConv.Create (ILThisConvention.InstanceExplicit,$2) } | callKind - { Callconv (ILThisConvention.Static,$1) } + { ILCallingConv.Create (ILThisConvention.Static,$1) } callKind: /* EMPTY */ diff --git a/src/Compiler/AbstractIL/ilprint.fs b/src/Compiler/AbstractIL/ilprint.fs index f1fb38174c9..0a892c76d3d 100644 --- a/src/Compiler/AbstractIL/ilprint.fs +++ b/src/Compiler/AbstractIL/ilprint.fs @@ -365,15 +365,15 @@ and output_bcc os bcc = | ILArgConvention.Default -> " " | ILArgConvention.VarArg -> "vararg ") -and output_callconv os (Callconv(hasthis, cc)) = +and output_callconv os (callconv: ILCallingConv) = output_string os - (match hasthis with + (match callconv.ThisConv with | ILThisConvention.Instance -> "instance " | ILThisConvention.InstanceExplicit -> "explicit " | ILThisConvention.Static -> "") - output_bcc os cc + output_bcc os callconv.BasicConv and goutput_dlocref env os (dref: ILType) = match dref with diff --git a/src/Compiler/AbstractIL/ilread.fs b/src/Compiler/AbstractIL/ilread.fs index bc31548cbdd..d0eae0bc82f 100644 --- a/src/Compiler/AbstractIL/ilread.fs +++ b/src/Compiler/AbstractIL/ilread.fs @@ -2861,7 +2861,7 @@ and byteAsCallConv b = ILArgConvention.Default let generic = (b &&& e_IMAGE_CEE_CS_CALLCONV_GENERIC) <> 0x0uy - generic, Callconv(byteAsHasThis b, cc) + generic, ILCallingConv.Create(byteAsHasThis b, cc) and seekReadMemberRefAsMethodData ctxt numTypars idx : VarArgMethodData = ctxt.seekReadMemberRefAsMethodData (MemberRefAsMspecIdx(numTypars, idx)) diff --git a/src/Compiler/AbstractIL/ilreflect.fs b/src/Compiler/AbstractIL/ilreflect.fs index 9aa9d6403a0..78b1fdf8b67 100644 --- a/src/Compiler/AbstractIL/ilreflect.fs +++ b/src/Compiler/AbstractIL/ilreflect.fs @@ -694,15 +694,15 @@ let envPopEntryPts emEnv = // convCallConv //---------------------------------------------------------------------------- -let convCallConv (Callconv(hasThis, basic)) = +let convCallConv (callConv: ILCallingConv) = let ccA = - match hasThis with + match callConv.ThisConv with | ILThisConvention.Static -> CallingConventions.Standard | ILThisConvention.InstanceExplicit -> CallingConventions.ExplicitThis | ILThisConvention.Instance -> CallingConventions.HasThis let ccB = - match basic with + match callConv.BasicConv with | ILArgConvention.Default -> enum 0 | ILArgConvention.CDecl -> enum 0 | ILArgConvention.StdCall -> enum 0 diff --git a/src/Compiler/AbstractIL/ilwrite.fs b/src/Compiler/AbstractIL/ilwrite.fs index f626e1e56ef..b974e814574 100644 --- a/src/Compiler/AbstractIL/ilwrite.fs +++ b/src/Compiler/AbstractIL/ilwrite.fs @@ -838,10 +838,10 @@ let hasthisToByte hasthis = | ILThisConvention.InstanceExplicit -> e_IMAGE_CEE_CS_CALLCONV_INSTANCE_EXPLICIT | ILThisConvention.Static -> 0x00uy -let callconvToByte ntypars (Callconv (hasthis, bcc)) = - hasthisToByte hasthis ||| +let callconvToByte ntypars (callconv: ILCallingConv) = + hasthisToByte callconv.ThisConv ||| (if ntypars > 0 then e_IMAGE_CEE_CS_CALLCONV_GENERIC else 0x00uy) ||| - (match bcc with + (match callconv.BasicConv with | ILArgConvention.FastCall -> e_IMAGE_CEE_CS_CALLCONV_FASTCALL | ILArgConvention.StdCall -> e_IMAGE_CEE_CS_CALLCONV_STDCALL | ILArgConvention.ThisCall -> e_IMAGE_CEE_CS_CALLCONV_THISCALL diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index 81891a408f2..9adfca4e3a8 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1285,8 +1285,8 @@ and p_ILBasicCallConv x st = | ILArgConvention.VarArg -> 5) st -and p_ILCallConv (Callconv(x, y)) st = - p_tup2 p_ILHasThis p_ILBasicCallConv (x, y) st +and p_ILCallConv (x: ILCallingConv) st = + p_tup2 p_ILHasThis p_ILBasicCallConv (x.ThisConv, x.BasicConv) st and p_ILCallSig x st = p_tup3 p_ILCallConv p_ILTypes p_ILType (x.CallingConv, x.ArgTypes, x.ReturnType) st @@ -1316,7 +1316,7 @@ let u_ILHasThis st = let u_ILCallConv st = let a, b = u_tup2 u_ILHasThis u_ILBasicCallConv st - Callconv(a, b) + ILCallingConv.Create(a, b) let u_ILTypeRef st = let a, b, c = u_tup3 u_ILScopeRef u_strings u_string st diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl index 055808bf332..ba8d1825ece 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.bsl @@ -319,22 +319,26 @@ FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean Equals(ILCallingConv) FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean Equals(ILCallingConv, System.Collections.IEqualityComparer) FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean Equals(System.Object) FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean Equals(System.Object, System.Collections.IEqualityComparer) -FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILArgConvention Item2 -FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILArgConvention get_Item2() +FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean IsInstance +FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean IsInstanceExplicit +FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean IsStatic +FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean get_IsInstance() +FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean get_IsInstanceExplicit() +FSharp.Compiler.AbstractIL.IL+ILCallingConv: Boolean get_IsStatic() +FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILArgConvention BasicConv +FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILArgConvention get_BasicConv() +FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILCallingConv Create(ILThisConvention, ILArgConvention) FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILCallingConv Instance -FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILCallingConv NewCallconv(ILThisConvention, ILArgConvention) FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILCallingConv Static FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILCallingConv get_Instance() FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILCallingConv get_Static() -FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILThisConvention Item1 -FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILThisConvention get_Item1() +FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILThisConvention ThisConv +FSharp.Compiler.AbstractIL.IL+ILCallingConv: ILThisConvention get_ThisConv() FSharp.Compiler.AbstractIL.IL+ILCallingConv: Int32 CompareTo(ILCallingConv) FSharp.Compiler.AbstractIL.IL+ILCallingConv: Int32 CompareTo(System.Object) FSharp.Compiler.AbstractIL.IL+ILCallingConv: Int32 CompareTo(System.Object, System.Collections.IComparer) FSharp.Compiler.AbstractIL.IL+ILCallingConv: Int32 GetHashCode() FSharp.Compiler.AbstractIL.IL+ILCallingConv: Int32 GetHashCode(System.Collections.IEqualityComparer) -FSharp.Compiler.AbstractIL.IL+ILCallingConv: Int32 Tag -FSharp.Compiler.AbstractIL.IL+ILCallingConv: Int32 get_Tag() FSharp.Compiler.AbstractIL.IL+ILCallingConv: System.String ToString() FSharp.Compiler.AbstractIL.IL+ILCallingSignature: Boolean Equals(ILCallingSignature) FSharp.Compiler.AbstractIL.IL+ILCallingSignature: Boolean Equals(ILCallingSignature, System.Collections.IEqualityComparer) diff --git a/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs b/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs index 473a503ba13..fc3641811a5 100644 --- a/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs @@ -50,7 +50,7 @@ module ModuleReader = MethodAttributes.NewSlot ||| MethodAttributes.SpecialName - let callingConv = Callconv(ILThisConvention.Instance, ILArgConvention.Default) + let callingConv = ILCallingConv.Instance let parameters = [] let ret = mkILReturn ILType.Void let genericParams = [] From 26714c183e67c662e346074183d5c55ebf1e2f65 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Wed, 19 Aug 2026 11:59:33 +0200 Subject: [PATCH 47/55] Make AI expert-review post file+line anchored inline comments, not a prose wall (#20291) Wave 5 contradicted itself (body must start with a disclosure line vs body must be empty/LGTM) and never fired the comments[] array, so reviews landed as conversational COMMENTED bodies with zero anchors. Rewrite Wave 5 into one coherent contract: findings become individual file+line anchored inline comments (each an independent, resolvable thread), the body is only ever a one-line disclosure or LGTM + a collapsed dimensions list, every body/comment is prefixed with the robot+detective disclosure, and each finding needs a user-code sample and validated (not guessed) behavior. Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> Copilot-Session: 676a3253-217c-4ae8-81d3-fa812749799a --- .github/agents/expert-reviewer.md | 36 ++++++++++++++++--------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/.github/agents/expert-reviewer.md b/.github/agents/expert-reviewer.md index c9735c7383d..4e7b8cfa6e1 100644 --- a/.github/agents/expert-reviewer.md +++ b/.github/agents/expert-reviewer.md @@ -476,34 +476,36 @@ Execute review in five waves, each building on the previous. ### Wave 5: Deliver Review as Inline Comments -**This wave is mandatory.** Analysis without posting is worthless — the review MUST appear on the PR as posted inline comments at the correct file and line. +**This wave is mandatory.** Analysis without posting is worthless — the review MUST appear on the PR as inline comments anchored to the exact file and line. A prose review body is the failure this wave exists to prevent: the author wrote the diff, so narrating it back is noise. Every review body and every comment begins with the robot+detective disclosure `🤖🕵️`. -1. **Deduplicate first.** Check existing reviews to avoid duplicate content: +1. **Deduplicate first.** ```bash gh api repos/{owner}/{repo}/pulls/{number}/reviews --jq 'length' ``` If reviews from automated accounts already exist, skip posting and apply the label only. -2. **Post findings as a review with inline comments** at the best-fitting file and line. Use the GitHub API to create a single review with all comments: +2. **Findings exist → one review, inline comments only.** Every finding — *including minor and "nice to have" ones* — is its own inline comment anchored to a file+line, so each becomes an independent, resolvable thread. Never collect findings into the body. ```bash gh api repos/{owner}/{repo}/pulls/{number}/reviews \ --method POST \ --field event=COMMENT \ - --field body='' \ + --field 'body=🤖🕵️ AI review — verify independently.' \ --field 'comments=[ - {"path":"src/Compiler/Checking/CheckDeclarations.fs","line":2750,"body":"**[Test Coverage]** This code path lacks a test. Add a test exercising this branch."}, - {"path":"src/Compiler/CodeGen/IlxGen.fs","line":1234,"body":"**[IL Emission]** Call `stripTyEqns` before this match to handle type abbreviations."} + {"path":"src/Compiler/CodeGen/IlxGen.fs","line":1234,"body":"🤖🕵️ Type abbreviation slips past the match — wrong branch taken.\n```fsharp\ntype Alias = int\nlet f (x: Alias) = () // reaches this case, mishandled\n```"} ]' ``` - Each comment needs: - - `path`: file path relative to repo root (from the diff) - - `line`: line number in the **new** version of the file (right side of diff) - - `body`: severity tag in `**[Dimension]**` format, the issue, and suggested fix + - Review **`body` = one short line**, the `🤖🕵️` disclosure. Never a summary, never a finding list. + - `path`: file path from the diff. `line`: line in the **new** file (right side of diff); use `start_line`+`line` for a range. + - Comment body: `🤖🕵️` + one fragment naming the **consequence** (what breaks), then a fenced **user-code** sample — the input/usage that triggers it, or the fix. Show how the problem looks in *user* code; do not restate the product diff. + - **Validated, not guessed.** If you have not run it and seen the result, drop the finding. "Would allocate" / "could box" / "may cancel" without a repro → drop. + - At most ~6–10 comments, ranked Behavioral > Quality > Nitpick. -3. **If no significant issues found**, post an approving review: +3. **No significant issues → approve.** Body is the disclosure plus, optionally, a collapsed list of what was covered — the ONE permitted multi-line body: ```bash - gh pr review {number} --repo {owner}/{repo} --approve --body "LGTM" + gh pr review {number} --repo {owner}/{repo} --approve \ + --body $'🤖🕵️ LGTM ✅\n\n
\nDimensions covered (expand)\n\n- IL emission\n- Binary compatibility\n- Concurrency\n
' ``` + The `
` block is a bare list of the dimensions/subagents that ran — no prose, no per-dimension write-up. 4. **Apply the label and request human review:** ```bash @@ -511,12 +513,12 @@ Execute review in five waves, each building on the previous. ``` **Delivery rules:** -- The review body MUST begin with an AI disclosure note (the `🤖` line above). This is non-negotiable — readers must know this is AI-generated, not human-written. -- At most 10 inline comments — prioritize Behavioral over Quality over Nitpick. -- Every comment must reference a specific file and line from the diff. +- Every review body and every inline comment begins with `🤖🕵️`. Non-negotiable — readers must know this is AI-generated. +- The review **body** is only ever: the one-line `🤖🕵️` disclosure (findings present), or `🤖🕵️ LGTM ✅` + the optional collapsed dimensions list (no findings). Anything else in the body — a summary, a numbered list of notes, praise, "two tiny things" — is a bug. +- Every finding is an inline comment anchored to a specific file+line from the diff. No exception for "minor" or "nice" notes: if it is worth saying, anchor it. +- Each comment carries a concrete **user-code** sample and describes **validated** behavior, not a guess. +- **Banned in any body or comment:** prose summary, restating what the PR does, `**[Dimension]**`/`file:LINE` as a text header in the body, hedge/filler ("consider", "might want to", "non-blocking nit", "for consistency"), and any finding lacking a file+line or a concrete code sample. - Never post duplicate content if reviews already exist on the PR. -- If the PR is too large to review fully, note skipped areas in the review body. -- **NEVER write a wall-of-text review body.** The body is either `LGTM` (approve) or empty (with inline findings). All analysis stays in your context — only actionable findings get posted as inline comments. A review body longer than 10 characters (other than `LGTM`) is a bug. ## Folder Hotspot Mapping From d9fff57ee737b86c3e08bbaa0e50086d8d60725c Mon Sep 17 00:00:00 2001 From: "dotnet-maestro[bot]" <42748379+dotnet-maestro[bot]@users.noreply.github.com> Date: Wed, 19 Aug 2026 10:03:25 +0000 Subject: [PATCH 48/55] Update dependencies from https://github.com/dotnet/arcade build 20260812.4 (#20248) On relative base path root Microsoft.DotNet.Arcade.Sdk From Version 11.0.0-beta.26369.1 -> To Version 11.0.0-beta.26412.4 Co-authored-by: dotnet-maestro[bot] Co-authored-by: Tomas Grosup --- eng/Version.Details.props | 2 +- eng/Version.Details.xml | 4 +- eng/common/Get-GitHubAppToken.ps1 | 164 ++++++++++++++++++ eng/common/SetupNugetSources.ps1 | 38 ++-- eng/common/SetupNugetSources.sh | 4 +- eng/common/build.ps1 | 7 +- eng/common/build.sh | 14 +- .../core-templates/job/helix-job-monitor.yml | 37 +++- eng/common/core-templates/job/onelocbuild.yml | 28 ++- .../job/publish-build-assets.yml | 2 - .../post-build/common-variables.yml | 2 - .../core-templates/post-build/post-build.yml | 1 + eng/common/core-templates/stages/renovate.yml | 2 + .../steps/enable-internal-sources.yml | 12 +- .../steps/get-github-app-token.yml | 79 +++++++++ .../core-templates/steps/publish-logs.yml | 26 +-- eng/common/cross/build-rootfs.sh | 38 ++-- eng/common/msbuild.ps1 | 10 +- eng/common/msbuild.sh | 16 +- .../steps/get-github-app-token.yml | 7 + .../templates/steps/get-github-app-token.yml | 7 + eng/common/tools.ps1 | 14 +- eng/common/tools.sh | 28 ++- global.json | 2 +- 24 files changed, 453 insertions(+), 91 deletions(-) create mode 100644 eng/common/Get-GitHubAppToken.ps1 create mode 100644 eng/common/core-templates/steps/get-github-app-token.yml create mode 100644 eng/common/templates-official/steps/get-github-app-token.yml create mode 100644 eng/common/templates/steps/get-github-app-token.yml diff --git a/eng/Version.Details.props b/eng/Version.Details.props index ff921b4a8cb..45f73738442 100644 --- a/eng/Version.Details.props +++ b/eng/Version.Details.props @@ -6,7 +6,7 @@ This file should be imported by eng/Versions.props - 11.0.0-beta.26369.1 + 11.0.0-beta.26414.2 18.11.0-1.26417.9 18.11.0-1.26417.9 diff --git a/eng/Version.Details.xml b/eng/Version.Details.xml index fc0c24a12e5..e367f1479c1 100644 --- a/eng/Version.Details.xml +++ b/eng/Version.Details.xml @@ -82,9 +82,9 @@ - + https://github.com/dotnet/arcade - 09bc8c946f4c4ae5d031c8875b85a6b8f1876b93 + 09a0bcffb8286738e8679282171cd1ba548c8c52 https://dev.azure.com/dnceng/internal/_git/dotnet-optimization diff --git a/eng/common/Get-GitHubAppToken.ps1 b/eng/common/Get-GitHubAppToken.ps1 new file mode 100644 index 00000000000..9c7e3dcd6ac --- /dev/null +++ b/eng/common/Get-GitHubAppToken.ps1 @@ -0,0 +1,164 @@ +# Mints a short-lived GitHub App installation access token by signing a JWT +# with a private key stored in Azure Key Vault (RSA, RS256). The signed JWT is +# exchanged with the GitHub API for a token scoped to a single installation. +# +# Requirements: +# - A GitHub App whose private key has been uploaded into Key Vault as an RSA +# key (the PEM converted to a Key Vault *key*, NOT stored as a secret). +# - The caller (the federated Azure service connection used to run this script) +# must have the `Key Vault Crypto User` role (or at minimum the `Sign` +# action) on that key. +# - The App must be installed on the target organization/account +# (`InstallationOwner`) with the permissions/repositories it needs. +# +# Installation tokens (ghs_*) are exempt from the enterprise classic-PAT +# lifetime policy, which is why this replaces the long-lived PAT. + +[CmdletBinding()] +param( + # Name of the Key Vault that holds the GitHub App's RSA signing key. + [Parameter(Mandatory = $true)] + [string] $KeyVaultName, + + # Name of the RSA key inside the Key Vault (the App's private key). + [Parameter(Mandatory = $true)] + [string] $KeyName, + + # The GitHub App's Client ID (the value to put in the `iss` JWT claim). + [Parameter(Mandatory = $true)] + [string] $AppClientId, + + # Login of the organization or user account whose installation we should + # mint the token for (e.g. `dotnet`, `microsoft`). + [Parameter(Mandatory = $true)] + [string] $InstallationOwner, + + # Optional Azure DevOps pipeline variable name to set with the installation + # token (marked as a secret). When not specified, the token is written to + # stdout instead. + [Parameter(Mandatory = $false)] + [string] $OutputVariableName +) + +$ErrorActionPreference = 'Stop' +$PSNativeCommandUseErrorActionPreference = $true + +. $PSScriptRoot\pipeline-logging-functions.ps1 + +function ConvertTo-Base64Url([byte[]] $bytes) { + return [Convert]::ToBase64String($bytes).TrimEnd('=').Replace('+', '-').Replace('/', '_') +} + +# Build JWT header and payload. Use [ordered] hashtables so JSON +# serialization is deterministic. +$jwtHeader = [ordered]@{ + alg = 'RS256' + typ = 'JWT' +} +$now = [System.DateTimeOffset]::UtcNow +$jwtPayload = [ordered]@{ + iat = $now.AddMinutes(-1).ToUnixTimeSeconds() + exp = $now.AddMinutes(5).ToUnixTimeSeconds() + iss = $AppClientId +} + +$headerEncoded = ConvertTo-Base64Url ([System.Text.Encoding]::UTF8.GetBytes(($jwtHeader | ConvertTo-Json -Compress))) +$payloadEncoded = ConvertTo-Base64Url ([System.Text.Encoding]::UTF8.GetBytes(($jwtPayload | ConvertTo-Json -Compress))) +$signingInput = "$headerEncoded.$payloadEncoded" + +# Key Vault `sign` expects the *digest* (base64), not the raw bytes. +$sha256 = [System.Security.Cryptography.SHA256]::Create() +$digestBytes = $sha256.ComputeHash([System.Text.Encoding]::UTF8.GetBytes($signingInput)) +$digestBase64 = [Convert]::ToBase64String($digestBytes) + +Write-Host "Signing JWT with key '$KeyName' in vault '$KeyVaultName'..." +$previousNativeCommandErrorPreference = $PSNativeCommandUseErrorActionPreference +try { + # Azure CLI can emit non-fatal Python warnings to stderr even when signing succeeds. + # Use the exit code to determine success for this invocation. + $PSNativeCommandUseErrorActionPreference = $false + $signatureBase64 = az keyvault key sign ` + --vault-name $KeyVaultName ` + --name $KeyName ` + --algorithm RS256 ` + --digest $digestBase64 ` + --query signature ` + --output tsv ` + --only-show-errors + $signExitCode = $LASTEXITCODE +} +catch { + Write-PipelineTelemetryError -Category 'Build' -Message "Failed to sign the JWT via Key Vault (key '$KeyName', vault '$KeyVaultName'): $_. Verify the service connection identity has the 'Key Vault Crypto User' role (Sign action) on the key." + exit 1 +} +finally { + $PSNativeCommandUseErrorActionPreference = $previousNativeCommandErrorPreference +} +if ($signExitCode -ne 0 -or [string]::IsNullOrWhiteSpace($signatureBase64)) { + Write-PipelineTelemetryError -Category 'Build' -Message "'az keyvault key sign' exited with code $signExitCode for key '$KeyName' in vault '$KeyVaultName'. Verify the service connection identity has the 'Key Vault Crypto User' role (Sign action) on the key." + exit 1 +} +$signatureUrl = $signatureBase64.Trim().TrimEnd('=').Replace('+', '-').Replace('/', '_') +$jwt = "$signingInput.$signatureUrl" + +$headers = @{ + Authorization = "Bearer $jwt" + 'X-GitHub-Api-Version' = '2022-11-28' + Accept = 'application/vnd.github+json' + 'User-Agent' = 'dotnet-arcade-onelocbuild' +} + +Write-Host "Looking up installation for '$InstallationOwner'..." +try { + $installations = @() + $page = 1 + do { + # Assign the response before wrapping it in @(). PowerShell otherwise + # preserves a top-level JSON array as one nested pipeline object. + $pageResponse = Invoke-RestMethod ` + -Uri "https://api.github.com/app/installations?per_page=100&page=$page" ` + -Headers $headers ` + -Method Get + $pageInstallations = @($pageResponse) + $installations += $pageInstallations + $page++ + } while ($pageInstallations.Count -eq 100) +} +catch { + Write-PipelineTelemetryError -Category 'Build' -Message "Failed to list GitHub App installations: $_. The signed JWT may be invalid or the App's Client ID ('$AppClientId') may be incorrect." + exit 1 +} +$matchingInstallations = @($installations | Where-Object { $_.account.login -ieq $InstallationOwner }) +if ($matchingInstallations.Count -eq 0) { + $found = ($installations | ForEach-Object { $_.account.login }) -join ', ' + Write-PipelineTelemetryError -Category 'Build' -Message "No installation found for '$InstallationOwner'. App is installed on: $found" + exit 1 +} +if ($matchingInstallations.Count -ne 1) { + $matchingIds = ($matchingInstallations | ForEach-Object { $_.id }) -join ', ' + Write-PipelineTelemetryError -Category 'Build' -Message "Found multiple installations for '$InstallationOwner': $matchingIds" + exit 1 +} +$installation = $matchingInstallations[0] +Write-Host "Using installation $($installation.id) for '$($installation.account.login)'." + +try { + $tokenResponse = Invoke-RestMethod ` + -Uri "https://api.github.com/app/installations/$($installation.id)/access_tokens" ` + -Headers $headers ` + -Method Post ` + -ContentType 'application/json' +} +catch { + Write-PipelineTelemetryError -Category 'Build' -Message "Failed to mint an installation access token for '$InstallationOwner' (installation $($installation.id)): $_" + exit 1 +} + +Write-Host "Got installation token for '$InstallationOwner' (expires $($tokenResponse.expires_at))." +if ($OutputVariableName) { + Write-Host "Setting pipeline variable '$OutputVariableName'." + Write-Host "##vso[task.setvariable variable=$OutputVariableName;issecret=true]$($tokenResponse.token)" +} +else { + Write-Host $tokenResponse.token -ForegroundColor Green +} diff --git a/eng/common/SetupNugetSources.ps1 b/eng/common/SetupNugetSources.ps1 index b3bddff355e..b7a3769364d 100644 --- a/eng/common/SetupNugetSources.ps1 +++ b/eng/common/SetupNugetSources.ps1 @@ -11,7 +11,7 @@ # condition: eq(variables['Agent.OS'], 'Windows_NT') # inputs: # filePath: $(System.DefaultWorkingDirectory)/eng/common/SetupNugetSources.ps1 -# arguments: -ConfigFile $(System.DefaultWorkingDirectory)/NuGet.config -Password $Env:Token +# arguments: -ConfigFile $(System.DefaultWorkingDirectory)/NuGet.config # env: # Token: $(InternalFeedToken) # @@ -29,12 +29,14 @@ [CmdletBinding()] param ( [Parameter(Mandatory = $true)][string]$ConfigFile, - $Password + # Keep the legacy name as an alias while callers migrate secrets to the Token environment variable. + [Alias("Password")]$Credential ) $ErrorActionPreference = "Stop" Set-StrictMode -Version 2.0 [Net.ServicePointManager]::SecurityProtocol = [Net.SecurityProtocolType]::Tls12 +$feedCredential = if ($env:Token) { $env:Token } else { $Credential } # This script only consumes helper functions from tools.ps1 to configure NuGet feeds. # Skip importing configure-toolset.ps1 so that repo-specific toolset setup (e.g. acquiring @@ -44,14 +46,14 @@ $disableConfigureToolsetImport = $true . $PSScriptRoot\tools.ps1 # Adds or enables the package source with the given name -function AddOrEnablePackageSource($sources, $disabledPackageSources, $SourceName, $SourceEndPoint, $creds, $Username, $pwd) { - if ($disabledPackageSources -eq $null -or -not (EnableInternalPackageSource -DisabledPackageSources $disabledPackageSources -Creds $creds -PackageSourceName $SourceName)) { - AddPackageSource -Sources $sources -SourceName $SourceName -SourceEndPoint $SourceEndPoint -Creds $creds -Username $userName -pwd $Password +function AddOrEnablePackageSource($sources, $disabledPackageSources, $SourceName, $SourceEndPoint, $creds, $Username, $credential) { + if ($disabledPackageSources -eq $null -or -not (EnableInternalPackageSource -DisabledPackageSources $disabledPackageSources -Creds $creds -PackageSourceName $SourceName -Credential $credential)) { + AddPackageSource -Sources $sources -SourceName $SourceName -SourceEndPoint $SourceEndPoint -Creds $creds -Username $Username -credential $credential } } # Add source entry to PackageSources -function AddPackageSource($sources, $SourceName, $SourceEndPoint, $creds, $Username, $pwd) { +function AddPackageSource($sources, $SourceName, $SourceEndPoint, $creds, $Username, $credential) { $packageSource = $sources.SelectSingleNode("add[@key='$SourceName']") if ($packageSource -eq $null) @@ -67,13 +69,13 @@ function AddPackageSource($sources, $SourceName, $SourceEndPoint, $creds, $Usern Write-Host "Package source $SourceName already present and enabled." } - AddCredential -Creds $creds -Source $SourceName -Username $Username -pwd $pwd + AddCredential -Creds $creds -Source $SourceName -Username $Username -credential $credential } # Add a credential node for the specified source -function AddCredential($creds, $source, $username, $pwd) { +function AddCredential($creds, $source, $username, $credential) { # If no cred supplied, don't do anything. - if (!$pwd) { + if (!$credential) { return; } @@ -108,19 +110,19 @@ function AddCredential($creds, $source, $username, $pwd) { $sourceElement.AppendChild($passwordElement) | Out-Null } - $passwordElement.SetAttribute("value", $pwd) + $passwordElement.SetAttribute("value", $credential) } # Enable all darc-int package sources. -function EnableMaestroInternalPackageSources($DisabledPackageSources, $Creds) { +function EnableMaestroInternalPackageSources($DisabledPackageSources, $Creds, $Credential) { $maestroInternalSources = $DisabledPackageSources.SelectNodes("add[contains(@key,'darc-int')]") ForEach ($DisabledPackageSource in $maestroInternalSources) { - EnableInternalPackageSource -DisabledPackageSources $DisabledPackageSources -Creds $Creds -PackageSourceName $DisabledPackageSource.key + EnableInternalPackageSource -DisabledPackageSources $DisabledPackageSources -Creds $Creds -PackageSourceName $DisabledPackageSource.key -Credential $Credential } } # Enables an internal package source by name, if found. Returns true if the package source was found and enabled, false otherwise. -function EnableInternalPackageSource($DisabledPackageSources, $Creds, $PackageSourceName) { +function EnableInternalPackageSource($DisabledPackageSources, $Creds, $PackageSourceName, $Credential) { $DisabledPackageSource = $DisabledPackageSources.SelectSingleNode("add[@key='$PackageSourceName']") if ($DisabledPackageSource) { Write-Host "Enabling internal source '$($DisabledPackageSource.key)'." @@ -128,7 +130,7 @@ function EnableInternalPackageSource($DisabledPackageSources, $Creds, $PackageSo # Due to https://github.com/NuGet/Home/issues/10291, we must actually remove the disabled entries $DisabledPackageSources.RemoveChild($DisabledPackageSource) - AddCredential -Creds $creds -Source $DisabledPackageSource.Key -Username $userName -pwd $Password + AddCredential -Creds $creds -Source $DisabledPackageSource.Key -Username $userName -credential $credential return $true } return $false @@ -153,7 +155,7 @@ if ($sources -eq $null) { $creds = $null $feedSuffix = "v3/index.json" -if ($Password) { +if ($feedCredential) { $feedSuffix = "v2" # Looks for a node. Create it if none is found. $creds = $doc.DocumentElement.SelectSingleNode("packageSourceCredentials") @@ -169,7 +171,7 @@ $userName = "dn-bot" $disabledSources = $doc.DocumentElement.SelectSingleNode("disabledPackageSources") if ($disabledSources -ne $null) { Write-Host "Checking for any darc-int disabled package sources in the disabledPackageSources node" - EnableMaestroInternalPackageSources -DisabledPackageSources $disabledSources -Creds $creds + EnableMaestroInternalPackageSources -DisabledPackageSources $disabledSources -Creds $creds -Credential $feedCredential } $dotnetVersions = @('5','6','7','8','9','10') @@ -177,8 +179,8 @@ foreach ($dotnetVersion in $dotnetVersions) { $feedPrefix = "dotnet" + $dotnetVersion; $dotnetSource = $sources.SelectSingleNode("add[@key='$feedPrefix']") if ($dotnetSource -ne $null) { - AddOrEnablePackageSource -Sources $sources -DisabledPackageSources $disabledSources -SourceName "$feedPrefix-internal" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/$feedPrefix-internal/nuget/$feedSuffix" -Creds $creds -Username $userName -pwd $Password - AddOrEnablePackageSource -Sources $sources -DisabledPackageSources $disabledSources -SourceName "$feedPrefix-internal-transport" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/$feedPrefix-internal-transport/nuget/$feedSuffix" -Creds $creds -Username $userName -pwd $Password + AddOrEnablePackageSource -Sources $sources -DisabledPackageSources $disabledSources -SourceName "$feedPrefix-internal" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/$feedPrefix-internal/nuget/$feedSuffix" -Creds $creds -Username $userName -credential $feedCredential + AddOrEnablePackageSource -Sources $sources -DisabledPackageSources $disabledSources -SourceName "$feedPrefix-internal-transport" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/$feedPrefix-internal-transport/nuget/$feedSuffix" -Creds $creds -Username $userName -credential $feedCredential } } diff --git a/eng/common/SetupNugetSources.sh b/eng/common/SetupNugetSources.sh index 67e7e0942ca..c3ae8ac054f 100755 --- a/eng/common/SetupNugetSources.sh +++ b/eng/common/SetupNugetSources.sh @@ -24,7 +24,9 @@ # This logic is also abstracted into enable-internal-sources.yml. ConfigFile=$1 -CredToken=$2 +# Prefer the environment variable so credentials do not appear in process arguments. +# Retain the positional argument as a compatibility fallback for existing callers. +CredToken=${Token:-$2} NL='\n' TB=' ' diff --git a/eng/common/build.ps1 b/eng/common/build.ps1 index dd84699f500..fee2f839919 100644 --- a/eng/common/build.ps1 +++ b/eng/common/build.ps1 @@ -8,6 +8,7 @@ Param( [bool] $warnAsError = $true, [string] $warnNotAsError = '', [bool] $nodeReuse = $true, + [bool][Alias('mt')]$msbuildMultiThreaded = $false, [switch] $buildCheck = $false, [switch][Alias('r')]$restore, [switch] $deployDeps, @@ -79,6 +80,7 @@ function Print-Usage() { Write-Host " -excludePrereleaseVS Set to exclude build engines in prerelease versions of Visual Studio" Write-Host " -nativeToolsOnMachine Sets the native tools on machine environment variable (indicating that the script should use native tools on machine)" Write-Host " -nodeReuse Sets nodereuse msbuild parameter ('true' or 'false')" + Write-Host " -msbuildMultiThreaded Sets MSBuild's multi-threaded mode, i.e. the -mt switch ('1' or '0') (short: -mt)" Write-Host " -buildCheck Sets /check msbuild parameter" Write-Host " -fromVMR Set when building from within the VMR" Write-Host " -disablePipelineSetResult Set to disable masking the actual exit code in the pipeline when the build fails" @@ -175,9 +177,8 @@ try { if (-not $excludeCIBinarylog) { $binaryLog = $true } - # Disable node reuse on CI unless explicitly opted in via MSBUILD_NODEREUSE_ENABLED. - # Internal testing only; this env var will be replaced with a switch (https://github.com/dotnet/arcade/issues/17013) and must not be depended on. - if ($env:MSBUILD_NODEREUSE_ENABLED -ne "1") { + # Node reuse isn't used on CI unless it was explicitly requested via -nodeReuse. + if (-not $PSBoundParameters.ContainsKey('nodeReuse')) { $nodeReuse = $false } } diff --git a/eng/common/build.sh b/eng/common/build.sh index e37edd6cff3..109d83ff73f 100755 --- a/eng/common/build.sh +++ b/eng/common/build.sh @@ -43,6 +43,7 @@ usage() echo " --pipelinesLog Promote msbuild errors/warnings to Azure Pipelines timeline issues; defaults to on in CI (short: -pl)" echo " --prepareMachine Prepare machine for CI run, clean up processes after build" echo " --nodeReuse Sets nodereuse msbuild parameter ('true' or 'false')" + echo " --msbuildMultiThreaded Sets MSBuild's multi-threaded mode, i.e. the -mt switch ('true' or 'false') (short: --mt)" echo " --warnAsError Sets warnaserror msbuild parameter ('true' or 'false')" echo " --warnNotAsError Sets a semi-colon delimited list of warning codes that should not be treated as errors" echo " --buildCheck Sets /check msbuild parameter" @@ -84,7 +85,9 @@ clean=false warn_as_error=true warn_not_as_error='' -node_reuse=true +# Empty means "not specified"; tools.sh defaults these to on for local builds and off on CI. +node_reuse='' +msbuild_multi_threaded='' build_check=false binary_log=false binary_log_name='' @@ -199,6 +202,10 @@ while [[ $# -gt 0 ]]; do node_reuse=$2 shift ;; + -msbuildmultithreaded|-mt) + msbuild_multi_threaded=$2 + shift + ;; -buildcheck) build_check=true ;; @@ -224,11 +231,6 @@ fi if [[ "$ci" == true ]]; then pipelines_log=true - # Disable node reuse on CI unless explicitly opted in via MSBUILD_NODEREUSE_ENABLED. - # Internal testing only; this env var will be replaced with a switch (https://github.com/dotnet/arcade/issues/17013) and must not be depended on. - if [[ "${MSBUILD_NODEREUSE_ENABLED:-}" != "1" ]]; then - node_reuse=false - fi if [[ "$exclude_ci_binary_log" == false ]]; then binary_log=true fi diff --git a/eng/common/core-templates/job/helix-job-monitor.yml b/eng/common/core-templates/job/helix-job-monitor.yml index 0da13cf69db..81ecccdd17b 100644 --- a/eng/common/core-templates/job/helix-job-monitor.yml +++ b/eng/common/core-templates/job/helix-job-monitor.yml @@ -26,6 +26,11 @@ parameters: type: string default: '' +# Whether failures in the monitor job should allow the pipeline to continue. +- name: continueOnError + type: boolean + default: false + # NuGet package id of the Helix job monitor tool. - name: toolPackageId type: string @@ -65,6 +70,12 @@ parameters: type: boolean default: true +# When true, allow the monitor to succeed when this stage produces no Helix jobs in any attempt. +# Forwarded as --allow-no-helix-jobs. +- name: allowNoHelixJobs + type: boolean + default: false + # When true, test results are reported to Azure DevOps using the fully qualified test name # (Namespace.Type.Method) as the stable automatedTestName and the visible title is qualified as # well (--use-fully-qualified-test-name). Opt-in because it changes AzDO test identity and display; @@ -73,6 +84,15 @@ parameters: type: boolean default: false +# Controls per-test output attachments. Defaults to Failed. +- name: testResultAttachmentMode + type: string + default: Failed + values: + - Failed + - All + - None + # Advanced: optional pipeline artifact (produced earlier in this run) that contains the tool # nupkg. When set, the artifact is downloaded and the tool is installed from the nupkg into # a local tool-path; this bypasses the repo's .config/dotnet-tools.json manifest and is @@ -97,6 +117,7 @@ jobs: - job: HelixJobMonitor displayName: Monitor Helix Jobs timeoutInMinutes: ${{ parameters.timeoutInMinutes }} + continueOnError: ${{ parameters.continueOnError }} ${{ if ne(length(parameters.dependsOn), 0) }}: dependsOn: ${{ parameters.dependsOn }} ${{ if ne(parameters.condition, '') }}: @@ -104,9 +125,11 @@ jobs: pool: ${{ if eq(variables['System.TeamProject'], 'public') }}: name: $(DncEngPublicBuildPool) + os: linux demands: ImageOverride -equals build.azurelinux.3.amd64.open ${{ else }}: name: $(DncEngInternalBuildPool) + os: linux demands: ImageOverride -equals build.azurelinux.3.amd64 steps: - checkout: self @@ -187,22 +210,31 @@ jobs: --helix-base-uri '${{ parameters.helixBaseUri }}' --polling-interval-seconds '${{ parameters.pollingIntervalSeconds }}' --fail-on-failed-tests '${{ parameters.failWorkItemsWithFailedTests }}' + --allow-no-helix-jobs '${{ parameters.allowNoHelixJobs }}' --use-fully-qualified-test-name '${{ parameters.useFullyQualifiedTestName }}' --max-wait-minutes "$((${{ parameters.timeoutInMinutes }} - 5))" # Set the tool's timeout slightly lower than the Azure DevOps job timeout to allow it to exit gracefully. --stage-name '$(System.StageName)' + --stage-attempt '$(System.StageAttempt)' ) organization='${{ parameters.organization }}' repository='${{ parameters.repository }}' + testResultAttachmentMode='${{ parameters.testResultAttachmentMode }}' # Fall back to Azure DevOps-provided environment variables when the caller did not # supply organization / repository explicitly. BUILD_REPOSITORY_NAME is typically - # 'owner/repo' for GitHub-backed builds. + # 'owner/repo' for GitHub-backed builds and 'owner-repo' for internal builds. if [ -z "$organization" ] || [ -z "$repository" ]; then buildRepoName="${BUILD_REPOSITORY_NAME:-}" if [ -n "$buildRepoName" ] && [[ "$buildRepoName" == */* ]]; then repoOwner="${buildRepoName%%/*}" repoName="${buildRepoName#*/}" + elif [ -n "$buildRepoName" ] && [[ "$buildRepoName" == *-* ]]; then + repoOwner="${buildRepoName%%-*}" + repoName="${buildRepoName#*-}" + fi + + if [ -n "${repoOwner:-}" ] && [ -n "${repoName:-}" ]; then if [ -z "$organization" ]; then organization="$repoOwner"; fi if [ -z "$repository" ]; then repository="$repoName"; fi fi @@ -210,6 +242,9 @@ jobs: if [ -n "$organization" ]; then toolArgs+=( --organization "$organization" ); fi if [ -n "$repository" ]; then toolArgs+=( --repository "$repository" ); fi + if [ -n "$testResultAttachmentMode" ]; then + toolArgs+=( --test-result-attachment-mode "$testResultAttachmentMode" ) + fi # Build.Reason and Build.SourceBranch are required to derive the Helix source filter # the same way the Helix SDK submitter does (PR -> 'pr', internal -> 'official', diff --git a/eng/common/core-templates/job/onelocbuild.yml b/eng/common/core-templates/job/onelocbuild.yml index 2816d2905a0..4f5653d73ac 100644 --- a/eng/common/core-templates/job/onelocbuild.yml +++ b/eng/common/core-templates/job/onelocbuild.yml @@ -14,6 +14,15 @@ parameters: # exist, and any pipeline that sets this to '' fall back to PAT-based auth via the CeapexPat parameter. CeapexServiceConnection: 'dnceng-onelocbuild-ceapex' + # GitHub App authentication for the OneLoc check-in PR (dnceng/internal only). + # The infrastructure identifiers are centralized here and the App path is enabled by default. + # DevDiv requires its own project-scoped service connection before this path can be enabled there. + UseGitHubAppAuthentication: true + GitHubAppServiceConnection: 'dnceng-oneloc-githubapp' + GitHubAppClientId: 'Iv23lijBU8x3gc9lDOc9' + GitHubAppKeyVaultName: 'EngKeyVault' + GitHubAppKeyName: 'oneloc-localization-app-key' + SourcesDirectory: $(System.DefaultWorkingDirectory) CreatePr: true AutoCompletePr: false @@ -89,6 +98,20 @@ jobs: outputVariableName: 'CeapexEntraToken' condition: ${{ parameters.condition }} + # Mint a short-lived GitHub App installation token for the loc check-in PR (dnceng/internal only). + # All other projects fall back to PAT-based auth, since the app service connection is scoped to dnceng/internal. + - ${{ if and(eq(parameters.RepoType, 'gitHub'), eq(parameters.UseGitHubAppAuthentication, true), eq(variables['System.TeamProject'], 'internal')) }}: + - template: /eng/common/core-templates/steps/get-github-app-token.yml + parameters: + is1ESPipeline: ${{ parameters.is1ESPipeline }} + azureSubscription: ${{ parameters.GitHubAppServiceConnection }} + keyVaultName: ${{ parameters.GitHubAppKeyVaultName }} + keyName: ${{ parameters.GitHubAppKeyName }} + appClientId: ${{ parameters.GitHubAppClientId }} + installationOwner: ${{ parameters.GitHubOrg }} + outputVariableName: 'GitHubAppInstallationToken' + condition: ${{ parameters.condition }} + - task: OneLocBuild@2 displayName: OneLocBuild env: @@ -110,7 +133,10 @@ jobs: patVariable: ${{ parameters.CeapexPat }} ${{ if eq(parameters.RepoType, 'gitHub') }}: repoType: ${{ parameters.RepoType }} - gitHubPatVariable: "${{ parameters.GithubPat }}" + ${{ if and(eq(parameters.UseGitHubAppAuthentication, true), eq(variables['System.TeamProject'], 'internal')) }}: + gitHubPatVariable: "$(GitHubAppInstallationToken)" + ${{ if or(eq(parameters.UseGitHubAppAuthentication, false), ne(variables['System.TeamProject'], 'internal')) }}: + gitHubPatVariable: "${{ parameters.GithubPat }}" ${{ if ne(parameters.MirrorRepo, '') }}: isMirrorRepoSelected: true gitHubOrganization: ${{ parameters.GitHubOrg }} diff --git a/eng/common/core-templates/job/publish-build-assets.yml b/eng/common/core-templates/job/publish-build-assets.yml index 4229288d3d3..330225ae093 100644 --- a/eng/common/core-templates/job/publish-build-assets.yml +++ b/eng/common/core-templates/job/publish-build-assets.yml @@ -58,8 +58,6 @@ jobs: parameters: is1ESPipeline: ${{ parameters.is1ESPipeline }} - ${{ if and(eq(parameters.runAsPublic, 'false'), ne(variables['System.TeamProject'], 'public'), notin(variables['Build.Reason'], 'PullRequest')) }}: - - group: Publish-Build-Assets - - group: AzureDevOps-Artifact-Feeds-Pats - name: runCodesignValidationInjection value: false # unconditional - needed for logs publishing (redactor tool version) diff --git a/eng/common/core-templates/post-build/common-variables.yml b/eng/common/core-templates/post-build/common-variables.yml index db298ae16ba..a3a8480e254 100644 --- a/eng/common/core-templates/post-build/common-variables.yml +++ b/eng/common/core-templates/post-build/common-variables.yml @@ -1,6 +1,4 @@ variables: - - group: Publish-Build-Assets - # Whether the build is internal or not - name: IsInternalBuild value: ${{ and(ne(variables['System.TeamProject'], 'public'), contains(variables['Build.SourceBranch'], 'internal')) }} diff --git a/eng/common/core-templates/post-build/post-build.yml b/eng/common/core-templates/post-build/post-build.yml index 9d951352696..6dcee6664d6 100644 --- a/eng/common/core-templates/post-build/post-build.yml +++ b/eng/common/core-templates/post-build/post-build.yml @@ -236,6 +236,7 @@ stages: StageLabel: 'Validation' JobLabel: 'Signing' BinlogToolVersion: $(BinlogToolVersion) + enableInternalRuntimes: false # SourceLink validation has been removed — the underlying CLI tool # (targeting netcoreapp2.1) has not functioned for years. diff --git a/eng/common/core-templates/stages/renovate.yml b/eng/common/core-templates/stages/renovate.yml index edab2818258..cfa9683794a 100644 --- a/eng/common/core-templates/stages/renovate.yml +++ b/eng/common/core-templates/stages/renovate.yml @@ -81,6 +81,8 @@ resources: extends: template: v1/1ES.Official.PipelineTemplate.yml@1ESPipelineTemplates parameters: + settings: + networkIsolationPolicy: Permissive pool: ${{ parameters.pool }} sdl: sourceAnalysisPool: ${{ parameters.sdlPool }} diff --git a/eng/common/core-templates/steps/enable-internal-sources.yml b/eng/common/core-templates/steps/enable-internal-sources.yml index 51af9a01709..843cdff7821 100644 --- a/eng/common/core-templates/steps/enable-internal-sources.yml +++ b/eng/common/core-templates/steps/enable-internal-sources.yml @@ -19,7 +19,7 @@ steps: displayName: Setup Internal Feeds inputs: filePath: $(System.DefaultWorkingDirectory)/eng/common/SetupNugetSources.ps1 - arguments: -ConfigFile $(System.DefaultWorkingDirectory)/NuGet.config -Password $Env:Token + arguments: -ConfigFile $(System.DefaultWorkingDirectory)/NuGet.config env: Token: ${{ parameters.legacyCredential }} - task: Bash@3 @@ -28,7 +28,7 @@ steps: inputs: targetType: inline script: | - "$(System.DefaultWorkingDirectory)/eng/common/SetupNugetSources.sh" "$(System.DefaultWorkingDirectory)/NuGet.config" "$Token" + "$(System.DefaultWorkingDirectory)/eng/common/SetupNugetSources.sh" "$(System.DefaultWorkingDirectory)/NuGet.config" env: Token: ${{ parameters.legacyCredential }} # If running on dnceng (internal project), just use the default behavior for NuGetAuthenticate. @@ -58,13 +58,17 @@ steps: displayName: Setup Internal Feeds inputs: filePath: $(System.DefaultWorkingDirectory)/eng/common/SetupNugetSources.ps1 - arguments: -ConfigFile $(System.DefaultWorkingDirectory)/NuGet.config -Password $(dnceng-artifacts-feeds-read-access-token) + arguments: -ConfigFile $(System.DefaultWorkingDirectory)/NuGet.config + env: + Token: $(dnceng-artifacts-feeds-read-access-token) - task: Bash@3 condition: and(succeeded(), ne(variables['Agent.Os'], 'Windows_NT')) displayName: Setup Internal Feeds inputs: filePath: $(System.DefaultWorkingDirectory)/eng/common/SetupNugetSources.sh - arguments: $(System.DefaultWorkingDirectory)/NuGet.config $(dnceng-artifacts-feeds-read-access-token) + arguments: $(System.DefaultWorkingDirectory)/NuGet.config + env: + Token: $(dnceng-artifacts-feeds-read-access-token) # This is required in certain scenarios to install the ADO credential provider. # It installed by default in some msbuild invocations (e.g. VS msbuild), but needs to be installed for others # (e.g. dotnet msbuild). diff --git a/eng/common/core-templates/steps/get-github-app-token.yml b/eng/common/core-templates/steps/get-github-app-token.yml new file mode 100644 index 00000000000..6d42a48d3c3 --- /dev/null +++ b/eng/common/core-templates/steps/get-github-app-token.yml @@ -0,0 +1,79 @@ +# Mints a short-lived GitHub App installation access token by signing a JWT +# with a private key stored in Azure Key Vault (RSA, RS256). The JWT is +# exchanged with the GitHub API for a token scoped to a single installation. +# +# Requirements (per GitHub App you want to authenticate as): +# - A GitHub App with its private key uploaded into Key Vault as an RSA key +# (PEM converted to a key, NOT stored as a secret). +# - The Azure service connection passed via `azureSubscription` must be +# granted the `Key Vault Crypto User` role (or at minimum `Sign` action) +# on that key. +# - The App must be installed on the target organization/account +# (`installationOwner`) with the permissions/repositories you need. +# +# Output: a secret pipeline variable named ${{ parameters.outputVariableName }} +# containing the installation access token. Token lifetime is ~1 hour and is +# automatically scrubbed from logs. Installation tokens are exempt from the +# enterprise classic-PAT lifetime policy. + +parameters: +# Azure DevOps service connection (federated) that can call +# `az keyvault key sign` on the App's signing key. +- name: azureSubscription + type: string + +# Name of the Key Vault that holds the GitHub App's RSA signing key. +- name: keyVaultName + type: string + +# Name of the RSA key inside the Key Vault (the App's private key). +- name: keyName + type: string + +# The GitHub App's Client ID (the value to put in the `iss` JWT claim). +# Prefer this over the numeric App ID; GitHub accepts either, but Client ID +# is the documented form going forward. +- name: appClientId + type: string + +# Login of the organization or user account whose installation we should +# mint the token for (e.g. `dotnet`, `microsoft`). +- name: installationOwner + type: string + +# Name of the pipeline variable that will receive the installation token. +- name: outputVariableName + type: string + +- name: is1ESPipeline + type: boolean + +- name: stepName + type: string + default: getGitHubAppInstallationToken + +- name: condition + type: string + default: '' + +- name: displayName + type: string + default: Get GitHub App installation token + +steps: +- task: AzureCLI@2 + displayName: ${{ parameters.displayName }} + name: ${{ parameters.stepName }} + ${{ if ne(parameters.condition, '') }}: + condition: ${{ parameters.condition }} + inputs: + azureSubscription: ${{ parameters.azureSubscription }} + scriptType: pscore + scriptLocation: inlineScript + inlineScript: | + & "$(System.DefaultWorkingDirectory)/eng/common/Get-GitHubAppToken.ps1" ` + -KeyVaultName '${{ parameters.keyVaultName }}' ` + -KeyName '${{ parameters.keyName }}' ` + -AppClientId '${{ parameters.appClientId }}' ` + -InstallationOwner '${{ parameters.installationOwner }}' ` + -OutputVariableName '${{ parameters.outputVariableName }}' diff --git a/eng/common/core-templates/steps/publish-logs.yml b/eng/common/core-templates/steps/publish-logs.yml index 2731e48cce4..3f0a9b9e6aa 100644 --- a/eng/common/core-templates/steps/publish-logs.yml +++ b/eng/common/core-templates/steps/publish-logs.yml @@ -5,6 +5,7 @@ parameters: # A default - in case value from eng/common/core-templates/post-build/common-variables.yml is not passed BinlogToolVersion: '1.0.11' is1ESPipeline: false + enableInternalRuntimes: true steps: - task: Powershell@2 @@ -25,16 +26,20 @@ steps: # Sensitive data can as well be added to $(System.DefaultWorkingDirectory)/eng/BinlogSecretsRedactionFile.txt' # If the file exists - sensitive data for redaction will be sourced from it # (single entry per line, lines starting with '# ' are considered comments and skipped) - arguments: -InputPath '$(System.DefaultWorkingDirectory)/PostBuildLogs' - -BinlogToolVersion '${{parameters.BinlogToolVersion}}' - -TokensFilePath '$(System.DefaultWorkingDirectory)/eng/BinlogSecretsRedactionFile.txt' - -runtimeSourceFeed https://ci.dot.net/internal - -runtimeSourceFeedKey '$(dotnetbuilds-internal-container-read-token-base64)' - '$(publishing-dnceng-devdiv-code-r-build-re)' - '$(dn-bot-all-orgs-artifact-feeds-rw)' - '$(akams-client-id)' - '$(System.AccessToken)' - ${{parameters.CustomSensitiveDataList}} + ${{ if and(parameters.enableInternalRuntimes, ne(variables['System.TeamProject'], 'public')) }}: + arguments: -InputPath '$(System.DefaultWorkingDirectory)/PostBuildLogs' + -BinlogToolVersion '${{parameters.BinlogToolVersion}}' + -TokensFilePath '$(System.DefaultWorkingDirectory)/eng/BinlogSecretsRedactionFile.txt' + -runtimeSourceFeed https://ci.dot.net/internal + -runtimeSourceFeedKey '$(dotnetbuilds-internal-container-read-token-base64)' + '$(System.AccessToken)' + ${{parameters.CustomSensitiveDataList}} + ${{ else }}: + arguments: -InputPath '$(System.DefaultWorkingDirectory)/PostBuildLogs' + -BinlogToolVersion '${{parameters.BinlogToolVersion}}' + -TokensFilePath '$(System.DefaultWorkingDirectory)/eng/BinlogSecretsRedactionFile.txt' + '$(System.AccessToken)' + ${{parameters.CustomSensitiveDataList}} continueOnError: true condition: always() @@ -57,4 +62,3 @@ steps: condition: always() retryCountOnTaskFailure: 10 # for any files being locked isProduction: false # logs are non-production artifacts - diff --git a/eng/common/cross/build-rootfs.sh b/eng/common/cross/build-rootfs.sh index 38a3512f148..f58abbd2d10 100755 --- a/eng/common/cross/build-rootfs.sh +++ b/eng/common/cross/build-rootfs.sh @@ -8,8 +8,8 @@ usage() echo "BuildArch can be: arm(default), arm64, loongarch64, ppc64le, riscv64, s390x, x64, x86" echo "CodeName - optional, Code name for Linux, can be: xenial(default), zesty, bionic, alpine" echo " for alpine can be specified with version: alpineX.YY or alpineedge" - echo " for FreeBSD can be: freebsd13, freebsd14" - echo " for OpenBSD can be: openbsd" + echo " for FreeBSD can be: freebsd14, freebsd15" + echo " for OpenBSD can be: openbsd7.8, openbsd7.9" echo " for illumos can be: illumos" echo " for Haiku can be: haiku." echo "lldbx.y - optional, LLDB version, can be: lldb3.9(default), lldb4.0, lldb5.0, lldb6.0 no-lldb. Ignored for alpine and FreeBSD" @@ -78,9 +78,9 @@ __AlpinePackages+=" krb5-dev" __AlpinePackages+=" openssl-dev" __AlpinePackages+=" zlib-dev" -__FreeBSDBase="13.5-RELEASE" -__FreeBSDPkg="2.7.5" -__FreeBSDABI="13" +__FreeBSDBase="14.4-RELEASE" +__FreeBSDPkg="2.8.0" +__FreeBSDABI="14" __FreeBSDPackages="libunwind" __FreeBSDPackages+=" icu" __FreeBSDPackages+=" libinotify" @@ -187,17 +187,14 @@ while :; do __AlpineArch=loongarch64 __QEMUArch=loongarch64 __UbuntuArch=loong64 - __UbuntuSuites=unreleased __LLDB_Package="liblldb-19-dev" ;; riscv64) __BuildArch=riscv64 __AlpineArch=riscv64 - __AlpinePackages="${__AlpinePackages// lldb-dev/}" __QEMUArch=riscv64 __UbuntuArch=riscv64 - __UbuntuPackages="${__UbuntuPackages// libunwind8-dev/}" - unset __LLDB_Package + __LLDB_Package="liblldb-19-dev" ;; ppc64le) __BuildArch=ppc64le @@ -291,6 +288,10 @@ while :; do __CodeName=noble __LLDB_Package="liblldb-19-dev" ;; + resolute) # Ubuntu 26.04 + __CodeName=resolute + __LLDB_Package="liblldb-21-dev" + ;; stretch) # Debian 9 __CodeName=stretch __LLDB_Package="liblldb-6.0-dev" @@ -331,7 +332,7 @@ while :; do # Debian-Ports architectures need different values case "$__UbuntuArch" in - amd64|arm64|armhf|i386|mips64el|ppc64el|riscv64|s390x) + amd64|arm64|armhf|i386|mips64el|ppc64el|riscv64|loong64|s390x) __KeyringFile="/usr/share/keyrings/debian-archive-keyring.gpg" if [[ -z "$__UbuntuRepo" ]]; then @@ -365,20 +366,29 @@ while :; do __AlpineVersion="$__AlpineMajorVersion.$__AlpineMinorVersion" fi ;; - freebsd13) + freebsd14) __CodeName=freebsd __SkipUnmount=1 ;; - freebsd14) + freebsd15) __CodeName=freebsd - __FreeBSDBase="14.3-RELEASE" - __FreeBSDABI="14" + __FreeBSDBase="15.1-RELEASE" + __FreeBSDABI="15" __SkipUnmount=1 ;; openbsd) __CodeName=openbsd __SkipUnmount=1 ;; + openbsd7.8) + __CodeName=openbsd + __SkipUnmount=1 + ;; + openbsd7.9) + __CodeName=openbsd + __OpenBSDVersion="7.9" + __SkipUnmount=1 + ;; illumos) __CodeName=illumos __SkipUnmount=1 diff --git a/eng/common/msbuild.ps1 b/eng/common/msbuild.ps1 index 495d533a909..b6dfb570ea5 100644 --- a/eng/common/msbuild.ps1 +++ b/eng/common/msbuild.ps1 @@ -3,6 +3,7 @@ Param( [string] $verbosity = 'minimal', [bool] $warnAsError = $true, [bool] $nodeReuse = $true, + [bool][Alias('mt')]$msbuildMultiThreaded = $false, [switch] $ci, [switch] $prepareMachine, [switch] $excludePrereleaseVS, @@ -13,12 +14,9 @@ Param( . $PSScriptRoot\tools.ps1 try { - if ($ci) { - # Disable node reuse on CI unless explicitly opted in via MSBUILD_NODEREUSE_ENABLED. - # Internal testing only; this env var will be replaced with a switch (https://github.com/dotnet/arcade/issues/17013) and must not be depended on. - if ($env:MSBUILD_NODEREUSE_ENABLED -ne "1") { - $nodeReuse = $false - } + # Node reuse isn't used on CI unless it was explicitly requested via -nodeReuse. + if ($ci -and -not $PSBoundParameters.ContainsKey('nodeReuse')) { + $nodeReuse = $false } MSBuild @extraArgs diff --git a/eng/common/msbuild.sh b/eng/common/msbuild.sh index 333be3232fc..a40c101237b 100755 --- a/eng/common/msbuild.sh +++ b/eng/common/msbuild.sh @@ -14,7 +14,9 @@ scriptroot="$( cd -P "$( dirname "$source" )" && pwd )" verbosity='minimal' warn_as_error=true -node_reuse=true +# Empty means "not specified"; tools.sh defaults these to on for local builds and off on CI. +node_reuse='' +msbuild_multi_threaded='' prepare_machine=false extra_args='' @@ -33,6 +35,10 @@ while (($# > 0)); do node_reuse=$2 shift 2 ;; + --msbuildmultithreaded|--mt) + msbuild_multi_threaded=$2 + shift 2 + ;; --ci) ci=true shift 1 @@ -50,13 +56,5 @@ done . "$scriptroot/tools.sh" -if [[ "$ci" == true ]]; then - # Disable node reuse on CI unless explicitly opted in via MSBUILD_NODEREUSE_ENABLED. - # Internal testing only; this env var will be replaced with a switch (https://github.com/dotnet/arcade/issues/17013) and must not be depended on. - if [[ "${MSBUILD_NODEREUSE_ENABLED:-}" != "1" ]]; then - node_reuse=false - fi -fi - MSBuild $extra_args ExitWithExitCode 0 diff --git a/eng/common/templates-official/steps/get-github-app-token.yml b/eng/common/templates-official/steps/get-github-app-token.yml new file mode 100644 index 00000000000..c89f3641a4d --- /dev/null +++ b/eng/common/templates-official/steps/get-github-app-token.yml @@ -0,0 +1,7 @@ +steps: +- template: /eng/common/core-templates/steps/get-github-app-token.yml + parameters: + is1ESPipeline: true + + ${{ each parameter in parameters }}: + ${{ parameter.key }}: ${{ parameter.value }} diff --git a/eng/common/templates/steps/get-github-app-token.yml b/eng/common/templates/steps/get-github-app-token.yml new file mode 100644 index 00000000000..79e182c6416 --- /dev/null +++ b/eng/common/templates/steps/get-github-app-token.yml @@ -0,0 +1,7 @@ +steps: +- template: /eng/common/core-templates/steps/get-github-app-token.yml + parameters: + is1ESPipeline: false + + ${{ each parameter in parameters }}: + ${{ parameter.key }}: ${{ parameter.value }} diff --git a/eng/common/tools.ps1 b/eng/common/tools.ps1 index ebc31f7ecdc..e84033dad90 100644 --- a/eng/common/tools.ps1 +++ b/eng/common/tools.ps1 @@ -31,11 +31,16 @@ # Set to true to reuse msbuild nodes. Recommended to not reuse on CI. [bool]$nodeReuse = if (Test-Path variable:nodeReuse) { $nodeReuse } else { !$ci } +# Set to true to build with MSBuild's multi-threaded mode (-mt). Opt-in for now, so off unless it was +# explicitly requested. It's intended to become the default for local builds once it has proven out. +[bool]$msbuildMultiThreaded = if (Test-Path variable:msbuildMultiThreaded) { $msbuildMultiThreaded } else { $false } + # Configures warning treatment in msbuild. [bool]$warnAsError = if (Test-Path variable:warnAsError) { $warnAsError } else { $true } # Specifies semi-colon delimited list of warning codes that should not be treated as errors. -[string]$warnNotAsError = if (Test-Path variable:warnNotAsError) { $warnNotAsError } else { '' } +# Defaults to NuGet Audit warning codes NU1901-NU1904. +[string]$warnNotAsError = if ((Test-Path variable:warnNotAsError) -and $warnNotAsError) { $warnNotAsError } else { 'NU1901;NU1902;NU1903;NU1904' } # Specifies which msbuild engine to use for build: 'vs', 'dotnet' or unspecified (determined based on presence of tools.vs in global.json). [string]$msbuildEngine = if (Test-Path variable:msbuildEngine) { $msbuildEngine } else { $null } @@ -808,8 +813,8 @@ function MSBuild() { $cmdArgs = "$($buildTool.Command) /m /nologo /clp:Summary /v:$verbosity /nr:$nodeReuse /p:ContinuousIntegrationBuild=$ci" - # Add -mt flag for MSBuild multithreaded mode if enabled via environment variable - if ($env:MSBUILD_MT_ENABLED -eq "1") { + # Build with MSBuild's multi-threaded mode. + if ($msbuildMultiThreaded) { $cmdArgs += ' -mt' } @@ -821,7 +826,8 @@ function MSBuild() { } if ($warnAsError -and $warnNotAsError) { - $cmdArgs += " /warnnotaserror:$warnNotAsError /p:AdditionalWarningsNotAsErrors=$warnNotAsError" + $escapedWarnNotAsError = $warnNotAsError -replace ';', '%3B' + $cmdArgs += " /warnnotaserror:$warnNotAsError /p:AdditionalWarningsNotAsErrors=$escapedWarnNotAsError" } foreach ($arg in $args) { diff --git a/eng/common/tools.sh b/eng/common/tools.sh index cd31d8a0a0e..4d14b100b06 100755 --- a/eng/common/tools.sh +++ b/eng/common/tools.sh @@ -1,5 +1,15 @@ #!/usr/bin/env bash +# Normalizes the value of a boolean build argument. Accepts 1/0 in addition to true/false so that +# the same value works with the PowerShell scripts, whose [bool] parameters only bind 1/0. +function NormalizeBoolArg { + case "${1:-}" in + 1) echo true ;; + 0) echo false ;; + *) echo "${1:-}" ;; + esac +} + # Initialize variables if they aren't already defined. # CI mode - set to true on CI server for PR validation build or official build. @@ -43,17 +53,25 @@ restore=${restore:-true} verbosity=${verbosity:-'minimal'} # Set to true to reuse msbuild nodes. Recommended to not reuse on CI. +node_reuse=$(NormalizeBoolArg "${node_reuse:-}") if [[ "$ci" == true ]]; then node_reuse=${node_reuse:-false} else node_reuse=${node_reuse:-true} fi +# Set to true to build with MSBuild's multi-threaded mode (-mt). Opt-in for now, so off unless it was +# explicitly requested. It's intended to become the default for local builds once it has proven out. +msbuild_multi_threaded=$(NormalizeBoolArg "${msbuild_multi_threaded:-}") +msbuild_multi_threaded=${msbuild_multi_threaded:-false} + # Configures warning treatment in msbuild. +warn_as_error=$(NormalizeBoolArg "${warn_as_error:-}") warn_as_error=${warn_as_error:-true} # Specifies semi-colon delimited list of warning codes that should not be treated as errors. -warn_not_as_error=${warn_not_as_error:-''} +# Defaults to NuGet Audit warning codes NU1901-NU1904. +warn_not_as_error="${warn_not_as_error:-NU1901;NU1902;NU1903;NU1904}" # True to attempt using .NET Core already that meets requirements specified in global.json # installed on the machine instead of downloading one. @@ -587,18 +605,18 @@ function MSBuild { } } - # Add -mt flag for MSBuild multithreaded mode if enabled via environment variable + # Build with MSBuild's multi-threaded mode. local mt_switch="" - if [[ "${MSBUILD_MT_ENABLED:-}" == "1" ]]; then + if [[ "$msbuild_multi_threaded" == true ]]; then mt_switch="-mt" fi local warnnotaserror_switch="" if [[ -n "$warn_not_as_error" && "$warn_as_error" == true ]]; then - warnnotaserror_switch="/warnnotaserror:$warn_not_as_error /p:AdditionalWarningsNotAsErrors=$warn_not_as_error" + warnnotaserror_switch="/warnnotaserror:$warn_not_as_error /p:AdditionalWarningsNotAsErrors=${warn_not_as_error//;/%3B}" fi - RunBuildTool "$_InitializeBuildToolCommand" /m /nologo /clp:Summary /v:$verbosity /nr:$node_reuse $warnaserror_switch $mt_switch $warnnotaserror_switch "${logger_switch[@]}" /p:TreatWarningsAsErrors=$warn_as_error /p:ContinuousIntegrationBuild=$ci "$@" + RunBuildTool "$_InitializeBuildToolCommand" /m /nologo /clp:Summary /v:$verbosity /nr:$node_reuse $warnaserror_switch $mt_switch $warnnotaserror_switch ${logger_switch[@]+"${logger_switch[@]}"} /p:TreatWarningsAsErrors=$warn_as_error /p:ContinuousIntegrationBuild=$ci "$@" } function GetDarc { diff --git a/global.json b/global.json index 6dc5358084a..7765576685e 100644 --- a/global.json +++ b/global.json @@ -23,7 +23,7 @@ "xcopy-msbuild": "18.0.0" }, "msbuild-sdks": { - "Microsoft.DotNet.Arcade.Sdk": "11.0.0-beta.26369.1", + "Microsoft.DotNet.Arcade.Sdk": "11.0.0-beta.26414.2", "Microsoft.DotNet.Helix.Sdk": "8.0.0-beta.23255.2" } } From bc50d5e744eb1b8f7931d01cd06373f73c7abe19 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 19 Aug 2026 12:06:57 +0200 Subject: [PATCH 49/55] IL: cache C# extension methods per CCU (#20256) --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + src/Compiler/Checking/NameResolution.fs | 60 ++++++++++++++----- src/Compiler/Checking/import.fs | 1 + src/Compiler/Driver/CompilerImports.fs | 3 + src/Compiler/Driver/ParseAndCheckInputs.fs | 2 + src/Compiler/TypedTree/TypedTree.fs | 4 +- src/Compiler/TypedTree/TypedTree.fsi | 5 ++ 7 files changed, 59 insertions(+), 17 deletions(-) diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index 0c576e47667..eb722a46503 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -169,6 +169,7 @@ ### Improved +* IL: cache C# extension methods per CCU ([PR #20256](https://github.com/dotnet/fsharp/pull/20256)) * Nullness warning FS3261 on dotted method or property access (e.g. `x.Member`) now underlines the receiver expression and includes the member name and (when known) the binding name in the message. ([Issue #19658](https://github.com/dotnet/fsharp/issues/19658), [PR #19814](https://github.com/dotnet/fsharp/pull/19814)) * Direct delegate construction ([PR ##19993](https://github.com/dotnet/fsharp/pull/19993)) * IL: add `ILPreNamespace`, make `ILPreTypeDef` creation lazy ([PR #20092](https://github.com/dotnet/fsharp/pull/20092)) diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index b93d9e416b2..856519cd7ff 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -587,20 +587,9 @@ let GetTyconRefForExtensionMembers minfo (deref: Entity) amap m g = None /// Get the info for all the .NET-style extension members listed as static members in the type. -let private GetCSharpStyleIndexedExtensionMembersForTyconRef (amap: Import.ImportMap) m (tcrefOfStaticClass: TyconRef) = +let private ComputeCSharpStyleExtensionMembers (amap: Import.ImportMap) m (tcrefOfStaticClass: TyconRef) (importFailed: bool ref) = let g = amap.g - - let isApplicable = - IsTyconRefUsedForCSharpStyleExtensionMembers g tcrefOfStaticClass || - - g.langVersion.SupportsFeature(LanguageFeature.CSharpExtensionAttributeNotRequired) && - tcrefOfStaticClass.IsLocalRef && - not tcrefOfStaticClass.IsTypeAbbrev - - if not isApplicable then [] else - let ty = generalizedTyconRef g tcrefOfStaticClass - let pri = NextExtensionMethodPriority() let methods = protectAssemblyExploration [] @@ -608,7 +597,6 @@ let private GetCSharpStyleIndexedExtensionMembersForTyconRef (amap: Import.Impor [ for minfo in methods do if IsMethInfoPlainCSharpStyleExtensionMember g m true minfo then - let ilExtMem = ILExtMem (tcrefOfStaticClass, minfo, pri) // The results are indexed by the TyconRef of the first 'this' argument, if any. // So we need to go and crack the type of the 'this' argument. // @@ -620,9 +608,49 @@ let private GetCSharpStyleIndexedExtensionMembersForTyconRef (amap: Import.Impor // methods for tuple occur in C# code) let thisTyconRef = GetTyconRefForExtensionMembers minfo tcrefOfStaticClass.Deref amap m g match thisTyconRef with - | None -> () - | Some (Some tcref) -> yield Choice1Of2(tcref, ilExtMem) - | Some None -> yield Choice2Of2 ilExtMem ] + | None -> importFailed.Value <- true + | Some thisTyconRefOpt -> yield (thisTyconRefOpt, minfo) ] + +let private GetCSharpStyleIndexedExtensionMembersForTyconRef (amap: Import.ImportMap) m (tcrefOfStaticClass: TyconRef) = + let g = amap.g + + let isApplicable = + IsTyconRefUsedForCSharpStyleExtensionMembers g tcrefOfStaticClass || + + g.langVersion.SupportsFeature(LanguageFeature.CSharpExtensionAttributeNotRequired) && + tcrefOfStaticClass.IsLocalRef && + not tcrefOfStaticClass.IsTypeAbbrev + + // Checked before touching the CCU or its cache, so a non-extension class costs nothing extra. + if not isApplicable then [] else + + let shape = + // A local class is still gaining members while its own file is checked; only an imported one is + // immutable enough to share. The cache lives on the CCU, so it goes when the project does. + if tcrefOfStaticClass.IsLocalRef then + ComputeCSharpStyleExtensionMembers amap m tcrefOfStaticClass (ref false) + else + let cache = tcrefOfStaticClass.nlr.Ccu.Deref.CSharpStyleExtensionMembersCache + match cache.TryGetValue tcrefOfStaticClass.Stamp with + | true, shape -> shape :?> (TyconRef option * MethInfo) list + | _ -> + let importFailed = ref false + let shape = ComputeCSharpStyleExtensionMembers amap m tcrefOfStaticClass importFailed + + if not importFailed.Value then + cache.TryAdd(tcrefOfStaticClass.Stamp, (shape :> obj)) |> ignore + + shape + + if List.isEmpty shape then [] else + + let pri = NextExtensionMethodPriority() + + [ for thisTyconRefOpt, minfo in shape do + let ilExtMem = ILExtMem (tcrefOfStaticClass, minfo, pri) + match thisTyconRefOpt with + | Some tcref -> yield Choice1Of2(tcref, ilExtMem) + | None -> yield Choice2Of2 ilExtMem ] /// Query the declared properties of a type (including inherited properties) let IntrinsicPropInfosOfTypeInScope (infoReader: InfoReader) optFilter ad findFlag m ty = diff --git a/src/Compiler/Checking/import.fs b/src/Compiler/Checking/import.fs index fb8c1efee05..e226b411458 100644 --- a/src/Compiler/Checking/import.fs +++ b/src/Compiler/Checking/import.fs @@ -875,6 +875,7 @@ let ImportILAssembly(amap: unit -> ImportMap, m, auxModuleLoader, xmlDocInfoLoad MemberSignatureEquality= (fun ty1 ty2 -> typeEquivAux EraseAll (amap()).g ty1 ty2) TryGetILModuleDef = (fun () -> Some ilModule) TypeForwarders = forwarders + CSharpStyleExtensionMembersCache = ConcurrentDictionary(1, 0) XmlDocumentationInfo = match xmlDocInfoLoader, fileName with | Some xmlDocInfoLoader, Some fileName -> xmlDocInfoLoader.TryLoad(fileName) diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index 68edbca6bef..e9e5c2d4206 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -5,6 +5,7 @@ module internal FSharp.Compiler.CompilerImports open System +open System.Collections.Concurrent open System.Collections.Generic open System.Diagnostics open System.IO @@ -1532,6 +1533,7 @@ and [] TcImports ImportProvidedType = (fun ty -> ImportProvidedType (tcImports.GetImportMap()) m ty) TryGetILModuleDef = (fun () -> Some ilModule) TypeForwarders = CcuTypeForwarderTable.Empty + CSharpStyleExtensionMembersCache = ConcurrentDictionary(1, 0) XmlDocumentationInfo = match tcConfig.xmlDocInfoLoader with | Some xmlDocInfoLoader -> xmlDocInfoLoader.TryLoad(fileName) @@ -2156,6 +2158,7 @@ and [] TcImports UsesFSharp20PlusQuotations = minfo.usesQuotations MemberSignatureEquality = (fun ty1 ty2 -> typeEquivAux EraseAll (tcImports.GetTcGlobals()) ty1 ty2) TypeForwarders = ImportILAssemblyTypeForwarders(tcImports.GetImportMap, m, ilModule.GetRawTypeForwarders()) + CSharpStyleExtensionMembersCache = ConcurrentDictionary(1, 0) #if !NO_TYPEPROVIDERS XmlDocumentationInfo = match tcConfig.xmlDocInfoLoader with diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index 17a316b7553..954809f9488 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -6,6 +6,7 @@ module internal FSharp.Compiler.ParseAndCheckInputs open System open System.IO open System.Threading +open System.Collections.Concurrent open System.Collections.Generic open FSharp.Compiler.Parser @@ -1098,6 +1099,7 @@ let GetInitialTcState (m, ccuName, tcConfig: TcConfig, tcGlobals, tcImports: TcI Contents = ccuContents MemberSignatureEquality = typeEquivAux EraseAll tcGlobals TypeForwarders = CcuTypeForwarderTable.Empty + CSharpStyleExtensionMembersCache = ConcurrentDictionary(1, 0) XmlDocumentationInfo = None } diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 44e17e3b667..30a86256fa3 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -5899,7 +5899,9 @@ type CcuData = /// The table of .NET CLI type forwarders for this assembly TypeForwarders: CcuTypeForwarderTable - + + CSharpStyleExtensionMembersCache: ConcurrentDictionary + XmlDocumentationInfo: XmlDocumentationInfo option } [] diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index dede50853d2..988f462b0f8 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -3,6 +3,7 @@ module internal rec FSharp.Compiler.TypedTree open System open System.Diagnostics +open System.Collections.Concurrent open System.Collections.Generic open System.Collections.Immutable open Internal.Utilities.Collections @@ -4233,6 +4234,10 @@ type CcuData = /// The table of .NET CLI type forwarders for this assembly TypeForwarders: CcuTypeForwarderTable + + /// C#-style extension members of this assembly's static classes, keyed by static class stamp. + /// Typed as obj because MethInfo is declared after this file. + CSharpStyleExtensionMembersCache: ConcurrentDictionary XmlDocumentationInfo: XmlDocumentationInfo option } From d05075e098278aedcea3379159504d664628a495 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 19 Aug 2026 12:09:30 +0200 Subject: [PATCH 50/55] Parser: recover on missing 'when' conditions (#20071) --- .../.FSharp.Compiler.Service/11.0.100.md | 4 +- src/Compiler/SyntaxTree/ParseHelpers.fs | 42 +++++++++ src/Compiler/SyntaxTree/ParseHelpers.fsi | 17 ++++ src/Compiler/pars.fsy | 90 +++++++++---------- .../SyntaxTree/Expression/Match - When 01.fs | 4 + .../Expression/Match - When 01.fs.bsl | 21 +++++ .../SyntaxTree/Expression/Match - When 02.fs | 4 + .../Expression/Match - When 02.fs.bsl | 22 +++++ .../SyntaxTree/Expression/Match - When 03.fs | 5 ++ .../Expression/Match - When 03.fs.bsl | 28 ++++++ .../SyntaxTree/Expression/Match - When 04.fs | 7 ++ .../Expression/Match - When 04.fs.bsl | 24 +++++ .../Expression/Try - With 09.fs.bsl | 26 +++--- .../CompletionProviderTests.fs | 2 +- 14 files changed, 237 insertions(+), 59 deletions(-) create mode 100644 tests/service/data/SyntaxTree/Expression/Match - When 01.fs create mode 100644 tests/service/data/SyntaxTree/Expression/Match - When 01.fs.bsl create mode 100644 tests/service/data/SyntaxTree/Expression/Match - When 02.fs create mode 100644 tests/service/data/SyntaxTree/Expression/Match - When 02.fs.bsl create mode 100644 tests/service/data/SyntaxTree/Expression/Match - When 03.fs create mode 100644 tests/service/data/SyntaxTree/Expression/Match - When 03.fs.bsl create mode 100644 tests/service/data/SyntaxTree/Expression/Match - When 04.fs create mode 100644 tests/service/data/SyntaxTree/Expression/Match - When 04.fs.bsl diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index eb722a46503..b30a501d979 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -113,8 +113,8 @@ * Fix signature conformance: overloaded member with unit parameter `M(())` now matches sig `member M: unit -> unit`. ([Issue #19596](https://github.com/dotnet/fsharp/issues/19596), [PR #19615](https://github.com/dotnet/fsharp/pull/19615)) * Fix `--quiet` not suppressing NuGet restore output on stdout in F# Interactive ([Issue #18086](https://github.com/dotnet/fsharp/issues/18086)) * Reference assembly MVIDs are now deterministic across compiler invocations. Previously, `--refout` / `true` produced a different MVID every build because the implied signature hash used .NET's randomized `String.GetHashCode()`. ([Issue #19751](https://github.com/dotnet/fsharp/issues/19751), [PR #19801](https://github.com/dotnet/fsharp/pull/19801)) -* Parser: recover on unfinished if and binary expressions -([PR #19724](https://github.com/dotnet/fsharp/pull/19724)) +* Parser: recover on unfinished if and binary expressions ([PR #19724](https://github.com/dotnet/fsharp/pull/19724)) +* Parser: recover on missing 'when' conditions ([PR ##20071](https://github.com/dotnet/fsharp/pull/#20071)) * Fix `SynExpr.shouldBeParenthesizedInContext` to report parentheses as required around `SynExpr.Sequential` expressions used as record or anonymous-record field values, so the IDE "remove unnecessary parentheses" analyzer no longer breaks code like `{| A = ((); B = 3) |}`. ([Issue #17826](https://github.com/dotnet/fsharp/issues/17826), [PR #19850](https://github.com/dotnet/fsharp/pull/19850)) * Fix semantic classification of `IDisposable` and other interface types in type-occurrence positions being incorrectly classified as `DisposableType` instead of `Interface`. ([Issue #16268](https://github.com/dotnet/fsharp/issues/16268), [PR #19809](https://github.com/dotnet/fsharp/pull/19809)) * Fix missing semantic classification on second and later type qualifiers in nested copy-and-update expressions like `{ p with Person.Info.X = 1; Person.Info.Y = 2 }`. ([Issue #17428](https://github.com/dotnet/fsharp/issues/17428), [PR #19878](https://github.com/dotnet/fsharp/pull/19878)) diff --git a/src/Compiler/SyntaxTree/ParseHelpers.fs b/src/Compiler/SyntaxTree/ParseHelpers.fs index 9605fce5f2d..26b1b76133b 100644 --- a/src/Compiler/SyntaxTree/ParseHelpers.fs +++ b/src/Compiler/SyntaxTree/ParseHelpers.fs @@ -1258,3 +1258,45 @@ let mkAbstractMember [ SynMemberDefn.AbstractSlot(valSpfn, mkFlags (getSetAdjuster arity), mWhole, trivia) ] + +let mkMatchClauses patternAndGuard patternResult (mNextBar: range option) nextClauses mLastOuter = + let (pat: SynPat), guard = patternAndGuard + let (mArrow: range option), (resultExpr: SynExpr) = patternResult + + fun mBar -> + let m = unionRanges resultExpr.Range pat.Range + + let clause = + SynMatchClause(pat, guard, resultExpr, m, DebugPointAtTarget.Yes, { ArrowRange = mArrow; BarRange = mBar }) + + let clauses, mLast = + match nextClauses with + | Some patternClauses -> + let clauses, mLast = patternClauses mNextBar + clause :: clauses, mLast + + | _ -> [ clause ], resultExpr.Range + + clauses, mLastOuter |> Option.defaultValue mLast + +let mkMatchClausesRecoverMissingResult + (patternAndGuard: SynPat * SynExpr option) + exprDebugString + (mExpr: range option) + (mNextBar: range option) + nextClauses + mLastOuter + = + let pat, guard = patternAndGuard + + let mBeforeResult = + match mExpr with + | Some m -> m + | _ -> + + match guard with + | Some expr -> expr.Range + | _ -> pat.Range + + let patternResult = None, arbExpr (exprDebugString, mBeforeResult.EndRange) + mkMatchClauses patternAndGuard patternResult (mNextBar: range option) nextClauses mLastOuter diff --git a/src/Compiler/SyntaxTree/ParseHelpers.fsi b/src/Compiler/SyntaxTree/ParseHelpers.fsi index bcaa5bc9b19..41ca4630abe 100644 --- a/src/Compiler/SyntaxTree/ParseHelpers.fsi +++ b/src/Compiler/SyntaxTree/ParseHelpers.fsi @@ -298,3 +298,20 @@ val mkAbstractMember: typeWithConstraints: SynType * SynValInfo -> accessors: range option * (SynMemberKind * GetSetKeywords option * SynAccess option * SynAccess option) -> SynMemberDefn list + +val mkMatchClauses: + patternAndGuard: SynPat * SynExpr option -> + patternResult: range option * SynExpr -> + mNextBar: range option -> + nextClauses: (range option -> SynMatchClause list * range) option -> + mLastOuter: range option -> + (range option -> SynMatchClause list * range) + +val mkMatchClausesRecoverMissingResult: + patternAndGuard: SynPat * SynExpr option -> + exprDebugString: string -> + mExpr: range option -> + mNextBar: range option -> + nextClauses: (range option -> SynMatchClause list * range) option -> + mLastOuter: range option -> + (range option -> SynMatchClause list * range) diff --git a/src/Compiler/pars.fsy b/src/Compiler/pars.fsy index 31e653689fc..dc0af511b0b 100644 --- a/src/Compiler/pars.fsy +++ b/src/Compiler/pars.fsy @@ -164,7 +164,7 @@ let parse_error_rich = Some(fun (ctxt: ParseErrorContext<_>) -> %type tyconSpfnList %type atomicPatsOrNamePatPairs %type atomicPatterns -%type patternResult +%type patternResult %type declExpr %type minusExpr %type appExpr @@ -5072,66 +5072,64 @@ patternAndGuard: patternClauses: | patternAndGuard patternResult %prec prec_pat_pat_action - { let pat, guard = $1 - let mArrow, resultExpr = $2 - let mLast = resultExpr.Range - let m = unionRanges resultExpr.Range pat.Range - fun mBar -> - [SynMatchClause(pat, guard, resultExpr, m, DebugPointAtTarget.Yes, { ArrowRange = Some mArrow; BarRange = mBar })], mLast } + { mkMatchClauses $1 $2 None None None } | patternAndGuard patternResult barCanBeRightBeforeNull patternClauses - { let pat, guard = $1 - let mArrow, resultExpr = $2 - let mNextBar = rhs parseState 3 |> Some - let clauses, mLast = $4 mNextBar - let m = unionRanges resultExpr.Range pat.Range - fun mBar -> - (SynMatchClause(pat, guard, resultExpr, m, DebugPointAtTarget.Yes, { ArrowRange = Some mArrow; BarRange = mBar }) :: clauses), mLast } + { let mNextBar = rhs parseState 3 |> Some + mkMatchClauses $1 $2 mNextBar (Some $4) None } | patternAndGuard patternResult BAR barCanBeRightBeforeNull patternClauses - { let pat, guard = $1 - let mArrow, resultExpr = $2 + { let mNextBar = rhs parseState 3 |> Some let mBar1 = rhs parseState 3 let mBar2 = rhs parseState 4 reportParseErrorAt mBar2 (FSComp.SR.parsExpectingPattern ()) - let clauses, mLast = Some mBar1 |> $5 - let clauses = addEmptyMatchClause mBar1 mBar2 clauses + let patternClauses = + fun mNextBar -> + let clauses, mLast = Some mBar1 |> $5 + let clauses = addEmptyMatchClause mBar1 mBar2 clauses + clauses, mLast - fun mBar -> - let m = unionRanges resultExpr.Range pat.Range - let trivia = { ArrowRange = Some mArrow; BarRange = mBar } - SynMatchClause(pat, guard, resultExpr, m, DebugPointAtTarget.Yes, trivia) :: clauses, mLast } + mkMatchClauses $1 $2 mNextBar (Some patternClauses) None } | patternAndGuard error barCanBeRightBeforeNull patternClauses - { let pat, guard = $1 - let mNextBar = rhs parseState 3 |> Some - let clauses, mLast = $4 mNextBar - let patm = pat.Range - let m = guard |> Option.map (fun e -> unionRanges patm e.Range) |> Option.defaultValue patm - fun _mBar -> - (SynMatchClause(pat, guard, arbExpr ("patternClauses1", m.EndRange), m, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero) :: clauses), mLast } + { let mNextBar = rhs parseState 3 |> Some + mkMatchClausesRecoverMissingResult $1 "patternClauses1" None mNextBar (Some $4) None } | patternAndGuard patternResult barCanBeRightBeforeNull recover - { let pat, guard = $1 - let mArrow, resultExpr = $2 - let mLast = rhs parseState 3 - let m = unionRanges resultExpr.Range pat.Range - fun mBar -> - [SynMatchClause(pat, guard, resultExpr, m, DebugPointAtTarget.Yes, { ArrowRange = Some mArrow; BarRange = mBar })], mLast } + { let mLast = rhs parseState 3 |> Some + mkMatchClauses $1 $2 None None mLast } | patternAndGuard patternResult recover - { let pat, guard = $1 - let mArrow, resultExpr = $2 - let m = unionRanges resultExpr.Range pat.Range - fun mBar -> - [SynMatchClause(pat, guard, resultExpr, m, DebugPointAtTarget.Yes, { ArrowRange = Some mArrow; BarRange = mBar })], m } + { mkMatchClauses $1 $2 None None None } | patternAndGuard recover - { let pat, guard = $1 - let patm = pat.Range - let m = guard |> Option.map (fun e -> unionRanges patm e.Range) |> Option.defaultValue patm - fun mBar -> - [SynMatchClause(pat, guard, arbExpr ("patternClauses2", m.EndRange), m, DebugPointAtTarget.Yes, { ArrowRange = None; BarRange = mBar })], m } + { mkMatchClausesRecoverMissingResult $1 "patternClauses2" None None None None } + + | parenPattern WHEN patternResult %prec prec_recover + { let patternAndGuard = $1, None + let mWhen = rhs parseState 2 + reportParseErrorAt mWhen (FSComp.SR.parsExpectingExpression ()) + mkMatchClauses patternAndGuard $3 None None None } + + | parenPattern WHEN %prec prec_recover + { let patternAndGuard = $1, None + let mWhen = rhs parseState 2 + reportParseErrorAt mWhen (FSComp.SR.parsExpectingExpression ()) + mkMatchClausesRecoverMissingResult patternAndGuard "patternClauses3" (Some mWhen) None None None } + + | parenPattern WHEN barCanBeRightBeforeNull patternClauses %prec prec_recover + { let patternAndGuard = $1, None + let mWhen = rhs parseState 2 + reportParseErrorAt mWhen (FSComp.SR.parsExpectingExpression ()) + let mNextBar = rhs parseState 3 |> Some + mkMatchClausesRecoverMissingResult patternAndGuard "patternClauses4" (Some mWhen) mNextBar (Some $4) None } + + | parenPattern WHEN barCanBeRightBeforeNull %prec prec_recover + { let patternAndGuard = $1, None + let mWhen = rhs parseState 2 + reportParseErrorAt mWhen (FSComp.SR.parsExpectingExpression ()) + let mLast = rhs parseState 3 |> Some + mkMatchClausesRecoverMissingResult patternAndGuard "patternClauses5" (Some mWhen) None None mLast } patternGuard: | WHEN declExpr @@ -5144,7 +5142,7 @@ patternResult: | RARROW typedSequentialExprBlockR { let mArrow = rhs parseState 1 let expr = $2 mArrow - mArrow, expr } + Some mArrow, expr } ifExprCases: | ifExprThen ifExprElifs diff --git a/tests/service/data/SyntaxTree/Expression/Match - When 01.fs b/tests/service/data/SyntaxTree/Expression/Match - When 01.fs new file mode 100644 index 00000000000..8975d41270d --- /dev/null +++ b/tests/service/data/SyntaxTree/Expression/Match - When 01.fs @@ -0,0 +1,4 @@ +module Module + +match () with +| _ when true -> () diff --git a/tests/service/data/SyntaxTree/Expression/Match - When 01.fs.bsl b/tests/service/data/SyntaxTree/Expression/Match - When 01.fs.bsl new file mode 100644 index 00000000000..1a863c9a413 --- /dev/null +++ b/tests/service/data/SyntaxTree/Expression/Match - When 01.fs.bsl @@ -0,0 +1,21 @@ +ImplFile + (ParsedImplFileInput + ("/root/Expression/Match - When 01.fs", false, QualifiedNameOfFile Module, + [], + [SynModuleOrNamespace + ([Module], false, NamedModule, + [Expr + (Match + (Yes (3,0--3,13), Const (Unit, (3,6--3,8)), + [SynMatchClause + (Wild (4,2--4,3), Some (Const (Bool true, (4,9--4,13))), + Const (Unit, (4,17--4,19)), (4,2--4,19), Yes, + { ArrowRange = Some (4,14--4,16) + BarRange = Some (4,0--4,1) })], (3,0--4,19), + { MatchKeyword = (3,0--3,5) + WithKeyword = (3,9--3,13) }), (3,0--4,19))], + PreXmlDoc ((1,0), FSharp.Compiler.Xml.XmlDocCollector), [], None, + (1,0--4,19), { LeadingKeyword = Module (1,0--1,6) })], (true, true), + { ConditionalDirectives = [] + WarnDirectives = [] + CodeComments = [] }, set [])) diff --git a/tests/service/data/SyntaxTree/Expression/Match - When 02.fs b/tests/service/data/SyntaxTree/Expression/Match - When 02.fs new file mode 100644 index 00000000000..a9e4204bac3 --- /dev/null +++ b/tests/service/data/SyntaxTree/Expression/Match - When 02.fs @@ -0,0 +1,4 @@ +module Module + +match () with +| _ when -> () diff --git a/tests/service/data/SyntaxTree/Expression/Match - When 02.fs.bsl b/tests/service/data/SyntaxTree/Expression/Match - When 02.fs.bsl new file mode 100644 index 00000000000..b9101cf081c --- /dev/null +++ b/tests/service/data/SyntaxTree/Expression/Match - When 02.fs.bsl @@ -0,0 +1,22 @@ +ImplFile + (ParsedImplFileInput + ("/root/Expression/Match - When 02.fs", false, QualifiedNameOfFile Module, + [], + [SynModuleOrNamespace + ([Module], false, NamedModule, + [Expr + (Match + (Yes (3,0--3,13), Const (Unit, (3,6--3,8)), + [SynMatchClause + (Wild (4,2--4,3), None, Const (Unit, (4,12--4,14)), + (4,2--4,14), Yes, { ArrowRange = Some (4,9--4,11) + BarRange = Some (4,0--4,1) })], + (3,0--4,14), { MatchKeyword = (3,0--3,5) + WithKeyword = (3,9--3,13) }), (3,0--4,14))], + PreXmlDoc ((1,0), FSharp.Compiler.Xml.XmlDocCollector), [], None, + (1,0--4,14), { LeadingKeyword = Module (1,0--1,6) })], (true, true), + { ConditionalDirectives = [] + WarnDirectives = [] + CodeComments = [] }, set [])) + +(4,4)-(4,8) parse error Expecting expression diff --git a/tests/service/data/SyntaxTree/Expression/Match - When 03.fs b/tests/service/data/SyntaxTree/Expression/Match - When 03.fs new file mode 100644 index 00000000000..71813e0919f --- /dev/null +++ b/tests/service/data/SyntaxTree/Expression/Match - When 03.fs @@ -0,0 +1,5 @@ +module Module + +match () with +| a when +| b -> () diff --git a/tests/service/data/SyntaxTree/Expression/Match - When 03.fs.bsl b/tests/service/data/SyntaxTree/Expression/Match - When 03.fs.bsl new file mode 100644 index 00000000000..89142485a76 --- /dev/null +++ b/tests/service/data/SyntaxTree/Expression/Match - When 03.fs.bsl @@ -0,0 +1,28 @@ +ImplFile + (ParsedImplFileInput + ("/root/Expression/Match - When 03.fs", false, QualifiedNameOfFile Module, + [], + [SynModuleOrNamespace + ([Module], false, NamedModule, + [Expr + (Match + (Yes (3,0--3,13), Const (Unit, (3,6--3,8)), + [SynMatchClause + (Named (SynIdent (a, None), false, None, (4,2--4,3)), None, + ArbitraryAfterError ("patternClauses4", (4,8--4,8)), + (4,2--4,8), Yes, { ArrowRange = None + BarRange = Some (4,0--4,1) }); + SynMatchClause + (Named (SynIdent (b, None), false, None, (5,2--5,3)), None, + Const (Unit, (5,7--5,9)), (5,2--5,9), Yes, + { ArrowRange = Some (5,4--5,6) + BarRange = Some (5,0--5,1) })], (3,0--5,9), + { MatchKeyword = (3,0--3,5) + WithKeyword = (3,9--3,13) }), (3,0--5,9))], + PreXmlDoc ((1,0), FSharp.Compiler.Xml.XmlDocCollector), [], None, + (1,0--5,9), { LeadingKeyword = Module (1,0--1,6) })], (true, true), + { ConditionalDirectives = [] + WarnDirectives = [] + CodeComments = [] }, set [])) + +(4,4)-(4,8) parse error Expecting expression diff --git a/tests/service/data/SyntaxTree/Expression/Match - When 04.fs b/tests/service/data/SyntaxTree/Expression/Match - When 04.fs new file mode 100644 index 00000000000..4f5848f5851 --- /dev/null +++ b/tests/service/data/SyntaxTree/Expression/Match - When 04.fs @@ -0,0 +1,7 @@ +module Module + +match () with +| a when +| + +() \ No newline at end of file diff --git a/tests/service/data/SyntaxTree/Expression/Match - When 04.fs.bsl b/tests/service/data/SyntaxTree/Expression/Match - When 04.fs.bsl new file mode 100644 index 00000000000..7dfb6e7f1ec --- /dev/null +++ b/tests/service/data/SyntaxTree/Expression/Match - When 04.fs.bsl @@ -0,0 +1,24 @@ +ImplFile + (ParsedImplFileInput + ("/root/Expression/Match - When 04.fs", false, QualifiedNameOfFile Module, + [], + [SynModuleOrNamespace + ([Module], false, NamedModule, + [Expr + (Match + (Yes (3,0--3,13), Const (Unit, (3,6--3,8)), + [SynMatchClause + (Named (SynIdent (a, None), false, None, (4,2--4,3)), None, + ArbitraryAfterError ("patternClauses5", (4,8--4,8)), + (4,2--4,8), Yes, { ArrowRange = None + BarRange = Some (4,0--4,1) })], + (3,0--5,1), { MatchKeyword = (3,0--3,5) + WithKeyword = (3,9--3,13) }), (3,0--5,1)); + Expr (Const (Unit, (7,0--7,2)), (7,0--7,2))], + PreXmlDoc ((1,0), FSharp.Compiler.Xml.XmlDocCollector), [], None, + (1,0--7,2), { LeadingKeyword = Module (1,0--1,6) })], (true, true), + { ConditionalDirectives = [] + WarnDirectives = [] + CodeComments = [] }, set [])) + +(4,4)-(4,8) parse error Expecting expression diff --git a/tests/service/data/SyntaxTree/Expression/Try - With 09.fs.bsl b/tests/service/data/SyntaxTree/Expression/Try - With 09.fs.bsl index 03940fb6220..f26155af677 100644 --- a/tests/service/data/SyntaxTree/Expression/Try - With 09.fs.bsl +++ b/tests/service/data/SyntaxTree/Expression/Try - With 09.fs.bsl @@ -12,15 +12,21 @@ ImplFile (None, SynValInfo ([], SynArgInfo ([], false, None)), None), Wild (3,4--3,5), None, TryWith - (Const (Int32 1, (4,8--4,9)), [], (4,4--5,8), Yes (4,4--4,7), - Yes (5,4--5,8), { TryKeyword = (4,4--4,7) - TryToWithRange = (4,4--5,8) - WithKeyword = (5,4--5,8) - WithToEndRange = (5,4--5,8) }), - (3,4--3,5), NoneAtLet, { LeadingKeyword = Let (3,0--3,3) - InlineKeyword = None - EqualsRange = Some (3,6--3,7) })], - (3,0--5,8), { InKeyword = None }); + (Const (Int32 1, (4,8--4,9)), + [SynMatchClause + (Wild (5,9--5,10), None, + ArbitraryAfterError ("patternClauses3", (5,15--5,15)), + (5,9--5,15), Yes, { ArrowRange = None + BarRange = None })], (4,4--5,15), + Yes (4,4--4,7), Yes (5,4--5,8), + { TryKeyword = (4,4--4,7) + TryToWithRange = (4,4--5,8) + WithKeyword = (5,4--5,8) + WithToEndRange = (5,4--5,15) }), (3,4--3,5), NoneAtLet, + { LeadingKeyword = Let (3,0--3,3) + InlineKeyword = None + EqualsRange = Some (3,6--3,7) })], (3,0--5,15), + { InKeyword = None }); Expr (Const (Int32 3, (7,0--7,1)), (7,0--7,1))], PreXmlDoc ((1,0), FSharp.Compiler.Xml.XmlDocCollector), [], None, (1,0--7,1), { LeadingKeyword = Module (1,0--1,6) })], (true, true), @@ -28,4 +34,4 @@ ImplFile WarnDirectives = [] CodeComments = [] }, set [])) -(7,0)-(7,1) parse error Incomplete structured construct at or before this point in expression +(5,11)-(5,15) parse error Expecting expression diff --git a/vsintegration/tests/FSharp.Editor.Tests/CompletionProviderTests.fs b/vsintegration/tests/FSharp.Editor.Tests/CompletionProviderTests.fs index f85608e0cf9..04f786ea9f9 100644 --- a/vsintegration/tests/FSharp.Editor.Tests/CompletionProviderTests.fs +++ b/vsintegration/tests/FSharp.Editor.Tests/CompletionProviderTests.fs @@ -2102,7 +2102,7 @@ match { A = 1; B = 2 } with | { f = () } """ - VerifyCompletionList(fileContents, "| { f = ()", [ "A"; "B"; "C"; "D" ], []) + VerifyCompletionList(fileContents, "| { f = ()", [ "A"; "B" ], [ "C"; "D" ]) [] let ``issue #16260 [TO-BE-IMPROVED] operators are fumbling for now`` () = From 24119c44ad8166516fd295ea4c9c8928d62c023f Mon Sep 17 00:00:00 2001 From: Andrii Chebukin Date: Wed, 19 Aug 2026 12:32:05 +0200 Subject: [PATCH 51/55] Export DOTNET_ROOT for repo-local runtime resolution in CLI build scripts (#20277) --- eng/build-utils.ps1 | 2 ++ eng/build.sh | 3 +++ 2 files changed, 5 insertions(+) diff --git a/eng/build-utils.ps1 b/eng/build-utils.ps1 index e40cf36fd9f..644171f1eb4 100644 --- a/eng/build-utils.ps1 +++ b/eng/build-utils.ps1 @@ -241,6 +241,8 @@ function Make-BootstrapBuild() { # prepare FsLex and Fsyacc and AssemblyCheck $dotnetPath = InitializeDotNetCli + # Ensure apphosts spawned by this publish see the repo-local runtime even if the caller forgot DOTNET_ROOT. + $env:DOTNET_ROOT = $dotnetPath $dotnetExe = Join-Path $dotnetPath "dotnet.exe" # prepare compiler diff --git a/eng/build.sh b/eng/build.sh index e404208df89..0ae1c1b766d 100755 --- a/eng/build.sh +++ b/eng/build.sh @@ -384,6 +384,9 @@ trap TrapAndReportError EXIT InitializeDotNetCli $restore +# Apphosts (bootstrap fsc, testhost, etc.) resolve runtimes via DOTNET_ROOT, not PATH. +export DOTNET_ROOT="$DOTNET_INSTALL_DIR" + # Resolve product TFM from centralized source of truth if not overridden via --tfm if [[ "$tfm" == "" ]]; then tfm=$("$DOTNET_INSTALL_DIR/dotnet" msbuild "$scriptroot/TargetFrameworks.props" -getProperty:FSharpNetCoreProductTargetFramework 2>/dev/null | tr -d '[:space:]') From 1361727543589b7a2997cbae48302025cc93564a Mon Sep 17 00:00:00 2001 From: Bozhidar Batsov Date: Wed, 19 Aug 2026 13:58:57 +0300 Subject: [PATCH 52/55] Add FSI options tests (#19346) --- .../CompilerOptions/fsi/FsiCliTests.fs | 196 ++++++++++++++++++ 1 file changed, 196 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsi/FsiCliTests.fs b/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsi/FsiCliTests.fs index 39e6ad2524f..dfbc0f24fc7 100644 --- a/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsi/FsiCliTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsi/FsiCliTests.fs @@ -2,6 +2,8 @@ namespace CompilerOptions.Fsi +open System +open System.IO open Xunit open FSharp.Test open FSharp.Test.Compiler @@ -68,6 +70,200 @@ module FsiCliTests = Assert.NotEqual(0, result.ExitCode) Assert.Contains(expectedError, result.StdErr) + // ============================================================================ + // --quiet option tests + // ============================================================================ + + /// CLI Test: --quiet suppresses the banner + [] + let ``fsi quiet - suppresses banner`` () = + let result = runFsiProcess ["--quiet"; "--exec"; "--nologo"] + Assert.Equal(0, result.ExitCode) + Assert.DoesNotContain("Microsoft (R) F# Interactive", result.StdOut) + + /// In-process test: --quiet suppresses feedback output but expressions still evaluate + [] + let ``fsi quiet - expressions evaluate correctly`` () = + Fsx """let x = 1 + 1""" + |> withOptions ["--quiet"] + |> runFsi + |> shouldSucceed + + // ============================================================================ + // --exec option tests + // ============================================================================ + + /// CLI Test: --exec causes FSI to exit after evaluating (no interactive prompt) + [] + let ``fsi exec - exits after evaluating script`` () = + let tmpFile = Path.Combine(Path.GetTempPath(), $"fsi_exec_test_{Guid.NewGuid()}.fsx") + try + File.WriteAllText(tmpFile, "printfn \"hello from exec\"") + let result = runFsiProcess ["--exec"; "--nologo"; tmpFile] + Assert.Equal(0, result.ExitCode) + Assert.Contains("hello from exec", result.StdOut) + finally + try File.Delete(tmpFile) with _ -> () + + // ============================================================================ + // --use option tests + // ============================================================================ + + /// CLI Test: --use:file.fsx loads and executes a script file + [] + let ``fsi use - loads and executes script file`` () = + let tmpFile = Path.Combine(Path.GetTempPath(), $"fsi_use_test_{Guid.NewGuid()}.fsx") + try + File.WriteAllText(tmpFile, "printfn \"loaded via use\"") + let result = runFsiProcess ["--nologo"; "--exec"; $"--use:{tmpFile}"] + Assert.Equal(0, result.ExitCode) + Assert.Contains("loaded via use", result.StdOut) + finally + try File.Delete(tmpFile) with _ -> () + + /// CLI Test: --use with nonexistent file produces error + [] + let ``fsi use - nonexistent file produces error`` () = + let result = runFsiProcess ["--exec"; "--use:nonexistent_file_xyz.fsx"] + Assert.NotEqual(0, result.ExitCode) + + // ============================================================================ + // --load option tests + // ============================================================================ + + /// CLI Test: --load:file.fsx loads a file (definitions available) + [] + let ``fsi load - loads file definitions`` () = + let tmpFile = Path.Combine(Path.GetTempPath(), $"fsi_load_test_{Guid.NewGuid()}.fsx") + try + File.WriteAllText(tmpFile, "let loadedValue = 42") + let result = runFsiProcess ["--nologo"; "--exec"; $"--load:{tmpFile}"] + Assert.Equal(0, result.ExitCode) + finally + try File.Delete(tmpFile) with _ -> () + + /// CLI Test: --load with nonexistent file produces error + [] + let ``fsi load - nonexistent file produces error`` () = + let result = runFsiProcess ["--exec"; "--load:nonexistent_file_xyz.fsx"] + Assert.NotEqual(0, result.ExitCode) + + // ============================================================================ + // --gui option tests (switch: +/-) + // ============================================================================ + + /// CLI Test: --gui- is accepted without error + [] + let ``fsi gui - gui minus accepted`` () = + Fsx """1+1""" + |> withOptions ["--gui-"] + |> runFsi + |> shouldSucceed + + /// CLI Test: --gui+ is accepted without error + [] + let ``fsi gui - gui plus accepted`` () = + Fsx """1+1""" + |> withOptions ["--gui+"] + |> runFsi + |> shouldSucceed + + // ============================================================================ + // --readline option tests (switch: +/-) + // ============================================================================ + + /// CLI Test: --readline- is accepted without error + [] + let ``fsi readline - readline minus accepted`` () = + Fsx """1+1""" + |> withOptions ["--readline-"] + |> runFsi + |> shouldSucceed + + /// CLI Test: --readline+ is accepted without error + [] + let ``fsi readline - readline plus accepted`` () = + Fsx """1+1""" + |> withOptions ["--readline+"] + |> runFsi + |> shouldSucceed + + // ============================================================================ + // --quotations-debug option tests (switch: +/-) + // ============================================================================ + + /// CLI Test: --quotations-debug+ is accepted without error + [] + let ``fsi quotations-debug - plus accepted`` () = + Fsx """1+1""" + |> withOptions ["--quotations-debug+"] + |> runFsi + |> shouldSucceed + + /// CLI Test: --quotations-debug- is accepted without error + [] + let ``fsi quotations-debug - minus accepted`` () = + Fsx """1+1""" + |> withOptions ["--quotations-debug-"] + |> runFsi + |> shouldSucceed + + // ============================================================================ + // --shadowcopyreferences option tests (switch: +/-) + // ============================================================================ + + /// CLI Test: --shadowcopyreferences+ is accepted without error + [] + let ``fsi shadowcopyreferences - plus accepted`` () = + Fsx """1+1""" + |> withOptions ["--shadowcopyreferences+"] + |> runFsi + |> shouldSucceed + + /// CLI Test: --shadowcopyreferences- is accepted without error + [] + let ``fsi shadowcopyreferences - minus accepted`` () = + Fsx """1+1""" + |> withOptions ["--shadowcopyreferences-"] + |> runFsi + |> shouldSucceed + + // ============================================================================ + // --nologo option tests + // ============================================================================ + + /// CLI Test: --nologo suppresses the banner + [] + let ``fsi nologo - suppresses banner in subprocess`` () = + let result = runFsiProcess ["--nologo"; "--exec"] + Assert.Equal(0, result.ExitCode) + Assert.DoesNotContain("Microsoft (R) F# Interactive", result.StdOut) + + /// In-process test: FSI without --nologo shows the banner + [] + let ``fsi nologo - without nologo shows banner`` () = + Fsx """1+1""" + |> runFsi + |> shouldSucceed + |> withStdOutContains "Microsoft" + + // ============================================================================ + // Additional error case tests + // ============================================================================ + + /// CLI Test: completely unknown option produces FS0243 + [] + let ``fsi error - unknown option produces FS0243`` () = + let result = runFsiProcess ["--not-a-real-option"] + Assert.NotEqual(0, result.ExitCode) + Assert.Contains("Unrecognized option: '--not-a-real-option'", result.StdErr) + + /// CLI Test: --warn with invalid level produces error + [] + let ``fsi error - invalid warn level produces error`` () = + let result = runFsiProcess ["--warn:invalid"; "--exec"] + Assert.NotEqual(0, result.ExitCode) + // ============================================================================ // Issue #18086: --quiet must suppress NuGet restore stdout chatter // ============================================================================ From 732b9ebd4504e8f111df592921f12eb8b0c5f807 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Wed, 19 Aug 2026 13:40:06 +0200 Subject: [PATCH 53/55] Retarget the NativeAOT test to net10 to dogfood the net10 FSharp.Core (#20284) --- .../NativeAOT/NativeAOT_Test.fsproj | 2 +- tests/AheadOfTime/NativeAOT/check.ps1 | 29 ++++++++++++++++++- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/tests/AheadOfTime/NativeAOT/NativeAOT_Test.fsproj b/tests/AheadOfTime/NativeAOT/NativeAOT_Test.fsproj index 1fa87907110..18451f28110 100644 --- a/tests/AheadOfTime/NativeAOT/NativeAOT_Test.fsproj +++ b/tests/AheadOfTime/NativeAOT/NativeAOT_Test.fsproj @@ -2,7 +2,7 @@ Exe - net9.0 + net10.0 preview true diff --git a/tests/AheadOfTime/NativeAOT/check.ps1 b/tests/AheadOfTime/NativeAOT/check.ps1 index dc69fb765df..c31773529dd 100644 --- a/tests/AheadOfTime/NativeAOT/check.ps1 +++ b/tests/AheadOfTime/NativeAOT/check.ps1 @@ -9,7 +9,7 @@ $ErrorActionPreference = "Stop" $root = "NativeAOT_Test" -$tfm = "net9.0" +$tfm = "net10.0" $cwd = Get-Location Set-Location $PSScriptRoot @@ -20,6 +20,33 @@ if (-not ($LASTEXITCODE -eq 0)) { Write-Error "NativeAOT publish failed with exit code $LASTEXITCODE" -ErrorAction Stop } +# Prove this is a genuine net10 dogfood: a net10.0 consumer must resolve the locally-packed +# FSharp.Core's lib/net10.0 asset, not the netstandard2.1 fallback. Assert on the *selected* +# compile/runtime asset under "targets" (the "libraries" manifest lists every lib folder, so a +# plain substring search would false-pass even when ns2.1 was chosen). Without this the test would +# still succeed on the ns2.1 asset and the net10 target framework would go unexercised. +$assets = Join-Path $PSScriptRoot "obj/project.assets.json" +$assetsJson = Get-Content $assets -Raw | ConvertFrom-Json +$net10Selected = $false +foreach ($target in $assetsJson.targets.PSObject.Properties) { + foreach ($package in $target.Value.PSObject.Properties) { + if ($package.Name -like "FSharp.Core/*") { + $compileKeys = if ($package.Value.compile) { @($package.Value.compile.PSObject.Properties.Name) } else { @() } + $runtimeKeys = if ($package.Value.runtime) { @($package.Value.runtime.PSObject.Properties.Name) } else { @() } + # FSharp.Core packs only lib/{tfm} (no ref/, no runtimes/), so compile and runtime resolve + # from the same folder; require both to be net10 - anything else means a fallback was chosen. + if (($compileKeys -contains "lib/net10.0/FSharp.Core.dll") -and + ($runtimeKeys -contains "lib/net10.0/FSharp.Core.dll")) { + $net10Selected = $true + } + } + } +} +if (-not $net10Selected) { + Set-Location $cwd + Write-Error "The net10.0 consumer did not resolve the lib/net10.0 FSharp.Core asset (it fell back to a lower target framework). The net10 FSharp.Core target framework is not being dogfooded. See $assets." -ErrorAction Stop +} + $exe = Join-Path $PSScriptRoot "bin/release/$tfm/win-x64/publish/$root.exe" $output = (& $exe) -join "`n" $exitCode = $LASTEXITCODE From 8d995fae6c26010c3945db0dcab3406ef1ed0742 Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Thu, 28 May 2026 19:40:38 +0100 Subject: [PATCH 54/55] feat(Task, Async): parallelLimit, parallelDoLimit # Conflicts: # src/FSharp.Core/async.fsi # src/FSharp.Core/tasks.fs # src/FSharp.Core/tasks.fsi # tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl # tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl # tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl # tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl # tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModuleFunctions.fs # tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs --- docs/release-notes/.FSharp.Core/11.0.100.md | 1 + src/FSharp.Core/async.fs | 8 +++ src/FSharp.Core/async.fsi | 39 ++++++++++++++ src/FSharp.Core/tasks.fs | 34 ++++++++++++ src/FSharp.Core/tasks.fsi | 52 +++++++++++++++++++ ...p.Core.SurfaceArea.netstandard20.debug.bsl | 4 ++ ...Core.SurfaceArea.netstandard20.release.bsl | 4 ++ ...p.Core.SurfaceArea.netstandard21.debug.bsl | 4 ++ ...Core.SurfaceArea.netstandard21.release.bsl | 4 ++ .../AsyncModuleFunctions.fs | 38 ++++++++++++++ .../TaskModuleFunctions.fs | 50 ++++++++++++++++++ 11 files changed, 238 insertions(+) diff --git a/docs/release-notes/.FSharp.Core/11.0.100.md b/docs/release-notes/.FSharp.Core/11.0.100.md index d17942708c9..604d76acd28 100644 --- a/docs/release-notes/.FSharp.Core/11.0.100.md +++ b/docs/release-notes/.FSharp.Core/11.0.100.md @@ -16,3 +16,4 @@ * Add `Async.RunSynchronouslyImmediate`: runs work on the calling thread until the first asynchronous suspension (as opposed to `RunSynchronously`, which immediately offloads if not on a background and/or threadpool thread). ([Issue #1042](https://github.com/fsharp/fslang-suggestions/issues/1042), [PR #19804](https://github.com/dotnet/fsharp/pull/19804)) * Add modules for `Async`, `Task` and `ValueTask` with consistent `result`, `map`, `bind`, `ignore`, `catchWith`, `catch`, and `empty` functions ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) * Add conversion functions `Task.ofValueTask` and `ValueTask.ofTask`. ([LanguageSuggestion #1466](https://github.com/fsharp/fslang-suggestions/issues/1466), [PR #19844](https://github.com/dotnet/fsharp/pull/19844)) +* Add `parallelLimit`, `parallelDoLimit` to `Task` and `Async` modules, for bounded-parallelism execution of async/task computations, flowing cancellation. ([LanguageSuggestion #1467](https://github.com/fsharp/fslang-suggestions/issues/1467), [PR #20294](https://github.com/dotnet/fsharp/pull/20294)) diff --git a/src/FSharp.Core/async.fs b/src/FSharp.Core/async.fs index f9c5b63c522..cc268994815 100644 --- a/src/FSharp.Core/async.fs +++ b/src/FSharp.Core/async.fs @@ -2495,3 +2495,11 @@ module Async = [] let empty: Async = async.Zero() + + [] + let parallelLimit (maxDegreeOfParallelism: int) (computations: seq>) : Async<'T[]> = + Async.Parallel(computations, maxDegreeOfParallelism = maxDegreeOfParallelism) + + [] + let parallelDoLimit (maxDegreeOfParallelism: int) (computations: seq>) : Async = + parallelLimit maxDegreeOfParallelism computations |> ignore diff --git a/src/FSharp.Core/async.fsi b/src/FSharp.Core/async.fsi index fc17d93973a..a9af0a486a4 100644 --- a/src/FSharp.Core/async.fsi +++ b/src/FSharp.Core/async.fsi @@ -2074,3 +2074,42 @@ namespace Microsoft.FSharp.Control /// [] val empty: Async + + /// Creates an asynchronous computation that executes all the given asynchronous computations, using at + /// most maxDegreeOfParallelism simultaneously, and returns their results as an array.
+ /// While the result order matches the input order, there is no guarantee of relative start or completion order per computation. + /// + /// The maximum number of computations to run concurrently. + /// A sequence of computations to be parallelized. + /// + /// A computation that returns an array of results from the input computations in the same order they were supplied. + /// + /// + /// + /// let results = + /// [for i in 1..10 -> async { return i * i }] + /// |> Async.parallelLimit 3 + /// |> Async.RunSynchronously + /// results // evaluates to [| 1; 4; 9; 16; 25; 36; 49; 64; 81; 100 |] + /// + /// + [] + val parallelLimit: maxDegreeOfParallelism: int -> computations: seq> -> Async<'T[]> + + /// Creates an asynchronous computation that executes all the given unit asynchronous computations, + /// using at most maxDegreeOfParallelism simultaneously, discarding the results. + /// + /// The maximum number of computations to run concurrently. + /// A sequence of unit computations to be parallelized. + /// + /// A computation that runs all inputs with limited parallelism and returns unit. + /// + /// + /// + /// [for i in 1..10 do async { printfn "%d" i }] + /// |> Async.parallelDoLimit 3 + /// |> Async.RunSynchronously + /// + /// + [] + val parallelDoLimit: maxDegreeOfParallelism: int -> computations: seq> -> Async diff --git a/src/FSharp.Core/tasks.fs b/src/FSharp.Core/tasks.fs index 448e6b85a02..3e18c0407a9 100644 --- a/src/FSharp.Core/tasks.fs +++ b/src/FSharp.Core/tasks.fs @@ -719,8 +719,10 @@ module LowPlusPriority = namespace Microsoft.FSharp.Control +open System.Threading open System.Threading.Tasks open Microsoft.FSharp.Core +open Microsoft.FSharp.Collections open TaskBuilder open Microsoft.FSharp.Control.TaskBuilderExtensions open Microsoft.FSharp.Control.TaskBuilderExtensions.LowPriority @@ -788,6 +790,38 @@ module Task = let catch (task: Task<'T>) : Task> = task |> map Ok |> catchWith Error + [] + let parallelLimit + (maxDegreeOfParallelism: int) + (ct: CancellationToken) + (computations: seq Task<'T>>) + : Task<'T[]> = + task { + use sem = new SemaphoreSlim(maxDegreeOfParallelism, maxDegreeOfParallelism) + + return! + Task.WhenAll + [| + for f in computations -> + task { + do! sem.WaitAsync ct + + try + return! f ct + finally + sem.Release() |> Operators.ignore + } + |] + } + + [] + let parallelDoLimit + (maxDegreeOfParallelism: int) + (ct: CancellationToken) + (computations: seq Task>) + : Task = + parallelLimit maxDegreeOfParallelism ct computations |> ignore + #if NETSTANDARD2_1 || NET [] let inline ofValueTask (valueTask: ValueTask<'T>) : Task<'T> = diff --git a/src/FSharp.Core/tasks.fsi b/src/FSharp.Core/tasks.fsi index f948c5a7044..7ea81dfcc90 100644 --- a/src/FSharp.Core/tasks.fsi +++ b/src/FSharp.Core/tasks.fsi @@ -460,8 +460,10 @@ module HighPriority = namespace Microsoft.FSharp.Control +open System.Threading open System.Threading.Tasks open Microsoft.FSharp.Core +open Microsoft.FSharp.Collections /// Contains camelCase module-level functions for computations. /// @@ -582,6 +584,56 @@ module Task = [] val empty: Task + /// Creates a task that runs all given tasks with at most maxDegreeOfParallelism + /// running concurrently and returns their results in order. Relative start and finish order per computation is not guaranteed. + /// + /// The maximum number of tasks to run concurrently. + /// A cancellation token to pass to each task factory. + /// A sequence of task start functions accepting a . + /// + /// A task yielding the results of all input tasks in order. + /// + /// + /// + /// open System.Threading + /// let results = + /// [for i in 1..10 do fun _ct -> Task.result (i * i)] + /// |> Task.parallelLimit 3 CancellationToken.None + /// results.Result // evaluates to [| 1; 4; 9; 16; 25; 36; 49; 64; 81; 100 |] + /// + /// + [] + val parallelLimit: + maxDegreeOfParallelism: int -> + ct: CancellationToken -> + computations: seq Task<'T>> -> + Task<'T[]> + + /// Creates a task that runs all given unit tasks + /// with at most maxDegreeOfParallelism running concurrently, discarding the results. + /// + /// The maximum number of tasks to run concurrently. + /// A cancellation token to pass to each task factory. + /// A sequence of unit task start functions accepting a . + /// + /// A task that runs all inputs with the specified parallelism limit and returns unit. + /// + /// + /// + /// open System.Threading + /// do + /// [for i in 1..10 do fun _ct -> task { printfn "%d" i }] + /// |> Task.parallelDoLimit 3 CancellationToken.None + /// |> _.Wait() + /// + /// + [] + val parallelDoLimit: + maxDegreeOfParallelism: int -> + ct: CancellationToken -> + computations: seq Task> -> + Task + #if NETSTANDARD2_1 || NET /// Converts a to a . /// diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl index 5c26ed42a87..36400cab89f 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.debug.bsl @@ -620,9 +620,11 @@ Microsoft.FSharp.Control.AsyncActivation`1[T]: Void OnExceptionRaised() Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Empty Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] ParallelDoLimit(Int32, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] get_Empty() Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Control.FSharpAsync`1[TResult]], Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T[]] ParallelLimit[T](Int32, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] Result[T](T) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Bind[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[TResult], Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) @@ -762,6 +764,8 @@ Microsoft.FSharp.Control.ObservableModule: System.IObservable`1[T] Merge[T](Syst Microsoft.FSharp.Control.ObservableModule: System.Tuple`2[System.IObservable`1[TResult1],System.IObservable`1[TResult2]] Split[T,TResult1,TResult2](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpChoice`2[TResult1,TResult2]], System.IObservable`1[T]) Microsoft.FSharp.Control.ObservableModule: System.Tuple`2[System.IObservable`1[T],System.IObservable`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], System.IObservable`1[T]) Microsoft.FSharp.Control.ObservableModule: Void Add[T](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.Unit], System.IObservable`1[T]) +Microsoft.FSharp.Control.Task: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] ParallelDoLimit(Int32, System.Threading.CancellationToken, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit]]]) +Microsoft.FSharp.Control.Task: System.Threading.Tasks.Task`1[T[]] ParallelLimit[T](Int32, System.Threading.CancellationToken, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[T]]]) Microsoft.FSharp.Control.TaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.TaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.TaskBuilderBase: Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[TOverall],Microsoft.FSharp.Core.Unit] For[T,TOverall](System.Collections.Generic.IEnumerable`1[T], Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[TOverall],Microsoft.FSharp.Core.Unit]]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl index ed1221c1a43..1b1d4388db7 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard20.release.bsl @@ -620,9 +620,11 @@ Microsoft.FSharp.Control.AsyncActivation`1[T]: Void OnExceptionRaised() Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Empty Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] ParallelDoLimit(Int32, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] get_Empty() Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Control.FSharpAsync`1[TResult]], Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T[]] ParallelLimit[T](Int32, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] Result[T](T) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Bind[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[TResult], Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) @@ -762,6 +764,8 @@ Microsoft.FSharp.Control.ObservableModule: System.IObservable`1[T] Merge[T](Syst Microsoft.FSharp.Control.ObservableModule: System.Tuple`2[System.IObservable`1[TResult1],System.IObservable`1[TResult2]] Split[T,TResult1,TResult2](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpChoice`2[TResult1,TResult2]], System.IObservable`1[T]) Microsoft.FSharp.Control.ObservableModule: System.Tuple`2[System.IObservable`1[T],System.IObservable`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], System.IObservable`1[T]) Microsoft.FSharp.Control.ObservableModule: Void Add[T](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.Unit], System.IObservable`1[T]) +Microsoft.FSharp.Control.Task: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] ParallelDoLimit(Int32, System.Threading.CancellationToken, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit]]]) +Microsoft.FSharp.Control.Task: System.Threading.Tasks.Task`1[T[]] ParallelLimit[T](Int32, System.Threading.CancellationToken, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[T]]]) Microsoft.FSharp.Control.TaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.TaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.TaskBuilderBase: Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[TOverall],Microsoft.FSharp.Core.Unit] For[T,TOverall](System.Collections.Generic.IEnumerable`1[T], Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[TOverall],Microsoft.FSharp.Core.Unit]]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl index 94ff0a6b538..dc9b0deb1a9 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.debug.bsl @@ -622,9 +622,11 @@ Microsoft.FSharp.Control.AsyncActivation`1[T]: Void OnExceptionRaised() Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Empty Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] ParallelDoLimit(Int32, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] get_Empty() Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Control.FSharpAsync`1[TResult]], Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T[]] ParallelLimit[T](Int32, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] Result[T](T) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Bind[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[TResult], Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) @@ -768,6 +770,8 @@ Microsoft.FSharp.Control.ObservableModule: System.IObservable`1[T] Merge[T](Syst Microsoft.FSharp.Control.ObservableModule: System.Tuple`2[System.IObservable`1[TResult1],System.IObservable`1[TResult2]] Split[T,TResult1,TResult2](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpChoice`2[TResult1,TResult2]], System.IObservable`1[T]) Microsoft.FSharp.Control.ObservableModule: System.Tuple`2[System.IObservable`1[T],System.IObservable`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], System.IObservable`1[T]) Microsoft.FSharp.Control.ObservableModule: Void Add[T](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.Unit], System.IObservable`1[T]) +Microsoft.FSharp.Control.Task: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] ParallelDoLimit(Int32, System.Threading.CancellationToken, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit]]]) +Microsoft.FSharp.Control.Task: System.Threading.Tasks.Task`1[T[]] ParallelLimit[T](Int32, System.Threading.CancellationToken, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[T]]]) Microsoft.FSharp.Control.TaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.TaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.TaskBuilderBase: Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[TOverall],Microsoft.FSharp.Core.Unit] For[T,TOverall](System.Collections.Generic.IEnumerable`1[T], Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[TOverall],Microsoft.FSharp.Core.Unit]]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl index acb7fdf1e3f..e0bbaf2621d 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl +++ b/tests/FSharp.Core.UnitTests/FSharp.Core.SurfaceArea.netstandard21.release.bsl @@ -622,9 +622,11 @@ Microsoft.FSharp.Control.AsyncActivation`1[T]: Void OnExceptionRaised() Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.FSharpResult`2[T,System.Exception]] Catch[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Empty Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] Ignore[T](Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] ParallelDoLimit(Int32, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit]]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[Microsoft.FSharp.Core.Unit] get_Empty() Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Bind[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Control.FSharpAsync`1[TResult]], Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[TResult] Map[T,TResult](Microsoft.FSharp.Core.FSharpFunc`2[T,TResult], Microsoft.FSharp.Control.FSharpAsync`1[T]) +Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T[]] ParallelLimit[T](Int32, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Control.FSharpAsync`1[T]]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] CatchWith[T](Microsoft.FSharp.Core.FSharpFunc`2[System.Exception,T], Microsoft.FSharp.Control.FSharpAsync`1[T]) Microsoft.FSharp.Control.AsyncModule: Microsoft.FSharp.Control.FSharpAsync`1[T] Result[T](T) Microsoft.FSharp.Control.AsyncPrimitives: Microsoft.FSharp.Control.AsyncReturn Bind[T,TResult](Microsoft.FSharp.Control.AsyncActivation`1[T], Microsoft.FSharp.Control.FSharpAsync`1[TResult], Microsoft.FSharp.Core.FSharpFunc`2[TResult,Microsoft.FSharp.Control.FSharpAsync`1[T]]) @@ -768,6 +770,8 @@ Microsoft.FSharp.Control.ObservableModule: System.IObservable`1[T] Merge[T](Syst Microsoft.FSharp.Control.ObservableModule: System.Tuple`2[System.IObservable`1[TResult1],System.IObservable`1[TResult2]] Split[T,TResult1,TResult2](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.FSharpChoice`2[TResult1,TResult2]], System.IObservable`1[T]) Microsoft.FSharp.Control.ObservableModule: System.Tuple`2[System.IObservable`1[T],System.IObservable`1[T]] Partition[T](Microsoft.FSharp.Core.FSharpFunc`2[T,System.Boolean], System.IObservable`1[T]) Microsoft.FSharp.Control.ObservableModule: Void Add[T](Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.Unit], System.IObservable`1[T]) +Microsoft.FSharp.Control.Task: System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit] ParallelDoLimit(Int32, System.Threading.CancellationToken, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[Microsoft.FSharp.Core.Unit]]]) +Microsoft.FSharp.Control.Task: System.Threading.Tasks.Task`1[T[]] ParallelLimit[T](Int32, System.Threading.CancellationToken, System.Collections.Generic.IEnumerable`1[Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,System.Threading.Tasks.Task`1[T]]]) Microsoft.FSharp.Control.TaskBuilder: System.Threading.Tasks.Task`1[T] RunDynamic[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.TaskBuilder: System.Threading.Tasks.Task`1[T] Run[T](Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[T],T]) Microsoft.FSharp.Control.TaskBuilderBase: Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[TOverall],Microsoft.FSharp.Core.Unit] For[T,TOverall](System.Collections.Generic.IEnumerable`1[T], Microsoft.FSharp.Core.FSharpFunc`2[T,Microsoft.FSharp.Core.CompilerServices.ResumableCode`2[Microsoft.FSharp.Control.TaskStateMachineData`1[TOverall],Microsoft.FSharp.Core.Unit]]) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModuleFunctions.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModuleFunctions.fs index 3335e6910ac..68a353ff6a6 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModuleFunctions.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModuleFunctions.fs @@ -260,3 +260,41 @@ let ``Async.catch propagates Cancellation (async)`` () = let ``Async.empty returns unit`` () = let actual = Async.empty |> asyncWait Assert.Equal((), actual) + + [] + let ``Async.parallelLimit runs all computations`` () = + let results = + [for i in 1..5 do async { return i * i }] + |> Async.parallelLimit 2 + |> Async.RunSynchronously + Assert.True([| 1; 4; 9; 16; 25 |] = results) + + [] + let ``Async.parallelLimit limits concurrency`` () = + let mutable concurrent = 0 + let mutable maxConcurrent = 0 + let lockObj = obj() + let comp = + [for _ in 1..10 do + async { + let n = + lock lockObj (fun () -> + concurrent <- concurrent + 1 + if concurrent > maxConcurrent then maxConcurrent <- concurrent + concurrent) + do! Async.Sleep 1 + lock lockObj (fun () -> concurrent <- concurrent - 1) |> ignore + return n + }] + |> Async.parallelLimit 3 + comp |> Async.RunSynchronously |> ignore + Assert.True(maxConcurrent <= 3, $"max concurrent was {maxConcurrent}, expected <= 3") + + [] + let ``Async.parallelDoLimit runs all computations and returns unit`` () = + let results = System.Collections.Generic.List() + [for i in 1..5 do + async { lock results (fun () -> results.Add(i)) }] + |> Async.parallelDoLimit 2 + |> Async.RunSynchronously + Assert.Equal(5, results.Count) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs index 6791e0ffc07..18f899f8d9e 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/TaskModuleFunctions.fs @@ -301,6 +301,56 @@ module TaskModuleFunctionsTests = Assert.True t.IsCompletedSuccessfully Assert.Equal((), t.Result) + [] + let ``Task.parallelLimit runs all tasks and collects results`` () : Task = + task { + use cts = new CancellationTokenSource() + let! results = + [for i in 1..5 do fun (ct: CancellationToken) -> + Assert.Equal(cts.Token, ct) + Task.result (i * i)] + |> Task.parallelLimit 2 cts.Token + Assert.Equal([| 1; 4; 9; 16; 25 |], results) + } + + [] + let ``Task.parallelLimit limits concurrency`` () : Task = + task { + use cts = new CancellationTokenSource() + let mutable concurrent = 0 + let mutable maxConcurrent = 0 + let lockObj = obj() + let computations = + [for _ in 1..10 -> + fun (ct: CancellationToken) -> + Assert.Equal(cts.Token, ct) + task { + let n = + lock lockObj (fun () -> + concurrent <- concurrent + 1 + if concurrent > maxConcurrent then maxConcurrent <- concurrent + concurrent) + do! Task.Delay(1) + lock lockObj (fun () -> concurrent <- concurrent - 1) + return n + }] + let! _ = Task.parallelLimit 3 cts.Token computations + Assert.True(maxConcurrent <= 3, $"max concurrent was {maxConcurrent}, expected <= 3") + } + + [] + let ``Task.parallelDoLimit runs all tasks and returns unit`` () : Task = + task { + use cts = new CancellationTokenSource() + let mutable count = 0 + let computations = + [for _ in 1..5 -> + fun (ct: CancellationToken) -> + Assert.Equal(cts.Token, ct) + task { Interlocked.Increment &count |> ignore }] + do! Task.parallelDoLimit 2 cts.Token computations + Assert.Equal(5, count) + } #if NETSTANDARD2_1 || NET [] From 97fdfbe55bd4db2521eeba924ba695a77c48d745 Mon Sep 17 00:00:00 2001 From: Ruben Bartelink Date: Wed, 19 Aug 2026 13:05:14 +0100 Subject: [PATCH 55/55] tidy: Polish xmldoc --- src/FSharp.Core/async.fsi | 14 ++++++-------- src/FSharp.Core/tasks.fsi | 18 ++++++++---------- 2 files changed, 14 insertions(+), 18 deletions(-) diff --git a/src/FSharp.Core/async.fsi b/src/FSharp.Core/async.fsi index a9af0a486a4..2a3b6b64da7 100644 --- a/src/FSharp.Core/async.fsi +++ b/src/FSharp.Core/async.fsi @@ -2078,18 +2078,16 @@ namespace Microsoft.FSharp.Control /// Creates an asynchronous computation that executes all the given asynchronous computations, using at /// most maxDegreeOfParallelism simultaneously, and returns their results as an array.
/// While the result order matches the input order, there is no guarantee of relative start or completion order per computation. - /// /// The maximum number of computations to run concurrently. /// A sequence of computations to be parallelized. - /// /// A computation that returns an array of results from the input computations in the same order they were supplied. /// /// /// /// let results = - /// [for i in 1..10 -> async { return i * i }] + /// seq { for i in 1..10 -> async { return i * i } } /// |> Async.parallelLimit 3 - /// |> Async.RunSynchronously + /// |> Async.RunSynchronouslyImmediate /// results // evaluates to [| 1; 4; 9; 16; 25; 36; 49; 64; 81; 100 |] /// /// @@ -2097,8 +2095,8 @@ namespace Microsoft.FSharp.Control val parallelLimit: maxDegreeOfParallelism: int -> computations: seq> -> Async<'T[]> /// Creates an asynchronous computation that executes all the given unit asynchronous computations, - /// using at most maxDegreeOfParallelism simultaneously, discarding the results. - /// + /// using at most maxDegreeOfParallelism simultaneously.
 + /// Note there is no guarantee of relative start or completion order per computation. /// The maximum number of computations to run concurrently. /// A sequence of unit computations to be parallelized. /// @@ -2106,9 +2104,9 @@ namespace Microsoft.FSharp.Control /// /// /// - /// [for i in 1..10 do async { printfn "%d" i }] + /// seq { for i in 1..10 -> async { printfn "%d" i } } // NOTE output order can vary /// |> Async.parallelDoLimit 3 - /// |> Async.RunSynchronously + /// |> Async.RunSynchronouslyImmediate /// /// [] diff --git a/src/FSharp.Core/tasks.fsi b/src/FSharp.Core/tasks.fsi index 7ea81dfcc90..72a224cc567 100644 --- a/src/FSharp.Core/tasks.fsi +++ b/src/FSharp.Core/tasks.fsi @@ -585,19 +585,18 @@ module Task = val empty: Task /// Creates a task that runs all given tasks with at most maxDegreeOfParallelism - /// running concurrently and returns their results in order. Relative start and finish order per computation is not guaranteed. - /// + /// running concurrently and returns their results in order. + /// Relative start and finish order per computation is not guaranteed. /// The maximum number of tasks to run concurrently. /// A cancellation token to pass to each task factory. /// A sequence of task start functions accepting a . - /// - /// A task yielding the results of all input tasks in order. + /// A task yielding the results of all input tasks in the order supplied. /// /// /// /// open System.Threading /// let results = - /// [for i in 1..10 do fun _ct -> Task.result (i * i)] + /// seq { for i in 1..10 -> fun _ct -> Task.result (i * i) } /// |> Task.parallelLimit 3 CancellationToken.None /// results.Result // evaluates to [| 1; 4; 9; 16; 25; 36; 49; 64; 81; 100 |] /// @@ -609,20 +608,19 @@ module Task = computations: seq Task<'T>> -> Task<'T[]> - /// Creates a task that runs all given unit tasks - /// with at most maxDegreeOfParallelism running concurrently, discarding the results. - /// + /// Creates a task that runs the given unit tasks + /// with at most maxDegreeOfParallelism running concurrently. + /// Note there is no guarantee of relative start or completion order per computation. /// The maximum number of tasks to run concurrently. /// A cancellation token to pass to each task factory. /// A sequence of unit task start functions accepting a . - /// /// A task that runs all inputs with the specified parallelism limit and returns unit. /// /// /// /// open System.Threading /// do - /// [for i in 1..10 do fun _ct -> task { printfn "%d" i }] + /// seq { for i in 1..10 -> fun _ct -> task { printfn "%d" i } } // NOTE output order can vary /// |> Task.parallelDoLimit 3 CancellationToken.None /// |> _.Wait() ///