Skip to content

Commit f787435

Browse files
nojafnojaf
committed
Add tests that compare the heuristic with the typed tree information.
1 parent 5f04801 commit f787435

File tree

2 files changed

+219
-0
lines changed

2 files changed

+219
-0
lines changed

‎tests/ParallelTypeCheckingTests/ParallelTypeCheckingTests.fsproj‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@
4949
<Content Include="Tests\FCS.prepare.ps1" />
5050
<Content Include="Tests\ComponentTests.args.txt" />
5151
<Content Include="Tests\.gitignore" />
52+
<Compile Include="Tests\TypedTreeGraph.fs" />
5253
<Compile Include="Program.fs" />
5354
<Content Include="Docs.md" />
5455
</ItemGroup>

‎tests/ParallelTypeCheckingTests/Tests/TypedTreeGraph.fs‎

Lines changed: 218 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,218 @@
1+
module ParallelTypeCheckingTests.Tests.TypedTreeGraph
2+
3+
open System
4+
open System.Collections.Generic
5+
open System.IO
6+
open System.Linq
7+
open FSharp.Compiler.CodeAnalysis
8+
open FSharp.Compiler.Text
9+
open FSharp.Compiler.Symbols
10+
open NUnit.Framework
11+
open ParallelTypeCheckingTests
12+
open ParallelTypeCheckingTests.Utils
13+
open ParallelTypeCheckingTests.Types
14+
open ParallelTypeCheckingTests.DepResolving
15+
open ParallelTypeCheckingTests.TestUtils
16+
17+
type Codebase = { WorkDir: string; Path: string }
18+
19+
let codebases =
20+
[|
21+
{
22+
WorkDir = $@"{__SOURCE_DIRECTORY__}\.fcs_test\src\compiler"
23+
Path = $@"{__SOURCE_DIRECTORY__}\FCS.args.txt"
24+
}
25+
{
26+
WorkDir = $@"{__SOURCE_DIRECTORY__}\.fcs_test\tests\FSharp.Compiler.ComponentTests"
27+
Path = $@"{__SOURCE_DIRECTORY__}\ComponentTests.args.txt"
28+
}
29+
// Hard coded example ;)
30+
// {
31+
// WorkDir = @"C:\Users\nojaf\Projects\main-fantomas\src\Fantomas.Core"
32+
// Path = @"C:\Users\nojaf\Projects\main-fantomas\src\Fantomas.Core\args.txt"
33+
// }
34+
|]
35+
36+
let checker = FSharpChecker.Create(keepAssemblyContents = true)
37+
38+
type DepCollector(projectRoot: string, projectFile: string) =
39+
let deps = HashSet<string>()
40+
41+
member this.Add(declarationLocation: range) : unit =
42+
let sourceLocation = declarationLocation.FileName
43+
44+
if sourceLocation.StartsWith projectRoot && sourceLocation <> projectFile then
45+
deps.Add(sourceLocation.Substring(projectRoot.Length + 1)) |> ignore
46+
47+
member this.Deps = Seq.toArray deps
48+
49+
let rec collectFromSymbol (collector: DepCollector) (s: FSharpSymbol) =
50+
match s with
51+
| :? FSharpMemberOrFunctionOrValue as mfv ->
52+
if mfv.ImplementationLocation.IsSome || mfv.SignatureLocation.IsSome then
53+
collector.Add mfv.DeclarationLocation
54+
55+
collectFromSymbol collector mfv.ReturnParameter
56+
57+
for cpg in mfv.CurriedParameterGroups do
58+
for p in cpg do
59+
collectFromSymbol collector p
60+
61+
| :? FSharpParameter as fp ->
62+
if fp.Type.HasTypeDefinition then
63+
collector.Add fp.Type.TypeDefinition.DeclarationLocation
64+
65+
| :? FSharpEntity as e ->
66+
if
67+
not (e.IsFSharpModule || e.IsNamespace)
68+
&& (e.ImplementationLocation.IsSome || e.SignatureLocation.IsSome)
69+
then
70+
collector.Add e.DeclarationLocation
71+
72+
| :? FSharpActivePatternCase as apc -> collector.Add apc.DeclarationLocation
73+
| _ -> ()
74+
75+
// Fair warning: this isn't fast or optimized code
76+
let graphFromTypedTree
77+
(checker: FSharpChecker)
78+
(projectDir: string)
79+
(projectOptions: FSharpProjectOptions)
80+
: Dictionary<string, File> * IReadOnlyDictionary<File, File[]> =
81+
let files = Dictionary<string, File>()
82+
83+
let filesWithDeps =
84+
projectOptions
85+
.SourceFiles
86+
.AsParallel()
87+
.AsOrdered()
88+
.Select(fun fileName idx ->
89+
async {
90+
let sourceText = (File.ReadAllText >> SourceText.ofString) fileName
91+
let! parseResult, checkResult = checker.ParseAndCheckFileInProject(fileName, 1, sourceText, projectOptions)
92+
93+
let isFisBacked =
94+
not (fileName.EndsWith(".fsi"))
95+
&& (Array.exists (fun (option: string) -> option.Contains($"{fileName}i")) projectOptions.OtherOptions
96+
|| Array.exists (fun (file: string) -> file.Contains($"{fileName}i")) projectOptions.SourceFiles)
97+
98+
match checkResult with
99+
| FSharpCheckFileAnswer.Aborted _ -> return failwith "aborted"
100+
| FSharpCheckFileAnswer.Succeeded fileResult ->
101+
let allSymbols = fileResult.GetAllUsesOfAllSymbolsInFile() |> Seq.toArray
102+
let collector = DepCollector(projectDir, fileName)
103+
104+
for s in allSymbols do
105+
collectFromSymbol collector s.Symbol
106+
107+
let file: File =
108+
{
109+
Idx = FileIdx.make idx
110+
AST = ASTOrFsix.AST parseResult.ParseTree
111+
FsiBacked = isFisBacked
112+
}
113+
114+
files.Add(Path.GetFileName(fileName), file)
115+
116+
return (file, collector.Deps)
117+
}
118+
|> Async.RunSynchronously)
119+
.ToArray()
120+
121+
let graph =
122+
filesWithDeps
123+
|> Seq.sortBy (fun (file, _) -> file.Idx.Idx)
124+
|> Seq.map (fun (file, deps) ->
125+
let depsAsFiles = deps |> Array.map (fun dep -> files.[dep])
126+
file, depsAsFiles)
127+
|> readOnlyDict
128+
129+
files, graph
130+
131+
[<TestCaseSource(nameof codebases)>]
132+
[<Explicit("Really slow! Only useful as a sanity check that the test codebase is sound.")>]
133+
let ``Create Graph from typed tree`` (code: Codebase) =
134+
let previousDir = Environment.CurrentDirectory
135+
136+
try
137+
Environment.CurrentDirectory <- code.WorkDir
138+
139+
let args = File.ReadAllLines(code.Path) |> Array.map replacePaths
140+
let fileName = Path.GetFileNameWithoutExtension(args.[0].Replace("-o:", ""))
141+
142+
let sourceFiles, otherOptions =
143+
args
144+
|> Array.partition (fun option ->
145+
not (option.StartsWith("-"))
146+
&& (option.EndsWith(".fs") || option.EndsWith(".fsi")))
147+
148+
let otherOptions =
149+
otherOptions
150+
|> Array.map (fun otherOption ->
151+
// The reference to fsharp code needs to be an absolute one
152+
if otherOption.StartsWith("-r:..") then
153+
let absoluteBit = otherOption.Split(':').[1]
154+
$"-r:{Path.Combine(code.WorkDir, absoluteBit)}"
155+
else
156+
otherOption)
157+
158+
let proj =
159+
{
160+
ProjectFileName = fileName
161+
ProjectId = None
162+
SourceFiles = sourceFiles
163+
OtherOptions = otherOptions
164+
ReferencedProjects = [||]
165+
IsIncompleteTypeCheckEnvironment = false
166+
UseScriptResolutionRules = false
167+
LoadTime = DateTime.Now
168+
UnresolvedReferences = None
169+
OriginalLoadReferences = []
170+
Stamp = None
171+
}
172+
173+
let files, graphFromTypedTree = graphFromTypedTree checker code.WorkDir proj
174+
let path = $"{fileName}.typed-tree.deps.json"
175+
graphFromTypedTree |> Graph.map (fun n -> n.Name) |> Graph.serialiseToJson path
176+
177+
let sourceFiles =
178+
files.Values
179+
|> Seq.sortBy (fun file -> file.Idx.Idx)
180+
|> Seq.map (fun file ->
181+
let ast =
182+
match file.AST with
183+
| ASTOrFsix.AST ast -> ast
184+
| ASTOrFsix.Fsix _ -> failwith "unexpected fsix"
185+
186+
{ Idx = file.Idx; AST = ast }: SourceFile)
187+
|> Seq.toArray
188+
189+
let graphFromHeuristic = DependencyResolution.detectFileDependencies sourceFiles
190+
let path = $"{fileName}.deps.json"
191+
192+
graphFromHeuristic.Graph
193+
|> Graph.map (fun n -> n.Name)
194+
|> Graph.serialiseToJson path
195+
196+
Assert.True(graphFromTypedTree.Count = graphFromHeuristic.Graph.Count, "Both graphs should have the same amount of entries.")
197+
198+
let depNames (files: File array) =
199+
Array.map (fun (f: File) -> Path.GetFileName(f.Name)) files
200+
|> String.concat ", "
201+
202+
for KeyValue (file, deps) in graphFromHeuristic.Graph do
203+
let depsFromTypedTree = graphFromTypedTree.[file]
204+
205+
if Array.isEmpty depsFromTypedTree && not (Array.isEmpty deps) then
206+
printfn $"{file.Name} has %A{(depNames deps)} while the typed tree had none!"
207+
else
208+
let isSuperSet =
209+
depsFromTypedTree |> Seq.forall (fun ttDep -> Seq.contains ttDep deps)
210+
211+
Assert.IsTrue(
212+
isSuperSet,
213+
$"""{file.Name} did not contain a superset of the typed tree dependencies:
214+
Typed tree dependencies: %A{depNames depsFromTypedTree}.
215+
Heuristic dependencies: %A{depNames deps}."""
216+
)
217+
finally
218+
Environment.CurrentDirectory <- previousDir

0 commit comments

Comments
 (0)