From 27d28190dbea560f8aee0bff1d5f607f07aa6ba7 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 23 Feb 2023 10:07:54 +0100 Subject: [PATCH] Add test flag to dump signature data. --- src/Compiler/Driver/CompilerConfig.fs | 4 + src/Compiler/Driver/CompilerConfig.fsi | 4 + src/Compiler/Driver/CompilerImports.fs | 7 ++ src/Compiler/Driver/CompilerOptions.fs | 1 + src/Compiler/TypedTree/TypedTreeOps.fs | 105 ++++++++++++++++++++++++ src/Compiler/TypedTree/TypedTreeOps.fsi | 3 + 6 files changed, 124 insertions(+) diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs index 6a534a174b1..d3b3ee5d73e 100644 --- a/src/Compiler/Driver/CompilerConfig.fs +++ b/src/Compiler/Driver/CompilerConfig.fs @@ -604,6 +604,8 @@ type TcConfigBuilder = mutable captureIdentifiersWhenParsing: bool mutable typeCheckingConfig: TypeCheckingConfig + + mutable dumpSignatureData: bool } // Directories to start probing in @@ -803,6 +805,7 @@ type TcConfigBuilder = TypeCheckingMode.Sequential DumpGraph = false } + dumpSignatureData = false } member tcConfigB.FxResolver = @@ -1343,6 +1346,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member _.parallelReferenceResolution = data.parallelReferenceResolution member _.captureIdentifiersWhenParsing = data.captureIdentifiersWhenParsing member _.typeCheckingConfig = data.typeCheckingConfig + member _.dumpSignatureData = data.dumpSignatureData static member Create(builder, validate) = use _ = UseBuildPhase BuildPhase.Parameter diff --git a/src/Compiler/Driver/CompilerConfig.fsi b/src/Compiler/Driver/CompilerConfig.fsi index 04b87e3e428..7f29c346eb8 100644 --- a/src/Compiler/Driver/CompilerConfig.fsi +++ b/src/Compiler/Driver/CompilerConfig.fsi @@ -513,6 +513,8 @@ type TcConfigBuilder = mutable captureIdentifiersWhenParsing: bool mutable typeCheckingConfig: TypeCheckingConfig + + mutable dumpSignatureData: bool } static member CreateNew: @@ -884,6 +886,8 @@ type TcConfig = member typeCheckingConfig: TypeCheckingConfig + member dumpSignatureData: bool + /// Represents a computation to return a TcConfig. Normally this is just a constant immutable TcConfig, /// but for F# Interactive it may be based on an underlying mutable TcConfigBuilder. [] diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index 2b6fc09a653..20ae178fdb1 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -138,6 +138,13 @@ let GetSignatureData (file, ilScopeRef, ilModule, byteReader) : PickledDataWithR let WriteSignatureData (tcConfig: TcConfig, tcGlobals, exportRemapping, ccu: CcuThunk, fileName, inMem) : ILResource = let mspec = ApplyExportRemappingToEntity tcGlobals exportRemapping ccu.Contents + if tcConfig.dumpSignatureData then + tcConfig.outputFile + |> Option.iter (fun outputFile -> + let outputFile = FileSystem.GetFullPathShim(outputFile) + let signatureDataFile = FileSystem.ChangeExtensionShim(outputFile, ".signature-data.json") + serializeEntity signatureDataFile mspec) + // For historical reasons, we use a different resource name for FSharp.Core, so older F# compilers // don't complain when they see the resource. let rName, compress = diff --git a/src/Compiler/Driver/CompilerOptions.fs b/src/Compiler/Driver/CompilerOptions.fs index f74c049d3d7..7ae8e8f3e4a 100644 --- a/src/Compiler/Driver/CompilerOptions.fs +++ b/src/Compiler/Driver/CompilerOptions.fs @@ -1383,6 +1383,7 @@ let testFlag tcConfigB = { tcConfigB.typeCheckingConfig with DumpGraph = true } + | "DumpSignatureData" -> tcConfigB.dumpSignatureData <- true #if DEBUG | "ShowParserStackOnParseError" -> showParserStackOnParseError <- true #endif diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 1873a63abee..a6ce02a1c29 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -3,6 +3,7 @@ /// Defines derived expression manipulation and construction functions. module internal FSharp.Compiler.TypedTreeOps +open System.CodeDom.Compiler open System.Collections.Generic open System.Collections.Immutable open Internal.Utilities @@ -11,6 +12,7 @@ open Internal.Utilities.Library open Internal.Utilities.Library.Extras open Internal.Utilities.Rational +open FSharp.Compiler.IO open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.CompilerGlobalState open FSharp.Compiler.DiagnosticsLogger @@ -10481,3 +10483,106 @@ let tryAddExtensionAttributeIfNotAlreadyPresent match tryFindExtensionAttributeIn tryFindExtensionAttribute with | None -> entity | Some extensionAttrib -> { entity with entity_attribs = extensionAttrib :: entity.Attribs } + +type TypedTreeNode = + { + Kind: string + Name: string + Children: TypedTreeNode list + } + +let rec visitEntity (entity: Entity) : TypedTreeNode = + let kind = + if entity.IsModule then + "module" + elif entity.IsNamespace then + "namespace" + else + "other" + + let children = + if not entity.IsModuleOrNamespace then + Seq.empty + else + seq { + yield! Seq.map visitEntity entity.ModuleOrNamespaceType.AllEntities + yield! Seq.map visitVal entity.ModuleOrNamespaceType.AllValsAndMembers + } + + { + Kind = kind + Name = entity.CompiledName + Children = Seq.toList children + } + +and visitVal (v: Val) : TypedTreeNode = + let children = + seq { + match v.ValReprInfo with + | None -> () + | Some reprInfo -> + yield! + reprInfo.ArgInfos + |> Seq.collect (fun argInfos -> + argInfos + |> Seq.map (fun argInfo -> { + Name = argInfo.Name |> Option.map (fun i -> i.idText) |> Option.defaultValue "" + Kind = "ArgInfo" + Children = [] + }) + ) + + yield! + v.Typars + |> Seq.map (fun typar -> { + Name = typar.Name + Kind = "Typar" + Children = [] + }) + } + + { + Name = v.CompiledName None + Kind = "val" + Children = Seq.toList children + } + +let rec serializeNode (writer: IndentedTextWriter) (addTrailingComma:bool) (node: TypedTreeNode) = + writer.WriteLine("{") + // Add indent after opening { + writer.Indent <- writer.Indent + 1 + + writer.WriteLine($"\"name\": \"{node.Name}\",") + writer.WriteLine($"\"kind\": \"{node.Kind}\",") + + if node.Children.IsEmpty then + writer.WriteLine("\"children\": []") + else + writer.WriteLine("\"children\": [") + + // Add indent after opening [ + writer.Indent <- writer.Indent + 1 + + node.Children + |> List.iteri (fun idx -> serializeNode writer (idx + 1 < node.Children.Length)) + + // Remove indent before closing ] + writer.Indent <- writer.Indent - 1 + writer.WriteLine("]") + + // Remove indent before closing } + writer.Indent <- writer.Indent - 1 + if addTrailingComma then + writer.WriteLine("},") + else + writer.WriteLine("}") + +let rec serializeEntity path (entity: Entity) = + let root = visitEntity entity + use sw = new System.IO.StringWriter() + use writer = new IndentedTextWriter(sw) + serializeNode writer false root + writer.Flush() + let json = sw.ToString() + use out = FileSystem.OpenFileForWriteShim(path, fileMode = System.IO.FileMode.Create) + out.WriteAllText(json) diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index c0a97858951..c6cf1c303a8 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -2695,3 +2695,6 @@ val (|EmptyModuleOrNamespaces|_|): /// Add an System.Runtime.CompilerServices.ExtensionAttribute to the Entity if found via predicate and not already present. val tryAddExtensionAttributeIfNotAlreadyPresent: tryFindExtensionAttributeIn: ((Attrib list -> Attrib option) -> Attrib option) -> entity: Entity -> Entity + +/// Serialize an entity to a very basic json structure. +val serializeEntity: path: string -> entity: Entity -> unit