From 5d7aa48cf707fff3a0fd986f00e18a7eed4a23ec Mon Sep 17 00:00:00 2001 From: dawe Date: Sat, 1 Apr 2023 20:44:15 +0200 Subject: [PATCH] call the GenerateXmlDocumentation Commands from a CodeFix --- .../CodeFixes/GenerateXmlDocumentation.fs | 158 ++++++++++++++++++ .../LspServers/AdaptiveFSharpLspServer.fs | 1 + .../LspServers/FsAutoComplete.Lsp.fs | 1 + .../CodeFixTests/Tests.fs | 147 ++++++++++++++++ 4 files changed, 307 insertions(+) create mode 100644 src/FsAutoComplete/CodeFixes/GenerateXmlDocumentation.fs diff --git a/src/FsAutoComplete/CodeFixes/GenerateXmlDocumentation.fs b/src/FsAutoComplete/CodeFixes/GenerateXmlDocumentation.fs new file mode 100644 index 000000000..33a21dfe5 --- /dev/null +++ b/src/FsAutoComplete/CodeFixes/GenerateXmlDocumentation.fs @@ -0,0 +1,158 @@ +module FsAutoComplete.CodeFix.GenerateXmlDocumentation + +open FsToolkit.ErrorHandling +open FsAutoComplete.CodeFix.Types +open Ionide.LanguageServerProtocol.Types +open FsAutoComplete +open FsAutoComplete.LspHelpers +open FSharp.Compiler.Syntax +open FSharp.Compiler.Text.Range + +let title = "Generate placeholder XML documentation" + +let private longIdentContainsPos (longIdent: LongIdent) (pos: FSharp.Compiler.Text.pos) = + longIdent + |> List.tryFind (fun i -> rangeContainsPos i.idRange pos) + |> Option.isSome + +let private isLowerAstElemWithEmptyPreXmlDoc input pos = + SyntaxTraversal.Traverse( + pos, + input, + { new SyntaxVisitorBase<_>() with + member _.VisitBinding(_, defaultTraverse, synBinding) = + match synBinding with + | SynBinding(xmlDoc = xmlDoc) as s when rangeContainsPos s.RangeOfBindingWithoutRhs pos && xmlDoc.IsEmpty -> + Some() + | _ -> defaultTraverse synBinding + + member _.VisitComponentInfo(_, synComponentInfo) = + match synComponentInfo with + | SynComponentInfo(longId = longId; xmlDoc = xmlDoc) when longIdentContainsPos longId pos && xmlDoc.IsEmpty -> + Some() + | _ -> None + + member _.VisitRecordDefn(_, fields, _) = + let isInLine c = + match c with + | SynField(xmlDoc = xmlDoc; idOpt = Some ident) when rangeContainsPos ident.idRange pos && xmlDoc.IsEmpty -> + Some() + | _ -> None + + fields |> List.tryPick isInLine + + member _.VisitUnionDefn(_, cases, _) = + let isInLine c = + match c with + | SynUnionCase(xmlDoc = xmlDoc; ident = (SynIdent(ident = ident))) when + rangeContainsPos ident.idRange pos && xmlDoc.IsEmpty + -> + Some() + | _ -> None + + cases |> List.tryPick isInLine + + member _.VisitEnumDefn(_, cases, _) = + let isInLine b = + match b with + | SynEnumCase(xmlDoc = xmlDoc; ident = (SynIdent(ident = ident))) when + rangeContainsPos ident.idRange pos && xmlDoc.IsEmpty + -> + Some() + | _ -> None + + cases |> List.tryPick isInLine + + member _.VisitLetOrUse(_, _, defaultTraverse, bindings, _) = + let isInLine b = + match b with + | SynBinding(xmlDoc = xmlDoc) as s when rangeContainsPos s.RangeOfBindingWithoutRhs pos && xmlDoc.IsEmpty -> + Some() + | _ -> defaultTraverse b + + bindings |> List.tryPick isInLine + + member _.VisitExpr(_, _, defaultTraverse, expr) = defaultTraverse expr } // needed for nested let bindings + ) + +let private isModuleOrNamespaceOrAutoPropertyWithEmptyPreXmlDoc input pos = + SyntaxTraversal.Traverse( + pos, + input, + { new SyntaxVisitorBase<_>() with + + member _.VisitModuleOrNamespace(_, synModuleOrNamespace) = + match synModuleOrNamespace with + | SynModuleOrNamespace(longId = longId; xmlDoc = xmlDoc) when + longIdentContainsPos longId pos && xmlDoc.IsEmpty + -> + Some() + | SynModuleOrNamespace(decls = decls) -> + + let rec findNested decls = + decls + |> List.tryPick (fun d -> + match d with + | SynModuleDecl.NestedModule(moduleInfo = moduleInfo; decls = decls) -> + match moduleInfo with + | SynComponentInfo(longId = longId; xmlDoc = xmlDoc) when + longIdentContainsPos longId pos && xmlDoc.IsEmpty + -> + Some() + | _ -> findNested decls + | SynModuleDecl.Types(typeDefns = typeDefns) -> + typeDefns + |> List.tryPick (fun td -> + match td with + | SynTypeDefn(typeRepr = SynTypeDefnRepr.ObjectModel(_, members, _)) -> + members + |> List.tryPick (fun m -> + match m with + | SynMemberDefn.AutoProperty(ident = ident; xmlDoc = xmlDoc) when + rangeContainsPos ident.idRange pos && xmlDoc.IsEmpty + -> + Some() + | _ -> None) + | _ -> None) + | _ -> None) + + findNested decls } + ) + +let private isAstElemWithEmptyPreXmlDoc input pos = + match isLowerAstElemWithEmptyPreXmlDoc input pos with + | Some xml -> Some xml + | _ -> isModuleOrNamespaceOrAutoPropertyWithEmptyPreXmlDoc input pos + +let fix (getParseResultsForFile: GetParseResultsForFile) : CodeFix = + fun codeActionParams -> + asyncResult { + let filePath = codeActionParams.TextDocument.GetFilePath() |> Utils.normalizePath + let fcsPos = protocolPosToPos codeActionParams.Range.Start + let! (parseAndCheck, lineStr, _sourceText) = getParseResultsForFile filePath fcsPos + let showFix = isAstElemWithEmptyPreXmlDoc parseAndCheck.GetAST fcsPos + + match showFix with + | Some _ -> + let! docEdit = Commands.GenerateXmlDocumentation(parseAndCheck, fcsPos, lineStr) + + match docEdit with + | Some({ InsertPosition = insertPosition + InsertText = formattedXmlDoc }) -> + let protocolPos = fcsPosToLsp insertPosition + + let editRange = + { Start = protocolPos + End = protocolPos } + + let text = formattedXmlDoc + + return + [ { Edits = [| { Range = editRange; NewText = text } |] + File = codeActionParams.TextDocument + Title = title + SourceDiagnostic = None + Kind = FixKind.Refactor } ] + | _ -> return [] + | None -> return [] + } diff --git a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs index 3de5c9de5..15d843f3d 100644 --- a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs +++ b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs @@ -1504,6 +1504,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar AddExplicitTypeAnnotation.fix tryGetParseResultsForFile ConvertPositionalDUToNamed.fix tryGetParseResultsForFile getRangeText ConvertTripleSlashCommentToXmlTaggedDoc.fix tryGetParseResultsForFile getRangeText + GenerateXmlDocumentation.fix tryGetParseResultsForFile UseTripleQuotedInterpolation.fix tryGetParseResultsForFile getRangeText RenameParamToMatchSignature.fix tryGetParseResultsForFile |]) diff --git a/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs b/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs index 072d46636..2c18a602e 100644 --- a/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs +++ b/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs @@ -1191,6 +1191,7 @@ type FSharpLspServer(state: State, lspClient: FSharpLspClient) = AddExplicitTypeAnnotation.fix tryGetParseResultsForFile ConvertPositionalDUToNamed.fix tryGetParseResultsForFile getRangeText ConvertTripleSlashCommentToXmlTaggedDoc.fix tryGetParseResultsForFile getRangeText + GenerateXmlDocumentation.fix tryGetParseResultsForFile UseTripleQuotedInterpolation.fix tryGetParseResultsForFile getRangeText RenameParamToMatchSignature.fix tryGetParseResultsForFile |] diff --git a/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs b/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs index fd90b1cfe..8abc53017 100644 --- a/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs +++ b/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs @@ -1014,6 +1014,152 @@ let private convertTripleSlashCommentToXmlTaggedDocTests state = Diagnostics.acceptAll selectCodeFix ]) +let private generateXmlDocumentationTests state = + serverTestList (nameof GenerateXmlDocumentation) state defaultConfigDto None (fun server -> + [ let selectCodeFix = CodeFix.withTitle GenerateXmlDocumentation.title + + testCaseAsync "documentation for function with two parameters" + <| CodeFix.check + server + """ + let $0f x y = x + y + """ + Diagnostics.acceptAll + selectCodeFix + """ + /// + /// + /// + /// + let f x y = x + y + """ + + testCaseAsync "documentation for use" + <| CodeFix.check + server + """ + let f a b _ = + use $0r = new System.IO.BinaryReader(null) + + a + b + """ + Diagnostics.acceptAll + selectCodeFix + """ + let f a b _ = + /// + /// + use r = new System.IO.BinaryReader(null) + + a + b + """ + + testCaseAsync "not applicable for record type" + <| CodeFix.checkNotApplicable + server + """ + type MyRec$0ord = { Foo: int } + """ + Diagnostics.acceptAll + selectCodeFix + + testCaseAsync "not applicable for discriminated union type" + <| CodeFix.checkNotApplicable + server + """ + type Dis$0cUnionTest = + | Field1 + | Field2 + """ + Diagnostics.acceptAll + selectCodeFix + + testCaseAsync "not applicable for discriminated union case" + <| CodeFix.checkNotApplicable + server + """ + type DiscUnionTest = + | C$0ase1 + | Case2 + """ + Diagnostics.acceptAll + selectCodeFix + + testCaseAsync "not applicable on enum type" + <| CodeFix.checkNotApplicable + server + """ + type myE$0num = + | value1 = 1 + | value2 = 2 + """ + Diagnostics.acceptAll + selectCodeFix + + testCaseAsync "not applicable on class type" + <| CodeFix.checkNotApplicable + server + """ + type MyC$0lass() = + member val Name = "" with get, set + """ + Diagnostics.acceptAll + selectCodeFix + + testCaseAsync "documentation on member" + <| CodeFix.check + server + """ + type MyClass() = + n$0ew(x: int) = MyClass() + """ + Diagnostics.acceptAll + selectCodeFix + """ + type MyClass() = + /// + /// + /// + new(x: int) = MyClass() + """ + + testCaseAsync "documentation on autoproperty" + <| CodeFix.check + server + """ + type MyClass() = + member val Na$0me = "" with get, set + """ + Diagnostics.acceptAll + selectCodeFix + """ + type MyClass() = + /// + /// + member val Name = "" with get, set + """ + + testCaseAsync "not applicable on named module" + <| CodeFix.checkNotApplicable + server + """ + module $0M + let f x = x + """ + Diagnostics.acceptAll + selectCodeFix + + testCaseAsync "not applicable on nested module" + <| CodeFix.checkNotApplicable + server + """ + module M + module MyNestedMo$0dule = + let x = 3 + """ + Diagnostics.acceptAll + selectCodeFix ]) + let private generateAbstractClassStubTests state = let config = { defaultConfigDto with AbstractClassStubGeneration = Some true } serverTestList (nameof GenerateAbstractClassStub) state config None (fun server -> [ @@ -2063,6 +2209,7 @@ let tests state = testList "CodeFix-tests" [ generateAbstractClassStubTests state generateRecordStubTests state generateUnionCasesTests state + generateXmlDocumentationTests state ImplementInterfaceTests.tests state makeDeclarationMutableTests state makeOuterBindingRecursiveTests state