diff --git a/src/FsAutoComplete/CodeFixes/ConvertPositionalDUToNamed.fs b/src/FsAutoComplete/CodeFixes/ConvertPositionalDUToNamed.fs new file mode 100644 index 000000000..e1cce10cb --- /dev/null +++ b/src/FsAutoComplete/CodeFixes/ConvertPositionalDUToNamed.fs @@ -0,0 +1,162 @@ +/// A codefix that converts DU case matches from positional form to named form +/// +/// Given this type: +/// +/// type Person = Person of first: string * middle: string option * last: string +/// +/// +/// This codefix will take the following destructuring pattern: +/// +/// let (Person(f, m, l)) = person +/// +/// and convert it to the following pattern: +/// +/// let (Person(first = f; middle = m; last = l)) = person +/// +/// +module FsAutoComplete.CodeFix.ConvertPositionalDUToNamed + +open FsToolkit.ErrorHandling +open FsAutoComplete.CodeFix.Navigation +open FsAutoComplete.CodeFix.Types +open Ionide.LanguageServerProtocol.Types +open FsAutoComplete +open FsAutoComplete.LspHelpers +open FSharp.Compiler.CodeAnalysis +open FSharp.Compiler.Symbols +open FsAutoComplete.FCSPatches +open FSharp.Compiler.Syntax +open FSharp.Compiler.Syntax.SyntaxTraversal + +type ParseAndCheckResults with + member x.TryGetPositionalUnionPattern(pos: FcsPos) = + let rec (|UnionNameAndPatterns|_|) = + function + | SynPat.LongIdent (longDotId = ident + argPats = SynArgPats.Pats [ SynPat.Paren (pat = SynPat.Tuple (elementPats = duFieldPatterns) + range = parenRange) ]) -> + Some(ident, duFieldPatterns, parenRange) + | SynPat.LongIdent (longDotId = ident + argPats = SynArgPats.Pats [ SynPat.Paren (pat = singleDUFieldPattern; range = parenRange) ]) -> + Some(ident, [ singleDUFieldPattern ], parenRange) + | SynPat.Paren(pat = UnionNameAndPatterns (ident, duFieldPatterns, parenRange)) -> + Some(ident, duFieldPatterns, parenRange) + | SynPat.Paren(pat = UnionNameAndPatterns (ident, duFieldPatterns, parenRange)) -> + Some(ident, duFieldPatterns, parenRange) + | _ -> None + + let visitor = + { new SyntaxVisitorBase<_>() with + member x.VisitBinding(path, defaultTraverse, binding) = + match binding with + // DU case with multiple + | SynBinding(headPat = UnionNameAndPatterns (ident, duFieldPatterns, parenRange)) -> + Some(ident, duFieldPatterns, parenRange) + | _ -> defaultTraverse binding + + // I shouldn't have to override my own VisitExpr, but the default traversal doesn't seem to be triggering the `VisitMatchClause` method I've defined below. + member x.VisitExpr(path, traverse, defaultTraverse, expr) = + match expr with + | SynExpr.Match (expr = argExpr; clauses = clauses) -> + let path = SyntaxNode.SynExpr argExpr :: path + + match x.VisitExpr(path, traverse, defaultTraverse, argExpr) with + | Some x -> Some x + | None -> + clauses + |> List.tryPick (function + | SynMatchClause(pat = UnionNameAndPatterns (ident, duFieldPatterns, parenRange)) -> + Some(ident, duFieldPatterns, parenRange) + | _ -> None) + | _ -> defaultTraverse expr + + member x.VisitMatchClause(path, defaultTraverse, matchClause) = + match matchClause with + | SynMatchClause(pat = UnionNameAndPatterns (ident, duFieldPatterns, parenRange)) -> + Some(ident, duFieldPatterns, parenRange) + | _ -> defaultTraverse matchClause } + + Traverse(pos, x.GetParseResults.ParseTree, visitor) + +let private (|MatchedFields|UnmatchedFields|NotEnoughFields|) (astFields: SynPat list, unionFields: string list) = + let userFieldsCount = astFields.Length + let typeFieldsCount = unionFields.Length + + match compare userFieldsCount typeFieldsCount with + | -1 -> UnmatchedFields(List.zip astFields unionFields[0 .. userFieldsCount - 1], unionFields.[userFieldsCount..]) + | 0 -> MatchedFields(List.zip astFields unionFields) + | 1 -> NotEnoughFields + | _ -> failwith "impossible" + +let private createEdit (astField: SynPat, duField: string) : TextEdit list = + let prefix = $"{duField} = " + let startRange = astField.Range.Start |> fcsPosToProtocolRange + let suffix = "; " + let endRange = astField.Range.End |> fcsPosToProtocolRange + + [ { NewText = prefix; Range = startRange } + { NewText = suffix; Range = endRange } ] + +let private createWildCard endRange (duField: string) : TextEdit = + let wildcard = $"{duField} = _; " + let range = endRange + { NewText = wildcard; Range = range } + +let fix (getParseResultsForFile: GetParseResultsForFile) (getRangeText: GetRangeText) : 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! (duIdent, duFields, parenRange) = + parseAndCheck.TryGetPositionalUnionPattern(fcsPos) + |> Result.ofOption (fun _ -> "Not inside a DU pattern") + + let! symbolUse = + parseAndCheck.TryGetSymbolUse duIdent.Range.Start lineStr + |> Result.ofOption (fun _ -> "No matching symbol for position") + + let! unionCase = + match symbolUse.Symbol with + | :? FSharpUnionCase as uc -> Ok uc + | _ -> Error "Not a union case" + + let allFieldNames = + unionCase.Fields + |> List.ofSeq + |> List.map (fun f -> f.Name) + + let! edits = + match (duFields, allFieldNames) with + | MatchedFields pairs -> pairs |> List.collect createEdit |> List.toArray |> Ok + + | UnmatchedFields (pairs, leftover) -> + result { + let! endPos = + dec sourceText (fcsPosToLsp parenRange.End) + |> Option.map protocolPosToRange + |> Result.ofOption (fun _ -> "No end position for range") + + let matchedEdits = pairs |> List.collect createEdit + let leftoverEdits = leftover |> List.map (createWildCard endPos) + + return + List.append matchedEdits leftoverEdits + |> List.toArray + } + | NotEnoughFields -> Ok [||] + + match edits with + | [||] -> return [] + | edits -> + return + [ { Edits = edits + File = codeActionParams.TextDocument + Title = "Convert to named patterns" + SourceDiagnostic = None + Kind = FixKind.Refactor } ] + } diff --git a/src/FsAutoComplete/FsAutoComplete.Lsp.fs b/src/FsAutoComplete/FsAutoComplete.Lsp.fs index eaefbc621..4b67ac908 100644 --- a/src/FsAutoComplete/FsAutoComplete.Lsp.fs +++ b/src/FsAutoComplete/FsAutoComplete.Lsp.fs @@ -828,7 +828,8 @@ type FSharpLspServer(backgroundServiceEnabled: bool, state: State, lspClient: FS AddTypeToIndeterminateValue.fix tryGetParseResultsForFile tryGetProjectOptions ChangeTypeOfNameToNameOf.fix tryGetParseResultsForFile AddMissingInstanceMember.fix - AddExplicitTypeToParameter.fix tryGetParseResultsForFile |] + AddExplicitTypeToParameter.fix tryGetParseResultsForFile + ConvertPositionalDUToNamed.fix tryGetParseResultsForFile getRangeText |] match p.RootPath, c.AutomaticWorkspaceInit with diff --git a/src/FsAutoComplete/LspHelpers.fs b/src/FsAutoComplete/LspHelpers.fs index 9df8e5bdc..2fa2729f6 100644 --- a/src/FsAutoComplete/LspHelpers.fs +++ b/src/FsAutoComplete/LspHelpers.fs @@ -23,9 +23,13 @@ module Conversions = let protocolPosToPos (pos: Lsp.Position): FcsPos = FcsPos.mkPos (pos.Line + 1) (pos.Character) + let protocolPosToRange (pos: Lsp.Position): Lsp.Range = + { Start = pos; End = pos } + /// convert a compiler position to an LSP position - let fcsPosToLsp (pos: FcsPos): Lsp.Position = - { Line = pos.Line - 1; Character = pos.Column } + let fcsPosToLsp (pos: FcsPos) : Lsp.Position = + { Line = pos.Line - 1 + Character = pos.Column } /// convert a compiler range to an LSP range let fcsRangeToLsp(range: FcsRange): Lsp.Range = diff --git a/test/FsAutoComplete.Tests.Lsp/CodeFixTests.fs b/test/FsAutoComplete.Tests.Lsp/CodeFixTests.fs index ef9a31c33..2fb5c347a 100644 --- a/test/FsAutoComplete.Tests.Lsp/CodeFixTests.fs +++ b/test/FsAutoComplete.Tests.Lsp/CodeFixTests.fs @@ -67,7 +67,7 @@ let abstractClassGenerationTests state = | Ok (Some (TextDocumentCodeActionResult.CodeActions [| { Title = "Generate abstract class members" } |])) -> () | Ok other -> failtestf $"Should have generated the rest of the base class, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) + }) let canGenerateForIdent = testCaseAsync @@ -90,7 +90,7 @@ let abstractClassGenerationTests state = | Ok (Some (TextDocumentCodeActionResult.CodeActions [| { Title = "Generate abstract class members" } |])) -> () | Ok other -> failtestf $"Should have generated the rest of the base class, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) + }) testList "abstract class generation" @@ -100,8 +100,7 @@ let abstractClassGenerationTests state = let generateMatchTests state = let server = async { - let path = - Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "MatchCaseGeneration") + let path = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "MatchCaseGeneration") let! (server, events) = serverInitialize path { defaultConfigDto with UnionCaseStubGeneration = Some true } state do! waitForWorkspaceFinishedParsing events @@ -137,13 +136,12 @@ let generateMatchTests state = () | Ok other -> failtestf $"Should have generated the rest of match cases, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) ] + }) ] let missingFunKeywordTests state = let server = async { - let path = - Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "MissingFunKeyword") + let path = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "MissingFunKeyword") let! (server, events) = serverInitialize path defaultConfigDto state do! waitForWorkspaceFinishedParsing events @@ -181,13 +179,12 @@ let missingFunKeywordTests state = () | Ok other -> failtestf $"Should have generated missing fun keyword, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) ] + }) ] let outerBindingRecursiveTests state = let server = async { - let path = - Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "OuterBindingRecursive") + let path = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "OuterBindingRecursive") let! (server, events) = serverInitialize path defaultConfigDto state do! waitForWorkspaceFinishedParsing events @@ -225,7 +222,7 @@ let outerBindingRecursiveTests state = () | Ok other -> failtestf $"Should have generated a rec keyword, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) ] + }) ] let nameofInsteadOfTypeofNameTests state = let server = @@ -269,13 +266,12 @@ let nameofInsteadOfTypeofNameTests state = () | Ok other -> failtestf $"Should have generated nameof, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) ] + }) ] let missingInstanceMemberTests state = let server = async { - let path = - Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "MissingInstanceMember") + let path = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "MissingInstanceMember") let! (server, events) = serverInitialize path defaultConfigDto state do! waitForWorkspaceFinishedParsing events @@ -313,7 +309,7 @@ let missingInstanceMemberTests state = () | Ok other -> failtestf $"Should have generated an instance member, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) ] + }) ] let unusedValueTests state = let (|ActReplace|_|) = (|Refactor|_|) "Replace with _" "_" @@ -323,11 +319,9 @@ let unusedValueTests state = let server = async { - let path = - Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "UnusedValue") + let path = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "UnusedValue") - let cfg = - { defaultConfigDto with UnusedDeclarationsAnalyzer = Some true } + let cfg = { defaultConfigDto with UnusedDeclarationsAnalyzer = Some true } let! (server, events) = serverInitialize path cfg state do! waitForWorkspaceFinishedParsing events @@ -366,7 +360,7 @@ let unusedValueTests state = | Ok (Some (TextDocumentCodeActionResult.CodeActions [| ActReplace |])) -> () | Ok other -> failtestf $"Should have generated _, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) + }) let canReplaceUnusedBinding = testCaseAsync @@ -390,7 +384,7 @@ let unusedValueTests state = | Ok (Some (TextDocumentCodeActionResult.CodeActions [| ActReplace; ActPrefix "six" |])) -> () | Ok other -> failtestf $"Should have generated _, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) + }) let canReplaceUnusedParameter = testCaseAsync @@ -416,7 +410,7 @@ let unusedValueTests state = _ (* explicit type annotation codefix *) |])) -> () | Ok other -> failtestf $"Should have generated _, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) + }) testList "unused value" @@ -425,19 +419,15 @@ let unusedValueTests state = canReplaceUnusedParameter ] let removeUnusedBindingTests state = - let (|RemoveBinding|_|) = - (|Refactor|_|) "Remove unused binding" "" + let (|RemoveBinding|_|) = (|Refactor|_|) "Remove unused binding" "" - let (|RemoveParameter|_|) = - (|Refactor|_|) "Remove unused parameter" "" + let (|RemoveParameter|_|) = (|Refactor|_|) "Remove unused parameter" "" let server = async { - let path = - Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "RemoveUnusedBinding") + let path = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "RemoveUnusedBinding") - let cfg = - { defaultConfigDto with FSIExtraParameters = Some [| "--warnon:1182" |] } + let cfg = { defaultConfigDto with FSIExtraParameters = Some [| "--warnon:1182" |] } let! (server, events) = serverInitialize path cfg state do! waitForWorkspaceFinishedParsing events @@ -478,7 +468,7 @@ let removeUnusedBindingTests state = _ (* explicit type annotation codefix *) |])) -> () | Ok other -> failtestf $"Should have generated _, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) + }) let canRemoveUnusedSingleCharacterFunctionParameterInParens = testCaseAsync @@ -504,7 +494,7 @@ let removeUnusedBindingTests state = _ (* explicit type annotation codefix *) |])) -> () | Ok other -> failtestf $"Should have generated _, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) + }) let canRemoveUnusedBindingInsideTopLevel = testCaseAsync @@ -529,7 +519,7 @@ let removeUnusedBindingTests state = | Ok (Some (TextDocumentCodeActionResult.CodeActions [| RemoveBinding & AtRange replacementRange |])) -> () | Ok other -> failtestf $"Should have generated _, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) + }) testList @@ -560,8 +550,7 @@ let addExplicitTypeAnnotationTests state = } |> Async.Cache - let (|ExplicitAnnotation|_|) = - (|Refactor|_|) "Add explicit type annotation" + let (|ExplicitAnnotation|_|) = (|Refactor|_|) "Add explicit type annotation" testList "explicit type annotations" @@ -581,13 +570,12 @@ let addExplicitTypeAnnotationTests state = | Ok (Some (TextDocumentCodeActionResult.CodeActions [| ExplicitAnnotation "(f: Foo)" |])) -> () | Ok other -> failtestf $"Should have generated explicit type annotation, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) ] + }) ] let negationToSubstraction state = let server = async { - let path = - Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "NegationToSubstraction") + let path = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "NegationToSubstraction") let cfg = defaultConfigDto let! (server, events) = serverInitialize path cfg state @@ -605,8 +593,7 @@ let negationToSubstraction state = } |> Async.Cache - let (|NegationToSubstraction|_|) = - (|Refactor|_|) "Negation to substraction" + let (|NegationToSubstraction|_|) = (|Refactor|_|) "Negation to substraction" testList "negation to substraction" @@ -615,7 +602,6 @@ let negationToSubstraction state = (async { let! (server, filePath, diagnostics) = server - printfn "%A" diagnostics let diagnostic = diagnostics |> Array.tryFind (fun d -> d.Code = Some "3" && d.Range.Start.Line = 2) @@ -631,23 +617,163 @@ let negationToSubstraction state = match! server.TextDocumentCodeAction context with | Ok (Some (TextDocumentCodeActionResult.CodeActions [| { Title = "Use subtraction instead of negation" Kind = Some "quickfix" - Edit = Some { - DocumentChanges = Some [| { - Edits = [|{ - Range = { - Start = { - Line = 2; - Character = 15 }; - End = { - Line = 2; - Character = 16 } - }; - NewText = "- " - }|] }|] } } |])) - -> () + Edit = Some { DocumentChanges = Some [| { Edits = [| { Range = { Start = { Line = 2 + Character = 15 } + End = { Line = 2 + Character = 16 } } + NewText = "- " } |] } |] } } |])) -> + () | Ok other -> failtestf $"Should have converted negation to substraction, but instead generated %A{other}" | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" - }) ] + }) ] + +let positionalToNamedDUTests state = + let server = + async { + let path = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "PositionalToNamedDU") + + let cfg = defaultConfigDto + let! (server, events) = serverInitialize path cfg state + do! waitForWorkspaceFinishedParsing events + let path = Path.Combine(path, "Script.fsx") + let tdop: DidOpenTextDocumentParams = { TextDocument = loadDocument path } + do! server.TextDocumentDidOpen tdop + + let! diagnostics = + events + |> waitForParseResultsForFile "Script.fsx" + |> AsyncResult.bimap (fun _ -> failtest "Should have had errors") id + + return (server, path) + } + |> Async.Cache + + let expectEdits invokePos edits = + async { + let! (server, filePath) = server + + let context: CodeActionParams = + { Context = { Diagnostics = [||] } + Range = invokePos + TextDocument = { Uri = Path.FilePathToUri filePath } } + + match! server.TextDocumentCodeAction context with + | Ok (Some (TextDocumentCodeActionResult.CodeActions [| { Title = "Convert to named patterns" + Kind = Some "refactor" + Edit = Some { DocumentChanges = Some [| { Edits = es } |] } } |])) when + es = edits + -> + () + | Ok other -> failtestf $"Should have converted positional DUs to named patterns, but instead generated %A{other}" + | Error reason -> failtestf $"Should have succeeded, but failed with %A{reason}" + } + + testList + "convert positional DU match to named" + [ testCaseAsync + "in parenthesized let binding" + (let patternPos = + { Start = { Line = 2; Character = 9 } + End = { Line = 2; Character = 10 } } + + let edits = + [| { Range = + { Start = { Line = 2; Character = 7 } + End = { Line = 2; Character = 7 } } + NewText = "a = " } + { Range = + { Start = { Line = 2; Character = 8 } + End = { Line = 2; Character = 8 } } + NewText = "; " } + { Range = + { Start = { Line = 2; Character = 10 } + End = { Line = 2; Character = 10 } } + NewText = "b = " } + { Range = + { Start = { Line = 2; Character = 11 } + End = { Line = 2; Character = 11 } } + NewText = "; " } |] + + expectEdits patternPos edits) + testCaseAsync + "in simple match" + (let patternPos = + { Start = { Line = 5; Character = 5 } + End = { Line = 5; Character = 6 } } + + let edits = + [| { Range = + { Start = { Line = 5; Character = 4 } + End = { Line = 5; Character = 4 } } + NewText = "a = " } + { Range = + { Start = { Line = 5; Character = 5 } + End = { Line = 5; Character = 5 } } + NewText = "; " } + { Range = + { Start = { Line = 5; Character = 7 } + End = { Line = 5; Character = 7 } } + NewText = "b = " } + { Range = + { Start = { Line = 5; Character = 8 } + End = { Line = 5; Character = 8 } } + NewText = "; " } |] + + expectEdits patternPos edits) + testCaseAsync + "in parenthesized match" + (let patternPos = + { Start = { Line = 8; Character = 7 } + End = { Line = 8; Character = 8 } } + + let edits = + [| { Range = + { Start = { Line = 8; Character = 5 } + End = { Line = 8; Character = 5 } } + NewText = "a = " } + { Range = + { Start = { Line = 8; Character = 6 } + End = { Line = 8; Character = 6 } } + NewText = "; " } + { Range = + { Start = { Line = 8; Character = 8 } + End = { Line = 8; Character = 8 } } + NewText = "b = " } + { Range = + { Start = { Line = 8; Character = 9 } + End = { Line = 8; Character = 9 } } + NewText = "; " } |] + + expectEdits patternPos edits) + testCaseAsync + "when there are new fields on the DU" + (let patternPos = + { Start = { Line = 12; Character = 29 } + End = { Line = 12; Character = 30 } } + + let edits = + [| { Range = + { Start = { Line = 12; Character = 28 } + End = { Line = 12; Character = 28 } } + NewText = "a = " } + { Range = + { Start = { Line = 12; Character = 29 } + End = { Line = 12; Character = 29 } } + NewText = "; " } + { Range = + { Start = { Line = 12; Character = 31 } + End = { Line = 12; Character = 31 } } + NewText = "b = " } + { Range = + { Start = { Line = 12; Character = 32 } + End = { Line = 12; Character = 32 } } + NewText = "; " } + { Range = + { Start = { Line = 12; Character = 32 } + End = { Line = 12; Character = 32 } } + NewText = "c = _; " } |] + + expectEdits patternPos edits) ] let tests state = testList @@ -661,5 +787,5 @@ let tests state = unusedValueTests state addExplicitTypeAnnotationTests state negationToSubstraction state - // removeUnusedBindingTests state - ] + removeUnusedBindingTests state + positionalToNamedDUTests state ] diff --git a/test/FsAutoComplete.Tests.Lsp/TestCases/PositionalToNamedDU/Script.fsx b/test/FsAutoComplete.Tests.Lsp/TestCases/PositionalToNamedDU/Script.fsx new file mode 100644 index 000000000..136ec8017 --- /dev/null +++ b/test/FsAutoComplete.Tests.Lsp/TestCases/PositionalToNamedDU/Script.fsx @@ -0,0 +1,13 @@ +type A = A of a: int * b: bool + +let (A(a, b)) = A(1, true) + +match A(1, true) with +| A(a, b) -> () + +match A(1, true) with +| (A(a, b)) -> () + +type ThirdFieldWasJustAdded = ThirdFieldWasJustAdded of a: int * b: bool * c: char + +let (ThirdFieldWasJustAdded(a, b)) = ThirdFieldWasJustAdded(1, true, 'c')