CLI Scripts in F#
Every F# repository of any size grows a handful of .fsx scripts: a build, a release, a few diagnostics. Each one wants a flag or two, and each one ends up scanning fsi.CommandLineArgs by hand, with a usage string typed to match.
We're going to have a look at how Partas.Build can help by porting a repositories script tools.
fantomas is a good specimen:
- build.fsx
- src
scripts
- ast.fsx
- BuildAnalyzers.fsx
- BuildCommon.fsx
- BuildCompiler.fsx
- BuildRelease.fsx
- BuildScripts.fsx
- chain.fsx
- format.fsx
- oak.fsx
- shared.fsx
- writer-events.fsx
Each script runs on its own and is composed into build.fsx for CI. Between them they scan for --dry-run, --signature, --define and --editorconfig, sniff CI from the environment, and guard their entry points with a file-path comparison.
Partas.Build
Partas.Build is Fun.Build's stage/pipeline DSL in front of System.CommandLine, with FSharp.SystemCommandLine's input combinators for declaring options. It depends on none of the three; it absorbed the first and last.
What it adds is that a stage declares the flags it reads, and the command line, its help, its validation and --explain derive from that.
| Library | Flags | Help | Pipelines |
|---|---|---|---|
| Hand-rolled | scanned from the argument array | typed by hand | none |
Fun.Build | scanned from the argument array | typed by hand | stage / pipeline |
FSharp.SystemCommandLine | declared | generated | none |
Partas.Build | declared by the stage that reads them | generated | stage / pipeline |
The rest of this post ports the scripts for fantomas above, starting with the file they all load.
25 collapsed lines
#r "../artifacts/bin/Fantomas.FCS/debug/Fantomas.FCS.dll"
#r "../artifacts/bin/Fantomas.Core/debug/Fantomas.Core.dll"
#r "nuget: editorconfig, 0.15.0"
#load "../src/Fantomas/Suggestion.fs"
#load "../src/Fantomas/EditorConfig.fs"
open System.IO
open Fantomas.Core
open Fantomas.EditorConfig
let parseEditorConfigContent (content: string) : FormatConfig =
let tempDir = Path.Combine(Path.GetTempPath(), Path.GetRandomFileName())
Directory.CreateDirectory(tempDir) |> ignore
let editorConfigPath = Path.Combine(tempDir, ".editorconfig")
let fsharpFile = Path.Combine(tempDir, "temp.fs")
File.WriteAllText(editorConfigPath, $"root = true\n\n[*.fs]\n%s{content}")
File.WriteAllText(fsharpFile, "")
try
match tryReadConfiguration fsharpFile with
| Some result -> result.Config
| None -> FormatConfig.Default
finally
Directory.Delete(tempDir, true)
/// Parses args and returns (source, isSignature, config).
/// Accepts either a file path as last arg, or source code via stdin.
/// Optional flags: --editorconfig <content>, --signature
let parseArgs (args: string array) =
let editorConfigIdx = args |> Array.tryFindIndex (fun a -> a = "--editorconfig")
let hasSignatureFlag = args |> Array.exists (fun a -> a = "--signature")
let defineIdx = args |> Array.tryFindIndex (fun a -> a = "--define")
let config =
match editorConfigIdx with
| Some idx -> parseEditorConfigContent args.[idx + 1]
| None -> FormatConfig.Default
let defines =
match defineIdx with
| Some idx -> args.[idx + 1].Split(',') |> Array.toList
| None -> []
// Collect flag indices to determine which arg (if any) is the input file
let flagIndices =
[|
match editorConfigIdx with
| Some idx ->
yield idx
yield idx + 1
| None -> ()
match defineIdx with
| Some idx ->
yield idx
yield idx + 1
| None -> ()
yield!
args
|> Array.indexed
|> Array.choose (fun (i, a) -> if a = "--signature" then Some i else None)
|]
let positionalArgs =
args
|> Array.indexed
|> Array.filter (fun (i, _) -> not (Array.contains i flagIndices))
|> Array.map snd
match Array.tryLast positionalArgs with
| Some path when File.Exists(path) ->
let sample = File.ReadAllText(path)
let isSignature = hasSignatureFlag || path.EndsWith(".fsi")
sample, isSignature, config, defines
| _ ->
let sample = stdin.ReadToEnd()
sample, hasSignatureFlag, config, defines
Declaring Options
Previously
shared.fsx reads three flags and an input path, and hands the parsed values to every script that loads it.
The flags first:
let parseArgs args =
let editorConfigIdx = args |> Array.tryFindIndex (fun a -> a = "--editorconfig")
let hasSignatureFlag = args |> Array.exists (fun a -> a = "--signature")
let defineIdx = args |> Array.tryFindIndex (fun a -> a = "--define")
let config =
match editorConfigIdx with
| Some idx -> parseEditorConfigContent args.[idx + 1]
| None -> FormatConfig.Default
let defines =
match defineIdx with
| Some idx -> args.[idx + 1].Split(',') |> Array.toList
| None -> []
Partas.Build
Three flags, three declarations. The type parameter is the parser:
#r "nuget: Partas.Build, 0.4.0-alpha.3"
open Partas.Build
module Options =
let signature = Input.option<bool> "--signature"
let defines = Input.option<string list> "--define"
let editorConfig = Input.optionMaybe<string> "--editorconfig"
Deriving Values at Bind Time
Previously
let parseArgs args =
let editorConfigIdx = args |> Array.tryFindIndex (fun a -> a = "--editorconfig")
let hasSignatureFlag = args |> Array.exists (fun a -> a = "--signature")
let defineIdx = args |> Array.tryFindIndex (fun a -> a = "--define")
let config =
match editorConfigIdx with
| Some idx -> parseEditorConfigContent args.[idx + 1]
| None -> FormatConfig.Default
parseArgs turns the raw string into a FormatConfig itself.
Partas.Build
InputSpec.map does the same thing once, where the option is declared, so nothing downstream ever sees the string:
let editorConfig =
Input.optionMaybe<string> "--editorconfig"
|> InputSpec.ofInput
|> InputSpec.map (function
| None -> FormatConfig.Default
| Some content -> parseEditorConfigContent content)
Combining Inputs
Previously
The second half of parseArgs is index bookkeeping: collect the positions every flag occupies so the one token left over can be the file.
Partas.Build
Declare the argument instead and the parser finds it:
let inputPath =
Input.argument<string> "input"
|> Input.description "input file or content"
let inputContent = input {
let! inputPath = inputPath
and! signature = signature
return
if File.Exists inputPath then
{| sample = File.ReadAllText inputPath
isSignature = signature || inputPath.EndsWith ".fsi" |}
else
{| sample = inputPath; isSignature = signature |}
}
input { } is applicative. and! unions the inputs of each binding, so inputContent is a value that declares <input> and --signature and reads them, and whatever binds inputContent later inherits both without naming either.
That is the whole of shared2.fsx: four declarations and one input block in place of parseArgs.
Before/After
#r "../artifacts/bin/Fantomas.FCS/debug/Fantomas.FCS.dll"
#r "../artifacts/bin/Fantomas.Core/debug/Fantomas.Core.dll"
#r "nuget: editorconfig, 0.15.0"
#load "../src/Fantomas/Suggestion.fs"
#load "../src/Fantomas/EditorConfig.fs"
open System.IO
open Fantomas.Core
open Fantomas.EditorConfig
let parseEditorConfigContent (content: string) : FormatConfig =
let tempDir = Path.Combine(Path.GetTempPath(), Path.GetRandomFileName())
Directory.CreateDirectory(tempDir) |> ignore
let editorConfigPath = Path.Combine(tempDir, ".editorconfig")
let fsharpFile = Path.Combine(tempDir, "temp.fs")
File.WriteAllText(editorConfigPath, $"root = true\n\n[*.fs]\n%s{content}")
File.WriteAllText(fsharpFile, "")
try
match tryReadConfiguration fsharpFile with
| Some result -> result.Config
| None -> FormatConfig.Default
finally
Directory.Delete(tempDir, true)
/// Parses args and returns (source, isSignature, config).
/// Accepts either a file path as last arg, or source code via stdin.
/// Optional flags: --editorconfig <content>, --signature
let parseArgs (args: string array) =
let editorConfigIdx = args |> Array.tryFindIndex (fun a -> a = "--editorconfig")
let hasSignatureFlag = args |> Array.exists (fun a -> a = "--signature")
let defineIdx = args |> Array.tryFindIndex (fun a -> a = "--define")
let config =
match editorConfigIdx with
| Some idx -> parseEditorConfigContent args.[idx + 1]
| None -> FormatConfig.Default
let defines =
match defineIdx with
| Some idx -> args.[idx + 1].Split(',') |> Array.toList
| None -> []
// Collect flag indices to determine which arg (if any) is the input file
let flagIndices =
[|
match editorConfigIdx with
| Some idx ->
yield idx
yield idx + 1
| None -> ()
match defineIdx with
| Some idx ->
yield idx
yield idx + 1
| None -> ()
yield!
args
|> Array.indexed
|> Array.choose (fun (i, a) -> if a = "--signature" then Some i else None)
|]
let positionalArgs =
args
|> Array.indexed
|> Array.filter (fun (i, _) -> not (Array.contains i flagIndices))
|> Array.map snd
match Array.tryLast positionalArgs with
| Some path when File.Exists(path) ->
let sample = File.ReadAllText(path)
let isSignature = hasSignatureFlag || path.EndsWith(".fsi")
sample, isSignature, config, defines
| _ ->
let sample = stdin.ReadToEnd()
sample, hasSignatureFlag, config, defines
#r "../artifacts/bin/Fantomas.FCS/debug/Fantomas.FCS.dll"
#r "../artifacts/bin/Fantomas.Core/debug/Fantomas.Core.dll"
#r "nuget: editorconfig, 0.15.0"
#r "nuget: Partas.Build, 0.4.0-alpha.3"
#load "../src/Fantomas/Suggestion.fs"
#load "../src/Fantomas/EditorConfig.fs"
open Partas.Build
open System.IO
open Fantomas.Core
open Fantomas.EditorConfig
module Utils =
let runIfMain (name: string) (fn: unit -> int): unit =
if Args.scriptName() |> ValueOption.exists ((=) name)
then fn() |> exit
module Options =
let editorConfig=
Input.optionMaybe<string> "--editorconfig"
|> InputSpec.ofInput
|> InputSpec.map (function
| None -> FormatConfig.Default
| Some content ->
let tempDir = Path.Combine(Path.GetTempPath(), Path.GetRandomFileName())
Directory.CreateDirectory(tempDir) |> ignore
let editorConfigPath = Path.Combine(tempDir, ".editorconfig")
let fsharpFile = Path.Combine(tempDir, "temp.fs")
File.WriteAllText(editorConfigPath, $"root = true\n\n[*.fs]\n%s{content}")
File.WriteAllText(fsharpFile, "")
try
match tryReadConfiguration fsharpFile with
| Some result -> result.Config
| None -> FormatConfig.Default
finally
Directory.Delete(tempDir, true)
)
let signature =
Input.option<bool> "--signature"
|> Input.alias "-s"
let defines =
Input.option<string list> "--define"
|> Input.alias "-d"
let inputPath =
Input.argument<string> "input"
|> Input.description "input file or content"
let inputContent = input {
let! inputPath = inputPath
and! signature = signature
return
if File.Exists(inputPath) then
{| sample = File.ReadAllText(inputPath)
isSignature = signature || inputPath.EndsWith(".fsi") |}
else
{| sample = inputPath
isSignature = signature |}
}
A Script Is a Root Command
Previously
The original ast.fsx ends with the entry-point dance every script repeats:
match Array.tryHead fsi.CommandLineArgs with
| Some scriptPath ->
let scriptFile = FileInfo(scriptPath)
let sourceFile = FileInfo(Path.Combine(__SOURCE_DIRECTORY__, __SOURCE_FILE__))
if scriptFile.FullName = sourceFile.FullName then
let sample, isSignature, _, defines = parseArgs fsi.CommandLineArgs.[1..]
parseAst sample isSignature defines |> printfn "%s"
| _ -> printfn "Usage: dotnet fsi ast.fsx [--signature] [--define FOO,BAR] <input file>"
The usage string is typed by hand, so it is already stale: --editorconfig is parsed but not listed.
Partas.Build
ast2.fsx, in full:
#load "shared2.fsx"
open Shared2
open Partas.Build
let parseAst = input {
let! inputContent = Options.inputContent
and! defines = Options.defines
return
try
Fantomas.FCS.Parse.parseFile inputContent.isSignature (SourceText.ofString inputContent.sample) defines
|> fst
|> sprintf "%A"
with ex ->
$"Error while parsing AST: %A{ex}"
}
Utils.runIfMain "ast2.fsx" <| fun () ->
rootCommandOfScript {
name "ast2.fsx"
description "Parse ast"
input {
let! parsedAst = parseAst
return stage "parsed ast" { echo parsedAst }
}
}
Utils.runIfMain is the "am I the script being run, or a #load" check, written once in shared2.fsx:
let runIfMain (name: string) (fn: unit -> int) =
if Args.scriptName () |> ValueOption.exists ((=) name) then fn () |> exit
What a contributor sees:
$ dotnet fsi scripts/ast2.fsx -- --help
Description:
Parse ast
Usage:
ast2.fsx <input> [options]
Arguments:
<input> input file or content
Options:
-s, --signature
-d, --define <define>
--explain Print the resolved stage tree and exit, running nothing
-?, -h, --help Show help and usage information
--version Show version information
Nobody wrote that. --signature is a bool so it is a switch; --define is a string list so it takes values; the aliases came from Input.alias. The help cannot drift from the parser because it is the parser.
format2.fsx, oak2.fsx, writer-events2.fsx and chain2.fsx are the same twenty lines with a different input { } block. writer-events2.fsx binds Options.editorConfig as well, so its --help has one more row:
--editorconfig <editorconfig>
The Build Script
Previously
build.fsx is Fun.Build: nine pipelines, each ending in runIfOnlySpecified, with flags read the only way Fun.Build allows:
let isDryRun = fsi.CommandLineArgs |> Array.exists (fun arg -> arg = "--dry-run")
let jsonFlagDuringCI: string =
if String.IsNullOrEmpty(Environment.GetEnvironmentVariable "CI") then String.Empty else "--json"
pipeline "Build" {
workingDir __SOURCE_DIRECTORY__
stage "RestoreTools" { run "dotnet tool restore" }
stage "CheckFormat" { run $"dotnet fantomas check src analyzers docs scripts build.fsx {jsonFlagDuringCI}" }
// ...
stage "Docs" {
whenNot { platformOSX }
envVars [| "DOTNET_ROLL_FORWARD_TO_PRERELEASE", "1"; "DOTNET_ROLL_FORWARD", "LatestMajor" |]
run $"dotnet fsdocs build --clean --properties Configuration=Release --fscoptions \" -r:{semanticVersioning}\" --eval --strict --nonpublic"
}
runIfOnlySpecified false
}
Partas.Build
Partas.Build keeps stage and pipeline as they are. What changes is that a stage can bind a flag, and a command sits in front of the pipelines.
Stages Declare Their Flags
module Blocks =
let restoreTools = input {
let! quick = Options.quick
return stage "restore tools" {
when' (not quick)
run "dotnet tool restore"
}
}
let checkFormat = input {
let! ci = Baked.Input.CI.isCI
let json = if ci then "--json" else ""
return stage "check format" { run $"dotnet fantomas check {formatTargets} {json}" }
}
let test = input {
let! config = Options.config
and! skip = Options.skipTests
return stage "unit tests" {
when' (not skip)
run (cmd $"dotnet test -c {config} --tl")
}
}
let fsdocs = input {
let! watch = Options.watch
let verb = if watch then "watch" else "build"
return stage "fsdocs" {
whenOSX false
envVars [ "DOTNET_ROLL_FORWARD_TO_PRERELEASE", "1"; "DOTNET_ROLL_FORWARD", "LatestMajor" ]
run (cmd $"dotnet fsdocs {verb} --properties Configuration=Release --fscoptions \" -r:{semanticVersioning}\" --eval --nonpublic")
}
}
Commands Assemble Stages
rootCommandOfScript {
name "build2.fsx"
description "Fantomas build"
command "build" {
description "Restore, check formatting, build, check scripts, test, pack and build the docs"
workingDir repositoryRoot
Blocks.restoreTools
Blocks.clean [ analysisReportsDir; artifactsDir ]
Blocks.checkFormat
stage "build debug" { run (cmd $"dotnet build {scriptProject} --tl") }
checkScripts
Blocks.build
checkDocScripts
Blocks.test
Blocks.pack
Blocks.fsdocs
}
command "docs" {
description "Build the docs, or serve them with --watch"
workingDir repositoryRoot
Blocks.restoreTools
stage "build" { run "dotnet build -c Release src/Fantomas/Fantomas.fsproj --tl" }
Blocks.fsdocs
}
command "repo-config" {
description "Point git at the repository's hooks and blame settings"
workingDir repositoryRoot
stage "git" {
run "git config core.hooksPath .githooks"
run "git config blame.ignoreRevsFile .git-blame-ignore-revs"
run "git config blame.markIgnoredLines true"
}
}
BuildScripts2.commands
BuildAnalyzers2.commands
BuildRelease2.commands
BuildCompiler2.commands
}
|> exit
workingDir on the root is a default every command inherits; a pipeline that sets its own wins. runIfOnlySpecified has no equivalent because a subcommand only runs when named.
Flags travel up from the stages that read them:
$ dotnet fsi build2.fsx -- build --help
Description:
Restore, check formatting, build, test, pack and build the docs
Usage:
build2.fsx build [options]
Options:
-q, --quick Skip tool restore and clean
--ci Indicates that the build is running in a CI environment; defaults to true if environment variables indicate so
-c, --configuration <Debug|Release> [default: Release]
--skip-tests Skip the unit tests
--watch Serve the docs and rebuild on change
--explain Print the resolved stage tree and exit, running nothing
-?, -h, --help Show help and usage information
docs --help lists --quick, --configuration and --watch and nothing else, because those are the flags its three blocks bind. format --help lists none.
Validation is System.CommandLine's:
$ dotnet fsi build2.fsx -- build -c Relaese
Argument 'Relaese' not recognized. Must be one of:
'Debug'
'Release'
--explain
Every command that runs a pipeline gets --explain: resolve the stage tree against the flags given, print it, run nothing.
$ dotnet fsi build2.fsx -- build --explain --quick --skip-tests
build
├─ restore tools (skipped)
│ └─ $ dotnet tool restore
├─ clean (skipped)
│ └─ step 1
├─ check format
│ └─ $ dotnet fantomas check src analyzers docs scripts build.fsx
├─ build debug
│ └─ $ dotnet build C:\...\src\Fantomas.Core\Fantomas.Core.fsproj --tl
├─ check scripts
│ └─ step 1
├─ build
│ └─ $ dotnet build -c Release --tl
├─ check doc scripts
│ └─ step 1
├─ unit tests (skipped)
│ └─ $ dotnet test -c Release --tl
├─ pack
│ └─ $ dotnet pack --no-restore -c Release --tl
└─ fsdocs
└─ $ dotnet fsdocs build --properties Configuration=Release --fscoptions " -r:C:\...\SemanticVersioning.dll" --eval --nonpublic --clean --strict
Two things in that output are worth a second look.
One File, Library and CLI
Previously
build.fsx loads four Build*.fsx files in a fixed order, and each of them opens with a guard that exits if it was run directly. The ports load what they need themselves and end the same way:
#load "BuildCommon2.fsx"
let commands =
[
command "release" { (* ... *) }
command "publish-alpha" { (* ... *) }
command "push-client" { (* ... *) }
]
runIfMain "BuildRelease2.fsx" (fun () ->
rootCommandOfScript {
name "BuildRelease2.fsx"
commands
})
Partas.Build
build2.fsx yields BuildRelease2.commands and gets the three subcommands. dotnet fsi scripts/BuildRelease2.fsx -- release --dry-run gets the same three and nothing else. A command is a value, and a list of them is yieldable wherever one is.
Building a Command Line
pushPackage in the original reads NUGET_KEY from the environment and interpolates it into a string. The port takes the key as a value and masks it:
let pushPackage (dryRun: bool) (nupkg: string) : Async<int> =
let pushPackage (key: string option) (dryRun: bool) (nupkg: string) : Async<int> =
let push =
cmd $"dotnet nuget push {nupkg} --source https://api.nuget.org/v3/index.json"
|> Cmd.secretOptionWhenSome "--api-key" key
if dryRun then
printfn $"[DRY-RUN] Would push package: {nupkg}"
printfn $"[DRY-RUN] Would run: {Cmd.toLogString push}"
async { return 0 }
else
let key = Environment.GetEnvironmentVariable("NUGET_KEY")
Cli.Wrap("dotnet")
.WithArguments($"nuget push \"{nupkg}\" --api-key \"{key}\" --source https://api.nuget.org/v3/index.json")
.ExecuteAsync()
Proc.stream push
$ dotnet fsi build2.fsx -- publish-alpha --dry-run --quick --nuget-key oy2abc
[DRY-RUN] Would run: dotnet nuget push C:\...\fantomas.8.0.0-beta-001.nupkg --source https://api.nuget.org/v3/index.json --api-key ***
[DRY-RUN] Would run: dotnet nuget push C:\...\Fantomas.Core.8.0.0-beta-001.nupkg --source https://api.nuget.org/v3/index.json --api-key ***
[DRY-RUN] Would run: dotnet nuget push C:\...\Fantomas.FCS.8.0.0-beta-001.nupkg --source https://api.nuget.org/v3/index.json --api-key ***
The key comes from --nuget-key, whose default is the environment variable, so the flag exists for a laptop and the variable for the runner:
let nugetKey =
Input.optionMaybe<string> "--nuget-key"
|> Input.desc "NuGet API key; defaults to NUGET_KEY"
|> Input.def (Environment.GetEnvironmentVariable "NUGET_KEY" |> Option.ofObj)
A conditional flag is an argIf rather than a second copy of the line. The gh release create call in the original assembles isDraftFlag and prereleaseFlag strings, each empty or not, and interpolates both:
let isDraftFlag =
if isRevision || isPrerelease then String.Empty
else "--draft"
let prereleaseFlag = if isPrerelease then "--prerelease" else String.Empty
let releaseCommand =
$"release create v{currentRelease.Version} {files} {isDraftFlag} {prereleaseFlag} --title \"{currentRelease.Title}\" --notes-file \"{noteFile}\""
let releaseCommand =
cmd $"gh release create v{currentRelease.Version} --title {currentRelease.Title} --notes-file {noteFile}"
|> Cmd.args (List.ofArray nugetPackages)
|> Cmd.argIf isDraft [ "--draft" ]
|> Cmd.argIf isPrerelease [ "--prerelease" ]
--title takes a value with spaces in it, and it is one argument because it is one hole.
A Step That Decides Whether to Run
FormatChanged asks git for the changed files and either prints a message or runs fantomas over them. In Fun.Build that meant a CliWrap call inside the step, with output piping wired by hand. A step can instead return the command, or nothing:
stage "format" {
run (fun _ ->
async {
let! files = changedFiles ()
match List.filter (hasExtension [ ".fs"; ".fsx"; ".fsi" ]) files with
| [] ->
printfn "No changed F# files to format."
return (Ok None: Result<Cmd option, string>)
| sources -> return Ok(Some(cmd $"dotnet fantomas --json" |> Cmd.args sources))
})
}
The runner starts whatever comes back, streams its output like any other step, and maps its exit code through the stage's accepted codes.
Timings
A run ends with the per-stage table; skipped stages say so instead of vanishing.
Stage timings
╭──────────┬──────┬─────────╮
│ Stage │ Time │ Outcome │
├──────────┼──────┼─────────┤
│ versions │ 0.1s │ ok │
│ restore │ - │ skipped │
│ nested │ 0.0s │ ok │
│ inner │ 0.0s │ ok │
╰──────────┴──────┴─────────╯
What Went Away
parseArgs, and one hand-written usage string per script.- The
fsi.CommandLineArgsentry-point check, replaced by onerunIfMaininshared2.fsx. isDryRun,jsonFlagDuringCIand every other flag read by scanning the argument array.- The CliWrap dependency.
runstreams a child process's output already, and the places that read a process's output as a value share a forty-lineProcmodule overCmd. - The
runIfOnlySpecifiedguards, and the "do not run this file directly" guards in front of them.
The ported tree, with the new files in bold:
- build2.fsx
scripts
- ast2.fsx
- BuildAnalyzers2.fsx
- BuildCommon2.fsx
- BuildCompiler2.fsx
- BuildRelease2.fsx
- BuildScripts2.fsx
- chain2.fsx
- format2.fsx
- oak2.fsx
- shared2.fsx
- writer-events2.fsx
What stayed is the part worth keeping. stage, pipeline, whenNot, envVars, parallel' and timeout are Fun.Build's, and a Fun.Build script ports stage by stage. The difference is that the flags a stage reads are now part of its type, and the command line, its help, its validation and --explain all fall out of that.
Appendix: Every File, Before and After
The tabs are synced: pick Ported once and every file shows its port.
#!/usr/bin/env -S dotnet fsi --
#r "nuget: Fun.Build, 1.1.18"
#r "nuget: CliWrap, 3.6.4"
#r "nuget: FSharp.Data, 6.3.0"
#r "nuget: Ionide.KeepAChangelog, 0.1.8"
#r "nuget: Humanizer.Core, 2.14.1"
// The build is split across these, and they are loaded in dependency order: each expects the ones
// above it to be in scope and does not load them itself. Loading a file twice would compile it
// twice, and two copies of a type are two different types, so the order lives here and nowhere else.
#load "scripts/BuildCommon.fsx"
#load "scripts/BuildScripts.fsx"
#load "scripts/BuildAnalyzers.fsx"
#load "scripts/BuildRelease.fsx"
#load "scripts/BuildCompiler.fsx"
open System
open System.IO
open Fun.Build
open CliWrap
open BuildCommon
open BuildScripts
open BuildAnalyzers
open BuildRelease
open BuildCompiler
/// Every test project, by name. Each writes its raw coverage beside its own project file.
let coverageProjects: string list =
[ "Fantomas.Core.Tests"; "Fantomas.Tests"; "Fantomas.Client.Tests" ]
let coverageXmlFiles: string list =
coverageProjects
|> List.map (fun (name: string) -> __SOURCE_DIRECTORY__ </> "src" </> name </> "coverage.xml")
/// Run one test project under AltCover, measuring the one assembly it is there to exercise.
///
/// The filter is a negative lookahead: instrument that assembly and nothing else, which keeps the
/// generated Fantomas.FCS parser and the test assembly itself out of the report and makes the run
/// fast. It cannot name several assemblies at once, because AltCover reads `|` as the separator
/// between filters rather than as alternation, so each project is run with its own.
let coverageCommand (name: string) (assemblyPattern: string) : string =
let project: string = __SOURCE_DIRECTORY__ </> "src" </> name </> $"{name}.fsproj"
$"dotnet test {project} -c Release /p:AltCover=true "
+ $"\"/p:AltCoverAssemblyFilter=^(?!{assemblyPattern}$)\""
let benchmarkAssembly =
binDir </> "Fantomas.Benchmarks" </> "release" </> "Fantomas.Benchmarks.dll"
let semanticVersioning =
binDir </> "Fantomas" </> "release" </> "SemanticVersioning.dll"
let isDryRun =
let args = fsi.CommandLineArgs
Array.exists (fun arg -> arg = "--dry-run") args
/// `--json` when a hosted runner is what is reading the output, and nothing when a person is.
///
/// GitHub Actions sets `CI` to `true`, and so does nearly every other hosted runner; nothing sets
/// it on a development machine. The value itself is not worth matching on, only whether it is
/// there, because no two runners agree on what to put in it.
let jsonFlagDuringCI: string =
if String.IsNullOrEmpty(Environment.GetEnvironmentVariable "CI") then
String.Empty
else
"--json"
pipeline "Build" {
workingDir __SOURCE_DIRECTORY__
stage "RestoreTools" { run "dotnet tool restore" }
stage "Clean" { run (cleanFolders [| analysisReportsDir; artifactsDir |]) }
stage "CheckFormat" { run $"dotnet fantomas check src analyzers docs scripts build.fsx {jsonFlagDuringCI}" }
stage "BuildDebug" { run $"dotnet build \"{scriptProject}\" --tl" }
stage "CheckScripts" { run checkScripts }
stage "Build" { run "dotnet build -c Release --tl" }
stage "CheckDocScripts" { run checkDocScripts }
stage "UnitTests" { run "dotnet test -c Release --tl" }
stage "Pack" { run "dotnet pack --no-restore -c Release --tl" }
stage "Docs" {
whenNot { platformOSX }
envVars
[|
"DOTNET_ROLL_FORWARD_TO_PRERELEASE", "1"
"DOTNET_ROLL_FORWARD", "LatestMajor"
|]
run
$"dotnet fsdocs build --clean --properties Configuration=Release --fscoptions \" -r:{semanticVersioning}\" --eval --strict --nonpublic"
}
runIfOnlySpecified false
}
pipeline "Benchmark" {
workingDir __SOURCE_DIRECTORY__
stage "Prepare" { run "dotnet build -c Release src/Fantomas.Benchmarks --tl" }
stage "Benchmark" { run $"dotnet \"{benchmarkAssembly}\"" }
runIfOnlySpecified true
}
// Line and branch coverage for the three projects Fantomas ships, via AltCover's MSBuild
// integration. Every test project is run under AltCover, each measuring the one assembly it is
// there to exercise, and ReportGenerator merges the three results into a single report.
//
// So `Fantomas.Core`'s figure comes from `Fantomas.Core.Tests` alone, even though `Fantomas.Tests`
// exercises Core heavily through real formatting. Core is understated here rather than wrong.
//
// The filter is a negative lookahead naming the three assemblies to instrument. Everything else
// is left alone, which keeps the generated Fantomas.FCS parser and the test assemblies
// themselves out of the report. AltCover writes OpenCover XML, which is for tooling rather than
// reading, so ReportGenerator turns it into a browsable HTML report afterwards.
//
// A test that starts the fantomas process, as those in Fantomas.Tests/Integration do, adds
// nothing here, because the child process is not instrumented. That is the point rather than a
// flaw: what this measures is how much of the tool can be reached without starting one.
//
// Produces:
// src/<project>/coverage.xml raw OpenCover XML, one per test project
// coveragereport/index.html browsable report, per file and per line
pipeline "Coverage" {
workingDir __SOURCE_DIRECTORY__
stage "RestoreTools" { run "dotnet tool restore" }
stage "Clean" {
run (cleanFolders [| coverageReportDir |])
// A stale coverage.xml from an earlier run would otherwise be merged into the report.
run (fun _ ->
async {
for file in coverageXmlFiles do
if File.Exists file then
File.Delete file
return 0
})
}
stage "Coverage" {
run (coverageCommand "Fantomas.Core.Tests" @"Fantomas\.Core")
run (coverageCommand "Fantomas.Tests" "fantomas")
run (coverageCommand "Fantomas.Client.Tests" @"Fantomas\.Client")
}
stage "Report" {
run (
$"dotnet reportgenerator -reports:{String.Join(';', coverageXmlFiles)} "
+ $"-targetdir:{coverageReportDir} -reporttypes:Html;TextSummary"
)
run (fun _ ->
async {
let summary = coverageReportDir </> "Summary.txt"
let index = coverageReportDir </> "index.html"
if File.Exists summary then
printfn "%s" (File.ReadAllText summary)
printfn $"Browse the full report at {index}"
return 0
})
}
runIfOnlySpecified true
}
pipeline "FormatChanged" {
workingDir __SOURCE_DIRECTORY__
stage "Format" {
run (fun _ ->
async {
let! files = changedFiles ()
let sources: string list =
List.filter (hasExtension [ ".fs"; ".fsx"; ".fsi" ]) files
match sources with
| [] ->
printfn "No changed F# files to format."
return 0
| sources ->
let arguments: string =
sources
|> List.map (fun (source: string) -> $"\"{source}\"")
|> String.concat " "
// CliWrap discards the child's output unless it is given somewhere to put
// it, and what fantomas has to say about the files is the point of the run.
let toConsole: PipeTarget =
PipeTarget.ToDelegate(fun (line: string) -> printfn "%s" line)
let! result =
Cli
.Wrap("dotnet")
.WithArguments($"fantomas --json {arguments}")
.WithStandardOutputPipe(toConsole)
.WithStandardErrorPipe(toConsole)
.WithValidation(CommandResultValidation.None)
.ExecuteAsync()
.Task
|> Async.AwaitTask
return result.ExitCode
})
}
runIfOnlySpecified true
}
pipeline "PushClient" {
workingDir __SOURCE_DIRECTORY__
stage "Pack" { run "dotnet pack ./src/Fantomas.Client -c Release --tl" }
stage "Push" {
run (fun _ ->
async {
return!
Directory.EnumerateFiles(packagesDir, "Fantomas.Client.*.nupkg", SearchOption.TopDirectoryOnly)
|> Seq.tryExactlyOne
|> Option.map pushPackage
|> Option.defaultValue (
async {
printfn "Fantomas.Client package was not found."
return -1
}
)
})
}
runIfOnlySpecified true
}
pipeline "Docs" {
workingDir __SOURCE_DIRECTORY__
stage "Prepare" {
run "dotnet tool restore"
run "dotnet build -c Release src/Fantomas/Fantomas.fsproj"
}
stage "Watch" {
envVars
[|
"DOTNET_ROLL_FORWARD_TO_PRERELEASE", "1"
"DOTNET_ROLL_FORWARD", "LatestMajor"
|]
run
$"dotnet fsdocs watch --properties Configuration=Release --fscoptions \" -r:{semanticVersioning}\" --eval --nonpublic"
}
runIfOnlySpecified true
}
pipeline "FormatAll" {
workingDir __SOURCE_DIRECTORY__
stage "Fantomas" { run "dotnet fantomas --json src analyzers docs scripts build.fsx" }
runIfOnlySpecified true
}
pipeline "EnsureRepoConfig" {
workingDir __SOURCE_DIRECTORY__
stage "Git" {
run "git config core.hooksPath .githooks"
// Without this, `.git-blame-ignore-revs` is a file git only reads when asked to on the
// command line. GitHub's blame view honours it on its own; a clone does not.
run "git config blame.ignoreRevsFile .git-blame-ignore-revs"
// Mark a line whose real author had to be guessed past an ignored commit, so a skipped
// attribution is not read as a genuine one.
run "git config blame.markIgnoredLines true"
}
runIfOnlySpecified true
}
pipeline "Init" {
workingDir __SOURCE_DIRECTORY__
stage "Download FCS files" {
run (fun _ ->
[|
// Not a compiler source. This is the MSBuild task that turns FSComp.txt into the SR
// module. Since dotnet/fsharp#20097 the generated diagnostic accessors return RichText
// instead of string, and the task shipped in the .NET SDK cannot generate those yet.
"src/FSharp.Build/FSharpEmbedResourceText.fs"
89 collapsed lines
"src/Compiler/FSComp.txt"
"src/Compiler/FSStrings.resx"
"src/Compiler/Utilities/NullHelpers.fs"
"src/Compiler/Utilities/Activity.fsi"
"src/Compiler/Utilities/Activity.fs"
"src/Compiler/Utilities/Caches.fsi"
"src/Compiler/Utilities/Caches.fs"
"src/Compiler/Utilities/sformat.fsi"
"src/Compiler/Utilities/sformat.fs"
"src/Compiler/Utilities/sr.fsi"
"src/Compiler/Utilities/sr.fs"
"src/Compiler/Facilities/RichText.fsi"
"src/Compiler/Facilities/RichText.fs"
"src/Compiler/Utilities/ResizeArray.fsi"
"src/Compiler/Utilities/ResizeArray.fs"
"src/Compiler/Utilities/HashMultiMap.fsi"
"src/Compiler/Utilities/HashMultiMap.fs"
"src/Compiler/Utilities/ReadOnlySpan.fsi"
"src/Compiler/Utilities/ReadOnlySpan.fs"
"src/Compiler/Utilities/TaggedCollections.fsi"
"src/Compiler/Utilities/TaggedCollections.fs"
"src/Compiler/Utilities/illib.fsi"
"src/Compiler/Utilities/illib.fs"
"src/Compiler/Utilities/Cancellable.fsi"
"src/Compiler/Utilities/Cancellable.fs"
"src/Compiler/Utilities/FileSystem.fsi"
"src/Compiler/Utilities/FileSystem.fs"
"src/Compiler/Utilities/ildiag.fsi"
"src/Compiler/Utilities/ildiag.fs"
"src/Compiler/Utilities/zmap.fsi"
"src/Compiler/Utilities/zmap.fs"
"src/Compiler/Utilities/zset.fsi"
"src/Compiler/Utilities/zset.fs"
"src/Compiler/Utilities/XmlAdapters.fsi"
"src/Compiler/Utilities/XmlAdapters.fs"
"src/Compiler/Utilities/InternalCollections.fsi"
"src/Compiler/Utilities/InternalCollections.fs"
"src/Compiler/Utilities/lib.fsi"
"src/Compiler/Utilities/lib.fs"
"src/Compiler/Utilities/PathMap.fsi"
"src/Compiler/Utilities/PathMap.fs"
"src/Compiler/Utilities/range.fsi"
"src/Compiler/Utilities/range.fs"
"src/Compiler/Facilities/LanguageFeatures.fsi"
"src/Compiler/Facilities/LanguageFeatures.fs"
"src/Compiler/Facilities/DiagnosticOptions.fsi"
"src/Compiler/Facilities/DiagnosticOptions.fs"
"src/Compiler/Facilities/DiagnosticsLogger.fsi"
"src/Compiler/Facilities/DiagnosticsLogger.fs"
"src/Compiler/Facilities/Hashing.fsi"
"src/Compiler/Facilities/Hashing.fs"
"src/Compiler/Facilities/prim-lexing.fsi"
"src/Compiler/Facilities/prim-lexing.fs"
"src/Compiler/Facilities/prim-parsing.fsi"
"src/Compiler/Facilities/prim-parsing.fs"
"src/Compiler/AbstractIL/illex.fsl"
"src/Compiler/AbstractIL/ilpars.fsy"
"src/Compiler/AbstractIL/il.fsi"
"src/Compiler/AbstractIL/il.fs"
"src/Compiler/AbstractIL/ilascii.fsi"
"src/Compiler/AbstractIL/ilascii.fs"
"src/Compiler/SyntaxTree/PrettyNaming.fsi"
"src/Compiler/SyntaxTree/PrettyNaming.fs"
"src/Compiler/pplex.fsl"
"src/Compiler/pppars.fsy"
"src/Compiler/lex.fsl"
"src/Compiler/pars.fsy"
"src/Compiler/SyntaxTree/UnicodeLexing.fsi"
"src/Compiler/SyntaxTree/UnicodeLexing.fs"
"src/Compiler/SyntaxTree/XmlDocIncludeExpander.fsi"
"src/Compiler/SyntaxTree/XmlDocIncludeExpander.fs"
"src/Compiler/SyntaxTree/XmlDoc.fsi"
"src/Compiler/SyntaxTree/XmlDoc.fs"
"src/Compiler/SyntaxTree/SyntaxTrivia.fsi"
"src/Compiler/SyntaxTree/SyntaxTrivia.fs"
"src/Compiler/SyntaxTree/SyntaxTree.fsi"
"src/Compiler/SyntaxTree/SyntaxTree.fs"
"src/Compiler/SyntaxTree/SyntaxTreeOps.fsi"
"src/Compiler/SyntaxTree/SyntaxTreeOps.fs"
"src/Compiler/SyntaxTree/WarnScopes.fsi"
"src/Compiler/SyntaxTree/WarnScopes.fs"
"src/Compiler/SyntaxTree/LexerStore.fsi"
"src/Compiler/SyntaxTree/LexerStore.fs"
"src/Compiler/SyntaxTree/ParseHelpers.fsi"
"src/Compiler/SyntaxTree/ParseHelpers.fs"
"src/Compiler/SyntaxTree/LexHelpers.fsi"
"src/Compiler/SyntaxTree/LexHelpers.fs"
"src/Compiler/SyntaxTree/LexFilter.fsi"
"src/Compiler/SyntaxTree/LexFilter.fs"
|]
|> Array.map (downloadCompilerFile fsharpCompilerHash)
|> Async.Parallel
|> Async.Ignore)
}
runIfOnlySpecified true
}
pipeline "Release" {
workingDir __SOURCE_DIRECTORY__
stage "Build" { run "dotnet build -c Release" }
stage "UnitTests" { run "dotnet test -c Release" }
stage "Pack" { run "dotnet pack -c Release" }
stage "Release" {
run (fun _ ->
async {
if isDryRun then
printfn "[DRY-RUN] Starting release pipeline in dry-run mode"
else
printfn "Starting release pipeline"
let currentRelease, lastPublishedDate = getCurrentReleaseAndLastPublishedDate ()
if Option.isSome currentRelease.PublishedDate then
printfn $"Release {currentRelease.Version} already exists on GitHub. Skipping release process."
return 0
else
printfn $"Release {currentRelease.Version} does not exist yet. Proceeding with release process."
// Determine if this is a prerelease
let isPrerelease = currentRelease.Version.Contains("-")
if isPrerelease then
printfn $"Detected prerelease version: {currentRelease.Version}"
// Push packages to NuGet
let nugetPackages =
Directory.EnumerateFiles(packagesDir, "*.nupkg", SearchOption.TopDirectoryOnly)
|> Seq.filter (fun nupkg -> not (nupkg.Contains("Fantomas.Client")))
|> Seq.toArray
printfn $"Found {nugetPackages.Length} packages to push to NuGet:"
nugetPackages |> Array.iter (fun pkg -> printfn $" - {Path.GetFileName(pkg)}")
let! nugetExitCodes = nugetPackages |> Array.map pushPackage |> Async.Sequential
let nugetSuccess = nugetExitCodes |> Array.forall (fun code -> code = 0)
if nugetSuccess then
printfn "All NuGet packages pushed successfully"
else
let exitCodesStr = nugetExitCodes |> Array.map string |> String.concat ", "
printfn $"Warning: Some NuGet packages failed to push. Exit codes: {exitCodesStr}"
let notes = getReleaseNotes currentRelease lastPublishedDate
printfn "Release notes that will be used:"
printfn "---"
printfn "%s" notes
printfn "---"
let noteFile = Path.GetTempFileName()
File.WriteAllText(noteFile, notes)
let files = nugetPackages |> Array.map (sprintf "\"%s\"") |> String.concat " "
// We create a draft release for minor and majors. Those that requires a manual publish.
// This is to allow us to add additional release notes when it makes sense.
// Extract patch version from currentRelease.Version (handle prerelease format)
let versionParts = currentRelease.Version.Split('-')
let mainVersion = versionParts.[0]
let patchVersion =
let parts = mainVersion.Split('.')
if parts.Length >= 3 then
match Int32.TryParse(parts.[2]) with
| true, p -> p
| _ -> 0
else
0
let isRevision = patchVersion <> 0
// Draft only for stable minor/major releases (patch = 0 and not prerelease)
let isDraftFlag =
if isRevision || isPrerelease then
String.Empty
else
"--draft"
let prereleaseFlag = if isPrerelease then "--prerelease" else String.Empty
let releaseType =
if isPrerelease then "prerelease (published)"
elif isRevision then "revision (published)"
else "minor/major (draft)"
printfn $"Release type: {releaseType}"
if isPrerelease then
printfn "This is a prerelease version"
let releaseCommand =
$"release create v{currentRelease.Version} {files} {isDraftFlag} {prereleaseFlag} --title \"{currentRelease.Title}\" --notes-file \"{noteFile}\""
let! draftExitCode =
if isDryRun then
printfn $"[DRY-RUN] Would execute: gh {releaseCommand}"
async { return 0 }
else
printfn $"Creating GitHub release: v{currentRelease.Version}"
async {
let! result =
Cli
.Wrap("gh")
.WithArguments(releaseCommand)
.WithValidation(CommandResultValidation.None)
.ExecuteAsync()
.Task
|> Async.AwaitTask
return result.ExitCode
}
if File.Exists noteFile then
File.Delete(noteFile)
if draftExitCode = 0 then
printfn $"Successfully created GitHub release: v{currentRelease.Version}"
else
printfn $"Warning: GitHub release creation returned exit code: {draftExitCode}"
return Seq.max [| yield! nugetExitCodes; yield draftExitCode |]
})
}
runIfOnlySpecified true
}
pipeline "PublishAlpha" {
workingDir __SOURCE_DIRECTORY__
stage "Clean" { run (cleanFolders [| analysisReportsDir; artifactsDir |]) }
stage "Build" { run "dotnet build -c Release --tl" }
stage "Pack" { run "dotnet pack --no-restore -c Release --tl" }
stage "Publish" {
run (fun ctx ->
async {
let nugetPackages =
Directory.EnumerateFiles(packagesDir, "*.nupkg", SearchOption.TopDirectoryOnly)
|> Seq.filter (fun nupkg -> not (nupkg.Contains("Fantomas.Client")))
|> Seq.toArray
let! nugetExitCodes = nugetPackages |> Array.map pushPackage |> Async.Sequential
return Seq.sum nugetExitCodes
})
}
runIfOnlySpecified true
}
pipeline "Analyze" {
workingDir __SOURCE_DIRECTORY__
stage "RestoreTools" { run "dotnet tool restore" }
stage "RestoreSolution" { run "dotnet restore --tl" }
stage "BuildAnalyzers" { run buildLocalAnalyzers }
stage "Analyze" {
run (fun _ ->
projectsToAnalyze
|> List.map (fun (project: string) -> { Project = project; Files = [] })
|> analyzeTargets excludeLocalAdvisory everyFinding)
}
runIfOnlySpecified true
}
// The same analyzers, over the files the working tree touches.
//
// A project is only loaded when it owns a changed file, and is then analyzed for that file alone,
// which is the difference between minutes and seconds on the test projects. What this cannot see
// is a finding a change causes in a file other than the ones you edited, which is what the full
// `Analyze` pipeline is still for before opening a pull request.
pipeline "AnalyzeChanged" {
workingDir __SOURCE_DIRECTORY__
stage "RestoreTools" { run "dotnet tool restore" }
stage "RestoreSolution" { run "dotnet restore --tl" }
stage "BuildAnalyzers" { run buildLocalAnalyzers }
stage "Analyze" {
run (fun _ ->
async {
let! files = changedFiles ()
// Everything reports and nothing fails. Warning rather than something lower
// because these are still findings to act on, and the tool prints every severity
// either way; the only thing being given up here is the non-zero exit.
let demoteLocalErrors: string list = "--treat-as-warning" :: localErrorRules
match targetsFor files with
| [] ->
printfn "No changed file belongs to a project that is analyzed."
return 0
| targets ->
let! scopes = changedLines ()
return! analyzeTargets demoteLocalErrors (keepFinding scopes) targets
})
}
runIfOnlySpecified true
}
tryPrintPipelineCommandHelp ()
#!/usr/bin/env -S dotnet fsi --
// Each file below is a library when loaded and a CLI when run directly, and each loads what it
// needs itself, so the order here does not matter.
#load "scripts/BuildCommon2.fsx"
#load "scripts/BuildScripts2.fsx"
#load "scripts/BuildAnalyzers2.fsx"
#load "scripts/BuildRelease2.fsx"
#load "scripts/BuildCompiler2.fsx"
open System
open System.IO
open Partas.Build
open BuildCommon2
open BuildScripts2
let formatTargets = "src analyzers docs scripts build.fsx"
let semanticVersioning =
binDir </> "Fantomas" </> "release" </> "SemanticVersioning.dll"
let benchmarkAssembly =
binDir </> "Fantomas.Benchmarks" </> "release" </> "Fantomas.Benchmarks.dll"
module Options =
let watch =
Input.option<bool> "--watch"
|> Input.desc "Serve the docs and rebuild on change"
module Blocks =
let checkFormat =
input {
let! ci = Options.ci
let json = if ci then "--json" else ""
return stage "check format" { run $"dotnet fantomas check {formatTargets} {json}" }
}
let fsdocs =
input {
let! watch = Options.watch
let verb = if watch then "watch" else "build"
return
stage "fsdocs" {
whenOSX false
envVars
[
"DOTNET_ROLL_FORWARD_TO_PRERELEASE", "1"
"DOTNET_ROLL_FORWARD", "LatestMajor"
]
run (
cmd
$"dotnet fsdocs {verb} --properties Configuration=Release --fscoptions \" -r:{semanticVersioning}\" --eval --nonpublic"
|> Cmd.argIf (not watch) [ "--clean"; "--strict" ]
)
}
}
/// Every test project, by name. Each writes its raw coverage beside its own project file.
let coverageProjects: string list =
[ "Fantomas.Core.Tests"; "Fantomas.Tests"; "Fantomas.Client.Tests" ]
let coverageXmlFiles: string list =
coverageProjects
|> List.map (fun (name: string) -> repositoryRoot </> "src" </> name </> "coverage.xml")
/// One test project under AltCover, instrumenting only the assembly it is there to exercise.
let coverageCommand (name: string) (assemblyPattern: string) : Cmd =
let project: string = repositoryRoot </> "src" </> name </> $"{name}.fsproj"
cmd $"dotnet test {project} -c Release /p:AltCover=true /p:AltCoverAssemblyFilter=^(?!{assemblyPattern}$)"
rootCommandOfScript {
name "build2.fsx"
description "Fantomas build"
command "build" {
description "Restore, check formatting, build, check scripts, test, pack and build the docs"
workingDir repositoryRoot
Blocks.restoreTools
Blocks.clean [ analysisReportsDir; artifactsDir ]
Blocks.checkFormat
stage "build debug" { run (cmd $"dotnet build {scriptProject} --tl") }
checkScripts
Blocks.build
checkDocScripts
Blocks.test
Blocks.pack
Blocks.fsdocs
}
command "benchmark" {
description "Build and run the benchmarks"
workingDir repositoryRoot
stage "prepare" { run "dotnet build -c Release src/Fantomas.Benchmarks --tl" }
stage "benchmark" { run (cmd $"dotnet {benchmarkAssembly}") }
}
command "coverage" {
description "Line and branch coverage of the three shipped projects, merged into coveragereport/"
workingDir repositoryRoot
Blocks.restoreTools
stage "clean" {
run (cleanFolders [ coverageReportDir ])
run (fun _ ->
for file in coverageXmlFiles do
if File.Exists file then
File.Delete file)
}
stage "coverage" {
run (coverageCommand "Fantomas.Core.Tests" @"Fantomas\.Core")
run (coverageCommand "Fantomas.Tests" "fantomas")
run (coverageCommand "Fantomas.Client.Tests" @"Fantomas\.Client")
}
stage "report" {
run (
cmd
$"dotnet reportgenerator -reports:{String.Join(';', coverageXmlFiles)} -targetdir:{coverageReportDir} -reporttypes:Html;TextSummary"
)
run (fun _ ->
let summary = coverageReportDir </> "Summary.txt"
if File.Exists summary then
printfn "%s" (File.ReadAllText summary)
let index = coverageReportDir </> "index.html"
printfn $"Browse the full report at {index}")
}
}
command "format-changed" {
description "Format the F# files the working tree changed"
workingDir repositoryRoot
stage "format" {
run (fun _ ->
async {
let! files = changedFiles ()
match List.filter (hasExtension [ ".fs"; ".fsx"; ".fsi" ]) files with
| [] ->
printfn "No changed F# files to format."
return (Ok None: Result<Cmd option, string>)
| sources -> return Ok(Some(cmd $"dotnet fantomas --json" |> Cmd.args sources))
})
}
}
command "docs" {
description "Build the docs, or serve them with --watch"
workingDir repositoryRoot
Blocks.restoreTools
stage "build" { run "dotnet build -c Release src/Fantomas/Fantomas.fsproj --tl" }
Blocks.fsdocs
}
command "format" {
description "Format every source file"
workingDir repositoryRoot
stage "fantomas" { run $"dotnet fantomas --json {formatTargets}" }
}
command "repo-config" {
description "Point git at the repository's hooks and blame settings"
workingDir repositoryRoot
stage "git" {
run "git config core.hooksPath .githooks"
run "git config blame.ignoreRevsFile .git-blame-ignore-revs"
run "git config blame.markIgnoredLines true"
}
}
BuildScripts2.commands
BuildAnalyzers2.commands
BuildRelease2.commands
BuildCompiler2.commands
}
|> exit
#r "../artifacts/bin/Fantomas.FCS/debug/Fantomas.FCS.dll"
#r "../artifacts/bin/Fantomas.Core/debug/Fantomas.Core.dll"
#r "nuget: editorconfig, 0.15.0"
#load "../src/Fantomas/Suggestion.fs"
#load "../src/Fantomas/EditorConfig.fs"
open System.IO
open Fantomas.Core
open Fantomas.EditorConfig
let parseEditorConfigContent (content: string) : FormatConfig =
let tempDir = Path.Combine(Path.GetTempPath(), Path.GetRandomFileName())
Directory.CreateDirectory(tempDir) |> ignore
let editorConfigPath = Path.Combine(tempDir, ".editorconfig")
let fsharpFile = Path.Combine(tempDir, "temp.fs")
File.WriteAllText(editorConfigPath, $"root = true\n\n[*.fs]\n%s{content}")
File.WriteAllText(fsharpFile, "")
try
match tryReadConfiguration fsharpFile with
| Some result -> result.Config
| None -> FormatConfig.Default
finally
Directory.Delete(tempDir, true)
/// Parses args and returns (source, isSignature, config).
/// Accepts either a file path as last arg, or source code via stdin.
/// Optional flags: --editorconfig <content>, --signature
let parseArgs (args: string array) =
let editorConfigIdx = args |> Array.tryFindIndex (fun a -> a = "--editorconfig")
let hasSignatureFlag = args |> Array.exists (fun a -> a = "--signature")
let defineIdx = args |> Array.tryFindIndex (fun a -> a = "--define")
let config =
match editorConfigIdx with
| Some idx -> parseEditorConfigContent args.[idx + 1]
| None -> FormatConfig.Default
let defines =
match defineIdx with
| Some idx -> args.[idx + 1].Split(',') |> Array.toList
| None -> []
// Collect flag indices to determine which arg (if any) is the input file
let flagIndices =
[|
match editorConfigIdx with
| Some idx ->
yield idx
yield idx + 1
| None -> ()
match defineIdx with
| Some idx ->
yield idx
yield idx + 1
| None -> ()
yield!
args
|> Array.indexed
|> Array.choose (fun (i, a) -> if a = "--signature" then Some i else None)
|]
let positionalArgs =
args
|> Array.indexed
|> Array.filter (fun (i, _) -> not (Array.contains i flagIndices))
|> Array.map snd
match Array.tryLast positionalArgs with
| Some path when File.Exists(path) ->
let sample = File.ReadAllText(path)
let isSignature = hasSignatureFlag || path.EndsWith(".fsi")
sample, isSignature, config, defines
| _ ->
let sample = stdin.ReadToEnd()
sample, hasSignatureFlag, config, defines
#r "../artifacts/bin/Fantomas.FCS/debug/Fantomas.FCS.dll"
#r "../artifacts/bin/Fantomas.Core/debug/Fantomas.Core.dll"
#r "nuget: editorconfig, 0.15.0"
#r "nuget: Partas.Build, 0.4.0-alpha.3"
#load "../src/Fantomas/Suggestion.fs"
#load "../src/Fantomas/EditorConfig.fs"
open Partas.Build
open System.IO
open Fantomas.Core
open Fantomas.EditorConfig
module Utils =
let runIfMain (name: string) (fn: unit -> int): unit =
if Args.scriptName() |> ValueOption.exists ((=) name)
then fn() |> exit
module Options =
let editorConfig=
Input.optionMaybe<string> "--editorconfig"
|> InputSpec.ofInput
|> InputSpec.map (function
| None -> FormatConfig.Default
| Some content ->
let tempDir = Path.Combine(Path.GetTempPath(), Path.GetRandomFileName())
Directory.CreateDirectory(tempDir) |> ignore
let editorConfigPath = Path.Combine(tempDir, ".editorconfig")
let fsharpFile = Path.Combine(tempDir, "temp.fs")
File.WriteAllText(editorConfigPath, $"root = true\n\n[*.fs]\n%s{content}")
File.WriteAllText(fsharpFile, "")
try
match tryReadConfiguration fsharpFile with
| Some result -> result.Config
| None -> FormatConfig.Default
finally
Directory.Delete(tempDir, true)
)
let signature =
Input.option<bool> "--signature"
|> Input.alias "-s"
let defines =
Input.option<string list> "--define"
|> Input.alias "-d"
let inputPath =
Input.argument<string> "input"
|> Input.description "input file or content"
let inputContent = input {
let! inputPath = inputPath
and! signature = signature
return
if File.Exists(inputPath) then
{| sample = File.ReadAllText(inputPath)
isSignature = signature || inputPath.EndsWith(".fsi") |}
else
{| sample = inputPath
isSignature = signature |}
}
#load "shared.fsx"
open System.IO
open Shared
let parseAst (input: string) (isSignature: bool) (defines: string list) =
try
let ast =
Fantomas.FCS.Parse.parseFile isSignature (Fantomas.FCS.Text.SourceText.ofString input) defines
|> fst
$"%A{ast}"
with ex ->
$"Error while parsing AST: %A{ex}"
match Array.tryHead fsi.CommandLineArgs with
| Some scriptPath ->
let scriptFile = FileInfo(scriptPath)
let sourceFile = FileInfo(Path.Combine(__SOURCE_DIRECTORY__, __SOURCE_FILE__))
if scriptFile.FullName = sourceFile.FullName then
let sample, isSignature, _, defines = parseArgs fsi.CommandLineArgs.[1..]
parseAst sample isSignature defines |> printfn "%s"
| _ -> printfn "Usage: dotnet fsi ast.fsx [--signature] [--define FOO,BAR] <input file>"
#load "shared2.fsx"
open System.IO
open Shared2
open Partas.Build
let parseAst = input {
let! inputContent = Options.inputContent
and! defines = Options.defines
return
try
let ast =
Fantomas.FCS.Parse.parseFile inputContent.isSignature (Fantomas.FCS.Text.SourceText.ofString inputContent.sample) defines
|> fst
$"%A{ast}"
with ex ->
$"Error while parsing AST: %A{ex}"
}
Utils.runIfMain "ast2.fsx" <| fun () ->
rootCommandOfScript {
name "ast2.fsx"
description "Parse ast"
input {
let! parsedAst = parseAst
return stage "parsed ast" {
echo parsedAst
}
}
}
#load "shared.fsx"
open System.IO
open Fantomas.Core
open Shared
let parseOak (input: string) (isSignature: bool) (defines: string list) =
async {
try
let! oaks = CodeFormatter.ParseOakAsync(isSignature, input)
let result =
if List.isEmpty defines then
Array.tryHead oaks
else
let sortedDefines = List.sort defines
oaks |> Array.tryFind (fun (_, d) -> List.sort d = sortedDefines)
match result with
| None -> return "No Oak found in input"
| Some(oak, _) -> return (string oak)
with ex ->
return $"Error while parsing to Oak: %A{ex}"
}
match Array.tryHead fsi.CommandLineArgs with
| Some scriptPath ->
let scriptFile = FileInfo(scriptPath)
let sourceFile = FileInfo(Path.Combine(__SOURCE_DIRECTORY__, __SOURCE_FILE__))
if scriptFile.FullName = sourceFile.FullName then
let sample, isSignature, _, defines = parseArgs fsi.CommandLineArgs.[1..]
parseOak sample isSignature defines |> Async.RunSynchronously |> printfn "%s"
| _ -> printfn "Usage: dotnet fsi oak.fsx [--signature] [--define FOO,BAR] <input file>"
#load "shared2.fsx"
open System.IO
open Fantomas.Core
open Shared2
open Partas.Build
let parseOak = input {
let! inputContent = Options.inputContent
and! defines = Options.defines
let input = inputContent.sample
let isSignature = inputContent.isSignature
return async {
try
let! oaks = CodeFormatter.ParseOakAsync(isSignature, input)
let result =
if List.isEmpty defines then
Array.tryHead oaks
else
let sortedDefines = List.sort defines
oaks |> Array.tryFind (fun (_, d) -> List.sort d = sortedDefines)
match result with
| None -> return "No Oak found in input"
| Some(oak, _) -> return (string oak)
with ex ->
return $"Error while parsing to Oak: %A{ex}"
}
}
Utils.runIfMain "oak2.fsx" <| fun () ->
rootCommandOfScript {
name "oak2.fsx"
input {
let! asyncCont = parseOak
return stage "oak" {
echo (Async.RunSynchronously asyncCont)
}
}
}
#load "shared.fsx"
open System.IO
open Fantomas.Core
open Shared
let format (input: string) (isSignature: bool) (config: FormatConfig) =
async {
try
let! result = CodeFormatter.FormatDocumentAsync(isSignature, input, config)
let formattedCode = result.Code
// Check for diagnostics in the formatted output
let sourceText = Fantomas.FCS.Text.SourceText.ofString formattedCode
let _, diagnostics = Fantomas.FCS.Parse.parseFile isSignature sourceText []
for d in diagnostics do
eprintfn "Diagnostic: %A %A %s %A" d.Severity d.ErrorNumber d.Message d.Range
return formattedCode
with ex ->
return $"Error while formatting: %A{ex}"
}
match Array.tryHead fsi.CommandLineArgs with
| Some scriptPath ->
let scriptFile = FileInfo(scriptPath)
let sourceFile = FileInfo(Path.Combine(__SOURCE_DIRECTORY__, __SOURCE_FILE__))
if scriptFile.FullName = sourceFile.FullName then
let sample, isSignature, config, _ = parseArgs fsi.CommandLineArgs.[1..]
format sample isSignature config |> Async.RunSynchronously |> printfn "%s"
| _ -> printfn "Usage: dotnet fsi format.fsx [--editorconfig <content>] <input file>"
#load "shared2.fsx"
open System.IO
open Fantomas.Core
open Shared2
open Partas.Build
let format = input {
let! inputContent = Options.inputContent
and! editorConfig = Options.editorConfig
let input = inputContent.sample
let isSignature = inputContent.isSignature
return
async {
try
let! result = CodeFormatter.FormatDocumentAsync(isSignature, input, editorConfig)
let formattedCode = result.Code
// Check for diagnostics in the formatted output
let sourceText = Fantomas.FCS.Text.SourceText.ofString formattedCode
let _, diagnostics = Fantomas.FCS.Parse.parseFile isSignature sourceText []
for d in diagnostics do
eprintfn "Diagnostic: %A %A %s %A" d.Severity d.ErrorNumber d.Message d.Range
return formattedCode
with ex ->
return $"Error while formatting: %A{ex}"
}
}
Utils.runIfMain "format2.fsx" <| fun () ->
rootCommandOfScript {
name "format2.fsx"
input {
let! asyncCont = format
return stage "formatted" {
echo (Async.RunSynchronously asyncCont)
}
}
}
#load "shared.fsx"
open System.IO
open Fantomas.Core
open Shared
let getWriterEvents (input: string) (isSignature: bool) (config: FormatConfig) (defines: string list) =
async {
try
let! events = CodeFormatter.GetWriterEventsAsync(isSignature, input, config, defines)
return events |> Array.map string |> String.concat "\n"
with ex ->
return $"Error while getting writer events: %A{ex}"
}
match Array.tryHead fsi.CommandLineArgs with
| Some scriptPath ->
let scriptFile = FileInfo(scriptPath)
let sourceFile = FileInfo(Path.Combine(__SOURCE_DIRECTORY__, __SOURCE_FILE__))
if scriptFile.FullName = sourceFile.FullName then
let sample, isSignature, config, defines = parseArgs fsi.CommandLineArgs.[1..]
getWriterEvents sample isSignature config defines
|> Async.RunSynchronously
|> printfn "%s"
| _ -> printfn "Usage: dotnet fsi writer-events.fsx [--editorconfig <content>] [--define FOO,BAR] <input file>"
#load "shared2.fsx"
open System.IO
open Fantomas.Core
open Shared2
open Partas.Build
let getWriterEvents = input {
let! inputContent = Options.inputContent
and! config = Options.editorConfig
and! defines = Options.defines
let input = inputContent.sample
let isSignature = inputContent.isSignature
return async {
try
let! events = CodeFormatter.GetWriterEventsAsync(isSignature, input, config, defines)
return events |> Array.map string |> String.concat "\n"
with ex ->
return $"Error while getting writer events: %A{ex}"
}
}
Utils.runIfMain "writer-events2.fsx" <| fun () ->
rootCommandOfScript {
name "writer-events2.fsx"
input {
let! asyncCont = getWriterEvents
return stage "writer events" {
echo (Async.RunSynchronously asyncCont)
}
}
}
#load "shared.fsx"
open System.IO
open Fantomas.Core
open Fantomas.Core.SyntaxOak
open Shared
// Best-effort: extract a short display name from the member expression of a segment.
let rec exprName (e: Expr) : string =
match e with
| Expr.Ident n -> n.Text
| Expr.OptVar n ->
n.Identifier.Content
|> List.choose (function
| IdentifierOrDot.Ident i -> Some i.Text
| _ -> None)
|> String.concat "."
| Expr.TypeApp n -> $"{exprName n.Identifier}<...>"
| _ -> e.GetType().Name
let printChain (chain: ExprChain) =
printfn "Chain:"
printfn " Head : %s" (exprName chain.Head)
printfn " Segments: %d" chain.Segments.Length
// When the chain has a terminal call, its method name lives in the LAST segment
// (the call itself is the Terminal). Labelling that one "navigation" would be a lie.
let hasTerminal =
match chain.Terminal with
| ChainTerminal.NoTerminal -> false
| _ -> true
let lastIndex = chain.Segments.Length - 1
chain.Segments
|> List.iteri (fun i seg ->
match seg with
| ChainSegment.DotMember(_, expr) when hasTerminal && i = lastIndex ->
printfn " [%02d] terminal .%s (called below)" i (exprName expr)
| ChainSegment.DotMember(_, expr) -> printfn " [%02d] navigation .%s" i (exprName expr)
| ChainSegment.DotApplication(_, expr, ChainCall.Unit _) ->
printfn " [%02d] action .%s()" i (exprName expr)
| ChainSegment.DotApplication(_, expr, ChainCall.Paren _) ->
printfn " [%02d] action .%s(...)" i (exprName expr)
| ChainSegment.DotIndex(_, idx) -> printfn " [%02d] navigation .[%s]" i (exprName idx))
let terminalStr =
match chain.Terminal with
| ChainTerminal.NoTerminal -> "(none)"
| ChainTerminal.SpaceAllowed(ChainCall.Unit _) -> "SpaceAllowed ()"
| ChainTerminal.SpaceAllowed(ChainCall.Paren _) -> "SpaceAllowed (...)"
| ChainTerminal.NoSpaceAllowed(ChainCall.Unit _) -> "NoSpaceAllowed ()"
| ChainTerminal.NoSpaceAllowed(ChainCall.Paren _) -> "NoSpaceAllowed (...)"
printfn " Terminal: %s" terminalStr
// Recursively collect all ExprChain nodes in the Oak's Node tree.
let rec collectChains (node: Node) : ExprChain list =
[
match node with
| :? ExprChain as chain -> yield chain
| _ -> ()
for child in node.Children do
yield! collectChains child
]
match Array.tryHead fsi.CommandLineArgs with
| Some scriptPath ->
let scriptFile = FileInfo(scriptPath)
let sourceFile = FileInfo(Path.Combine(__SOURCE_DIRECTORY__, __SOURCE_FILE__))
if scriptFile.FullName = sourceFile.FullName then
let source, isSignature, _, _ = parseArgs fsi.CommandLineArgs.[1..]
let oak =
CodeFormatter.ParseOakAsync(isSignature, source)
|> Async.RunSynchronously
|> Array.head
|> fst
let chains = collectChains oak
if chains.IsEmpty then
printfn "No chain expression found in input."
else
printfn "Found %d chain(s):\n" chains.Length
chains
|> List.iteri (fun i chain ->
printfn "--- Chain #%d ---" (i + 1)
printChain chain
printfn "")
| _ ->
printfn "Usage: dotnet fsi chain.fsx [--signature] [<input file>]"
printfn " source code is read from stdin when no input file is given"
#load "shared2.fsx"
open System.IO
open Fantomas.Core
open Fantomas.Core.SyntaxOak
open Shared2
// Best-effort: extract a short display name from the member expression of a segment.
let rec exprName (e: Expr) : string =
match e with
| Expr.Ident n -> n.Text
| Expr.OptVar n ->
n.Identifier.Content
|> List.choose (function
| IdentifierOrDot.Ident i -> Some i.Text
| _ -> None)
|> String.concat "."
| Expr.TypeApp n -> $"{exprName n.Identifier}<...>"
| _ -> e.GetType().Name
let printChain (chain: ExprChain) =
printfn "Chain:"
printfn " Head : %s" (exprName chain.Head)
printfn " Segments: %d" chain.Segments.Length
// When the chain has a terminal call, its method name lives in the LAST segment
// (the call itself is the Terminal). Labelling that one "navigation" would be a lie.
let hasTerminal =
match chain.Terminal with
| ChainTerminal.NoTerminal -> false
| _ -> true
let lastIndex = chain.Segments.Length - 1
chain.Segments
|> List.iteri (fun i seg ->
match seg with
| ChainSegment.DotMember(_, expr) when hasTerminal && i = lastIndex ->
printfn " [%02d] terminal .%s (called below)" i (exprName expr)
| ChainSegment.DotMember(_, expr) -> printfn " [%02d] navigation .%s" i (exprName expr)
| ChainSegment.DotApplication(_, expr, ChainCall.Unit _) ->
printfn " [%02d] action .%s()" i (exprName expr)
| ChainSegment.DotApplication(_, expr, ChainCall.Paren _) ->
printfn " [%02d] action .%s(...)" i (exprName expr)
| ChainSegment.DotIndex(_, idx) -> printfn " [%02d] navigation .[%s]" i (exprName idx))
let terminalStr =
match chain.Terminal with
| ChainTerminal.NoTerminal -> "(none)"
| ChainTerminal.SpaceAllowed(ChainCall.Unit _) -> "SpaceAllowed ()"
| ChainTerminal.SpaceAllowed(ChainCall.Paren _) -> "SpaceAllowed (...)"
| ChainTerminal.NoSpaceAllowed(ChainCall.Unit _) -> "NoSpaceAllowed ()"
| ChainTerminal.NoSpaceAllowed(ChainCall.Paren _) -> "NoSpaceAllowed (...)"
printfn " Terminal: %s" terminalStr
// Recursively collect all ExprChain nodes in the Oak's Node tree.
let rec collectChains (node: Node) : ExprChain list =
[
match node with
| :? ExprChain as chain -> yield chain
| _ -> ()
for child in node.Children do
yield! collectChains child
]
open Partas.Build
Utils.runIfMain "chain2.fsx" <| fun _ ->
rootCommandOfScript {
name "chain2.fsx"
input {
let! inputContent = Options.inputContent
return stage "chain" {
run (async {
let! oak = CodeFormatter.ParseOakAsync(inputContent.isSignature, inputContent.sample)
let oak = oak |> Array.head |> fst
let chains = collectChains oak
if chains.IsEmpty then
printfn "No chain expression found in input."
else
printfn "Found %d chain(s):\n" chains.Length
chains
|> List.iteri (fun i chain ->
printfn "--- Chain #%d ---" (i + 1)
printChain chain
printfn "")
})
}
}
}
#r "nuget: CliWrap, 3.6.4"
open System
open System.IO
open CliWrap
open CliWrap.Buffered
// This file is loaded by `build.fsx`. It defines things and runs nothing, so a direct run would
// look like a success while doing no work at all. Say so instead.
if Path.GetFileName(fsi.CommandLineArgs[0]) = Path.GetFileName __SOURCE_FILE__ then
eprintfn "%s is loaded by build.fsx and is not meant to be run on its own." (Path.GetFileName __SOURCE_FILE__)
eprintfn "Run a pipeline instead, for example: dotnet fsi build.fsx -- -p Build"
exit 1
// What every part of the build agrees on: where things are, how to run a process, and what the
// working tree changed.
//
// Anything here is used by at least two of `build.fsx`, `BuildAnalyzers.fsx`, `BuildRelease.fsx` and
// `BuildCompiler.fsx`. Anything used by only one of them belongs in that one.
let (</>) a b = Path.Combine(a, b)
/// The repository root.
///
/// `__SOURCE_DIRECTORY__` is the folder of the file it is written in, which here is `scripts/` and
/// not the root. Every path below is anchored to this instead, so that what the build points at does
/// not depend on which script did the loading.
let repositoryRoot: string = Path.GetFullPath(__SOURCE_DIRECTORY__ </> "..")
let artifactsDir: string = repositoryRoot </> "artifacts"
let binDir: string = artifactsDir </> "bin"
let packagesDir: string = artifactsDir </> "package" </> "release"
let coverageReportDir: string = repositoryRoot </> "coveragereport"
/// Where the analyzers write their report per project, before the reports are merged into one.
let analysisReportsDir: string = repositoryRoot </> "analysisreports"
/// The merged analyzer report. Holds the last run and nothing more.
let mergedAnalysisReport: string = repositoryRoot </> "analysis.sarif"
/// Deleting a folder can fail with "Directory not empty" when something writes into it while
/// the delete is walking it, Finder dropping a .DS_Store back in is enough. The delete does
/// remove what it got to, so retry a couple of times before giving up.
let rec private deleteDirectory (attempt: int) (dir: string) : Async<unit> =
async {
try
Directory.Delete(dir, true)
with :? IOException when attempt < 5 ->
do! Async.Sleep(100 * attempt)
if Directory.Exists(dir) then
return! deleteDirectory (attempt + 1) dir
}
let cleanFolders (input: string seq) : Async<unit> =
async {
for dir in input do
if Directory.Exists(dir) then
do! deleteDirectory 1 dir
}
let runGitCommand (arguments: string) =
async {
let! result =
Cli.Wrap("git").WithArguments(arguments).WithWorkingDirectory(repositoryRoot).ExecuteBufferedAsync().Task
|> Async.AwaitTask
return result.ExitCode, result.StandardOutput, result.StandardError
}
/// The files git reports as changed in the working tree, as paths relative to the repository root.
///
/// The porcelain format is two status columns, a space, and then the path, so the path starts at
/// the fourth character. A rename reads as `old -> new`, of which only the new path still exists.
/// Deleted files are dropped: there is nothing left to look at.
///
/// Untracked files are asked for one by one. Git otherwise reports a new folder as a single entry
/// and the files inside it are never named, which is exactly the case of a feature that arrives as
/// a new folder of sources.
let changedFiles () : Async<string list> =
async {
let! exitCode, stdout, stdErr =
runGitCommand "status --porcelain --untracked-files=all"
if exitCode <> 0 then
failwith $"Could not read the git status.\n{stdErr}"
return
stdout.Split('\n')
|> Array.choose (fun (line: string) ->
let line: string = line.TrimEnd('\r')
if line.Length < 4 || line[0] = 'D' || line[1] = 'D' then
None
else
let path: string = line.Substring 3
let path: string =
match path.IndexOf(" -> ", StringComparison.Ordinal) with
| -1 -> path
| arrow -> path.Substring(arrow + 4)
Some(path.Trim('"').Replace('\\', '/')))
|> List.ofArray
}
let hasExtension (extensions: string list) (path: string) : bool =
extensions
|> List.exists (fun (extension: string) -> path.EndsWith(extension, StringComparison.Ordinal))
/// How much of a file the working tree touched.
type ChangedLines =
/// Every line, which is what a file that git has never seen amounts to.
| WholeFile
/// The lines a diff hunk added or altered.
| Lines of Set<int>
/// The lines the working tree changed, per file, keyed by repository relative path.
///
/// `git diff HEAD` covers staged and unstaged changes alike, and `-U0` asks for no context lines,
/// so every hunk header names exactly the lines that differ. An untracked file has no diff to read
/// and is new in its entirety.
let changedLines () : Async<Map<string, ChangedLines>> =
async {
let! files = changedFiles ()
let! exitCode, stdout, stdErr = runGitCommand "diff -U0 HEAD --"
if exitCode <> 0 then
failwith $"Could not read the git diff.\n{stdErr}"
let hunk: Text.RegularExpressions.Regex =
Text.RegularExpressions.Regex(@"^@@ -\S+ \+(?<start>\d+)(,(?<count>\d+))? @@")
let mutable scopes: Map<string, ChangedLines> = Map.empty
let mutable current: string option = None
for line in stdout.Split('\n') do
let line: string = line.TrimEnd('\r')
if line.StartsWith("+++ b/", StringComparison.Ordinal) then
current <- Some(line.Substring 6)
elif line.StartsWith("+++ ", StringComparison.Ordinal) then
current <- None
else
let m: Text.RegularExpressions.Match = hunk.Match line
match current with
| None -> ()
| Some file when m.Success ->
let start: int = int m.Groups["start"].Value
let count: int =
if m.Groups["count"].Success then
int m.Groups["count"].Value
else
1
// A pure deletion reports a count of zero. Nothing of it survives to report on.
let added: Set<int> = set [ start .. start + count - 1 ]
let merged: ChangedLines =
match Map.tryFind file scopes with
| Some(Lines existing) -> Lines(Set.union existing added)
| _ -> Lines added
scopes <- Map.add file merged scopes
| Some _ -> ()
// Anything git named as changed but has no diff hunk is untracked, so all of it is new.
for file in files do
if not (Map.containsKey file scopes) then
scopes <- Map.add file WholeFile scopes
return scopes
}
/// How much of the file a finding sits in the working tree touched, or `None` when it touched none
/// of it.
///
/// `changedLines` puts an entry in the map for every file git named, so a miss here is a fact and
/// not an absence of information: git was asked, and said this file did not change.
let scopeFor (scopes: Map<string, ChangedLines>) (path: string) : ChangedLines option =
let normalized: string = path.Replace('\\', '/')
scopes
|> Map.tryPick (fun (file: string) (scope: ChangedLines) ->
if normalized.EndsWith(file, StringComparison.Ordinal) then
Some scope
else
None)
#r "nuget: Partas.Build, 0.4.0-alpha.3"
open System
open System.Diagnostics
open System.IO
open Partas.Build
// What every part of the build agrees on: where things are, how a process is run, what the working
// tree changed, and the CLI options and stages more than one command uses.
let (</>) a b = Path.Combine(a, b)
/// The repository root. Every path below is anchored here rather than at `__SOURCE_DIRECTORY__`.
let repositoryRoot: string = Path.GetFullPath(__SOURCE_DIRECTORY__ </> "..")
let artifactsDir: string = repositoryRoot </> "artifacts"
let binDir: string = artifactsDir </> "bin"
let packagesDir: string = artifactsDir </> "package" </> "release"
let coverageReportDir: string = repositoryRoot </> "coveragereport"
/// Where the analyzers write a report per project, before the reports are merged into one.
let analysisReportsDir: string = repositoryRoot </> "analysisreports"
/// The merged analyzer report. Holds the last run and nothing more.
let mergedAnalysisReport: string = repositoryRoot </> "analysis.sarif"
/// Runs `fn` only when `name` is the script `dotnet fsi` was started with, so a file that is
/// `#load`ed is a library and the same file run directly is a CLI.
let runIfMain (name: string) (fn: unit -> int) : unit =
if Args.scriptName () |> ValueOption.exists ((=) name) then
fn () |> exit
/// Running a `Cmd` outside a stage, for the places that need its output as a value.
module Proc =
let private startInfo (cmd: Cmd) : ProcessStartInfo =
let info =
ProcessStartInfo(
cmd.Executable,
UseShellExecute = false,
WorkingDirectory = repositoryRoot,
RedirectStandardOutput = true,
RedirectStandardError = true
)
for arg in cmd.Arguments do
info.ArgumentList.Add arg
info
/// Runs to completion and returns the exit code with both output streams, held back whole.
let buffered (cmd: Cmd) : Async<int * string * string> =
async {
use proc = Process.Start(startInfo cmd)
let stdout = proc.StandardOutput.ReadToEndAsync()
let stderr = proc.StandardError.ReadToEndAsync()
do! proc.WaitForExitAsync() |> Async.AwaitTask
let! out = Async.AwaitTask stdout
let! err = Async.AwaitTask stderr
return proc.ExitCode, out, err
}
/// Runs to completion, printing the command and forwarding its output line by line.
let stream (cmd: Cmd) : Async<int> =
async {
printfn "$ %s" (Cmd.toLogString cmd)
use proc = new Process(StartInfo = startInfo cmd)
proc.OutputDataReceived.Add(fun e ->
if not (isNull e.Data) then
printfn "%s" e.Data)
proc.ErrorDataReceived.Add(fun e ->
if not (isNull e.Data) then
eprintfn "%s" e.Data)
proc.Start() |> ignore
proc.BeginOutputReadLine()
proc.BeginErrorReadLine()
do! proc.WaitForExitAsync() |> Async.AwaitTask
return proc.ExitCode
}
/// Deletes a folder, retrying while something else still holds a file in it.
let rec private deleteDirectory (attempt: int) (dir: string) : Async<unit> =
async {
try
Directory.Delete(dir, true)
with :? IOException when attempt < 5 ->
do! Async.Sleep(100 * attempt)
if Directory.Exists dir then
return! deleteDirectory (attempt + 1) dir
}
let cleanFolders (input: string seq) : Async<unit> =
async {
for dir in input do
if Directory.Exists dir then
do! deleteDirectory 1 dir
}
let runGitCommand (arguments: string) : Async<int * string * string> =
Proc.buffered (Cmd.create "git" arguments)
/// The files git reports as changed in the working tree, as paths relative to the repository root.
/// Deleted files are dropped; a rename contributes only its new path.
let changedFiles () : Async<string list> =
async {
let! exitCode, stdout, stdErr =
runGitCommand "status --porcelain --untracked-files=all"
if exitCode <> 0 then
failwith $"Could not read git status.\n{stdErr}"
return
stdout.Split('\n')
|> Array.choose (fun (line: string) ->
let line: string = line.TrimEnd('\r')
if line.Length < 4 || line[0] = 'D' || line[1] = 'D' then
None
else
let path: string = line.Substring 3
let path: string =
match path.IndexOf(" -> ", StringComparison.Ordinal) with
| -1 -> path
| arrow -> path.Substring(arrow + 4)
Some(path.Trim('"').Replace('\\', '/')))
|> List.ofArray
}
let hasExtension (extensions: string list) (path: string) : bool =
extensions
|> List.exists (fun (extension: string) -> path.EndsWith(extension, StringComparison.Ordinal))
/// How much of a file the working tree touched.
type ChangedLines =
| Lines of Set<int>
| WholeFile
/// The changed lines of every changed file. An untracked file has no diff and is new in its entirety.
let changedLines () : Async<Map<string, ChangedLines>> =
async {
let! files = changedFiles ()
let! exitCode, stdout, stdErr = runGitCommand "diff -U0 HEAD --"
if exitCode <> 0 then
failwith $"Could not diff.\n{stdErr}"
let hunk =
Text.RegularExpressions.Regex(@"^@@ -\S+ \+(?<start>\d+)(,(?<count>\d+))? @@")
let mutable scopes: Map<string, ChangedLines> = Map.empty
let mutable current: string option = None
for line in stdout.Split('\n') do
let line: string = line.TrimEnd('\r')
if line.StartsWith("+++ b/", StringComparison.Ordinal) then
current <- Some(line.Substring 6)
elif line.StartsWith("+++ ", StringComparison.Ordinal) then
current <- None
else
let m = hunk.Match line
match current with
| Some file when m.Success ->
let start: int = int m.Groups["start"].Value
let count: int =
if m.Groups["count"].Success then
int m.Groups["count"].Value
else
1
let added: Set<int> = set [ start .. start + count - 1 ]
let merged: ChangedLines =
match Map.tryFind file scopes with
| Some(Lines existing) -> Lines(Set.union existing added)
| _ -> Lines added
scopes <- Map.add file merged scopes
| _ -> ()
for file in files do
if not (Map.containsKey file scopes) then
scopes <- Map.add file WholeFile scopes
return scopes
}
/// The scope of a path as the analyzers report it, which may be absolute or root-relative.
let scopeFor (scopes: Map<string, ChangedLines>) (path: string) : ChangedLines option =
let normalized: string = path.Replace('\\', '/')
scopes
|> Map.tryPick (fun (file: string) (scope: ChangedLines) ->
if normalized = file || normalized.EndsWith("/" + file, StringComparison.Ordinal) then
Some scope
else
None)
/// The CLI options more than one command reads. A stage binds one in an `input { }` block, and that
/// is what puts the option in the command's `--help`.
module Options =
let quick =
Input.option<bool> "--quick"
|> Input.alias "-q"
|> Input.desc "Skip tool restore and clean"
let skipTests =
Input.option<bool> "--skip-tests" |> Input.desc "Skip the unit tests"
let ci = Baked.Input.CI.isCI
let config =
Input.option<string> "--configuration"
|> Input.alias "-c"
|> Input.def "Release"
|> Input.acceptOnlyFromAmong [ "Debug"; "Release" ]
let dryRun =
Input.option<bool> "--dry-run"
|> Input.desc "Print what would be pushed or created, without doing it"
let nugetKey =
Input.optionMaybe<string> "--nuget-key"
|> Input.desc "NuGet API key; defaults to NUGET_KEY"
|> Input.def (
Environment.GetEnvironmentVariable "NUGET_KEY"
|> Option.ofObj
|> Option.filter (String.IsNullOrWhiteSpace >> not)
)
/// The stages every command opens with.
module Blocks =
let restoreTools =
input {
let! quick = Options.quick
return
stage "restore tools" {
when' (not quick)
run "dotnet tool restore"
}
}
let restoreSolution =
input {
let! quick = Options.quick
return
stage "restore solution" {
when' (not quick)
run "dotnet restore --tl"
}
}
let clean (folders: string list) =
input {
let! quick = Options.quick
return
stage "clean" {
when' (not quick)
run (cleanFolders folders)
}
}
let build =
input {
let! config = Options.config
return stage "build" { run (cmd $"dotnet build -c {config} --tl") }
}
let test =
input {
let! config = Options.config
and! skip = Options.skipTests
return
stage "unit tests" {
when' (not skip)
run (cmd $"dotnet test -c {config} --tl")
}
}
let pack =
input {
let! config = Options.config
return stage "pack" { run (cmd $"dotnet pack --no-restore -c {config} --tl") }
}
#r "nuget: CliWrap, 3.6.4"
open System.IO
open System.Text.RegularExpressions
open CliWrap
open CliWrap.Buffered
// Loaded by `build.fsx`, after `BuildCommon.fsx`. An error here saying BuildCommon is not defined
// means this file was run on its own; it is a library, so run a pipeline from build.fsx instead.
open BuildCommon
// Compiling this repository's own scripts without running them.
//
// Nothing else in the build looks at them, so a rename in `src/` that one of them refers to breaks
// it silently: the script keeps sitting there and fails the next time somebody reaches for it,
// which is usually in the middle of something else. The documentation scripts have exactly that
// problem too, and both of the ones that `#load` a file out of `src/` were broken this way.
//
// They fall into two groups, and the difference is which build they reference: the scripts beside
// this file take the debug build, the documentation takes the release one. That is why there are
// two entry points here rather than one, run from two different points of the pipeline.
/// The project the diagnostic scripts are compiled against.
///
/// Anchored at `repositoryRoot` rather than written relative, so it names the same project whatever
/// the working directory of the run is.
///
/// `shared.fsx` references the debug build of Fantomas.Core, and Fantomas.Core references
/// Fantomas.FCS, so building this one project puts both assemblies where the scripts look for them.
/// The CLI and the test projects are no part of what a script loads and are not built for this.
///
/// It is the debug build they reference, and that is not a detail to tidy away into the release
/// build the rest of the pipeline makes: these scripts are for prototyping against a local
/// Fantomas, which is something you want to be able to step through.
let scriptProject: string =
repositoryRoot </> "src" </> "Fantomas.Core" </> "Fantomas.Core.fsproj"
/// Of the given scripts, the ones that are meant to be run directly.
///
/// A script that another of them `#load`s is left out, because it is already compiled as part of
/// whatever loads it. Several cannot be compiled alone at all, by design: this file and its
/// neighbours expect `BuildCommon.fsx` to be in scope, which is only true when `build.fsx` did the
/// loading. Reading the `#load` lines rather than listing those exceptions means a script added
/// later is checked without anything here having to be edited.
let private runnableIn (scripts: string list) : string list =
let loadDirective: Regex = Regex("^\\s*#load\\s+\"([^\"]+)\"")
let loaded: Set<string> =
scripts
|> Seq.collect (fun (script: string) ->
let folder: string = Path.GetDirectoryName script
File.ReadLines script
|> Seq.choose (fun (line: string) ->
let matched: Match = loadDirective.Match line
if matched.Success then
Some(Path.GetFullPath(folder </> matched.Groups[1].Value))
else
None))
|> Set.ofSeq
scripts
|> List.filter (fun (script: string) -> not (loaded.Contains(Path.GetFullPath script)))
/// `build.fsx` and the diagnostic scripts beside this file, which reference the debug build.
let runnableScripts () : string list =
[
repositoryRoot </> "build.fsx"
yield! Directory.EnumerateFiles(repositoryRoot </> "scripts", "*.fsx")
]
|> runnableIn
/// The documentation scripts, which fsdocs turns into the pages of the site. They reference the
/// release build, so they can only be compiled once the pipeline has made one.
let runnableDocScripts () : string list =
Directory.EnumerateFiles(repositoryRoot </> "docs", "*.fsx", SearchOption.AllDirectories)
|> List.ofSeq
|> runnableIn
/// Compile one script and stop short of running it, reporting whatever the compiler said.
let private typecheckScript (script: string) : Async<string * int * string> =
async {
let! result =
Cli
.Wrap("dotnet")
.WithArguments($"fsi --typecheck-only --nologo \"{script}\"")
.WithWorkingDirectory(repositoryRoot)
.WithValidation(CommandResultValidation.None)
.ExecuteBufferedAsync()
.Task
|> Async.AwaitTask
return script, result.ExitCode, (result.StandardOutput + result.StandardError).Trim()
}
/// Compile each of the given scripts, and report what the compiler said about any that would not
/// compile. Writes nothing: no script is run, and the assemblies they reference are built by the
/// stage before whichever one calls this.
let private check (scripts: string list) : Async<int> =
async {
// One at a time: the compiler output of a script that fails is the point of this, and
// running them together interleaves it beyond reading.
let! results = scripts |> List.map typecheckScript |> Async.Sequential
for (script: string), (exitCode: int), (output: string) in results do
let name: string = Path.GetRelativePath(repositoryRoot, script)
if exitCode = 0 then
printfn "%s compiles." name
else
printfn "%s does not compile:" name
printfn "%s" output
let failed: int =
results |> Array.filter (fun (_, exitCode, _) -> exitCode <> 0) |> Array.length
return (if failed = 0 then 0 else 1)
}
/// Compile `build.fsx` and the diagnostic scripts. Needs the debug build.
let checkScripts _ : Async<int> = check (runnableScripts ())
/// Compile the documentation scripts. Needs the release build.
let checkDocScripts _ : Async<int> = check (runnableDocScripts ())
#load "BuildCommon2.fsx"
open System.IO
open System.Text.RegularExpressions
open Partas.Build
open BuildCommon2
// Compiling the repository's own scripts without running them, so a rename in `src/` that one of
// them refers to breaks the build rather than the next person who reaches for the script.
/// The project the diagnostic scripts are compiled against. `shared.fsx` references the debug build
/// of Fantomas.Core, which references Fantomas.FCS, so building this one project places both.
let scriptProject: string =
repositoryRoot </> "src" </> "Fantomas.Core" </> "Fantomas.Core.fsproj"
/// Of the given scripts, the ones meant to be run directly: a script another one `#load`s is
/// compiled as part of the loader and is left out.
let private runnableIn (scripts: string list) : string list =
let loadDirective: Regex = Regex("^\\s*#load\\s+\"([^\"]+)\"")
let loaded: Set<string> =
scripts
|> Seq.collect (fun (script: string) ->
let folder: string = Path.GetDirectoryName script
File.ReadLines script
|> Seq.choose (fun (line: string) ->
let matched: Match = loadDirective.Match line
if matched.Success then
Some(Path.GetFullPath(folder </> matched.Groups[1].Value))
else
None))
|> Set.ofSeq
scripts
|> List.filter (fun (script: string) -> not (loaded.Contains(Path.GetFullPath script)))
/// Both build scripts and the diagnostic scripts beside this file. They reference the debug build.
let runnableScripts () : string list =
[
repositoryRoot </> "build.fsx"
repositoryRoot </> "build2.fsx"
yield! Directory.EnumerateFiles(repositoryRoot </> "scripts", "*.fsx")
]
|> runnableIn
/// The documentation scripts fsdocs turns into pages. They reference the release build.
let runnableDocScripts () : string list =
Directory.EnumerateFiles(repositoryRoot </> "docs", "*.fsx", SearchOption.AllDirectories)
|> List.ofSeq
|> runnableIn
/// Compiles one script and stops short of running it, reporting what the compiler said.
let private typecheckScript (script: string) : Async<string * int * string> =
async {
let! exitCode, stdout, stderr =
Proc.buffered (cmd $"dotnet fsi --typecheck-only --nologo {script}")
return script, exitCode, (stdout + stderr).Trim()
}
/// Compiles the scripts one at a time, so the compiler output of one that fails stays in one piece.
let private check (scripts: string list) : Async<int> =
async {
let! results = scripts |> List.map typecheckScript |> Async.Sequential
for (script: string), (exitCode: int), (output: string) in results do
let name: string = Path.GetRelativePath(repositoryRoot, script)
if exitCode = 0 then
printfn "%s compiles." name
else
printfn "%s does not compile:" name
printfn "%s" output
let failed: int =
results |> Array.filter (fun (_, exitCode, _) -> exitCode <> 0) |> Array.length
return (if failed = 0 then 0 else 1)
}
/// Compiles the build and diagnostic scripts. Needs the debug build.
let checkScripts =
stage "check scripts" { run (fun _ -> check (runnableScripts ())) }
/// Compiles the documentation scripts. Needs the release build.
let checkDocScripts =
stage "check doc scripts" { run (fun _ -> check (runnableDocScripts ())) }
let commands =
[
command "check-scripts" {
description "Compile the build and diagnostic scripts against a debug build of Fantomas.Core"
workingDir repositoryRoot
stage "build debug" { run (cmd $"dotnet build {scriptProject} --tl") }
checkScripts
}
command "check-doc-scripts" {
description "Compile the documentation scripts against a release build"
workingDir repositoryRoot
Blocks.build
checkDocScripts
}
]
runIfMain "BuildScripts2.fsx" (fun () ->
rootCommandOfScript {
name "BuildScripts2.fsx"
commands
})
#r "nuget: CliWrap, 3.6.4"
#r "nuget: FSharp.Data, 6.3.0"
open System
open System.IO
open System.Xml.Linq
open System.Xml.XPath
open CliWrap
open CliWrap.Buffered
open FSharp.Data
// Loaded by `build.fsx`, after `BuildCommon.fsx`. An error here saying BuildCommon is not defined
// means this file was run on its own; it is a library, so run a pipeline from build.fsx instead.
open BuildCommon
// Running the analyzers, and deciding which of their findings a run set out to report.
//
// The pipelines reach all of this through a handful of names: `projectsToAnalyze`, `targetsFor`,
// `analyzeTargets` and the two filters. Everything between those and the SARIF on disk is detail,
// and detail that grew every time the reporting was made more honest.
/// The projects the analyzers run over: every project in the solution, minus the ones whose source
/// is not ours to change. Fantomas.FCS is generated from the vendored compiler sources, and
/// Fantomas.FCS.BuildTasks compiles a single vendored compiler file, so a finding in either is
/// something to report upstream rather than something to fix here. Reading the solution rather than
/// globbing keeps the rest of the build tooling out.
///
/// This includes the analyzers themselves, which are in the solution like everything else. There is
/// nothing circular about a rule reporting on the project that defines it: the pipelines build the
/// analyzers before running them, so what looks at this code is the build the run started with.
let projectsToAnalyze: string list =
let excluded = set [ "Fantomas.FCS" ]
// Analyzing a project costs roughly what type checking it costs, so the largest one decides how
// long the whole run takes. Starting with it means it is never the one left waiting for a slot.
let sourceSize (project: string) =
Directory.EnumerateFiles(Path.GetDirectoryName(repositoryRoot </> project), "*.fs", SearchOption.AllDirectories)
|> Seq.sumBy (fun file -> FileInfo(file).Length)
XDocument.Load(repositoryRoot </> "fantomas.slnx").XPathSelectElements("//Project")
|> Seq.map (fun project -> project.Attribute(XName.Get "Path").Value.Replace('\\', '/'))
|> Seq.filter (fun path -> not (excluded.Contains(Path.GetFileNameWithoutExtension path)))
|> Seq.sortByDescending sourceSize
|> Seq.toList
/// One project to hand to the analyzers, and which of its files to look at.
///
/// `Files` holds absolute paths, because that is the only form `--include-files` matches: give it a
/// path relative to the repository root and it matches nothing, says nothing about it and reports a
/// clean project. An empty list asks for every file of the project.
type AnalysisTarget = { Project: string; Files: string list }
/// What to analyze for a set of changed files: every project that owns one, along with the files of
/// its own that changed. A project owns everything under its own folder, which is how every project
/// of this solution is laid out. The order is the one `projectsToAnalyze` puts them in.
///
/// Only compiled sources and project files count. A script, a document or a test data file is not
/// part of any compilation, so changing one leaves the analyzers with nothing new to say.
///
/// A changed project file asks for the whole project: what it compiles is no longer what it
/// compiled before, and there is no single source file that stands for that.
let targetsFor (files: string list) : AnalysisTarget list =
let sources: string list = List.filter (hasExtension [ ".fs"; ".fsi" ]) files
let projectFiles: string list = List.filter (hasExtension [ ".fsproj" ]) files
projectsToAnalyze
|> List.choose (fun (project: string) ->
let folder: string = project.Substring(0, project.LastIndexOf '/' + 1)
let owns (file: string) : bool =
file.StartsWith(folder, StringComparison.Ordinal)
if List.exists owns projectFiles then
Some { Project = project; Files = [] }
else
match List.filter owns sources with
| [] -> None
| owned ->
Some
{
Project = project
Files = List.map (fun (file: string) -> repositoryRoot </> file) owned
})
/// Where the analyzer project this repository owns is built to. It is deliberately outside the
/// solution and does not inherit the root `Directory.Build.props`, so this is an ordinary
/// `bin` folder rather than anything under `artifacts`.
///
/// `--analyzers-path` is handed this folder rather than `analyzers`, because the SDK searches
/// recursively for `*Analyzer*.dll` and would otherwise also find `Fantomas.Analyzers.Tests.dll`.
let localAnalyzerPath: string =
repositoryRoot
</> "analyzers"
</> "Fantomas.Analyzers"
</> "bin"
</> "Release"
</> "net8.0"
/// The analyzers are in the solution, so `Build` compiles and tests them along with everything
/// else. The `Analyze` pipelines do not depend on `Build` having run, so they build them again,
/// which is cheap and means editing a rule and rerunning the analysis is a single command.
let buildLocalAnalyzers: string =
"dotnet build analyzers/Fantomas.Analyzers -c Release --tl"
/// Where the analyzers live on disk. The two packages are ordinary package references, so MSBuild
/// already knows the restored path of each and there is no second place to keep the version in
/// sync. The third is ours, and is built by the pipeline that is about to use it.
let analyzerPaths () : Async<string list> =
async {
if not (File.Exists(localAnalyzerPath </> "Fantomas.Analyzers.dll")) then
failwith
$"The local analyzers are not built. Expected an assembly in {localAnalyzerPath}.\nRun `dotnet build analyzers/Fantomas.Analyzers -c Release` first."
let! result =
Cli
.Wrap("dotnet")
.WithArguments(
"msbuild src/Fantomas/Fantomas.fsproj -getProperty:PkgIonide_Analyzers "
+ "-getProperty:PkgG-Research_FSharp_Analyzers"
)
.WithWorkingDirectory(repositoryRoot)
.WithValidation(CommandResultValidation.None)
.ExecuteBufferedAsync()
.Task
|> Async.AwaitTask
if result.ExitCode <> 0 then
failwith $"Could not resolve the analyzer packages. Run `dotnet restore` first.\n{result.StandardError}"
let properties = JsonValue.Parse(result.StandardOutput).GetProperty("Properties")
return
[
for property in properties.Properties() do
let name, value = property
match value.AsString() with
| "" -> failwith $"MSBuild has no value for {name}. Run `dotnet restore` first."
| path -> path </> "analyzers" </> "dotnet" </> "fs"
localAnalyzerPath
]
}
/// The number of results a single analyzer report holds, used to report what a project turned up
/// the moment it finishes.
let sarifResultCount (report: string) : int =
if not (File.Exists report) then
0
else
JsonValue.Parse(File.ReadAllText report).GetProperty("runs").AsArray()
|> Array.sumBy (fun run ->
match run.TryGetProperty "results" with
| Some results -> results.AsArray().Length
| None -> 0)
/// Folds the per-project reports into the one SARIF run that GitHub code scanning takes.
///
/// SARIF carries a run per tool invocation, but code scanning rejects a file holding several unless
/// each names its own category, and one project of this solution is not an analysis of its own. The
/// runs all come from the same tool, so their results concatenate into a single run. Every
/// invocation is kept, which is what records that a project was looked at even when it turned up
/// nothing.
///
/// The reports carry no rule metadata, only a `ruleId` per result, so there is no rule table to
/// renumber against. Should a later version of the analyzers SDK start writing one, this has to
/// merge that too.
/// The same record with one property replaced, leaving every other property where it was.
let withProperty (name: string) (value: JsonValue) (record: JsonValue) : JsonValue =
JsonValue.Record
[|
for existing, current in record.Properties() ->
if existing = name then
existing, value
else
existing, current
|]
/// A run's `tool.driver.rules`, which is empty when it has none.
let rulesOf (run: JsonValue) : JsonValue array =
run.TryGetProperty "tool"
|> Option.bind (fun (tool: JsonValue) -> tool.TryGetProperty "driver")
|> Option.bind (fun (driver: JsonValue) -> driver.TryGetProperty "rules")
|> Option.map (fun (rules: JsonValue) -> rules.AsArray())
|> Option.defaultValue [||]
/// The same run carrying these rules instead.
let withRules (rules: JsonValue array) (run: JsonValue) : JsonValue =
match run.TryGetProperty "tool" with
| None -> run
| Some tool ->
match tool.TryGetProperty "driver" with
| None -> run
| Some driver ->
let driver: JsonValue = withProperty "rules" (JsonValue.Array rules) driver
withProperty "tool" (withProperty "driver" driver tool) run
let mergeSarifReports (reports: string list) (target: string) : unit =
let documents =
reports
|> List.filter File.Exists
|> List.map (fun report -> JsonValue.Parse(File.ReadAllText report))
let runs =
documents
|> List.collect (fun document -> document.GetProperty("runs").AsArray() |> List.ofArray)
match documents, runs with
| firstDocument :: _, firstRun :: _ ->
let concat (name: string) =
runs
|> List.collect (fun run ->
match run.TryGetProperty name with
| Some array -> List.ofArray (array.AsArray())
| None -> [])
|> Array.ofList
|> JsonValue.Array
// `ruleIndex` addresses `tool.driver.rules` by position within its own run, so merging the
// runs means pointing every result at where its own rule ended up. Keeping the first run's
// rules and every run's results, as this used to, left every run after the first pointing
// into an array it was never numbered against.
//
// Identical entries collapse. The analyzers write one entry per finding rather than one per
// rule, its `name` being that finding's message, so the same entry is written again for
// every finding that reads the same: two bindings called `filename` with no annotation
// produce the same id and the same message, in one project or in two. GitHub refuses to
// ingest a document whose rules array holds a duplicate, and it is the merged document that
// is uploaded.
let rules, results =
let merged: ResizeArray<JsonValue> = ResizeArray()
let seen: Collections.Generic.Dictionary<string, int> =
Collections.Generic.Dictionary()
let indexOf (rule: JsonValue) : int =
let key: string = rule.ToString()
match seen.TryGetValue key with
| true, index -> index
| false, _ ->
let index: int = merged.Count
merged.Add rule
seen[key] <- index
index
let results: JsonValue list =
runs
|> List.collect (fun (run: JsonValue) ->
// Every rule of the run is placed, whether a result points at it or not, so that
// this says the same as before about what the tool knows.
let placed: int array = Array.map indexOf (rulesOf run)
let repoint (result: JsonValue) : JsonValue =
match result.TryGetProperty "ruleIndex" with
| None -> result
| Some index ->
let original: int = index.AsInteger()
if original >= 0 && original < placed.Length then
withProperty "ruleIndex" (JsonValue.Number(decimal placed[original])) result
else
result
match run.TryGetProperty "results" with
| None -> []
| Some results -> results.AsArray() |> Array.map repoint |> List.ofArray)
List.ofSeq merged, results
let merged =
JsonValue.Record
[|
"$schema", firstDocument.GetProperty("$schema")
"version", firstDocument.GetProperty("version")
"runs",
JsonValue.Array
[|
JsonValue.Record
[|
"tool", (withRules (Array.ofList rules) firstRun).GetProperty("tool")
"columnKind", firstRun.GetProperty("columnKind")
"results", JsonValue.Array(Array.ofList results)
"invocations", concat "invocations"
|]
|]
|]
File.WriteAllText(target, merged.ToString())
| _ -> failwith "The analyzers wrote no report to merge."
/// Runs the analyzers over the given targets, one process per project, several at a time.
///
/// A single process walking every project in turn takes minutes and says nothing until the last one
/// is done, which is a long time to stare at a blank terminal. Each project is instead analyzed on
/// its own, and its output is held back and printed in one piece as that project finishes, so
/// findings arrive while the run is still going and no two projects can interleave their lines.
///
/// A target that names files is analyzed for those files alone. The project is still loaded and
/// type checked, but a whole project is checked file by file, so looking at one file of
/// `Fantomas.Core.Tests` takes seconds where the whole project takes minutes.
///
/// Whatever is analyzed here is what `analysis.sarif` holds afterwards, so a run over a couple of
/// files replaces the report of an earlier run over the solution.
///
/// The local rules that report at error severity, and so fail a run when they fire.
///
/// `AnalyzeChanged` demotes these, because the run you do while working should report everything
/// and stop for nothing. `Analyze` leaves them alone, so CI is where they bite.
let localErrorRules: string list =
[ "FANTOMAS-PIPEBACK-001"; "FANTOMAS-PRIVATE-001" ]
/// The local analyzers that are kept out of the full run.
///
/// They report on debt that predates them, and a finding in `Analyze` becomes a code scanning alert
/// on the pull request whatever its severity. `AnalyzeChanged` still runs them, over the files you
/// touched, which is the scope both rules ask for. Drop one of these once its debt is gone.
///
/// `FANTOMAS-KEEPINDENT-001` and `FANTOMAS-OPENS-001` are deliberately not here. Both arrived with
/// debt of their own, and both times that debt was cleared in the change that added the rule, so
/// the full run has nothing old to report and anything it does report is something the change in
/// front of you introduced.
let localAdvisoryAnalyzers: string list =
[ "AnnotationAnalyzer"; "UnnecessaryParensAnalyzer" ]
/// The codes of those same rules, which is what a finding carries.
let localAdvisoryCodes: Set<string> =
set [ "FANTOMAS-ANNOTATE-001"; "FANTOMAS-PARENS-001" ]
/// Decides whether a finding is worth showing, from its rule, its file and its line. `Analyze`
/// shows all of them; only `AnalyzeChanged` narrows.
type FindingFilter = string -> string -> int -> bool
let everyFinding: FindingFilter = fun _ _ _ -> true
/// Whether a finding is one this run set out to report.
///
/// Two questions, in order. **Is the file one the working tree changed?** If not the finding is
/// dropped whatever its rule, because `AnalyzeChanged` reports on the code in front of you and this
/// is not it. That test only started mattering once a changed `.fsproj` began asking for the whole
/// project: analysing every file of `Fantomas.Tests` to report on the two you added buries them
/// under the project's existing debt, and a run whose findings you have to hand-filter is a run that
/// tells you nothing.
///
/// **And, for the advisory rules, is it on a line that changed?** A file is a much coarser scope
/// than they ask for: one line changed in a file of several thousand otherwise surfaces every
/// unannotated binding and every stray pair of parentheses in it, and both rules are guidance for
/// the code you are writing rather than a reason to sweep the file. Every other rule reports
/// anywhere in a file you edited, which is the scope those rules do ask for.
///
/// A file git has never seen is new in its entirety, so everything in it is worth reporting.
let keepFinding (scopes: Map<string, ChangedLines>) : FindingFilter =
fun (code: string) (path: string) (line: int) ->
match scopeFor scopes path with
| None -> false
| Some WholeFile -> true
| Some(Lines lines) -> not (localAdvisoryCodes.Contains code) || Set.contains line lines
/// Drops the advisory findings that sit on lines the working tree did not touch.
///
/// `AnalyzeChanged` scopes itself to the files you edited, which for the two advisory rules is much
/// coarser than they ask for: one line changed in a file of several thousand surfaces every
/// unannotated binding and every stray pair of parentheses in it, where both rules are about the
/// code you are writing. The other rules are left alone, because a finding from one of those is
/// worth seeing wherever it is.
///
/// Reads the tool's own output format. Anything it cannot parse is kept, so a change upstream makes
/// this stop narrowing rather than start hiding.
let narrowOutput (keep: FindingFilter) (output: string) : string =
let finding: Text.RegularExpressions.Regex =
Text.RegularExpressions.Regex(@"^(?<path>.+?)\((?<line>\d+),\d+\): \w+ (?<code>[A-Z][A-Z0-9-]*) :")
output.Split('\n')
|> Array.filter (fun (line: string) ->
let m: Text.RegularExpressions.Match =
finding.Match(line.TrimStart('\u001b').TrimStart())
if not m.Success then
true
else
keep m.Groups["code"].Value m.Groups["path"].Value (int m.Groups["line"].Value))
|> String.concat "\n"
/// The same narrowing, over the report a project just wrote, so that `analysis.sarif` and what was
/// printed say the same thing.
let narrowReport (keep: FindingFilter) (report: string) : unit =
if File.Exists report then
let document: JsonValue = JsonValue.Parse(File.ReadAllText report)
let keepResult (result: JsonValue) : bool =
match result.TryGetProperty "ruleId" with
| None -> true
| Some ruleId ->
let location: JsonValue =
result.GetProperty("locations").AsArray().[0].GetProperty("physicalLocation")
let path: string =
location.GetProperty("artifactLocation").GetProperty("uri").AsString()
let line: int = location.GetProperty("region").GetProperty("startLine").AsInteger()
keep (ruleId.AsString()) path line
// The tool writes one `tool.driver.rules` entry per finding, whose `name` is that finding's
// own message rather than the rule's. Filtering `results` and leaving the rules alone
// therefore leaves every dropped finding's message behind, and a report whose `results` is
// empty while `rules` still spells out seventy findings reads as a contradiction, and is
// one. So the rules no surviving result points at go too, and what is left is renumbered,
// because `ruleIndex` addresses that array by position.
let narrowRun (run: JsonValue) : JsonValue =
match run.TryGetProperty "results" with
| None -> run
| Some results ->
let kept: JsonValue array = Array.filter keepResult (results.AsArray())
let rules: JsonValue array = rulesOf run
let referenced: int array =
kept
|> Array.choose (fun (result: JsonValue) ->
result.TryGetProperty "ruleIndex"
|> Option.map (fun (index: JsonValue) -> index.AsInteger()))
|> Array.filter (fun (index: int) -> index >= 0 && index < rules.Length)
|> Array.distinct
|> Array.sort
let renumbered: Map<int, int> =
referenced
|> Array.mapi (fun (position: int) (original: int) -> original, position)
|> Map.ofArray
let repointed: JsonValue array =
kept
|> Array.map (fun (result: JsonValue) ->
match result.TryGetProperty "ruleIndex" with
| None -> result
| Some index ->
match Map.tryFind (index.AsInteger()) renumbered with
| None -> result
| Some position -> withProperty "ruleIndex" (JsonValue.Number(decimal position)) result)
run
|> withProperty "results" (JsonValue.Array repointed)
|> withRules (Array.map (fun (index: int) -> rules[index]) referenced)
let runs: JsonValue array =
document.GetProperty("runs").AsArray() |> Array.map narrowRun
let narrowed: JsonValue =
JsonValue.Record
[|
for name, value in document.Properties() ->
if name = "runs" then
name, JsonValue.Array runs
else
name, value
|]
File.WriteAllText(report, narrowed.ToString())
/// Returns the highest exit code of the runs, so a project the analyzers could not process fails
/// the stage rather than passing for want of findings.
///
/// `extraArguments` is passed to every invocation, and is how the two pipelines differ.
let analyzeTargets (extraArguments: string list) (keep: FindingFilter) (targets: AnalysisTarget list) : Async<int> =
async {
let! analyzers = analyzerPaths ()
if Directory.Exists analysisReportsDir then
Directory.Delete(analysisReportsDir, true)
Directory.CreateDirectory analysisReportsDir |> ignore
let names =
targets
|> List.map (fun (target: AnalysisTarget) -> Path.GetFileNameWithoutExtension target.Project)
|> String.concat ", "
let count: string =
match targets.Length with
| 1 -> "1 project"
| n -> $"{n} projects"
printfn $"Analyzing {count}: {names}"
let analyzeProject (target: AnalysisTarget) =
async {
let name = Path.GetFileNameWithoutExtension target.Project
let report = analysisReportsDir </> $"{name}.sarif"
let started = DateTime.UtcNow
let arguments =
[
"fsharp-analyzers"
// Neither of these is source anybody wrote. The test SDK generates its
// entry point into the compilation from the package cache, and MSBuild
// generates an `AssemblyInfo` per project under `obj`. Both are part of
// what gets type checked, and a finding in either is not a finding about
// this repository. `AssemblyInfo` earns its place here because it opens
// `System` and `System.Reflection` and then writes every attribute out
// fully qualified, so `FANTOMAS-OPENS-001` has two true things to say
// about each of them and nowhere to say them.
"--exclude-files"
"**/Microsoft.NET.Test.Sdk.Program.fs"
"**/*.AssemblyInfo.fs"
for analyzer in analyzers do
"--analyzers-path"
analyzer
// One flag, then every file. Repeating the flag is an error, and the tool
// answers it by printing its help and finding nothing, which reads as a
// clean project.
match target.Files with
| [] -> ()
| files ->
"--include-files"
yield! files
"--code-root"
repositoryRoot
"--report"
report
yield! extraArguments
"--project"
repositoryRoot </> target.Project
]
let! result =
Cli
.Wrap("dotnet")
.WithArguments(arguments)
.WithWorkingDirectory(repositoryRoot)
.WithValidation(CommandResultValidation.None)
.ExecuteBufferedAsync()
.Task
|> Async.AwaitTask
narrowReport keep report
let elapsed = DateTime.UtcNow - started
let findings = sarifResultCount report
// A non-zero exit is worth saying out loud. The tool exits non-zero both for a
// finding at error severity and for a run that never happened, and a bare
// "no findings" would read the same either way.
let summary =
match result.ExitCode, findings with
| 0, 0 -> "no findings"
| 0, 1 -> "1 finding"
| 0, n -> $"{n} findings"
| code, 0 -> $"no findings, exit code {code}"
| code, n -> $"{n} findings, exit code {code}"
let scope =
match target.Files with
| [] -> ""
| [ _ ] -> " (1 file)"
| files -> $" ({files.Length} files)"
printfn $"\n=== {name}{scope}: {summary} in {elapsed.TotalSeconds:F1}s"
printf "%s" (narrowOutput keep result.StandardOutput)
eprintf "%s" result.StandardError
return report, result.ExitCode
}
// Every analyzer process type checks a whole project, so a handful at a time is what keeps
// the machine busy without the runs starving each other of memory.
let! results =
Async.Parallel(List.map analyzeProject targets, max 2 (Environment.ProcessorCount / 2))
mergeSarifReports (results |> Array.map fst |> List.ofArray) (mergedAnalysisReport)
return results |> Array.map snd |> Array.fold max 0
}
/// Each of these takes a list of values after a single flag. Repeating the flag is an error.
let excludeLocalAdvisory: string list =
"--exclude-analyzers" :: localAdvisoryAnalyzers
#r "nuget: FSharp.Data, 6.3.0"
#load "BuildCommon2.fsx"
open System
open System.IO
open System.Xml.Linq
open System.Xml.XPath
open FSharp.Data
open Partas.Build
open BuildCommon2
// Running the analyzers, and deciding which of their findings a run set out to report.
/// The projects the analyzers run over: every project in the solution minus the ones whose source
/// is not ours to change. Largest first, so the longest run is never the one left waiting for a slot.
let projectsToAnalyze: string list =
let excluded = set [ "Fantomas.FCS" ]
let sourceSize (project: string) =
Directory.EnumerateFiles(Path.GetDirectoryName(repositoryRoot </> project), "*.fs", SearchOption.AllDirectories)
|> Seq.sumBy (fun file -> FileInfo(file).Length)
XDocument.Load(repositoryRoot </> "fantomas.slnx").XPathSelectElements("//Project")
|> Seq.map (fun project -> project.Attribute(XName.Get "Path").Value.Replace('\\', '/'))
|> Seq.filter (fun path -> not (excluded.Contains(Path.GetFileNameWithoutExtension path)))
|> Seq.sortByDescending sourceSize
|> Seq.toList
/// One project to hand to the analyzers, and which of its files to look at. `Files` holds absolute
/// paths, the only form `--include-files` matches; an empty list asks for every file of the project.
type AnalysisTarget = { Project: string; Files: string list }
/// What to analyze for a set of changed files: every project that owns one, along with the files of
/// its own that changed. A changed project file asks for the whole project.
let targetsFor (files: string list) : AnalysisTarget list =
let sources: string list = List.filter (hasExtension [ ".fs"; ".fsi" ]) files
let projectFiles: string list = List.filter (hasExtension [ ".fsproj" ]) files
projectsToAnalyze
|> List.choose (fun (project: string) ->
let folder: string = project.Substring(0, project.LastIndexOf '/' + 1)
let owns (file: string) : bool =
file.StartsWith(folder, StringComparison.Ordinal)
if List.exists owns projectFiles then
Some { Project = project; Files = [] }
else
match List.filter owns sources with
| [] -> None
| owned ->
Some
{
Project = project
Files = List.map (fun (file: string) -> repositoryRoot </> file) owned
})
/// Where the analyzer project this repository owns is built to. Handed to `--analyzers-path` as a
/// folder rather than `analyzers`, so the SDK's recursive search does not also find the test assembly.
let localAnalyzerPath: string =
repositoryRoot
</> "analyzers"
</> "Fantomas.Analyzers"
</> "bin"
</> "Release"
</> "net8.0"
let buildLocalAnalyzers: string =
"dotnet build analyzers/Fantomas.Analyzers -c Release --tl"
/// Where the analyzers live on disk: the two package references at their restored paths, and ours.
let analyzerPaths () : Async<string list> =
async {
if not (File.Exists(localAnalyzerPath </> "Fantomas.Analyzers.dll")) then
failwith
$"The local analyzers are not built. Expected an assembly in {localAnalyzerPath}.\nRun `dotnet build analyzers/Fantomas.Analyzers -c Release` first."
let! exitCode, stdout, stderr =
Proc.buffered (
cmd
$"dotnet msbuild src/Fantomas/Fantomas.fsproj -getProperty:PkgIonide_Analyzers -getProperty:PkgG-Research_FSharp_Analyzers"
)
if exitCode <> 0 then
failwith $"Could not resolve the analyzer packages. Run `dotnet restore` first.\n{stderr}"
let properties = JsonValue.Parse(stdout).GetProperty("Properties")
return
[
for name, value in properties.Properties() do
match value.AsString() with
| "" -> failwith $"MSBuild has no value for {name}. Run `dotnet restore` first."
| path -> path </> "analyzers" </> "dotnet" </> "fs"
localAnalyzerPath
]
}
/// The number of results a single analyzer report holds.
let sarifResultCount (report: string) : int =
if not (File.Exists report) then
0
else
JsonValue.Parse(File.ReadAllText report).GetProperty("runs").AsArray()
|> Array.sumBy (fun run ->
match run.TryGetProperty "results" with
| Some results -> results.AsArray().Length
| None -> 0)
/// The same record with one property replaced.
let withProperty (name: string) (value: JsonValue) (record: JsonValue) : JsonValue =
JsonValue.Record
[|
for existing, current in record.Properties() ->
if existing = name then
existing, value
else
existing, current
|]
/// A run's `tool.driver.rules`, which is empty when it has none.
let rulesOf (run: JsonValue) : JsonValue array =
run.TryGetProperty "tool"
|> Option.bind (fun (tool: JsonValue) -> tool.TryGetProperty "driver")
|> Option.bind (fun (driver: JsonValue) -> driver.TryGetProperty "rules")
|> Option.map (fun (rules: JsonValue) -> rules.AsArray())
|> Option.defaultValue [||]
/// The same run carrying these rules instead.
let withRules (rules: JsonValue array) (run: JsonValue) : JsonValue =
match run.TryGetProperty "tool" with
| None -> run
| Some tool ->
match tool.TryGetProperty "driver" with
| None -> run
| Some driver ->
let driver: JsonValue = withProperty "rules" (JsonValue.Array rules) driver
withProperty "tool" (withProperty "driver" driver tool) run
/// Folds the per-project reports into the one SARIF run GitHub code scanning takes. Every result is
/// repointed at where its rule ended up in the merged rules array, and identical rules collapse.
let mergeSarifReports (reports: string list) (target: string) : unit =
let documents =
reports
|> List.filter File.Exists
|> List.map (fun report -> JsonValue.Parse(File.ReadAllText report))
let runs =
documents
|> List.collect (fun document -> document.GetProperty("runs").AsArray() |> List.ofArray)
match documents, runs with
| firstDocument :: _, firstRun :: _ ->
let concat (name: string) =
runs
|> List.collect (fun run ->
match run.TryGetProperty name with
| Some array -> List.ofArray (array.AsArray())
| None -> [])
|> Array.ofList
|> JsonValue.Array
let rules, results =
let merged: ResizeArray<JsonValue> = ResizeArray()
let seen: Collections.Generic.Dictionary<string, int> =
Collections.Generic.Dictionary()
let indexOf (rule: JsonValue) : int =
let key: string = rule.ToString()
match seen.TryGetValue key with
| true, index -> index
| false, _ ->
let index: int = merged.Count
merged.Add rule
seen[key] <- index
index
let results: JsonValue list =
runs
|> List.collect (fun (run: JsonValue) ->
let placed: int array = Array.map indexOf (rulesOf run)
let repoint (result: JsonValue) : JsonValue =
match result.TryGetProperty "ruleIndex" with
| None -> result
| Some index ->
let original: int = index.AsInteger()
if original >= 0 && original < placed.Length then
withProperty "ruleIndex" (JsonValue.Number(decimal placed[original])) result
else
result
match run.TryGetProperty "results" with
| None -> []
| Some results -> results.AsArray() |> Array.map repoint |> List.ofArray)
List.ofSeq merged, results
let merged =
JsonValue.Record
[|
"$schema", firstDocument.GetProperty("$schema")
"version", firstDocument.GetProperty("version")
"runs",
JsonValue.Array
[|
JsonValue.Record
[|
"tool", (withRules (Array.ofList rules) firstRun).GetProperty("tool")
"columnKind", firstRun.GetProperty("columnKind")
"results", JsonValue.Array(Array.ofList results)
"invocations", concat "invocations"
|]
|]
|]
File.WriteAllText(target, merged.ToString())
| _ -> failwith "The analyzers wrote no report to merge."
/// The local rules that report at error severity, and so fail a run when they fire.
let localErrorRules: string list =
[ "FANTOMAS-PIPEBACK-001"; "FANTOMAS-PRIVATE-001" ]
/// The local analyzers kept out of the full run: they report on debt that predates them.
let localAdvisoryAnalyzers: string list =
[ "AnnotationAnalyzer"; "UnnecessaryParensAnalyzer" ]
/// The codes of those same rules, which is what a finding carries.
let localAdvisoryCodes: Set<string> =
set [ "FANTOMAS-ANNOTATE-001"; "FANTOMAS-PARENS-001" ]
/// Decides whether a finding is worth showing, from its rule, its file and its line.
type FindingFilter = string -> string -> int -> bool
let everyFinding: FindingFilter = fun _ _ _ -> true
/// Keeps a finding in a file the working tree changed. The advisory rules are narrowed further to
/// the lines that changed; a file git has never seen is new in its entirety.
let keepFinding (scopes: Map<string, ChangedLines>) : FindingFilter =
fun (code: string) (path: string) (line: int) ->
match scopeFor scopes path with
| None -> false
| Some WholeFile -> true
| Some(Lines lines) -> not (localAdvisoryCodes.Contains code) || Set.contains line lines
/// Drops the findings `keep` rejects from the tool's console output. Anything that does not parse
/// as a finding is kept.
let narrowOutput (keep: FindingFilter) (output: string) : string =
let finding =
Text.RegularExpressions.Regex(@"^(?<path>.+?)\((?<line>\d+),\d+\): \w+ (?<code>[A-Z][A-Z0-9-]*) :")
output.Split('\n')
|> Array.filter (fun (line: string) ->
let m = finding.Match(line.TrimStart('').TrimStart())
if not m.Success then
true
else
keep m.Groups["code"].Value m.Groups["path"].Value (int m.Groups["line"].Value))
|> String.concat "\n"
/// The same narrowing over the report a project just wrote, rules renumbered to match.
let narrowReport (keep: FindingFilter) (report: string) : unit =
if File.Exists report then
let document: JsonValue = JsonValue.Parse(File.ReadAllText report)
let keepResult (result: JsonValue) : bool =
match result.TryGetProperty "ruleId" with
| None -> true
| Some ruleId ->
let location: JsonValue =
result.GetProperty("locations").AsArray().[0].GetProperty("physicalLocation")
let path: string =
location.GetProperty("artifactLocation").GetProperty("uri").AsString()
let line: int = location.GetProperty("region").GetProperty("startLine").AsInteger()
keep (ruleId.AsString()) path line
let narrowRun (run: JsonValue) : JsonValue =
match run.TryGetProperty "results" with
| None -> run
| Some results ->
let kept: JsonValue array = Array.filter keepResult (results.AsArray())
let rules: JsonValue array = rulesOf run
let referenced: int array =
kept
|> Array.choose (fun (result: JsonValue) ->
result.TryGetProperty "ruleIndex"
|> Option.map (fun (index: JsonValue) -> index.AsInteger()))
|> Array.filter (fun (index: int) -> index >= 0 && index < rules.Length)
|> Array.distinct
|> Array.sort
let renumbered: Map<int, int> =
referenced
|> Array.mapi (fun (position: int) (original: int) -> original, position)
|> Map.ofArray
let repointed: JsonValue array =
kept
|> Array.map (fun (result: JsonValue) ->
match result.TryGetProperty "ruleIndex" with
| None -> result
| Some index ->
match Map.tryFind (index.AsInteger()) renumbered with
| None -> result
| Some position -> withProperty "ruleIndex" (JsonValue.Number(decimal position)) result)
run
|> withProperty "results" (JsonValue.Array repointed)
|> withRules (Array.map (fun (index: int) -> rules[index]) referenced)
let runs: JsonValue array =
document.GetProperty("runs").AsArray() |> Array.map narrowRun
let narrowed: JsonValue =
JsonValue.Record
[|
for name, value in document.Properties() ->
if name = "runs" then
name, JsonValue.Array runs
else
name, value
|]
File.WriteAllText(report, narrowed.ToString())
/// Runs the analyzers over the targets, one process per project, several at a time. Each project's
/// output is held back and printed whole as it finishes. Returns the highest exit code.
let analyzeTargets (extraArguments: string list) (keep: FindingFilter) (targets: AnalysisTarget list) : Async<int> =
async {
let! analyzers = analyzerPaths ()
if Directory.Exists analysisReportsDir then
Directory.Delete(analysisReportsDir, true)
Directory.CreateDirectory analysisReportsDir |> ignore
let names =
targets
|> List.map (fun (target: AnalysisTarget) -> Path.GetFileNameWithoutExtension target.Project)
|> String.concat ", "
let count: string =
match targets.Length with
| 1 -> "1 project"
| n -> $"{n} projects"
printfn $"Analyzing {count}: {names}"
let analyzeProject (target: AnalysisTarget) =
async {
let name = Path.GetFileNameWithoutExtension target.Project
let report = analysisReportsDir </> $"{name}.sarif"
let started = DateTime.UtcNow
// Generated sources are excluded: the test SDK's entry point and MSBuild's per-project
// `AssemblyInfo` are type checked with the rest, and a finding in either is not ours.
let arguments =
[
"fsharp-analyzers"
"--exclude-files"
"**/Microsoft.NET.Test.Sdk.Program.fs"
"**/*.AssemblyInfo.fs"
for analyzer in analyzers do
"--analyzers-path"
analyzer
// One flag, then every file: repeating the flag makes the tool print its help.
match target.Files with
| [] -> ()
| files ->
"--include-files"
yield! files
"--code-root"
repositoryRoot
"--report"
report
yield! extraArguments
"--project"
repositoryRoot </> target.Project
]
let! exitCode, stdout, stderr = Proc.buffered (Cmd.ofList "dotnet" arguments)
narrowReport keep report
let elapsed = DateTime.UtcNow - started
let findings = sarifResultCount report
let summary =
match exitCode, findings with
| 0, 0 -> "no findings"
| 0, 1 -> "1 finding"
| 0, n -> $"{n} findings"
| code, 0 -> $"no findings, exit code {code}"
| code, n -> $"{n} findings, exit code {code}"
let scope =
match target.Files with
| [] -> ""
| [ _ ] -> " (1 file)"
| files -> $" ({files.Length} files)"
printfn $"\n=== {name}{scope}: {summary} in {elapsed.TotalSeconds:F1}s"
printf "%s" (narrowOutput keep stdout)
eprintf "%s" stderr
return report, exitCode
}
let! results =
Async.Parallel(List.map analyzeProject targets, max 2 (Environment.ProcessorCount / 2))
mergeSarifReports (results |> Array.map fst |> List.ofArray) mergedAnalysisReport
return results |> Array.map snd |> Array.fold max 0
}
/// Each of these takes a list of values after a single flag. Repeating the flag is an error.
let excludeLocalAdvisory: string list =
"--exclude-analyzers" :: localAdvisoryAnalyzers
let commands =
[
command "analyze" {
description "Run the analyzers over every project and merge the reports into analysis.sarif"
workingDir repositoryRoot
Blocks.restoreTools
Blocks.restoreSolution
stage "build analyzers" { run buildLocalAnalyzers }
stage "analyze" {
run (fun _ ->
projectsToAnalyze
|> List.map (fun (project: string) -> { Project = project; Files = [] })
|> analyzeTargets excludeLocalAdvisory everyFinding)
}
}
command "analyze-changed" {
description
"Run the analyzers over the files the working tree changed; reports everything, fails on nothing"
workingDir repositoryRoot
Blocks.restoreTools
Blocks.restoreSolution
stage "build analyzers" { run buildLocalAnalyzers }
stage "analyze" {
run (fun _ ->
async {
let! files = changedFiles ()
let demoteLocalErrors: string list = "--treat-as-warning" :: localErrorRules
match targetsFor files with
| [] ->
printfn "No changed file belongs to a project that is analyzed."
return 0
| targets ->
let! scopes = changedLines ()
return! analyzeTargets demoteLocalErrors (keepFinding scopes) targets
})
}
}
]
runIfMain "BuildAnalyzers2.fsx" (fun () ->
rootCommandOfScript {
name "BuildAnalyzers2.fsx"
commands
})
#r "nuget: CliWrap, 3.6.4"
#r "nuget: FSharp.Data, 6.3.0"
#r "nuget: Ionide.KeepAChangelog, 0.1.8"
#r "nuget: Humanizer.Core, 2.14.1"
open System
open System.IO
open CliWrap
open CliWrap.Buffered
open FSharp.Data
open Ionide.KeepAChangelog
open Ionide.KeepAChangelog.Domain
open SemVersion
open Humanizer
// Loaded by `build.fsx`, after `BuildCommon.fsx`. An error here saying BuildCommon is not defined
// means this file was run on its own; it is a library, so run a pipeline from build.fsx instead.
open BuildCommon
// Working out what a release is: which version is being cut, what changed since the last one, and
// the notes that go with it. Reading only, apart from `pushPackage`; the pipelines decide what to do
// with any of it.
/// Whether this run was asked not to publish anything.
let isDryRun: bool =
let args = fsi.CommandLineArgs
Array.exists (fun arg -> arg = "--dry-run") args
/// Push a package to NuGet, unless this run was told not to publish.
let pushPackage nupkg =
async {
if isDryRun then
printfn $"[DRY-RUN] Would push package: {nupkg}"
return 0
else
let key = Environment.GetEnvironmentVariable("NUGET_KEY")
let! result =
Cli
.Wrap("dotnet")
.WithArguments(
$"nuget push \"{nupkg}\" --api-key \"{key}\" --source https://api.nuget.org/v3/index.json"
)
.ExecuteAsync()
.Task
|> Async.AwaitTask
return result.ExitCode
}
type GithubRelease =
{
Version: string
Title: string
Date: DateTime
/// None when GitHub has no release for this version: it is not created yet, or the
/// version went to NuGet by hand the way 7.0.6 did.
PublishedDate: string option
Draft: string
}
let formatVersion (v: SemanticVersion) : string =
if String.IsNullOrEmpty v.Prerelease then
$"{v.Major}.{v.Minor}.{v.Patch}"
else
$"{v.Major}.{v.Minor}.{v.Patch}-{v.Prerelease}"
/// Releases are ordered on their version and not on their date. A hotfix for an older major is
/// released from its own branch, so it can enter the changelog with a date that is newer than
/// the entry main is about to release: 7.0.6 is dated after 8.0.0-alpha-013.
/// SemanticVersion itself does not support the comparison constraint, hence the tuple.
let versionSortKey (v: SemanticVersion) : int * int * int * int * string =
let prerelease = if isNull v.Prerelease then String.Empty else v.Prerelease
v.Major.GetValueOrDefault(),
v.Minor.GetValueOrDefault(),
v.Patch.GetValueOrDefault(),
// a stable release comes after the prereleases that led up to it
(if prerelease = String.Empty then 1 else 0),
prerelease
/// The date the GitHub release for this version was published.
/// None when GitHub has no release for it, which is what happens for a version that was pushed
/// to NuGet by hand, like 7.0.6.
let getPublishedDate (version: string) : string option =
let prefixedVersion = $"v{version}"
printfn $"Checking if release {prefixedVersion} already exists on GitHub..."
let cmdResult =
Cli
.Wrap("gh")
.WithArguments($"release view {prefixedVersion} --json publishedAt -t \"{{{{.publishedAt}}}}\"")
.WithValidation(CommandResultValidation.None)
.ExecuteBufferedAsync()
.Task.Result
if cmdResult.ExitCode <> 0 then
printfn $"Release {prefixedVersion} does not exist yet"
None
else
let output = cmdResult.StandardOutput.Trim()
let lastIdx = output.LastIndexOf("Z", StringComparison.Ordinal)
let dateStr = output.Substring(0, lastIdx)
printfn $"Release {prefixedVersion} already exists, published at: {dateStr}"
Some dateStr
let mkGithubRelease (v: SemanticVersion, d: DateTime, cd: ChangelogData option) : GithubRelease =
match cd with
| None -> failwith "Each Fantomas release is expected to have at least one section."
| Some cd ->
let version = formatVersion v
printfn $"Parsing release version: {version} (prerelease: {not (String.IsNullOrEmpty v.Prerelease)})"
let title =
let month = d.ToString("MMMM")
let day = d.Day.Ordinalize()
$"{month} {day} Release"
let publishDate = getPublishedDate version
let sections =
[
"Added", cd.Added
"Changed", cd.Changed
"Fixed", cd.Fixed
"Deprecated", cd.Deprecated
"Removed", cd.Removed
"Security", cd.Security
yield! (Map.toList cd.Custom)
]
|> List.choose (fun (header, lines) ->
if lines.IsEmpty then
None
else
lines
|> List.map (fun line -> line.TrimStart())
|> String.concat "\n"
|> sprintf "### %s\n%s" header
|> Some)
|> String.concat "\n\n"
let draft =
$"""# {version}
{sections}"""
{
Version = version
Title = title
Date = d
PublishedDate = publishDate
Draft = draft
}
let getReleaseNotes (currentRelease: GithubRelease) (lastPublishedDate: string option) : string =
let date =
match lastPublishedDate with
| Some d ->
printfn $"Using last release published date for author attribution: {d}"
d
| None ->
// Query GitHub for the most recent published release
printfn "No earlier changelog entry is on GitHub, querying GitHub for most recent release..."
let ghReleaseResult =
Cli
.Wrap("gh")
.WithArguments("release list --limit 1 --json createdAt")
.WithValidation(CommandResultValidation.None)
.ExecuteBufferedAsync()
.Task.Result
if
ghReleaseResult.ExitCode = 0
&& not (String.IsNullOrWhiteSpace(ghReleaseResult.StandardOutput.Trim()))
then
let jsonOutput = ghReleaseResult.StandardOutput.Trim()
let jsonValue = FSharp.Data.JsonValue.Parse(jsonOutput)
let releases = jsonValue.AsArray()
if releases.Length > 0 then
match releases.[0].TryGetProperty("createdAt") with
| Some createdAtJson ->
let createdAt = createdAtJson.AsString()
// Parse ISO 8601 date and convert back to string format for the query
let dateTime =
DateTime
.Parse(createdAt, null, System.Globalization.DateTimeStyles.RoundtripKind)
.ToUniversalTime()
let ghDate = dateTime.ToString("yyyy-MM-ddTHH:mm:ss")
printfn $"Using most recent GitHub release date for author attribution: {ghDate}"
ghDate
| None ->
let fallbackDate = DateTime.UtcNow.ToString("yyyy-MM-dd")
printfn $"GitHub release missing createdAt, using current date: {fallbackDate}"
fallbackDate
else
let fallbackDate = DateTime.UtcNow.ToString("yyyy-MM-dd")
printfn $"No GitHub releases found, using current date: {fallbackDate}"
fallbackDate
else
let fallbackDate = DateTime.UtcNow.ToString("yyyy-MM-dd")
printfn $"Could not query GitHub releases, using current date: {fallbackDate}"
fallbackDate
printfn $"Querying PRs closed after {date} for author attribution..."
let authorMsg =
let queryResult =
Cli
.Wrap("gh")
.WithArguments($"pr list -S \"state:closed base:main closed:>{date}\" --json commits,mergedAt")
.WithValidation(CommandResultValidation.None)
.ExecuteBufferedAsync()
.Task.Result
if queryResult.ExitCode <> 0 then
printfn $"Warning: Failed to query PRs for author attribution (exit code: {queryResult.ExitCode})"
String.Empty
else
let jsonOutput = queryResult.StandardOutput.Trim()
// Parse JSON to filter by mergedAt timestamp
let jsonValue = FSharp.Data.JsonValue.Parse(jsonOutput)
let prs = jsonValue.AsArray()
// Parse the date as ISO 8601 format (GitHub always returns dates in this format: "2025-08-02T10:25:30Z")
let cutoffTimestamp =
DateTime.Parse(date, null, System.Globalization.DateTimeStyles.RoundtripKind).ToUniversalTime()
printfn $"Filtering PRs merged after: {cutoffTimestamp:O}"
let authors =
prs
|> Array.collect (fun (pr: FSharp.Data.JsonValue) ->
let mergedAtOpt =
match pr.TryGetProperty("mergedAt") with
| Some mergedAtJson ->
let mergedAtStr = mergedAtJson.AsString()
match
DateTime.TryParse(mergedAtStr, null, System.Globalization.DateTimeStyles.RoundtripKind)
with
| true, dt -> Some(dt.ToUniversalTime())
| false, _ -> None
| None -> None
match mergedAtOpt with
| Some mergedAt when mergedAt > cutoffTimestamp ->
match pr.TryGetProperty("commits") with
| Some commitsJson ->
let commits = commitsJson.AsArray()
commits
|> Array.collect (fun (commit: FSharp.Data.JsonValue) ->
match commit.TryGetProperty("authors") with
| Some authorsJson ->
let commitAuthors = authorsJson.AsArray()
commitAuthors
|> Array.choose (fun (author: FSharp.Data.JsonValue) ->
match author.TryGetProperty("login") with
| Some loginJson ->
let login = loginJson.AsString()
// Filter out bots
if login.EndsWith("[bot]", StringComparison.Ordinal) then
None
else
Some(login)
| None -> None)
| None -> [||])
| None -> [||]
| _ -> [||])
|> Array.distinct
|> Array.sort
printfn $"Found {authors.Length} contributors for this release"
if authors.Length = 0 then
String.Empty
elif authors.Length = 1 then
$"Special thanks to @%s{authors.[0]}!"
else
let lastAuthor = Array.last authors
let otherAuthors =
if authors.Length = 2 then
$"@{authors.[0]}"
else
authors
|> Array.take (authors.Length - 1)
|> Array.map (sprintf "@%s")
|> String.concat ", "
$"Special thanks to %s{otherAuthors} and @%s{lastAuthor}!"
$"""{currentRelease.Draft}
{authorMsg}
[https://www.nuget.org/packages/fantomas/{currentRelease.Version}](https://www.nuget.org/packages/fantomas/{currentRelease.Version})
"""
let getCurrentReleaseAndLastPublishedDate () : GithubRelease * string option =
printfn "Parsing CHANGELOG.md to find current and last release..."
let changelog = FileInfo(repositoryRoot </> "CHANGELOG.md")
let changeLogResult =
match Parser.parseChangeLog changelog with
| Error error -> failwithf "Failed to parse changelog: %A" error
| Ok result ->
printfn $"Found {result.Releases.Length} releases in changelog"
result
let releases =
changeLogResult.Releases
|> List.sortByDescending (fun (v, _, _) -> versionSortKey v)
match releases with
| [] -> failwith "Could not find any release in CHANGELOG.md"
| current :: earlierReleases ->
let currentRelease = mkGithubRelease current
printfn $"Current release: {currentRelease.Version}"
// The release below the current one does not have to exist on GitHub: 7.0.6 went to
// NuGet by hand from the v7.0.6 branch and never got a GitHub release. Walk down the
// recent entries until GitHub knows one, its publish date is what the contributor
// query is based on. Anything older than that is out of date anyway, getReleaseNotes
// then falls back to the most recent release GitHub reports.
let lastPublishedRelease =
earlierReleases
|> List.truncate 5
|> List.tryPick (fun (v, _, _) ->
let version = formatVersion v
getPublishedDate version |> Option.map (fun date -> version, date))
match lastPublishedRelease with
| Some(version, date) -> printfn $"Last release on GitHub: {version}, published at {date}"
| None -> printfn "None of the recent changelog entries has a GitHub release"
currentRelease, Option.map snd lastPublishedRelease
#r "nuget: FSharp.Data, 6.3.0"
#r "nuget: Ionide.KeepAChangelog, 0.1.8"
#r "nuget: Humanizer.Core, 2.14.1"
#load "BuildCommon2.fsx"
open System
open System.IO
open FSharp.Data
open Ionide.KeepAChangelog
open Ionide.KeepAChangelog.Domain
open SemVersion
open Humanizer
open Partas.Build
open BuildCommon2
// Working out what a release is: which version is being cut, what changed since the last one, and
// the notes that go with it. Reading only, apart from `pushPackage`.
/// Pushes a package to NuGet. The key is masked wherever the command is printed.
let pushPackage (key: string option) (dryRun: bool) (nupkg: string) : Async<int> =
let push =
cmd $"dotnet nuget push {nupkg} --source https://api.nuget.org/v3/index.json"
|> Cmd.secretOptionWhenSome "--api-key" key
if dryRun then
printfn $"[DRY-RUN] Would run: {Cmd.toLogString push}"
async { return 0 }
else
Proc.stream push
type GithubRelease =
{
Version: string
Title: string
Date: DateTime
/// None when GitHub has no release for this version: it is not created yet, or the
/// version went to NuGet by hand the way 7.0.6 did.
PublishedDate: string option
Draft: string
}
let formatVersion (v: SemanticVersion) : string =
if String.IsNullOrEmpty v.Prerelease then
$"{v.Major}.{v.Minor}.{v.Patch}"
else
$"{v.Major}.{v.Minor}.{v.Patch}-{v.Prerelease}"
/// Releases are ordered on their version and not on their date: a hotfix for an older major is
/// released from its own branch, so it can carry a date newer than the entry main is about to cut.
let versionSortKey (v: SemanticVersion) : int * int * int * int * string =
let prerelease = if isNull v.Prerelease then String.Empty else v.Prerelease
v.Major.GetValueOrDefault(),
v.Minor.GetValueOrDefault(),
v.Patch.GetValueOrDefault(),
(if prerelease = String.Empty then 1 else 0),
prerelease
/// The date the GitHub release for this version was published, or None when GitHub has none.
let getPublishedDate (version: string) : string option =
let prefixedVersion = $"v{version}"
printfn $"Checking if release {prefixedVersion} already exists on GitHub..."
let exitCode, stdout, _ =
Proc.buffered (cmd $"gh release view {prefixedVersion} --json publishedAt -t {{{{.publishedAt}}}}")
|> Async.RunSynchronously
if exitCode <> 0 then
printfn $"Release {prefixedVersion} does not exist yet"
None
else
let output = stdout.Trim()
let lastIdx = output.LastIndexOf("Z", StringComparison.Ordinal)
let dateStr = output.Substring(0, lastIdx)
printfn $"Release {prefixedVersion} already exists, published at: {dateStr}"
Some dateStr
let mkGithubRelease (v: SemanticVersion, d: DateTime, cd: ChangelogData option) : GithubRelease =
match cd with
| None -> failwith "Each Fantomas release is expected to have at least one section."
| Some cd ->
let version = formatVersion v
printfn $"Parsing release version: {version} (prerelease: {not (String.IsNullOrEmpty v.Prerelease)})"
let title =
let month = d.ToString("MMMM")
let day = d.Day.Ordinalize()
$"{month} {day} Release"
let publishDate = getPublishedDate version
let sections =
[
"Added", cd.Added
"Changed", cd.Changed
"Fixed", cd.Fixed
"Deprecated", cd.Deprecated
"Removed", cd.Removed
"Security", cd.Security
yield! (Map.toList cd.Custom)
]
|> List.choose (fun (header, lines) ->
if lines.IsEmpty then
None
else
lines
|> List.map (fun line -> line.TrimStart())
|> String.concat "\n"
|> sprintf "### %s\n%s" header
|> Some)
|> String.concat "\n\n"
let draft =
$"""# {version}
{sections}"""
{
Version = version
Title = title
Date = d
PublishedDate = publishDate
Draft = draft
}
/// The most recent release date GitHub knows, as the cutoff for contributor attribution.
let private mostRecentGithubReleaseDate () : string =
let exitCode, stdout, _ =
Proc.buffered (cmd $"gh release list --limit 1 --json createdAt")
|> Async.RunSynchronously
let fallback (reason: string) =
let date = DateTime.UtcNow.ToString("yyyy-MM-dd")
printfn $"{reason}, using current date: {date}"
date
if exitCode <> 0 || String.IsNullOrWhiteSpace(stdout.Trim()) then
fallback "Could not query GitHub releases"
else
let releases = JsonValue.Parse(stdout.Trim()).AsArray()
if releases.Length = 0 then
fallback "No GitHub releases found"
else
match releases.[0].TryGetProperty("createdAt") with
| None -> fallback "GitHub release missing createdAt"
| Some createdAt ->
let dateTime =
DateTime
.Parse(createdAt.AsString(), null, Globalization.DateTimeStyles.RoundtripKind)
.ToUniversalTime()
let ghDate = dateTime.ToString("yyyy-MM-ddTHH:mm:ss")
printfn $"Using most recent GitHub release date for author attribution: {ghDate}"
ghDate
/// The GitHub logins of everyone whose commits were merged to main after `date`, bots excluded.
let private contributorsSince (date: string) : string array =
printfn $"Querying PRs closed after {date} for author attribution..."
let query = $"state:closed base:main closed:>{date}"
let exitCode, stdout, _ =
Proc.buffered (cmd $"gh pr list -S {query} --json commits,mergedAt")
|> Async.RunSynchronously
if exitCode <> 0 then
printfn $"Warning: Failed to query PRs for author attribution (exit code: {exitCode})"
[||]
else
let cutoff =
DateTime.Parse(date, null, Globalization.DateTimeStyles.RoundtripKind).ToUniversalTime()
printfn $"Filtering PRs merged after: {cutoff:O}"
let property (name: string) (value: JsonValue) = value.TryGetProperty name
let mergedAfterCutoff (pr: JsonValue) =
match property "mergedAt" pr with
| Some mergedAt ->
match DateTime.TryParse(mergedAt.AsString(), null, Globalization.DateTimeStyles.RoundtripKind) with
| true, dt -> dt.ToUniversalTime() > cutoff
| _ -> false
| None -> false
JsonValue.Parse(stdout.Trim()).AsArray()
|> Array.filter mergedAfterCutoff
|> Array.collect (fun pr ->
property "commits" pr
|> Option.map (fun commits -> commits.AsArray())
|> Option.defaultValue [||])
|> Array.collect (fun commit ->
property "authors" commit
|> Option.map (fun authors -> authors.AsArray())
|> Option.defaultValue [||])
|> Array.choose (fun author ->
property "login" author
|> Option.map (fun login -> login.AsString())
|> Option.filter (fun login -> not (login.EndsWith("[bot]", StringComparison.Ordinal))))
|> Array.distinct
|> Array.sort
let getReleaseNotes (currentRelease: GithubRelease) (lastPublishedDate: string option) : string =
let date =
match lastPublishedDate with
| Some d ->
printfn $"Using last release published date for author attribution: {d}"
d
| None ->
printfn "No earlier changelog entry is on GitHub, querying GitHub for most recent release..."
mostRecentGithubReleaseDate ()
let authors = contributorsSince date
printfn $"Found {authors.Length} contributors for this release"
let authorMsg =
match authors with
| [||] -> String.Empty
| [| one |] -> $"Special thanks to @%s{one}!"
| _ ->
let lastAuthor = Array.last authors
let otherAuthors =
authors
|> Array.take (authors.Length - 1)
|> Array.map (sprintf "@%s")
|> String.concat ", "
$"Special thanks to %s{otherAuthors} and @%s{lastAuthor}!"
$"""{currentRelease.Draft}
{authorMsg}
[https://www.nuget.org/packages/fantomas/{currentRelease.Version}](https://www.nuget.org/packages/fantomas/{currentRelease.Version})
"""
let getCurrentReleaseAndLastPublishedDate () : GithubRelease * string option =
printfn "Parsing CHANGELOG.md to find current and last release..."
let changelog = FileInfo(repositoryRoot </> "CHANGELOG.md")
let changeLogResult =
match Parser.parseChangeLog changelog with
| Error error -> failwithf "Failed to parse changelog: %A" error
| Ok result ->
printfn $"Found {result.Releases.Length} releases in changelog"
result
let releases =
changeLogResult.Releases
|> List.sortByDescending (fun (v, _, _) -> versionSortKey v)
match releases with
| [] -> failwith "Could not find any release in CHANGELOG.md"
| current :: earlierReleases ->
let currentRelease = mkGithubRelease current
printfn $"Current release: {currentRelease.Version}"
// The release below the current one does not have to exist on GitHub. Walk down the recent
// entries until GitHub knows one; its publish date is what the contributor query is based on.
let lastPublishedRelease =
earlierReleases
|> List.truncate 5
|> List.tryPick (fun (v, _, _) ->
let version = formatVersion v
getPublishedDate version |> Option.map (fun date -> version, date))
match lastPublishedRelease with
| Some(version, date) -> printfn $"Last release on GitHub: {version}, published at {date}"
| None -> printfn "None of the recent changelog entries has a GitHub release"
currentRelease, Option.map snd lastPublishedRelease
/// Every package `pack` produced, except the client, which has a release cycle of its own.
let private packagesToPush () : string array =
Directory.EnumerateFiles(packagesDir, "*.nupkg", SearchOption.TopDirectoryOnly)
|> Seq.filter (fun nupkg -> not (nupkg.Contains("Fantomas.Client")))
|> Seq.toArray
/// Pushes the packages and creates the GitHub release, unless the release already exists.
let private releaseStage (key: string option) (dryRun: bool) : Async<int> =
async {
if dryRun then
printfn "[DRY-RUN] Starting release pipeline in dry-run mode"
else
printfn "Starting release pipeline"
let currentRelease, lastPublishedDate = getCurrentReleaseAndLastPublishedDate ()
if Option.isSome currentRelease.PublishedDate then
printfn $"Release {currentRelease.Version} already exists on GitHub. Skipping release process."
return 0
else
printfn $"Release {currentRelease.Version} does not exist yet. Proceeding with release process."
let isPrerelease = currentRelease.Version.Contains("-")
if isPrerelease then
printfn $"Detected prerelease version: {currentRelease.Version}"
let nugetPackages = packagesToPush ()
printfn $"Found {nugetPackages.Length} packages to push to NuGet:"
nugetPackages |> Array.iter (fun pkg -> printfn $" - {Path.GetFileName(pkg)}")
let! nugetExitCodes =
nugetPackages |> Array.map (pushPackage key dryRun) |> Async.Sequential
if nugetExitCodes |> Array.forall (fun code -> code = 0) then
printfn "All NuGet packages pushed successfully"
else
let exitCodesStr = nugetExitCodes |> Array.map string |> String.concat ", "
printfn $"Warning: Some NuGet packages failed to push. Exit codes: {exitCodesStr}"
let notes = getReleaseNotes currentRelease lastPublishedDate
printfn "Release notes that will be used:"
printfn "---"
printfn "%s" notes
printfn "---"
let noteFile = Path.GetTempFileName()
File.WriteAllText(noteFile, notes)
// A stable minor or major goes out as a draft, so notes can be added by hand before it
// is published. A revision or a prerelease is published as it is.
let patchVersion =
match currentRelease.Version.Split('-').[0].Split('.') with
| [| _; _; patch |] ->
match Int32.TryParse patch with
| true, p -> p
| _ -> 0
| _ -> 0
let isRevision = patchVersion <> 0
let isDraft = not isRevision && not isPrerelease
let releaseType =
if isPrerelease then "prerelease (published)"
elif isRevision then "revision (published)"
else "minor/major (draft)"
printfn $"Release type: {releaseType}"
let releaseCommand =
cmd
$"gh release create v{currentRelease.Version} --title {currentRelease.Title} --notes-file {noteFile}"
|> Cmd.args (List.ofArray nugetPackages)
|> Cmd.argIf isDraft [ "--draft" ]
|> Cmd.argIf isPrerelease [ "--prerelease" ]
let! releaseExitCode =
if dryRun then
printfn $"[DRY-RUN] Would execute: {Cmd.toLogString releaseCommand}"
async { return 0 }
else
printfn $"Creating GitHub release: v{currentRelease.Version}"
Proc.stream releaseCommand
if File.Exists noteFile then
File.Delete(noteFile)
if releaseExitCode = 0 then
printfn $"Successfully created GitHub release: v{currentRelease.Version}"
else
printfn $"Warning: GitHub release creation returned exit code: {releaseExitCode}"
return Seq.max [| yield! nugetExitCodes; yield releaseExitCode |]
}
let release =
input {
let! dryRun = Options.dryRun
and! key = Options.nugetKey
return stage "release" { run (fun _ -> releaseStage key dryRun) }
}
let publishAlpha =
input {
let! dryRun = Options.dryRun
and! key = Options.nugetKey
return
stage "publish" {
run (fun _ ->
async {
let! exitCodes =
packagesToPush () |> Array.map (pushPackage key dryRun) |> Async.Sequential
return Array.sum exitCodes
})
}
}
let pushClient =
input {
let! dryRun = Options.dryRun
and! key = Options.nugetKey
return
stage "push" {
run (fun _ ->
async {
match
Directory.EnumerateFiles(
packagesDir,
"Fantomas.Client.*.nupkg",
SearchOption.TopDirectoryOnly
)
|> Seq.tryExactlyOne
with
| Some nupkg -> return! pushPackage key dryRun nupkg
| None ->
printfn "Fantomas.Client package was not found."
return -1
})
}
}
let commands =
[
command "release" {
description "Build, test, pack, push to NuGet and create the GitHub release for the current CHANGELOG entry"
workingDir repositoryRoot
Blocks.build
Blocks.test
Blocks.pack
release
}
command "publish-alpha" {
description "Clean, build, pack and push every package except the client to NuGet"
workingDir repositoryRoot
Blocks.clean [ analysisReportsDir; artifactsDir ]
Blocks.build
Blocks.pack
publishAlpha
}
command "push-client" {
description "Pack and push Fantomas.Client to NuGet"
workingDir repositoryRoot
stage "pack" { run "dotnet pack ./src/Fantomas.Client -c Release --tl" }
pushClient
}
]
runIfMain "BuildRelease2.fsx" (fun () ->
rootCommandOfScript {
name "BuildRelease2.fsx"
commands
})
#r "nuget: CliWrap, 3.6.4"
#r "nuget: FSharp.Data, 6.3.0"
open System.IO
open System.Xml.Linq
open System.Xml.XPath
open FSharp.Data
// Loaded by `build.fsx`, after `BuildCommon.fsx`. An error here saying BuildCommon is not defined
// means this file was run on its own; it is a library, so run a pipeline from build.fsx instead.
open BuildCommon
// Keeping the vendored FCS sources up to date: which upstream commit they came from, and fetching a
// file at that commit. `Fantomas.FCS` is a copy of the compiler, so this is how the copy moves.
let deps = repositoryRoot </> ".deps"
let fsharpCompilerHash =
let xDoc = XElement.Load(repositoryRoot </> "Directory.Build.props")
xDoc.XPathSelectElements("//FCSCommitHash") |> Seq.head |> (fun xe -> xe.Value)
let updateFileRaw (file: FileInfo) =
let lines = File.ReadAllLines file.FullName
let updatedLines =
lines
|> Array.map (fun line ->
if line.StartsWith("namespace FSharp.Build") then
line.Replace("namespace FSharp.Build", "namespace Fantomas.FCS.Build")
elif line.Contains("FSharp.Compiler") then
line.Replace("FSharp.Compiler", "Fantomas.FCS")
elif line.Contains("[<TailCall>]") then
line.Replace("[<TailCall>]", "[<Microsoft.FSharp.Core.TailCall>]")
else
line)
File.WriteAllLines(file.FullName, updatedLines)
let downloadCompilerFile commitHash relativePath =
async {
let file = FileInfo(deps </> commitHash </> relativePath)
if file.Exists && file.Length <> 0 then
return ()
else
file.Directory.Create()
let fs = file.Create()
let fileName = Path.GetFileName(relativePath)
let url =
$"https://raw.githubusercontent.com/dotnet/fsharp/{commitHash}/{relativePath}"
let! response =
Http.AsyncRequestStream(
url,
headers = [| "Content-Disposition", $"attachment; filename=\"{fileName}\"" |]
)
if response.StatusCode <> 200 then
printfn $"Could not download %s{relativePath}"
do! Async.AwaitTask(response.ResponseStream.CopyToAsync(fs))
fs.Close()
updateFileRaw file
}
#load "BuildCommon2.fsx"
open System.IO
open System.Net.Http
open System.Xml.Linq
open System.Xml.XPath
open Partas.Build
open BuildCommon2
// Keeping the vendored FCS sources up to date: which upstream commit they came from, and fetching a
// file at that commit. `Fantomas.FCS` is a copy of the compiler, so this is how the copy moves.
let deps = repositoryRoot </> ".deps"
let fsharpCompilerHash =
let xDoc = XElement.Load(repositoryRoot </> "Directory.Build.props")
xDoc.XPathSelectElements("//FCSCommitHash") |> Seq.head |> (fun xe -> xe.Value)
let updateFileRaw (file: FileInfo) =
let lines = File.ReadAllLines file.FullName
let updatedLines =
lines
|> Array.map (fun line ->
if line.StartsWith("namespace FSharp.Build") then
line.Replace("namespace FSharp.Build", "namespace Fantomas.FCS.Build")
elif line.Contains("FSharp.Compiler") then
line.Replace("FSharp.Compiler", "Fantomas.FCS")
elif line.Contains("[<TailCall>]") then
line.Replace("[<TailCall>]", "[<Microsoft.FSharp.Core.TailCall>]")
else
line)
File.WriteAllLines(file.FullName, updatedLines)
let private http = new HttpClient()
/// Fetches one compiler file at the given commit into `.deps`, unless it is already there.
let downloadCompilerFile (commitHash: string) (relativePath: string) : Async<unit> =
async {
let file = FileInfo(deps </> commitHash </> relativePath)
if file.Exists && file.Length <> 0 then
return ()
else
file.Directory.Create()
let url =
$"https://raw.githubusercontent.com/dotnet/fsharp/{commitHash}/{relativePath}"
let! response = http.GetAsync url |> Async.AwaitTask
if not response.IsSuccessStatusCode then
printfn $"Could not download %s{relativePath}"
else
use fs = file.Create()
do! response.Content.CopyToAsync fs |> Async.AwaitTask
fs.Close()
updateFileRaw file
}
/// The compiler sources Fantomas.FCS is built from. The first is not a compiler source but the
/// MSBuild task that turns FSComp.txt into the SR module, which the SDK's own copy cannot generate
/// for the current compiler.
let compilerFiles: string array =
92 collapsed lines
[|
"src/FSharp.Build/FSharpEmbedResourceText.fs"
"src/Compiler/FSComp.txt"
"src/Compiler/FSStrings.resx"
"src/Compiler/Utilities/NullHelpers.fs"
"src/Compiler/Utilities/Activity.fsi"
"src/Compiler/Utilities/Activity.fs"
"src/Compiler/Utilities/Caches.fsi"
"src/Compiler/Utilities/Caches.fs"
"src/Compiler/Utilities/sformat.fsi"
"src/Compiler/Utilities/sformat.fs"
"src/Compiler/Utilities/sr.fsi"
"src/Compiler/Utilities/sr.fs"
"src/Compiler/Facilities/RichText.fsi"
"src/Compiler/Facilities/RichText.fs"
"src/Compiler/Utilities/ResizeArray.fsi"
"src/Compiler/Utilities/ResizeArray.fs"
"src/Compiler/Utilities/HashMultiMap.fsi"
"src/Compiler/Utilities/HashMultiMap.fs"
"src/Compiler/Utilities/ReadOnlySpan.fsi"
"src/Compiler/Utilities/ReadOnlySpan.fs"
"src/Compiler/Utilities/TaggedCollections.fsi"
"src/Compiler/Utilities/TaggedCollections.fs"
"src/Compiler/Utilities/illib.fsi"
"src/Compiler/Utilities/illib.fs"
"src/Compiler/Utilities/Cancellable.fsi"
"src/Compiler/Utilities/Cancellable.fs"
"src/Compiler/Utilities/FileSystem.fsi"
"src/Compiler/Utilities/FileSystem.fs"
"src/Compiler/Utilities/ildiag.fsi"
"src/Compiler/Utilities/ildiag.fs"
"src/Compiler/Utilities/zmap.fsi"
"src/Compiler/Utilities/zmap.fs"
"src/Compiler/Utilities/zset.fsi"
"src/Compiler/Utilities/zset.fs"
"src/Compiler/Utilities/XmlAdapters.fsi"
"src/Compiler/Utilities/XmlAdapters.fs"
"src/Compiler/Utilities/InternalCollections.fsi"
"src/Compiler/Utilities/InternalCollections.fs"
"src/Compiler/Utilities/lib.fsi"
"src/Compiler/Utilities/lib.fs"
"src/Compiler/Utilities/PathMap.fsi"
"src/Compiler/Utilities/PathMap.fs"
"src/Compiler/Utilities/range.fsi"
"src/Compiler/Utilities/range.fs"
"src/Compiler/Facilities/LanguageFeatures.fsi"
"src/Compiler/Facilities/LanguageFeatures.fs"
"src/Compiler/Facilities/DiagnosticOptions.fsi"
"src/Compiler/Facilities/DiagnosticOptions.fs"
"src/Compiler/Facilities/DiagnosticsLogger.fsi"
"src/Compiler/Facilities/DiagnosticsLogger.fs"
"src/Compiler/Facilities/Hashing.fsi"
"src/Compiler/Facilities/Hashing.fs"
"src/Compiler/Facilities/prim-lexing.fsi"
"src/Compiler/Facilities/prim-lexing.fs"
"src/Compiler/Facilities/prim-parsing.fsi"
"src/Compiler/Facilities/prim-parsing.fs"
"src/Compiler/AbstractIL/illex.fsl"
"src/Compiler/AbstractIL/ilpars.fsy"
"src/Compiler/AbstractIL/il.fsi"
"src/Compiler/AbstractIL/il.fs"
"src/Compiler/AbstractIL/ilascii.fsi"
"src/Compiler/AbstractIL/ilascii.fs"
"src/Compiler/SyntaxTree/PrettyNaming.fsi"
"src/Compiler/SyntaxTree/PrettyNaming.fs"
"src/Compiler/pplex.fsl"
"src/Compiler/pppars.fsy"
"src/Compiler/lex.fsl"
"src/Compiler/pars.fsy"
"src/Compiler/SyntaxTree/UnicodeLexing.fsi"
"src/Compiler/SyntaxTree/UnicodeLexing.fs"
"src/Compiler/SyntaxTree/XmlDocIncludeExpander.fsi"
"src/Compiler/SyntaxTree/XmlDocIncludeExpander.fs"
"src/Compiler/SyntaxTree/XmlDoc.fsi"
"src/Compiler/SyntaxTree/XmlDoc.fs"
"src/Compiler/SyntaxTree/SyntaxTrivia.fsi"
"src/Compiler/SyntaxTree/SyntaxTrivia.fs"
"src/Compiler/SyntaxTree/SyntaxTree.fsi"
"src/Compiler/SyntaxTree/SyntaxTree.fs"
"src/Compiler/SyntaxTree/SyntaxTreeOps.fsi"
"src/Compiler/SyntaxTree/SyntaxTreeOps.fs"
"src/Compiler/SyntaxTree/WarnScopes.fsi"
"src/Compiler/SyntaxTree/WarnScopes.fs"
"src/Compiler/SyntaxTree/LexerStore.fsi"
"src/Compiler/SyntaxTree/LexerStore.fs"
"src/Compiler/SyntaxTree/ParseHelpers.fsi"
"src/Compiler/SyntaxTree/ParseHelpers.fs"
"src/Compiler/SyntaxTree/LexHelpers.fsi"
"src/Compiler/SyntaxTree/LexHelpers.fs"
"src/Compiler/SyntaxTree/LexFilter.fsi"
"src/Compiler/SyntaxTree/LexFilter.fs"
|]
let commands =
[
command "init" {
description "Download the vendored compiler sources at the commit Directory.Build.props pins"
workingDir repositoryRoot
stage "download FCS files" {
run (fun _ ->
compilerFiles
|> Array.map (downloadCompilerFile fsharpCompilerHash)
|> Async.Parallel
|> Async.Ignore)
}
}
]
runIfMain "BuildCompiler2.fsx" (fun () ->
rootCommandOfScript {
name "BuildCompiler2.fsx"
commands
})