From ff2ee3dff13330755943113b70826eb91652f9f3 Mon Sep 17 00:00:00 2001
From: dawe <dawedawe@posteo.de>
Date: Fri, 21 Apr 2023 17:05:24 +0200
Subject: [PATCH] Improve xml doc command: - Don't add xml doc lines if there
 are already some doc lines present. - Work on all possible AST elements, not
 just the ones for which we get a result from TryGetSignatureData.

Adjust tests accordingly
---
 src/FsAutoComplete.Core/Commands.fs           | 158 ++++++++++++++++--
 .../CodeFixes/GenerateXmlDocumentation.fs     | 152 ++---------------
 .../CodeFixTests/Tests.fs                     |  72 ++++++--
 3 files changed, 214 insertions(+), 168 deletions(-)

diff --git a/src/FsAutoComplete.Core/Commands.fs b/src/FsAutoComplete.Core/Commands.fs
index e41c9911f..60f13f742 100644
--- a/src/FsAutoComplete.Core/Commands.fs
+++ b/src/FsAutoComplete.Core/Commands.fs
@@ -25,6 +25,7 @@ open System.Collections.Immutable
 open System.Collections.Generic
 open Ionide.ProjInfo.ProjectSystem
 open FSharp.Compiler.Syntax
+open FSharp.Compiler.Text.Range
 
 
 [<RequireQualifiedAccess>]
@@ -1978,14 +1979,138 @@ type Commands(checker: FSharpCompilerServiceChecker, state: State, hasAnalyzers:
   /// calculates the required indent and gives the position to insert the text.
   static member GenerateXmlDocumentation(tyRes: ParseAndCheckResults, triggerPosition: Position, lineStr: LineStr) =
     asyncResult {
+      let longIdentContainsPos (longIdent: LongIdent) (pos: FSharp.Compiler.Text.pos) =
+        longIdent
+        |> List.tryFind (fun i -> rangeContainsPos i.idRange pos)
+        |> Option.isSome
+
+      let 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 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 isAstElemWithEmptyPreXmlDoc input pos =
+        match isLowerAstElemWithEmptyPreXmlDoc input pos with
+        | Some xml -> Some xml
+        | _ -> isModuleOrNamespaceOrAutoPropertyWithEmptyPreXmlDoc input pos
+
       let trimmed = lineStr.TrimStart(' ')
       let indentLength = lineStr.Length - trimmed.Length
       let indentString = String.replicate indentLength " "
 
-      match! Commands.SignatureData tyRes triggerPosition lineStr |> Result.ofCoreResponse with
+      match isAstElemWithEmptyPreXmlDoc tyRes.GetAST triggerPosition with
       | None -> return None
-      | Some(_, memberParameters, genericParameters) ->
+      | Some() ->
 
+        let signatureData =
+          Commands.SignatureData tyRes triggerPosition lineStr |> Result.ofCoreResponse
 
         let summarySection = "/// <summary></summary>"
 
@@ -2001,19 +2126,22 @@ type Commands(checker: FSharpCompilerServiceChecker, state: State, hasAnalyzers:
           seq {
             yield summarySection
 
-            match memberParameters with
-            | [] -> ()
-            | parameters ->
-              yield!
-                parameters
-                |> List.concat
-                |> List.mapi (fun _index parameter -> parameterSection parameter)
-
-            match genericParameters with
-            | [] -> ()
-            | generics -> yield! generics |> List.mapi (fun _index generic -> genericArg generic)
-
-            yield returnsSection
+            match signatureData with
+            | Ok(Some(_, memberParameters, genericParameters)) ->
+              match memberParameters with
+              | [] -> ()
+              | parameters ->
+                yield!
+                  parameters
+                  |> List.concat
+                  |> List.mapi (fun _index parameter -> parameterSection parameter)
+
+              match genericParameters with
+              | [] -> ()
+              | generics -> yield! generics |> List.mapi (fun _index generic -> genericArg generic)
+
+              yield returnsSection
+            | _ -> ()
           }
           |> Seq.map (fun s -> indentString + s)
           |> String.concat Environment.NewLine
diff --git a/src/FsAutoComplete/CodeFixes/GenerateXmlDocumentation.fs b/src/FsAutoComplete/CodeFixes/GenerateXmlDocumentation.fs
index 33a21dfe5..81c1d28b6 100644
--- a/src/FsAutoComplete/CodeFixes/GenerateXmlDocumentation.fs
+++ b/src/FsAutoComplete/CodeFixes/GenerateXmlDocumentation.fs
@@ -5,154 +5,34 @@ 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)
+      let! docEdit = Commands.GenerateXmlDocumentation(parseAndCheck, fcsPos, lineStr)
 
-        match docEdit with
-        | Some({ InsertPosition = insertPosition
-                 InsertText = formattedXmlDoc }) ->
-          let protocolPos = fcsPosToLsp insertPosition
+      match docEdit with
+      | Some({ InsertPosition = insertPosition
+               InsertText = formattedXmlDoc }) ->
+        let protocolPos = fcsPosToLsp insertPosition
 
-          let editRange =
-            { Start = protocolPos
-              End = protocolPos }
+        let editRange =
+          { Start = protocolPos
+            End = protocolPos }
 
-          let text = formattedXmlDoc
+        let text = formattedXmlDoc
 
-          return
-            [ { Edits = [| { Range = editRange; NewText = text } |]
-                File = codeActionParams.TextDocument
-                Title = title
-                SourceDiagnostic = None
-                Kind = FixKind.Refactor } ]
-        | _ -> return []
-      | None -> return []
+        return
+          [ { Edits = [| { Range = editRange; NewText = text } |]
+              File = codeActionParams.TextDocument
+              Title = title
+              SourceDiagnostic = None
+              Kind = FixKind.Refactor } ]
+      | _ -> return []
     }
diff --git a/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs b/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs
index 53b511529..07e8454fe 100644
--- a/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs
+++ b/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs
@@ -1493,17 +1493,21 @@ let private generateXmlDocumentationTests state =
           a + b
         """
 
-      testCaseAsync "not applicable for record type"
-      <| CodeFix.checkNotApplicable
+      testCaseAsync "documentation for record type"
+      <| CodeFix.check
         server
         """
         type MyRec$0ord = { Foo: int }
         """
         Diagnostics.acceptAll
         selectCodeFix
+        """
+        /// <summary></summary>
+        type MyRecord = { Foo: int }
+        """
 
-      testCaseAsync "not applicable for discriminated union type"
-      <| CodeFix.checkNotApplicable
+      testCaseAsync "documentation for discriminated union type"
+      <| CodeFix.check
         server
         """
         type Dis$0cUnionTest =
@@ -1512,9 +1516,15 @@ let private generateXmlDocumentationTests state =
         """
         Diagnostics.acceptAll
         selectCodeFix
+        """
+        /// <summary></summary>
+        type DiscUnionTest =
+          | Field1
+          | Field2
+        """
 
-      testCaseAsync "not applicable for discriminated union case"
-      <| CodeFix.checkNotApplicable
+      testCaseAsync "documentation for discriminated union case"
+      <| CodeFix.check
         server
         """
         type DiscUnionTest =
@@ -1523,9 +1533,15 @@ let private generateXmlDocumentationTests state =
         """
         Diagnostics.acceptAll
         selectCodeFix
+        """
+        type DiscUnionTest =
+          /// <summary></summary>
+          | Case1
+          | Case2
+        """
 
-      testCaseAsync "not applicable on enum type"
-      <| CodeFix.checkNotApplicable
+      testCaseAsync "documentation for enum type"
+      <| CodeFix.check
         server
         """
         type myE$0num =
@@ -1534,9 +1550,15 @@ let private generateXmlDocumentationTests state =
         """
         Diagnostics.acceptAll
         selectCodeFix
+        """
+        /// <summary></summary>
+        type myEnum =
+        | value1 = 1
+        | value2 = 2
+        """
 
-      testCaseAsync "not applicable on class type"
-      <| CodeFix.checkNotApplicable
+      testCaseAsync "documentation for class type"
+      <| CodeFix.check
         server
         """
         type MyC$0lass() =
@@ -1544,8 +1566,13 @@ let private generateXmlDocumentationTests state =
         """
         Diagnostics.acceptAll
         selectCodeFix
+        """
+        /// <summary></summary>
+        type MyClass() =
+          member val Name = "" with get, set
+        """
 
-      testCaseAsync "documentation on member"
+      testCaseAsync "documentation for member"
       <| CodeFix.check
         server
         """
@@ -1562,7 +1589,7 @@ let private generateXmlDocumentationTests state =
           new(x: int) = MyClass()
         """
 
-      testCaseAsync "documentation on autoproperty"
+      testCaseAsync "documentation for autoproperty"
       <| CodeFix.check
         server
         """
@@ -1578,8 +1605,8 @@ let private generateXmlDocumentationTests state =
           member val Name = "" with get, set
         """
       
-      testCaseAsync "not applicable on named module"
-      <| CodeFix.checkNotApplicable
+      testCaseAsync "documentation for named module"
+      <| CodeFix.check
         server
         """
         module $0M
@@ -1587,9 +1614,14 @@ let private generateXmlDocumentationTests state =
         """
         Diagnostics.acceptAll
         selectCodeFix
+        """
+        /// <summary></summary>
+        module M
+          let f x = x
+        """
         
-      testCaseAsync "not applicable on nested module"
-      <| CodeFix.checkNotApplicable
+      testCaseAsync "documentation for nested module"
+      <| CodeFix.check
         server
         """
         module M
@@ -1597,7 +1629,13 @@ let private generateXmlDocumentationTests state =
             let x = 3
         """
         Diagnostics.acceptAll
-        selectCodeFix ])
+        selectCodeFix
+        """
+        module M
+          /// <summary></summary>
+          module MyNestedModule =
+            let x = 3
+        """ ])
 
 let private generateAbstractClassStubTests state =
   let config = { defaultConfigDto with AbstractClassStubGeneration = Some true }