From 7f02992b4a9d661d75ea92cc3229014d4dd4591e Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Thu, 4 Aug 2022 18:12:38 +0530 Subject: [PATCH 1/4] Remove exactprint dependencies from ghcide by introducing hls-refactor-plugin. All code actions have been moved to hls-refactor-plugin Mostly straightforward, only slight complication was that completion auto imports depends on exactprint, but I didn't want to remove all completion logic from ghcide just for this. Instead, I added logic to dynamically lookup the plugin that provides the extend import command, so that auto imports work as expected when you have hls-refactor-plugin enabled. Move lookupPluginId out of loop Replace code actions with lenses in benchmarks Allow plugins to use GetAnnotatedParsedSource by linking it in when depended on Move lookupPluginId to IdePlugins Add default extensions Move traceAst --- .github/workflows/test.yml | 4 + cabal.project | 1 + ghcide-bench/src/Experiments.hs | 14 +- ghcide/ghcide.cabal | 60 +- ghcide/src/Development/IDE/Core/Rules.hs | 5 - ghcide/src/Development/IDE/Core/Service.hs | 5 +- ghcide/src/Development/IDE/Core/Shake.hs | 6 +- ghcide/src/Development/IDE/GHC/Compat.hs | 2 - ghcide/src/Development/IDE/GHC/Orphans.hs | 8 - ghcide/src/Development/IDE/GHC/Util.hs | 32 - ghcide/src/Development/IDE/Main.hs | 5 +- .../src/Development/IDE/Plugin/Completions.hs | 81 +- .../IDE/Plugin/Completions/Logic.hs | 20 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 2 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 5 - ghcide/test/exe/Main.hs | 3567 +--------------- haskell-language-server.cabal | 11 + .../Development/IDE/Graph/Internal/Rules.hs | 2 +- hls-plugin-api/src/Ide/PluginUtils.hs | 4 +- hls-plugin-api/src/Ide/Types.hs | 28 +- .../hls-code-range-plugin.cabal | 1 + .../src/Ide/Plugin/CodeRange.hs | 6 +- .../src/Ide/Plugin/CodeRange/Rules.hs | 3 +- plugins/hls-gadt-plugin/hls-gadt-plugin.cabal | 1 + plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs | 1 + .../hls-haddock-comments-plugin.cabal | 1 + .../src/Ide/Plugin/HaddockComments.hs | 7 +- .../hls-haddock-comments-plugin/test/Main.hs | 2 +- plugins/hls-refactor-plugin/LICENSE | 201 + .../hls-refactor-plugin.cabal | 116 + .../Development/IDE/GHC/Compat/ExactPrint.hs | 4 - .../src/Development/IDE/GHC/Dump.hs | 1 + .../src/Development/IDE/GHC/ExactPrint.hs | 17 +- .../src/Development/IDE/Plugin/CodeAction.hs | 144 +- .../Development/IDE/Plugin/CodeAction/Args.hs | 4 +- .../IDE/Plugin/CodeAction/ExactPrint.hs | 12 +- .../IDE/Plugin/CodeAction/PositionIndexed.hs | 0 .../IDE/Plugin/CodeAction/RuleTypes.hs | 1 - .../Development/IDE/Plugin/CodeAction/Util.hs | 56 + plugins/hls-refactor-plugin/test/Main.hs | 3747 +++++++++++++++++ .../test/data/hiding/AVec.hs | 0 .../test/data/hiding/BVec.hs | 0 .../test/data/hiding/CVec.hs | 0 .../test/data/hiding/DVec.hs | 0 .../test/data/hiding/EVec.hs | 0 .../test/data/hiding/FVec.hs | 0 .../hiding/HideFunction.expected.append.E.hs | 0 .../HideFunction.expected.append.Prelude.hs | 0 .../HideFunction.expected.fromList.A.hs | 0 .../HideFunction.expected.fromList.B.hs | 0 ...ction.expected.qualified.append.Prelude.hs | 0 ...eFunction.expected.qualified.fromList.E.hs | 0 .../test/data/hiding/HideFunction.hs | 0 .../HideFunctionWithoutLocal.expected.hs | 0 .../data/hiding/HideFunctionWithoutLocal.hs | 0 .../hiding/HidePreludeIndented.expected.hs | 0 .../test/data/hiding/HidePreludeIndented.hs | 0 .../hiding/HidePreludeLocalInfix.expected.hs | 0 .../test/data/hiding/HidePreludeLocalInfix.hs | 0 ...deQualifyDuplicateRecordFields.expected.hs | 0 .../HideQualifyDuplicateRecordFields.hs | 0 .../HideQualifyDuplicateRecordFieldsSelf.hs | 0 .../data/hiding/HideQualifyInfix.expected.hs | 0 .../test/data/hiding/HideQualifyInfix.hs | 0 .../hiding/HideQualifySectionLeft.expected.hs | 0 .../data/hiding/HideQualifySectionLeft.hs | 0 .../HideQualifySectionRight.expected.hs | 0 .../data/hiding/HideQualifySectionRight.hs | 0 .../test/data/hiding/HideType.expected.A.hs | 0 .../test/data/hiding/HideType.expected.E.hs | 0 .../test/data/hiding/HideType.hs | 0 .../test/data/hiding/hie.yaml | 1 + .../test/data/hover/Bar.hs | 4 + .../test/data/hover/Foo.hs | 6 + .../test/data/hover/GotoHover.hs | 66 + .../test/data/hover/RecordDotSyntax.hs | 21 + .../test/data/hover/hie.yaml | 1 + .../import-placement/CommentAtTop.expected.hs | 0 .../data/import-placement/CommentAtTop.hs | 0 .../CommentAtTopMultipleComments.expected.hs | 0 .../CommentAtTopMultipleComments.hs | 0 .../CommentCurlyBraceAtTop.expected.hs | 0 .../CommentCurlyBraceAtTop.hs | 0 .../import-placement/DataAtTop.expected.hs | 0 .../test/data/import-placement/DataAtTop.hs | 0 .../import-placement/ImportAtTop.expected.hs | 0 .../test/data/import-placement/ImportAtTop.hs | 0 .../LangPragmaModuleAtTop.expected.hs | 0 .../import-placement/LangPragmaModuleAtTop.hs | 0 ...angPragmaModuleExplicitExports.expected.hs | 0 .../LangPragmaModuleExplicitExports.hs | 0 .../LangPragmaModuleWithComment.expected.hs | 0 .../LangPragmaModuleWithComment.hs | 0 .../LanguagePragmaAtTop.expected.hs | 0 .../import-placement/LanguagePragmaAtTop.hs | 0 ...LanguagePragmaAtTopWithComment.expected.hs | 0 .../LanguagePragmaAtTopWithComment.hs | 0 .../LanguagePragmasThenShebangs.expected.hs | 0 .../LanguagePragmasThenShebangs.hs | 0 .../ModuleDeclAndImports.expected.hs | 0 .../import-placement/ModuleDeclAndImports.hs | 0 .../MultiLineCommentAtTop.expected.hs | 0 .../import-placement/MultiLineCommentAtTop.hs | 0 .../MultiLinePragma.expected.hs | 0 .../data/import-placement/MultiLinePragma.hs | 0 .../MultipleImportsAtTop.expected.hs | 0 .../import-placement/MultipleImportsAtTop.hs | 0 ...uagePragmasNoModuleDeclaration.expected.hs | 0 ...tipleLanguagePragmasNoModuleDeclaration.hs | 0 .../import-placement/NewTypeAtTop.expected.hs | 0 .../data/import-placement/NewTypeAtTop.hs | 0 .../NoExplicitExportCommentAtTop.expected.hs | 0 .../NoExplicitExportCommentAtTop.hs | 0 .../NoExplicitExports.expected.hs | 0 .../import-placement/NoExplicitExports.hs | 0 .../NoModuleDeclaration.expected.hs | 0 .../import-placement/NoModuleDeclaration.hs | 0 ...oModuleDeclarationCommentAtTop.expected.hs | 0 .../NoModuleDeclarationCommentAtTop.hs | 0 .../OptionsNotAtTopWithSpaces.expected.hs | 0 .../OptionsNotAtTopWithSpaces.hs | 0 .../OptionsPragmaNotAtTop.expected.hs | 0 .../import-placement/OptionsPragmaNotAtTop.hs | 0 ...PragmaNotAtTopMultipleComments.expected.hs | 0 .../PragmaNotAtTopMultipleComments.hs | 0 ...ragmaNotAtTopWithCommentsAtTop.expected.hs | 0 .../PragmaNotAtTopWithCommentsAtTop.hs | 0 .../PragmaNotAtTopWithImports.expected.hs | 0 .../PragmaNotAtTopWithImports.hs | 0 .../PragmaNotAtTopWithModuleDecl.expected.hs | 0 .../PragmaNotAtTopWithModuleDecl.hs | 0 .../PragmasAndShebangsNoComment.expected.hs | 0 .../PragmasAndShebangsNoComment.hs | 0 .../PragmasShebangsAndModuleDecl.expected.hs | 0 .../PragmasShebangsAndModuleDecl.hs | 0 ...sShebangsModuleExplicitExports.expected.hs | 0 .../PragmasShebangsModuleExplicitExports.hs | 0 ...asThenShebangsMultilineComment.expected.hs | 0 .../PragmasThenShebangsMultilineComment.hs | 0 .../ShebangNotAtTop.expected.hs | 0 .../data/import-placement/ShebangNotAtTop.hs | 0 .../ShebangNotAtTopNoSpace.expected.hs | 0 .../ShebangNotAtTopNoSpace.hs | 0 .../ShebangNotAtTopWithSpaces.expected.hs | 0 .../ShebangNotAtTopWithSpaces.hs | 0 .../TwoDashOnlyComment.expected.hs | 0 .../import-placement/TwoDashOnlyComment.hs | 0 .../WhereDeclLowerInFile.expected.hs | 0 .../import-placement/WhereDeclLowerInFile.hs | 0 ...owerInFileWithCommentsBeforeIt.expected.hs | 0 ...hereDeclLowerInFileWithCommentsBeforeIt.hs | 0 ...ereKeywordLowerInFileNoExports.expected.hs | 0 .../WhereKeywordLowerInFileNoExports.hs | 0 .../hls-rename-plugin/hls-rename-plugin.cabal | 1 + .../src/Ide/Plugin/Rename.hs | 7 +- plugins/hls-rename-plugin/test/Main.hs | 2 +- .../hls-splice-plugin/hls-splice-plugin.cabal | 1 + .../src/Ide/Plugin/Splice.hs | 1 + .../hls-tactics-plugin.cabal | 1 + .../src/Wingman/LanguageServer.hs | 1 + .../hls-tactics-plugin/src/Wingman/Plugin.hs | 9 +- src/HlsPlugins.hs | 15 +- stack-lts16.yaml | 1 + stack-lts19.yaml | 1 + stack.yaml | 1 + 165 files changed, 4529 insertions(+), 3798 deletions(-) create mode 100644 plugins/hls-refactor-plugin/LICENSE create mode 100644 plugins/hls-refactor-plugin/hls-refactor-plugin.cabal rename {ghcide => plugins/hls-refactor-plugin}/src/Development/IDE/GHC/Compat/ExactPrint.hs (91%) rename {ghcide => plugins/hls-refactor-plugin}/src/Development/IDE/GHC/Dump.hs (99%) rename {ghcide => plugins/hls-refactor-plugin}/src/Development/IDE/GHC/ExactPrint.hs (98%) rename {ghcide => plugins/hls-refactor-plugin}/src/Development/IDE/Plugin/CodeAction.hs (93%) rename {ghcide => plugins/hls-refactor-plugin}/src/Development/IDE/Plugin/CodeAction/Args.hs (99%) rename {ghcide => plugins/hls-refactor-plugin}/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs (99%) rename {ghcide => plugins/hls-refactor-plugin}/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs (96%) create mode 100644 plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs create mode 100644 plugins/hls-refactor-plugin/test/Main.hs rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/AVec.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/BVec.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/CVec.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/DVec.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/EVec.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/FVec.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideFunction.expected.append.E.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideFunction.expected.append.Prelude.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideFunction.expected.fromList.A.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideFunction.expected.fromList.B.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideFunction.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideFunctionWithoutLocal.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideFunctionWithoutLocal.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HidePreludeIndented.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HidePreludeIndented.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HidePreludeLocalInfix.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HidePreludeLocalInfix.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideQualifyDuplicateRecordFields.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideQualifyInfix.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideQualifyInfix.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideQualifySectionLeft.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideQualifySectionLeft.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideQualifySectionRight.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideQualifySectionRight.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideType.expected.A.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideType.expected.E.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/HideType.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/hiding/hie.yaml (90%) create mode 100644 plugins/hls-refactor-plugin/test/data/hover/Bar.hs create mode 100644 plugins/hls-refactor-plugin/test/data/hover/Foo.hs create mode 100644 plugins/hls-refactor-plugin/test/data/hover/GotoHover.hs create mode 100644 plugins/hls-refactor-plugin/test/data/hover/RecordDotSyntax.hs create mode 100644 plugins/hls-refactor-plugin/test/data/hover/hie.yaml rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/CommentAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/CommentAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/CommentAtTopMultipleComments.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/CommentAtTopMultipleComments.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/CommentCurlyBraceAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/DataAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/DataAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ImportAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ImportAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LangPragmaModuleAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LangPragmaModuleAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LangPragmaModuleExplicitExports.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LangPragmaModuleWithComment.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LangPragmaModuleWithComment.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LanguagePragmaAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LanguagePragmaAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LanguagePragmaAtTopWithComment.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/LanguagePragmasThenShebangs.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ModuleDeclAndImports.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ModuleDeclAndImports.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/MultiLineCommentAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/MultiLineCommentAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/MultiLinePragma.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/MultiLinePragma.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/MultipleImportsAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/MultipleImportsAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NewTypeAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NewTypeAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NoExplicitExportCommentAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NoExplicitExports.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NoExplicitExports.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NoModuleDeclaration.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NoModuleDeclaration.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/OptionsNotAtTopWithSpaces.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/OptionsPragmaNotAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmaNotAtTopMultipleComments.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmaNotAtTopWithImports.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmasAndShebangsNoComment.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmasShebangsAndModuleDecl.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/PragmasThenShebangsMultilineComment.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ShebangNotAtTop.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ShebangNotAtTop.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ShebangNotAtTopNoSpace.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/ShebangNotAtTopWithSpaces.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/TwoDashOnlyComment.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/TwoDashOnlyComment.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/WhereDeclLowerInFile.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/WhereDeclLowerInFile.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs (100%) rename {ghcide => plugins/hls-refactor-plugin}/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs (100%) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 5b963a662d..4891398af9 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -160,6 +160,10 @@ jobs: name: Test hls-brittany-plugin run: cabal test hls-brittany-plugin --test-options="$TEST_OPTS" || cabal test hls-brittany-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-brittany-plugin --test-options="$TEST_OPTS" + - if: matrix.test + name: Test hls-refactor-plugin + run: cabal test hls-refactor-plugin --test-options="$TEST_OPTS" || cabal test hls-refactor-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refactor-plugin --test-options="$TEST_OPTS" + - if: matrix.test name: Test hls-floskell-plugin run: cabal test hls-floskell-plugin --test-options="$TEST_OPTS" || cabal test hls-floskell-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-floskell-plugin --test-options="$TEST_OPTS" diff --git a/cabal.project b/cabal.project index 047c2efcc2..91d017ccdf 100644 --- a/cabal.project +++ b/cabal.project @@ -32,6 +32,7 @@ packages: ./plugins/hls-stan-plugin ./plugins/hls-gadt-plugin ./plugins/hls-explicit-fixity-plugin + ./plugins/hls-refactor-plugin -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 1d8d6f6c5b..2d756d73fd 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -139,7 +139,7 @@ experiments = not . null <$> getCompletions doc (fromJust identifierP), --------------------------------------------------------------------------------------- benchWithSetup - "code actions" + "code lens" ( \docs -> do unless (any (isJust . identifierP) docs) $ error "None of the example modules is suitable for this experiment" @@ -148,13 +148,12 @@ experiments = waitForProgressStart waitForProgressDone ) - ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> - forM identifierP $ \p -> - getCodeActions doc (Range p p)) + ( \docs -> not . null <$> forM docs (\DocumentPositions{..} -> + getCodeLenses doc) ), --------------------------------------------------------------------------------------- benchWithSetup - "code actions after edit" + "code lens after edit" ( \docs -> do unless (any (isJust . identifierP) docs) $ error "None of the example modules is suitable for this experiment" @@ -166,9 +165,8 @@ experiments = changeDoc doc [charEdit stringLiteralP] waitForProgressStart waitForProgressDone - not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do - forM identifierP $ \p -> - getCodeActions doc (Range p p)) + not . null <$> forM docs (\DocumentPositions{..} -> do + getCodeLenses doc) ), --------------------------------------------------------------------------------------- benchWithSetup diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index e3af7960ce..e3a7a89ca0 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -60,7 +60,6 @@ library filepath, fingertree, focus, - ghc-exactprint < 1 || >= 1.4, ghc-trace-events, Glob, haddock-library >= 1.8 && < 1.11, @@ -74,16 +73,13 @@ library lsp ^>= 1.5.0.0 , monoid-subclasses, mtl, - network-uri, optparse-applicative, parallel, prettyprinter-ansi-terminal, prettyprinter >= 1.6, random, regex-tdfa >= 1.3.1.0, - retrie, text-rope, - safe, safe-exceptions, hls-graph ^>= 1.7, sorted-list, @@ -95,9 +91,7 @@ library time, transformers, unordered-containers >= 0.2.10.0, - utf8-string, vector, - vector-algorithms, hslogger, Diff ^>=0.4.0, vector, @@ -114,9 +108,6 @@ library hie-bios ^>= 0.9.1, implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5, base16-bytestring >=0.1.1 && <1.1 - if impl(ghc >= 9.2) - build-depends: - ghc-exactprint >= 1.4 if os(windows) build-depends: Win32 @@ -172,7 +163,6 @@ library Development.IDE.GHC.Compat Development.IDE.GHC.Compat.Core Development.IDE.GHC.Compat.Env - Development.IDE.GHC.Compat.ExactPrint Development.IDE.GHC.Compat.Iface Development.IDE.GHC.Compat.Logger Development.IDE.GHC.Compat.Outputable @@ -182,9 +172,7 @@ library Development.IDE.GHC.Compat.Util Development.IDE.Core.Compile Development.IDE.GHC.CoreFile - Development.IDE.GHC.Dump Development.IDE.GHC.Error - Development.IDE.GHC.ExactPrint Development.IDE.GHC.Orphans Development.IDE.GHC.Util Development.IDE.Import.DependencyInformation @@ -214,8 +202,6 @@ library Development.IDE.Plugin Development.IDE.Plugin.Completions Development.IDE.Plugin.Completions.Types - Development.IDE.Plugin.CodeAction - Development.IDE.Plugin.CodeAction.ExactPrint Development.IDE.Plugin.HLS Development.IDE.Plugin.HLS.GhcIde Development.IDE.Plugin.Test @@ -226,8 +212,6 @@ library Development.IDE.Core.FileExists Development.IDE.GHC.CPP Development.IDE.GHC.Warnings - Development.IDE.Plugin.CodeAction.PositionIndexed - Development.IDE.Plugin.CodeAction.Args Development.IDE.Plugin.Completions.Logic Development.IDE.Session.VersionCheck Development.IDE.Types.Action @@ -365,6 +349,7 @@ test-suite ghcide-tests ghc, -------------------------------------------------------------- ghcide, + ghcide-test-utils, ghc-typelits-knownnat, lsp, lsp-types, @@ -393,12 +378,10 @@ test-suite ghcide-tests build-depends: record-dot-preprocessor, record-hasfield - hs-source-dirs: test/cabal test/exe test/src bench/lib + hs-source-dirs: test/cabal test/exe bench/lib ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors main-is: Main.hs other-modules: - Development.IDE.Test - Development.IDE.Test.Diagnostic Development.IDE.Test.Runfiles FuzzySearch Progress @@ -418,3 +401,42 @@ test-suite ghcide-tests TupleSections TypeApplications ViewPatterns + +library ghcide-test-utils + visibility: public + default-language: Haskell2010 + build-depends: + aeson, + base, + containers, + data-default, + directory, + extra, + filepath, + ghcide, + lsp-types, + hls-plugin-api, + lens, + lsp-test ^>= 0.14, + tasty-hunit >= 0.10, + text, + hs-source-dirs: test/src + ghc-options: -Wunused-packages + exposed-modules: + Development.IDE.Test + Development.IDE.Test.Diagnostic + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index e3f1c4aaa3..dfba6a32e7 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -119,7 +119,6 @@ import Development.IDE.GHC.Compat hiding import qualified Development.IDE.GHC.Compat as Compat hiding (vcat, nest) import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph @@ -154,7 +153,6 @@ import System.Info.Extra (isWindows) import HIE.Bios.Ghc.Gap (hostIsDynamic) import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) import qualified Development.IDE.Core.Shake as Shake -import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake) import qualified Development.IDE.Types.Logger as Logger import qualified Development.IDE.Types.Shake as Shake import Development.IDE.GHC.CoreFile @@ -167,7 +165,6 @@ data Log | LogLoadingHieFile !NormalizedFilePath | LogLoadingHieFileFail !FilePath !SomeException | LogLoadingHieFileSuccess !FilePath - | LogExactPrint ExactPrint.Log | LogTypecheckedFOI !NormalizedFilePath deriving Show @@ -185,7 +182,6 @@ instance Pretty Log where , pretty (displayException e) ] LogLoadingHieFileSuccess path -> "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path - LogExactPrint log -> pretty log LogTypecheckedFOI path -> vcat [ "Typechecked a file which is not currently open in the editor:" <+> pretty (fromNormalizedFilePath path) , "This can indicate a bug which results in excessive memory usage." @@ -1230,7 +1226,6 @@ mainRule recorder RulesConfig{..} = do else defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing generateCoreRule recorder getImportMapRule recorder - getAnnotatedParsedSourceRule (cmapWithPrio LogExactPrint recorder) persistentHieFileRule recorder persistentDocMapRule persistentImportMapRule diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 8ef090e84e..9118dc68d7 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -41,6 +41,7 @@ import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Monitoring (Monitoring) import Development.IDE.Types.Shake (WithHieDb) +import Ide.Types (IdePlugins) import System.Environment (lookupEnv) data Log @@ -61,6 +62,7 @@ instance Pretty Log where -- | Initialise the Compiler Service. initialise :: Recorder (WithPriority Log) -> Config + -> IdePlugins IdeState -> Rules () -> Maybe (LSP.LanguageContextEnv Config) -> Logger @@ -70,7 +72,7 @@ initialise :: Recorder (WithPriority Log) -> IndexQueue -> Monitoring -> IO IdeState -initialise recorder defaultConfig mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do +initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -79,6 +81,7 @@ initialise recorder defaultConfig mainRule lspEnv logger debouncer options withH (cmapWithPrio LogShake recorder) lspEnv defaultConfig + plugins logger debouncer shakeProfiling diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index d341838e0a..211c5468a2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -158,7 +158,7 @@ import GHC.Stack (HasCallStack) import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS -import Ide.Types (PluginId) +import Ide.Types (PluginId, IdePlugins) import Language.LSP.Diagnostics import qualified Language.LSP.Server as LSP import Language.LSP.Types @@ -239,6 +239,7 @@ data ShakeExtras = ShakeExtras lspEnv :: Maybe (LSP.LanguageContextEnv Config) ,debouncer :: Debouncer NormalizedUri ,logger :: Logger + ,idePlugins :: IdePlugins IdeState ,globals :: TVar (HMap.HashMap TypeRep Dynamic) -- ^ Registry of global state used by rules. -- Small and immutable after startup, so not worth using an STM.Map. @@ -552,6 +553,7 @@ seqValue val = case val of shakeOpen :: Recorder (WithPriority Log) -> Maybe (LSP.LanguageContextEnv Config) -> Config + -> IdePlugins IdeState -> Logger -> Debouncer NormalizedUri -> Maybe FilePath @@ -563,7 +565,7 @@ shakeOpen :: Recorder (WithPriority Log) -> Monitoring -> Rules () -> IO IdeState -shakeOpen recorder lspEnv defaultConfig logger debouncer +shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts monitoring rules = mdo diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 8bb3c5fd1c..43cb524256 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -63,7 +63,6 @@ module Development.IDE.GHC.Compat( -- * Compat modules module Development.IDE.GHC.Compat.Core, module Development.IDE.GHC.Compat.Env, - module Development.IDE.GHC.Compat.ExactPrint, module Development.IDE.GHC.Compat.Iface, module Development.IDE.GHC.Compat.Logger, module Development.IDE.GHC.Compat.Outputable, @@ -119,7 +118,6 @@ module Development.IDE.GHC.Compat( import Data.Bifunctor import Development.IDE.GHC.Compat.Core import Development.IDE.GHC.Compat.Env -import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.Compat.Iface import Development.IDE.GHC.Compat.Logger import Development.IDE.GHC.Compat.Outputable diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 9ec6bfb5b8..3d506fbe4a 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -29,8 +29,6 @@ import Unique (getKey) #endif -import Retrie.ExactPrint (Annotated) - import Development.IDE.GHC.Compat import Development.IDE.GHC.Util @@ -195,12 +193,6 @@ instance NFData ModGuts where instance NFData (ImportDecl GhcPs) where rnf = rwhnf -instance Show (Annotated ParsedSource) where - show _ = "" - -instance NFData (Annotated ParsedSource) where - rnf = rwhnf - #if MIN_VERSION_ghc(9,0,1) instance (NFData HsModule) where #else diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 0ddd12faf6..4776626aa6 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -26,7 +26,6 @@ module Development.IDE.GHC.Util( setHieDir, dontWriteHieFiles, disableWarningsAsErrors, - traceAst, printOutputable ) where @@ -70,7 +69,6 @@ import Debug.Trace import Development.IDE.GHC.Compat as GHC import qualified Development.IDE.GHC.Compat.Parser as Compat import qualified Development.IDE.GHC.Compat.Units as Compat -import Development.IDE.GHC.Dump (showAstDataHtml) import Development.IDE.Types.Location import Foreign.ForeignPtr import Foreign.Ptr @@ -281,36 +279,6 @@ ioe_dupHandlesNotCompatible h = -------------------------------------------------------------------------------- -- Tracing exactprint terms -{-# NOINLINE timestamp #-} -timestamp :: POSIXTime -timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime - -debugAST :: Bool -debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1" - --- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection -traceAst :: (Data a, ExactPrint a, Outputable a, HasCallStack) => String -> a -> a -traceAst lbl x - | debugAST = trace doTrace x - | otherwise = x - where -#if MIN_VERSION_ghc(9,2,0) - renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True} -#else - renderDump = showSDocUnsafe . ppr -#endif - htmlDump = showAstDataHtml x - doTrace = unsafePerformIO $ do - u <- U.newUnique - let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u) - writeFile htmlDumpFileName $ renderDump htmlDump - return $ unlines - [prettyCallStack callStack ++ ":" -#if MIN_VERSION_ghc(9,2,0) - , exactPrint x -#endif - , "file://" ++ htmlDumpFileName] - -- Should in `Development.IDE.GHC.Orphans`, -- leave it here to prevent cyclic module dependency #if !MIN_VERSION_ghc(8,10,0) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index d5e19856a7..d342b1bb5d 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -378,6 +378,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig + argsHlsPlugins rules (Just env) logger @@ -422,7 +423,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -475,7 +476,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 4e5e96a3bd..8e95614a27 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -27,12 +27,8 @@ import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) -import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (GetAnnotatedParsedSource)) import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Graph -import Development.IDE.Plugin.CodeAction (newImport, - newImportToEdit) -import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports @@ -66,7 +62,6 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP - , pluginCommands = [extendImportCommand] , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority } @@ -155,8 +150,9 @@ getCompletionsLSP ide plId -> return (InL $ List []) (Just pfix', _) -> do let clientCaps = clientCapabilities $ shakeExtras ide + plugins = idePlugins $ shakeExtras ide config <- getCompletionsConfig plId - allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports + allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports pure $ InL (List $ orderedCompletions allCompletions) _ -> return (InL $ List []) _ -> return (InL $ List []) @@ -201,76 +197,3 @@ toModueNameText :: KT.Target -> T.Text toModueNameText target = case target of KT.TargetModule m -> T.pack $ moduleNameString m _ -> T.empty - -extendImportCommand :: PluginCommand IdeState -extendImportCommand = - PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler - -extendImportHandler :: CommandFunction IdeState ExtendImport -extendImportHandler ideState edit@ExtendImport {..} = do - res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit - whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do - let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList - srcSpan = rangeToSrcSpan nfp _range - LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtInfo $ - "Import " - <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent - <> "’ from " - <> importName - <> " (at " - <> printOutputable srcSpan - <> ")" - void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null - -extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) -extendImportHandler' ideState ExtendImport {..} - | Just fp <- uriToFilePath doc, - nfp <- toNormalizedFilePath' fp = - do - (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $ - runAction "extend import" ideState $ - runMaybeT $ do - -- We want accurate edits, so do not use stale data here - msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp - ps <- MaybeT $ use GetAnnotatedParsedSource nfp - (_, contents) <- MaybeT $ use GetFileContents nfp - return (msr, ps, contents) - let df = ms_hspp_opts msrModSummary - wantedModule = mkModuleName (T.unpack importName) - wantedQual = mkModuleName . T.unpack <$> importQual - existingImport = find (isWantedModule wantedModule wantedQual) msrImports - case existingImport of - Just imp -> do - fmap (nfp,) $ liftEither $ - rewriteToWEdit df doc -#if !MIN_VERSION_ghc(9,2,0) - (annsA ps) -#endif - $ - extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp) - Nothing -> do - let n = newImport importName sym importQual False - sym = if isNothing importQual then Just it else Nothing - it = case thingParent of - Nothing -> newThing - Just p -> p <> "(" <> newThing <> ")" - t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents) - return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) - | otherwise = - mzero - -isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool -isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) = - not (isQualifiedImport it) && unLoc ideclName == wantedModule -isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) = - unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual) -isWantedModule _ _ _ = False - -liftMaybe :: Monad m => Maybe a -> MaybeT m a -liftMaybe a = MaybeT $ pure a - -liftEither :: Monad m => Either e a -> MaybeT m a -liftEither (Left _) = mzero -liftEither (Right x) = return x diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 2269cb3914..c703ec7a66 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -59,7 +59,7 @@ import GHC.Plugins (Depth (AllTheWay), #endif import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), - PluginId) + IdePlugins(..), PluginId) import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.VFS as VFS @@ -161,7 +161,8 @@ occNameToComKind ty oc showModName :: ModuleName -> T.Text showModName = T.pack . moduleNameString -mkCompl :: PluginId -> IdeOptions -> CompItem -> CompletionItem +mkCompl :: Maybe PluginId -- ^ Plugin to use for the extend import command + -> IdeOptions -> CompItem -> CompletionItem mkCompl pId IdeOptions {..} @@ -175,7 +176,7 @@ mkCompl docs, additionalTextEdits } = do - let mbCommand = mkAdditionalEditsCommand pId `fmap` additionalTextEdits + let mbCommand = mkAdditionalEditsCommand pId =<< additionalTextEdits let ci = CompletionItem {_label = label, _kind = kind, @@ -217,9 +218,9 @@ mkCompl "line " <> printOutputable (srcLocLine loc) <> ", column " <> printOutputable (srcLocCol loc) -mkAdditionalEditsCommand :: PluginId -> ExtendImport -> Command -mkAdditionalEditsCommand pId edits = - mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) +mkAdditionalEditsCommand :: Maybe PluginId -> ExtendImport -> Maybe Command +mkAdditionalEditsCommand (Just pId) edits = Just $ mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) +mkAdditionalEditsCommand _ _ = Nothing mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> Provenance -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem mkNameCompItem doc thingParent origName provenance thingType isInfix docs !imp = CI {..} @@ -553,7 +554,7 @@ removeSnippetsWhen condition x = -- | Returns the cached completions for the given module and position. getCompletions - :: PluginId + :: IdePlugins a -> IdeOptions -> CachedCompletions -> Maybe (ParsedModule, PositionMapping) @@ -563,7 +564,7 @@ getCompletions -> CompletionsConfig -> HM.HashMap T.Text (HashSet.HashSet IdentInfo) -> IO [Scored CompletionItem] -getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} +getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo enteredQual = if T.null prefixModule then "" else prefixModule <> "." @@ -663,7 +664,8 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu | otherwise -> do -- assumes that nubOrdBy is stable let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls - let compls = (fmap.fmap.fmap) (mkCompl plId ideOpts) uniqueFiltCompls + let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts) uniqueFiltCompls + pId = lookupCommandProvider plugins (CommandId extendImportCommandId) return $ (fmap.fmap) snd $ sortBy (compare `on` lexicographicOrdering) $ diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index ea30eb2c53..8749a9efda 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -127,7 +127,7 @@ executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandH executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand execCmd where - pluginMap = Map.fromList ecs + pluginMap = Map.fromListWith (++) ecs parseCmdId :: T.Text -> Maybe (PluginId, CommandId) parseCmdId x = case T.splitOn ":" x of diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index 83f1f07130..7e6d924d16 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -12,7 +12,6 @@ import Development.IDE import Development.IDE.LSP.HoverDefinition import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.LSP.Outline -import qualified Development.IDE.Plugin.CodeAction as CodeAction import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types @@ -35,10 +34,6 @@ instance Pretty Log where descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder = [ descriptor "ghcide-hover-and-symbols", - CodeAction.iePluginDescriptor "ghcide-code-actions-imports-exports", - CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures", - CodeAction.bindingsPluginDescriptor "ghcide-code-actions-bindings", - CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes", Completions.descriptor (cmapWithPrio LogCompletions recorder) "ghcide-completions", TypeLenses.descriptor (cmapWithPrio LogTypeLenses recorder) "ghcide-type-lenses", Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core" diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 787e6941c4..12fce8ce67 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -40,7 +40,6 @@ import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.GHC.Util import qualified Development.IDE.Main as IDE -import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import Development.IDE.Spans.Common import Development.IDE.Test (Cursor, @@ -50,7 +49,6 @@ import Development.IDE.Test (Cursor, expectCurrentDiagnostics, expectDiagnostics, expectDiagnosticsWithTags, - expectMessages, expectNoMoreDiagnostics, flushMessages, getInterfaceFilesDir, @@ -103,7 +101,6 @@ import Data.IORef.Extra (atomicModifyIORef_) import Data.String (IsString (fromString)) import Data.Tuple.Extra import Development.IDE.Core.FileStore (getModTime) -import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), WaitForIdeRuleResult (..), @@ -198,7 +195,6 @@ main = do waitForProgressBegin closeDoc doc waitForProgressDone - , codeActionTests , initializeResponseTests , completionTests , cppTests @@ -225,7 +221,6 @@ main = do , rootUriTests , asyncTests , clientSettingsTest - , codeActionHelperFunctionTests , referenceTests , garbageCollectionTests , HieDbRetry.tests @@ -255,7 +250,7 @@ initializeResponseTests = withResource acquire release tests where , chk " doc highlight" _documentHighlightProvider (Just $ InL True) , chk " doc symbol" _documentSymbolProvider (Just $ InL True) , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) - , chk " code action" _codeActionProvider (Just $ InL True) + , chk " code action" _codeActionProvider (Just $ InL False) , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) , chk "NO doc range formatting" @@ -266,7 +261,7 @@ initializeResponseTests = withResource acquire release tests where , chk "NO doc link" _documentLinkProvider Nothing , chk "NO color" _colorProvider (Just $ InL False) , chk "NO folding range" _foldingRangeProvider (Just $ InL False) - , che " execute command" _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId] + , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) , chk "NO experimental" _experimental Nothing ] where @@ -817,40 +812,6 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r -- flush messages to ensure current diagnostics state is updated flushMessages -codeActionTests :: TestTree -codeActionTests = testGroup "code actions" - [ insertImportTests - , extendImportTests - , renameActionTests - , typeWildCardActionTests - , removeImportTests - , suggestImportClassMethodTests - , suggestImportTests - , suggestHideShadowTests - , suggestImportDisambiguationTests - , fixConstructorImportTests - , fixModuleImportTypoTests - , importRenameActionTests - , fillTypedHoleTests - , addSigActionTests - , insertNewDefinitionTests - , deleteUnusedDefinitionTests - , addInstanceConstraintTests - , addFunctionConstraintTests - , removeRedundantConstraintsTests - , addTypeAnnotationsToLiteralsTest - , exportUnusedTests - , addImplicitParamsConstraintTests - , removeExportTests - ] - -codeActionHelperFunctionTests :: TestTree -codeActionHelperFunctionTests = testGroup "code action helpers" - [ - extendImportTestsRegEx - ] - - codeLensesTests :: TestTree codeLensesTests = testGroup "code lenses" [ addSigLensesTests @@ -905,3291 +866,6 @@ watchedFilesTests = testGroup "watched files" ] ] -insertImportTests :: TestTree -insertImportTests = testGroup "insert import" - [ checkImport - "module where keyword lower in file no exports" - "WhereKeywordLowerInFileNoExports.hs" - "WhereKeywordLowerInFileNoExports.expected.hs" - "import Data.Int" - , checkImport - "module where keyword lower in file with exports" - "WhereDeclLowerInFile.hs" - "WhereDeclLowerInFile.expected.hs" - "import Data.Int" - , checkImport - "module where keyword lower in file with comments before it" - "WhereDeclLowerInFileWithCommentsBeforeIt.hs" - "WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs" - "import Data.Int" - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" - (checkImport - "Shebang not at top with spaces" - "ShebangNotAtTopWithSpaces.hs" - "ShebangNotAtTopWithSpaces.expected.hs" - "import Data.Monoid") - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" - (checkImport - "Shebang not at top no space" - "ShebangNotAtTopNoSpace.hs" - "ShebangNotAtTopNoSpace.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case " - ++ "when OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "OPTIONS_GHC pragma not at top with spaces" - "OptionsNotAtTopWithSpaces.hs" - "OptionsNotAtTopWithSpaces.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for " - ++ "case when shebang is not placed at top of file") - (checkImport - "Shebang not at top of file" - "ShebangNotAtTop.hs" - "ShebangNotAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case " - ++ "when OPTIONS_GHC is not placed at top of file") - (checkImport - "OPTIONS_GHC pragma not at top of file" - "OptionsPragmaNotAtTop.hs" - "OptionsPragmaNotAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case when " - ++ "OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "pragma not at top with comment at top" - "PragmaNotAtTopWithCommentsAtTop.hs" - "PragmaNotAtTopWithCommentsAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case when " - ++ "OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "pragma not at top multiple comments" - "PragmaNotAtTopMultipleComments.hs" - "PragmaNotAtTopMultipleComments.expected.hs" - "import Data.Monoid") - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case of multiline pragmas" - (checkImport - "after multiline language pragmas" - "MultiLinePragma.hs" - "MultiLinePragma.expected.hs" - "import Data.Monoid") - , checkImport - "pragmas not at top with module declaration" - "PragmaNotAtTopWithModuleDecl.hs" - "PragmaNotAtTopWithModuleDecl.expected.hs" - "import Data.Monoid" - , checkImport - "pragmas not at top with imports" - "PragmaNotAtTopWithImports.hs" - "PragmaNotAtTopWithImports.expected.hs" - "import Data.Monoid" - , checkImport - "above comment at top of module" - "CommentAtTop.hs" - "CommentAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "above multiple comments below" - "CommentAtTopMultipleComments.hs" - "CommentAtTopMultipleComments.expected.hs" - "import Data.Monoid" - , checkImport - "above curly brace comment" - "CommentCurlyBraceAtTop.hs" - "CommentCurlyBraceAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "above multi-line comment" - "MultiLineCommentAtTop.hs" - "MultiLineCommentAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "above comment with no module explicit exports" - "NoExplicitExportCommentAtTop.hs" - "NoExplicitExportCommentAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "above two-dash comment with no pipe" - "TwoDashOnlyComment.hs" - "TwoDashOnlyComment.expected.hs" - "import Data.Monoid" - , checkImport - "above comment with no (module .. where) decl" - "NoModuleDeclarationCommentAtTop.hs" - "NoModuleDeclarationCommentAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "comment not at top with no (module .. where) decl" - "NoModuleDeclaration.hs" - "NoModuleDeclaration.expected.hs" - "import Data.Monoid" - , checkImport - "comment not at top (data dec is)" - "DataAtTop.hs" - "DataAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "comment not at top (newtype is)" - "NewTypeAtTop.hs" - "NewTypeAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "with no explicit module exports" - "NoExplicitExports.hs" - "NoExplicitExports.expected.hs" - "import Data.Monoid" - , checkImport - "add to correctly placed exisiting import" - "ImportAtTop.hs" - "ImportAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "add to multiple correctly placed exisiting imports" - "MultipleImportsAtTop.hs" - "MultipleImportsAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "with language pragma at top of module" - "LangPragmaModuleAtTop.hs" - "LangPragmaModuleAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "with language pragma and explicit module exports" - "LangPragmaModuleWithComment.hs" - "LangPragmaModuleWithComment.expected.hs" - "import Data.Monoid" - , checkImport - "with language pragma at top and no module declaration" - "LanguagePragmaAtTop.hs" - "LanguagePragmaAtTop.expected.hs" - "import Data.Monoid" - , checkImport - "with multiple lang pragmas and no module declaration" - "MultipleLanguagePragmasNoModuleDeclaration.hs" - "MultipleLanguagePragmasNoModuleDeclaration.expected.hs" - "import Data.Monoid" - , checkImport - "with pragmas and shebangs" - "LanguagePragmasThenShebangs.hs" - "LanguagePragmasThenShebangs.expected.hs" - "import Data.Monoid" - , checkImport - "with pragmas and shebangs but no comment at top" - "PragmasAndShebangsNoComment.hs" - "PragmasAndShebangsNoComment.expected.hs" - "import Data.Monoid" - , checkImport - "module decl no exports under pragmas and shebangs" - "PragmasShebangsAndModuleDecl.hs" - "PragmasShebangsAndModuleDecl.expected.hs" - "import Data.Monoid" - , checkImport - "module decl with explicit import under pragmas and shebangs" - "PragmasShebangsModuleExplicitExports.hs" - "PragmasShebangsModuleExplicitExports.expected.hs" - "import Data.Monoid" - , checkImport - "module decl and multiple imports" - "ModuleDeclAndImports.hs" - "ModuleDeclAndImports.expected.hs" - "import Data.Monoid" - ] - -checkImport :: String -> FilePath -> FilePath -> T.Text -> TestTree -checkImport testComment originalPath expectedPath action = - testSessionWithExtraFiles "import-placement" testComment $ \dir -> - check (dir originalPath) (dir expectedPath) action - where - check :: FilePath -> FilePath -> T.Text -> Session () - check originalPath expectedPath action = do - oSrc <- liftIO $ readFileUtf8 originalPath - eSrc <- liftIO $ readFileUtf8 expectedPath - originalDoc <- createDoc originalPath "haskell" oSrc - _ <- waitForDiagnostics - shouldBeDoc <- createDoc expectedPath "haskell" eSrc - actionsOrCommands <- getAllCodeActions originalDoc - chosenAction <- liftIO $ pickActionWithTitle action actionsOrCommands - executeCodeAction chosenAction - originalDocAfterAction <- documentContents originalDoc - shouldBeDocContents <- documentContents shouldBeDoc - liftIO $ T.replace "\r\n" "\n" shouldBeDocContents @=? T.replace "\r\n" "\n" originalDocAfterAction - -renameActionTests :: TestTree -renameActionTests = testGroup "rename actions" - [ testSession "change to local variable name" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int" - , "foo argName = argNme" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’" - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "foo :: Int -> Int" - , "foo argName = argName" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "change to name of imported function" $ do - let content = T.unlines - [ "module Testing where" - , "import Data.Maybe (maybeToList)" - , "foo :: Maybe a -> [a]" - , "foo = maybToList" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’" - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "import Data.Maybe (maybeToList)" - , "foo :: Maybe a -> [a]" - , "foo = maybeToList" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "suggest multiple local variable names" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Char -> Char -> Char -> Char" - , "foo argument1 argument2 argument3 = argumentX" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45)) - ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"] - return() - , testSession "change infix function" $ do - let content = T.unlines - [ "module Testing where" - , "monus :: Int -> Int" - , "monus x y = max 0 (x - y)" - , "foo x y = x `monnus` y" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) - [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] - executeCodeAction fixTypo - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "monus :: Int -> Int" - , "monus x y = max 0 (x - y)" - , "foo x y = x `monus` y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -typeWildCardActionTests :: TestTree -typeWildCardActionTests = testGroup "type wildcard actions" - [ testUseTypeSignature "global signature" - [ "func :: _" - , "func x = x" - ] - [ "func :: p -> p" - , "func x = x" - ] - , testUseTypeSignature "local signature" - [ "func :: Int -> Int" - , "func x =" - , " let y :: _" - , " y = x * 2" - , " in y" - ] - [ "func :: Int -> Int" - , "func x =" - , " let y :: Int" - , " y = x * 2" - , " in y" - ] - , testUseTypeSignature "multi-line message 1" - [ "func :: _" - , "func x y = x + y" - ] - [ "func :: Integer -> Integer -> Integer" - , "func x y = x + y" - ] - , testUseTypeSignature "type in parentheses" - [ "func :: a -> _" - , "func x = (x, const x)" - ] - [ "func :: a -> (a, b -> a)" - , "func x = (x, const x)" - ] - , testUseTypeSignature "type in brackets" - [ "func :: _ -> Maybe a" - , "func xs = head xs" - ] - [ "func :: [Maybe a] -> Maybe a" - , "func xs = head xs" - ] - , testUseTypeSignature "unit type" - [ "func :: IO _" - , "func = putChar 'H'" - ] - [ "func :: IO ()" - , "func = putChar 'H'" - ] - , testUseTypeSignature "no spaces around '::'" - [ "func::_" - , "func x y = x + y" - ] - [ "func::Integer -> Integer -> Integer" - , "func x y = x + y" - ] - , testGroup "add parens if hole is part of bigger type" - [ testUseTypeSignature "subtype 1" - [ "func :: _ -> Integer -> Integer" - , "func x y = x + y" - ] - [ "func :: Integer -> Integer -> Integer" - , "func x y = x + y" - ] - , testUseTypeSignature "subtype 2" - [ "func :: Integer -> _ -> Integer" - , "func x y = x + y" - ] - [ "func :: Integer -> Integer -> Integer" - , "func x y = x + y" - ] - , testUseTypeSignature "subtype 3" - [ "func :: Integer -> Integer -> _" - , "func x y = x + y" - ] - [ "func :: Integer -> Integer -> Integer" - , "func x y = x + y" - ] - , testUseTypeSignature "subtype 4" - [ "func :: Integer -> _" - , "func x y = x + y" - ] - [ "func :: Integer -> (Integer -> Integer)" - , "func x y = x + y" - ] - ] - ] - where - -- | Test session of given name, checking action "Use type signature..." - -- on a test file with given content and comparing to expected result. - testUseTypeSignature name textIn textOut = testSession name $ do - let fileStart = "module Testing where" - content = T.unlines $ fileStart : textIn - expectedContentAfterAction = T.unlines $ fileStart : textOut - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - liftIO $ expectedContentAfterAction @=? contentAfterAction - -{-# HLINT ignore "Use nubOrd" #-} -removeImportTests :: TestTree -removeImportTests = testGroup "remove import actions" - [ testSession "redundant" $ do - let contentA = T.unlines - [ "module ModuleA where" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - , "stuffB :: Integer" - , "stuffB = 123" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "stuffB :: Integer" - , "stuffB = 123" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "qualified redundant" $ do - let contentA = T.unlines - [ "module ModuleA where" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA" - , "stuffB :: Integer" - , "stuffB = 123" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "stuffB :: Integer" - , "stuffB = 123" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant binding" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "stuffA = False" - , "stuffB :: Integer" - , "stuffB = 123" - , "stuffC = ()" - , "_stuffD = '_'" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffA, stuffB, _stuffD, stuffC, stuffA)" - , "main = print stuffB" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove _stuffD, stuffA, stuffC from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffB)" - , "main = print stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant binding - unicode regression " $ do - let contentA = T.unlines - [ "module ModuleA where" - , "data A = A" - , "ε :: Double" - , "ε = 0.5" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (A(..), ε)" - , "a = A" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove ε from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (A(..))" - , "a = A" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant operator" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "a !! _b = a" - , "a _b = a" - , "stuffB :: Integer" - , "stuffB = 123" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA as A ((), stuffB, (!!))" - , "main = print A.stuffB" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove !!, from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA as A (stuffB)" - , "main = print A.stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant all import" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "data A = A" - , "stuffB :: Integer" - , "stuffB = 123" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (A(..), stuffB)" - , "main = print stuffB" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove A from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffB)" - , "main = print stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant constructor import" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "data D = A | B" - , "data E = F" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (D(A,B), E(F))" - , "main = B" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove A, E, F from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (D(B))" - , "main = B" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "import containing the identifier Strict" $ do - let contentA = T.unlines - [ "module Strict where" - ] - _docA <- createDoc "Strict.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import Strict" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "remove all" $ do - let content = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleA where" - , "import Data.Function (fix, (&))" - , "import qualified Data.Functor.Const" - , "import Data.Functor.Identity" - , "import Data.Functor.Sum (Sum (InL, InR))" - , "import qualified Data.Kind as K (Constraint, Type)" - , "x = InL (Identity 123)" - , "y = fix id" - , "type T = K.Type" - ] - doc <- createDoc "ModuleC.hs" "haskell" content - _ <- waitForDiagnostics - [_, _, _, _, InR action@CodeAction { _title = actionTitle }] - <- nub <$> getAllCodeActions doc - liftIO $ "Remove all redundant imports" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleA where" - , "import Data.Function (fix)" - , "import Data.Functor.Identity" - , "import Data.Functor.Sum (Sum (InL))" - , "import qualified Data.Kind as K (Type)" - , "x = InL (Identity 123)" - , "y = fix id" - , "type T = K.Type" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "remove unused operators whose name ends with '.'" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "(@.) = 0 -- Must have an operator whose name ends with '.'" - , "a = 1 -- .. but also something else" - ] - _docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (a, (@.))" - , "x = a -- Must use something from module A, but not (@.)" - ] - docB <- createDoc "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [InR action@CodeAction { _title = actionTitle }, _] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove @. from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (a)" - , "x = a -- Must use something from module A, but not (@.)" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -extendImportTests :: TestTree -extendImportTests = testGroup "extend import actions" - [ testGroup "with checkAll" $ tests True - , testGroup "without checkAll" $ tests False - ] - where - tests overrideCheckProject = - [ testSession "extend all constructors for record field" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = B { a :: Int }" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A(B))" - , "f = a" - ]) - (Range (Position 2 4) (Position 2 5)) - [ "Add A(..) to the import list of ModuleA" - , "Add A(a) to the import list of ModuleA" - , "Add a to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A(..))" - , "f = a" - ]) - , testSession "extend all constructors with sibling" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data Foo" - , "data Bar" - , "data A = B | C" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA ( Foo, A (C) , Bar ) " - , "f = B" - ]) - (Range (Position 2 4) (Position 2 5)) - [ "Add A(..) to the import list of ModuleA" - , "Add A(B) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA ( Foo, A (..) , Bar ) " - , "f = B" - ]) - , testSession "extend all constructors with comment" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data Foo" - , "data Bar" - , "data A = B | C" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA ( Foo, A (C{-comment--}) , Bar ) " - , "f = B" - ]) - (Range (Position 2 4) (Position 2 5)) - [ "Add A(..) to the import list of ModuleA" - , "Add A(B) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA ( Foo, A (..{-comment--}) , Bar ) " - , "f = B" - ]) - , testSession "extend all constructors for type operator" $ template - [] - ("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - (Range (Position 3 17) (Position 3 18)) - [ "Add (:~:)(..) to the import list of Data.Type.Equality" - , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"] - (T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:) (..))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - , testSession "extend all constructors for class" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "class C a where" - , " m1 :: a -> a" - , " m2 :: a -> a" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1))" - , "b = m2" - ]) - (Range (Position 2 5) (Position 2 5)) - [ "Add C(..) to the import list of ModuleA" - , "Add C(m2) to the import list of ModuleA" - , "Add m2 to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (C(..))" - , "b = m2" - ]) - , testSession "extend single line import with value" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB)" - , "main = print (stuffA, stuffB)" - ]) - (Range (Position 2 17) (Position 2 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB, stuffA)" - , "main = print (stuffA, stuffB)" - ]) - , testSession "extend single line import with operator" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "(.*) :: Integer -> Integer -> Integer" - , "x .* y = x * y" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB)" - , "main = print (stuffB .* stuffB)" - ]) - (Range (Position 2 17) (Position 2 18)) - ["Add (.*) to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB, (.*))" - , "main = print (stuffB .* stuffB)" - ]) - , testSession "extend single line import with infix constructor" $ template - [] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import Data.List.NonEmpty (fromList)" - , "main = case (fromList []) of _ :| _ -> pure ()" - ]) - (Range (Position 2 5) (Position 2 6)) - [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty" - , "Add NonEmpty(..) to the import list of Data.List.NonEmpty" - ] - (T.unlines - [ "module ModuleB where" - , "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))" - , "main = case (fromList []) of _ :| _ -> pure ()" - ]) - , testSession "extend single line import with prefix constructor" $ template - [] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import Prelude hiding (Maybe(..))" - , "import Data.Maybe (catMaybes)" - , "x = Just 10" - ]) - (Range (Position 3 5) (Position 2 6)) - [ "Add Maybe(Just) to the import list of Data.Maybe" - , "Add Maybe(..) to the import list of Data.Maybe" - ] - (T.unlines - [ "module ModuleB where" - , "import Prelude hiding (Maybe(..))" - , "import Data.Maybe (catMaybes, Maybe (Just))" - , "x = Just 10" - ]) - , testSession "extend single line import with type" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "type A = Double" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - , "b :: A" - , "b = 0" - ]) - (Range (Position 2 5) (Position 2 5)) - ["Add A to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A)" - , "b :: A" - , "b = 0" - ]) - , testSession "extend single line import with constructor" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A)" - , "b :: A" - , "b = Constructor" - ]) - (Range (Position 3 5) (Position 3 5)) - [ "Add A(Constructor) to the import list of ModuleA" - , "Add A(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A (Constructor))" - , "b :: A" - , "b = Constructor" - ]) - , testSession "extend single line import with constructor (with comments)" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A ({-Constructor-}))" - , "b :: A" - , "b = Constructor" - ]) - (Range (Position 3 5) (Position 3 5)) - [ "Add A(Constructor) to the import list of ModuleA" - , "Add A(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A (Constructor{-Constructor-}))" - , "b :: A" - , "b = Constructor" - ]) - , testSession "extend single line import with mixed constructors" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data A = ConstructorFoo | ConstructorBar" - , "a = 1" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (A (ConstructorBar), a)" - , "b :: A" - , "b = ConstructorFoo" - ]) - (Range (Position 3 5) (Position 3 5)) - [ "Add A(ConstructorFoo) to the import list of ModuleA" - , "Add A(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)" - , "b :: A" - , "b = ConstructorFoo" - ]) - , testSession "extend single line qualified import with value" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffB)" - , "main = print (A.stuffA, A.stuffB)" - ]) - (Range (Position 2 17) (Position 2 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffB, stuffA)" - , "main = print (A.stuffA, A.stuffB)" - ]) - , testSession "extend multi line import with value" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffB" - , " )" - , "main = print (stuffA, stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffB, stuffA" - , " )" - , "main = print (stuffA, stuffB)" - ]) - , testSession "extend multi line import with trailing comma" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffB," - , " )" - , "main = print (stuffA, stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add stuffA to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffB, stuffA," - , " )" - , "main = print (stuffA, stuffB)" - ]) - , testSession "extend single line import with method within class" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "class C a where" - , " m1 :: a -> a" - , " m2 :: a -> a" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1))" - , "b = m2" - ]) - (Range (Position 2 5) (Position 2 5)) - [ "Add C(m2) to the import list of ModuleA" - , "Add m2 to the import list of ModuleA" - , "Add C(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1, m2))" - , "b = m2" - ]) - , testSession "extend single line import with method without class" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "class C a where" - , " m1 :: a -> a" - , " m2 :: a -> a" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1))" - , "b = m2" - ]) - (Range (Position 2 5) (Position 2 5)) - [ "Add m2 to the import list of ModuleA" - , "Add C(m2) to the import list of ModuleA" - , "Add C(..) to the import list of ModuleA" - ] - (T.unlines - [ "module ModuleB where" - , "import ModuleA (C(m1), m2)" - , "b = m2" - ]) - , testSession "extend import list with multiple choices" $ template - [("ModuleA.hs", T.unlines - -- this is just a dummy module to help the arguments needed for this test - [ "module ModuleA (bar) where" - , "bar = 10" - ]), - ("ModuleB.hs", T.unlines - -- this is just a dummy module to help the arguments needed for this test - [ "module ModuleB (bar) where" - , "bar = 10" - ])] - ("ModuleC.hs", T.unlines - [ "module ModuleC where" - , "import ModuleB ()" - , "import ModuleA ()" - , "foo = bar" - ]) - (Range (Position 3 17) (Position 3 18)) - ["Add bar to the import list of ModuleA", - "Add bar to the import list of ModuleB"] - (T.unlines - [ "module ModuleC where" - , "import ModuleB ()" - , "import ModuleA (bar)" - , "foo = bar" - ]) - , testSession "extend import list with constructor of type operator" $ template - [] - ("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - (Range (Position 3 17) (Position 3 18)) - [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality" - , "Add (:~:)(..) to the import list of Data.Type.Equality"] - (T.unlines - [ "module ModuleA where" - , "import Data.Type.Equality ((:~:) (Refl))" - , "x :: (:~:) [] []" - , "x = Refl" - ]) - , expectFailBecause "importing pattern synonyms is unsupported" - $ testSession "extend import list with pattern synonym" $ template - [("ModuleA.hs", T.unlines - [ "{-# LANGUAGE PatternSynonyms #-}" - , "module ModuleA where" - , "pattern Some x = Just x" - ]) - ] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import A ()" - , "k (Some x) = x" - ]) - (Range (Position 2 3) (Position 2 7)) - ["Add pattern Some to the import list of A"] - (T.unlines - [ "module ModuleB where" - , "import A (pattern Some)" - , "k (Some x) = x" - ]) - , ignoreForGHC92 "Diagnostic message has no suggestions" $ - testSession "type constructor name same as data constructor name" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "newtype Foo = Foo Int" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA(Foo)" - , "f :: Foo" - , "f = Foo 1" - ]) - (Range (Position 3 4) (Position 3 6)) - ["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA(Foo (Foo))" - , "f :: Foo" - , "f = Foo 1" - ]) - , testSession "type constructor name same as data constructor name, data constructor extraneous" $ template - [("ModuleA.hs", T.unlines - [ "module ModuleA where" - , "data Foo = Foo" - ])] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import ModuleA()" - , "f :: Foo" - , "f = undefined" - ]) - (Range (Position 2 4) (Position 2 6)) - ["Add Foo to the import list of ModuleA"] - (T.unlines - [ "module ModuleB where" - , "import ModuleA(Foo)" - , "f :: Foo" - , "f = undefined" - ]) - ] - where - codeActionTitle CodeAction{_title=x} = x - - template setUpModules moduleUnderTest range expectedTitles expectedContentB = do - configureCheckProject overrideCheckProject - - mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules - docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) - _ <- waitForDiagnostics - waitForProgressDone - actionsOrCommands <- getCodeActions docB range - let codeActions = - filter - (T.isPrefixOf "Add" . codeActionTitle) - [ca | InR ca <- actionsOrCommands] - actualTitles = codeActionTitle <$> codeActions - -- Note that we are not testing the order of the actions, as the - -- order of the expected actions indicates which one we'll execute - -- in this test, i.e., the first one. - liftIO $ sort expectedTitles @=? sort actualTitles - - -- Execute the action with the same title as the first expected one. - -- Since we tested that both lists have the same elements (possibly - -- in a different order), this search cannot fail. - let firstTitle:_ = expectedTitles - action = fromJust $ - find ((firstTitle ==) . codeActionTitle) codeActions - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ expectedContentB @=? contentAfterAction - -fixModuleImportTypoTests :: TestTree -fixModuleImportTypoTests = testGroup "fix module import typo" - [ testSession "works when single module suggested" $ do - doc <- createDoc "A.hs" "haskell" "import Data.Cha" - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ <- getCodeActions doc (R 0 0 0 10) - liftIO $ actionTitle @?= "replace with Data.Char" - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ contentAfterAction @?= "import Data.Char" - , testSession "works when multiple modules suggested" $ do - doc <- createDoc "A.hs" "haskell" "import Data.I" - _ <- waitForDiagnostics - actions <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions doc (R 0 0 0 10) - let actionTitles = [ title | InR CodeAction{_title=title} <- actions ] - liftIO $ actionTitles @?= [ "replace with Data.Eq" - , "replace with Data.Int" - , "replace with Data.Ix" - ] - let InR replaceWithDataEq : _ = actions - executeCodeAction replaceWithDataEq - contentAfterAction <- documentContents doc - liftIO $ contentAfterAction @?= "import Data.Eq" - ] - -extendImportTestsRegEx :: TestTree -extendImportTestsRegEx = testGroup "regex parsing" - [ - testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing - , testCase "parse malformed import list" $ template - "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217)" - Nothing - , testCase "parse multiple imports" $ template - "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)" - $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")]) - ] - where - template message expected = do - liftIO $ matchRegExMultipleImports message @=? expected - -suggestImportClassMethodTests :: TestTree -suggestImportClassMethodTests = - testGroup - "suggest import class methods" - [ testGroup - "new" - [ testSession "via parent" $ - template' - "import Data.Semigroup (Semigroup(stimes))" - (Range (Position 4 2) (Position 4 8)), - testSession "top level" $ - template' - "import Data.Semigroup (stimes)" - (Range (Position 4 2) (Position 4 8)), - testSession "all" $ - template' - "import Data.Semigroup" - (Range (Position 4 2) (Position 4 8)) - ], - testGroup - "extend" - [ testSession "via parent" $ - template - [ "module A where", - "", - "import Data.Semigroup ()" - ] - (Range (Position 6 2) (Position 6 8)) - "Add Semigroup(stimes) to the import list of Data.Semigroup" - [ "module A where", - "", - "import Data.Semigroup (Semigroup (stimes))" - ], - testSession "top level" $ - template - [ "module A where", - "", - "import Data.Semigroup ()" - ] - (Range (Position 6 2) (Position 6 8)) - "Add stimes to the import list of Data.Semigroup" - [ "module A where", - "", - "import Data.Semigroup (stimes)" - ] - ] - ] - where - decls = - [ "data X = X", - "instance Semigroup X where", - " (<>) _ _ = X", - " stimes _ _ = X" - ] - template beforeContent range executeTitle expectedContent = do - doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls) - _ <- waitForDiagnostics - waitForProgressDone - actions <- getCodeActions doc range - let actions' = [x | InR x <- actions] - titles = [_title | CodeAction {_title} <- actions'] - liftIO $ executeTitle `elem` titles @? T.unpack executeTitle <> " does not in " <> show titles - executeCodeAction $ fromJust $ find (\CodeAction {_title} -> _title == executeTitle) actions' - content <- documentContents doc - liftIO $ T.unlines (expectedContent <> decls) @=? content - template' executeTitle range = let c = ["module A where"] in template c range executeTitle $ c <> [executeTitle] - -suggestImportTests :: TestTree -suggestImportTests = testGroup "suggest import actions" - [ testGroup "Dont want suggestion" - [ -- extend import - test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" - -- data constructor - , test False [] "f = First" [] "import Data.Monoid (First)" - -- internal module - , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)" - -- package not in scope - , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" - -- don't omit the parent data type of a constructor - , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" - -- don't suggest data constructor when we only need the type - , test False [] "f :: Bar" [] "import Bar (Bar(Bar))" - -- don't suggest all data constructors for the data type - , test False [] "f :: Bar" [] "import Bar (Bar(..))" - ] - , testGroup "want suggestion" - [ wantWait [] "f = foo" [] "import Foo (foo)" - , wantWait [] "f = Bar" [] "import Bar (Bar(Bar))" - , wantWait [] "f :: Bar" [] "import Bar (Bar)" - , wantWait [] "f = Bar" [] "import Bar (Bar(..))" - , test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" - , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))" - , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)" - , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural" - , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)" - , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty" - , test True [] "f = First" [] "import Data.Monoid (First(First))" - , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))" - , test True [] "f = Version" [] "import Data.Version (Version(Version))" - , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))" - , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))" - , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" - , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)" - , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative" - , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))" - , test True [] "f = empty" [] "import Control.Applicative (empty)" - , test True [] "f = empty" [] "import Control.Applicative" - , test True [] "f = (&)" [] "import Data.Function ((&))" - , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" - , test True [] "f = Data.List.NonEmpty.nonEmpty" [] "import qualified Data.List.NonEmpty" - , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" - , test True [] "f = pack" [] "import Data.Text (pack)" - , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" - , test True [] "f = [] & id" [] "import Data.Function ((&))" - , test True [] "f = (&) [] id" [] "import Data.Function ((&))" - , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" - , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" - , test True [] "f :: a ~~ b" [] "import Data.Type.Equality (type (~~))" - , test True - ["qualified Data.Text as T" - ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , test True - [ "qualified Data.Text as T" - , "qualified Data.Function as T" - ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , test True - [ "qualified Data.Text as T" - , "qualified Data.Function as T" - , "qualified Data.Functor as T" - , "qualified Data.Data as T" - ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , test True [] "f = (.|.)" [] "import Data.Bits (Bits(..))" - , test True [] "f = empty" [] "import Control.Applicative (Alternative(..))" - ] - , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" - ] - where - test = test' False - wantWait = test' True True - - test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do - configureCheckProject waitForCheckProject - let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other - after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other - cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}" - liftIO $ writeFileUTF8 (dir "hie.yaml") cradle - liftIO $ writeFileUTF8 (dir "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"] - doc <- createDoc "Test.hs" "haskell" before - waitForProgressDone - _ <- waitForDiagnostics - -- there isn't a good way to wait until the whole project is checked atm - when waitForCheckProject $ liftIO $ sleep 0.5 - let defLine = fromIntegral $ length imps + 1 - range = Range (Position defLine 0) (Position defLine maxBound) - actions <- getCodeActions doc range - if wanted - then do - action <- liftIO $ pickActionWithTitle newImp actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ after @=? contentAfterAction - else - liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] - -suggestImportDisambiguationTests :: TestTree -suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" - [ testGroup "Hiding strategy works" - [ testGroup "fromList" - [ testCase "AVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use AVec for fromList, hiding other imports" - "HideFunction.expected.fromList.A.hs" - , testCase "BVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use BVec for fromList, hiding other imports" - "HideFunction.expected.fromList.B.hs" - ] - , testGroup "(++)" - [ testCase "EVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use EVec for ++, hiding other imports" - "HideFunction.expected.append.E.hs" - , testCase "Hide functions without local" $ - compareTwo - "HideFunctionWithoutLocal.hs" [(8,8)] - "Use local definition for ++, hiding other imports" - "HideFunctionWithoutLocal.expected.hs" - , testCase "Prelude" $ - compareHideFunctionTo [(8,9),(10,8)] - "Use Prelude for ++, hiding other imports" - "HideFunction.expected.append.Prelude.hs" - , testCase "Prelude and local definition, infix" $ - compareTwo - "HidePreludeLocalInfix.hs" [(2,19)] - "Use local definition for ++, hiding other imports" - "HidePreludeLocalInfix.expected.hs" - , testCase "AVec, indented" $ - compareTwo "HidePreludeIndented.hs" [(3,8)] - "Use AVec for ++, hiding other imports" - "HidePreludeIndented.expected.hs" - - ] - , testGroup "Vec (type)" - [ testCase "AVec" $ - compareTwo - "HideType.hs" [(8,15)] - "Use AVec for Vec, hiding other imports" - "HideType.expected.A.hs" - , testCase "EVec" $ - compareTwo - "HideType.hs" [(8,15)] - "Use EVec for Vec, hiding other imports" - "HideType.expected.E.hs" - ] - ] - , testGroup "Qualify strategy" - [ testCase "won't suggest full name for qualified module" $ - withHideFunction [(8,9),(10,8)] $ \_ actions -> do - liftIO $ - assertBool "EVec.fromList must not be suggested" $ - "Replace with qualified: EVec.fromList" `notElem` - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - liftIO $ - assertBool "EVec.++ must not be suggested" $ - "Replace with qualified: EVec.++" `notElem` - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - , testGroup "fromList" - [ testCase "EVec" $ - compareHideFunctionTo [(8,9),(10,8)] - "Replace with qualified: E.fromList" - "HideFunction.expected.qualified.fromList.E.hs" - , testCase "Hide DuplicateRecordFields" $ - compareTwo - "HideQualifyDuplicateRecordFields.hs" [(9, 9)] - "Replace with qualified: AVec.fromList" - "HideQualifyDuplicateRecordFields.expected.hs" - , testCase "Duplicate record fields should not be imported" $ do - withTarget ("HideQualifyDuplicateRecordFields" <.> ".hs") [(9, 9)] $ - \_ actions -> do - liftIO $ - assertBool "Hidings should not be presented while DuplicateRecordFields exists" $ - all not [ actionTitle =~ T.pack "Use ([A-Za-z][A-Za-z0-9]*) for fromList, hiding other imports" - | InR CodeAction { _title = actionTitle } <- actions] - withTarget ("HideQualifyDuplicateRecordFieldsSelf" <.> ".hs") [(4, 4)] $ - \_ actions -> do - liftIO $ - assertBool "ambiguity from DuplicateRecordFields should not be imported" $ - null actions - ] - , testGroup "(++)" - [ testCase "Prelude, parensed" $ - compareHideFunctionTo [(8,9),(10,8)] - "Replace with qualified: Prelude.++" - "HideFunction.expected.qualified.append.Prelude.hs" - , testCase "Prelude, infix" $ - compareTwo - "HideQualifyInfix.hs" [(4,19)] - "Replace with qualified: Prelude.++" - "HideQualifyInfix.expected.hs" - , testCase "Prelude, left section" $ - compareTwo - "HideQualifySectionLeft.hs" [(4,15)] - "Replace with qualified: Prelude.++" - "HideQualifySectionLeft.expected.hs" - , testCase "Prelude, right section" $ - compareTwo - "HideQualifySectionRight.hs" [(4,18)] - "Replace with qualified: Prelude.++" - "HideQualifySectionRight.expected.hs" - ] - ] - ] - where - hidingDir = "test/data/hiding" - compareTwo original locs cmd expected = - withTarget original locs $ \doc actions -> do - expected <- liftIO $ - readFileUtf8 (hidingDir expected) - action <- liftIO $ pickActionWithTitle cmd actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction - compareHideFunctionTo = compareTwo "HideFunction.hs" - auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs", "FVec.hs"] - withTarget file locs k = withTempDir $ \dir -> runInDir dir $ do - liftIO $ mapM_ (\fp -> copyFile (hidingDir fp) $ dir fp) - $ file : auxFiles - doc <- openDoc file "haskell" - waitForProgressDone - void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] - actions <- getAllCodeActions doc - k doc actions - withHideFunction = withTarget ("HideFunction" <.> "hs") - -suggestHideShadowTests :: TestTree -suggestHideShadowTests = - testGroup - "suggest hide shadow" - [ testGroup - "single" - [ testOneCodeAction - "hide unsued" - "Hide on from Data.Function" - (1, 2) - (1, 4) - [ "import Data.Function" - , "f on = on" - , "g on = on" - ] - [ "import Data.Function hiding (on)" - , "f on = on" - , "g on = on" - ] - , testOneCodeAction - "extend hiding unsued" - "Hide on from Data.Function" - (1, 2) - (1, 4) - [ "import Data.Function hiding ((&))" - , "f on = on" - ] - [ "import Data.Function hiding (on, (&))" - , "f on = on" - ] - , testOneCodeAction - "delete unsued" - "Hide on from Data.Function" - (1, 2) - (1, 4) - [ "import Data.Function ((&), on)" - , "f on = on" - ] - [ "import Data.Function ((&))" - , "f on = on" - ] - , testOneCodeAction - "hide operator" - "Hide & from Data.Function" - (1, 2) - (1, 5) - [ "import Data.Function" - , "f (&) = (&)" - ] - [ "import Data.Function hiding ((&))" - , "f (&) = (&)" - ] - , testOneCodeAction - "remove operator" - "Hide & from Data.Function" - (1, 2) - (1, 5) - [ "import Data.Function ((&), on)" - , "f (&) = (&)" - ] - [ "import Data.Function ( on)" - , "f (&) = (&)" - ] - , noCodeAction - "don't remove already used" - (2, 2) - (2, 4) - [ "import Data.Function" - , "g = on" - , "f on = on" - ] - ] - , testGroup - "multi" - [ testOneCodeAction - "hide from B" - "Hide ++ from B" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B hiding ((++))" - , "import C" - , "f (++) = (++)" - ] - , testOneCodeAction - "hide from C" - "Hide ++ from C" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B" - , "import C hiding ((++))" - , "f (++) = (++)" - ] - , testOneCodeAction - "hide from Prelude" - "Hide ++ from Prelude" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B" - , "import C" - , "import Prelude hiding ((++))" - , "f (++) = (++)" - ] - , testMultiCodeActions - "manual hide all" - [ "Hide ++ from Prelude" - , "Hide ++ from C" - , "Hide ++ from B" - ] - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B hiding ((++))" - , "import C hiding ((++))" - , "import Prelude hiding ((++))" - , "f (++) = (++)" - ] - , testOneCodeAction - "auto hide all" - "Hide ++ from all occurence imports" - (2, 2) - (2, 6) - [ "import B" - , "import C" - , "f (++) = (++)" - ] - [ "import B hiding ((++))" - , "import C hiding ((++))" - , "import Prelude hiding ((++))" - , "f (++) = (++)" - ] - ] - ] - where - testOneCodeAction testName actionName start end origin expected = - helper testName start end origin expected $ \cas -> do - action <- liftIO $ pickActionWithTitle actionName cas - executeCodeAction action - noCodeAction testName start end origin = - helper testName start end origin origin $ \cas -> do - liftIO $ cas @?= [] - testMultiCodeActions testName actionNames start end origin expected = - helper testName start end origin expected $ \cas -> do - let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames] - liftIO $ - (length r == length actionNames) - @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" - forM_ r executeCodeAction - helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do - void $ createDoc "B.hs" "haskell" $ T.unlines docB - void $ createDoc "C.hs" "haskell" $ T.unlines docC - doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) - void waitForDiagnostics - waitForProgressDone - cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2)) - void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] - contentAfter <- documentContents doc - liftIO $ contentAfter @?= T.unlines (header <> expected) - header = - [ "{-# OPTIONS_GHC -Wname-shadowing #-}" - , "module A where" - , "" - ] - -- for multi group - docB = - [ "module B where" - , "(++) = id" - ] - docC = - [ "module C where" - , "(++) = id" - ] - -insertNewDefinitionTests :: TestTree -insertNewDefinitionTests = testGroup "insert new definition actions" - [ testSession "insert new function definition" $ do - let txtB = - ["foo True = select [True]" - , "" - ,"foo False = False" - ] - txtB' = - ["" - ,"someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 0 0 0 50) - liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines (txtB ++ - [ "" - , "select :: [Bool] -> Bool" - , "select = _" - ] - ++ txtB') - , testSession "define a hole" $ do - let txtB = - ["foo True = _select [True]" - , "" - ,"foo False = False" - ] - txtB' = - ["" - ,"someOtherCode = ()" - ] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 0 0 0 50) - liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines ( - ["foo True = select [True]" - , "" - ,"foo False = False" - , "" - , "select :: [Bool] -> Bool" - , "select = _" - ] - ++ txtB') - , testSession "insert new function definition - Haddock comments" $ do - let start = ["foo :: Int -> Bool" - , "foo x = select (x + 1)" - , "" - , "-- | This is a haddock comment" - , "haddock :: Int -> Int" - , "haddock = undefined" - ] - let expected = ["foo :: Int -> Bool" - , "foo x = select (x + 1)" - , "" - , "select :: Int -> Bool" - , "select = _" - , "" - , "-- | This is a haddock comment" - , "haddock :: Int -> Int" - , "haddock = undefined"] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 0 50) - liftIO $ actionTitle @?= "Define select :: Int -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines expected - , testSession "insert new function definition - normal comments" $ do - let start = ["foo :: Int -> Bool" - , "foo x = select (x + 1)" - , "" - , "-- This is a normal comment" - , "normal :: Int -> Int" - , "normal = undefined" - ] - let expected = ["foo :: Int -> Bool" - , "foo x = select (x + 1)" - , "" - , "select :: Int -> Bool" - , "select = _" - , "" - , "-- This is a normal comment" - , "normal :: Int -> Int" - , "normal = undefined"] - docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) - _ <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 0 50) - liftIO $ actionTitle @?= "Define select :: Int -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines expected - ] - - -deleteUnusedDefinitionTests :: TestTree -deleteUnusedDefinitionTests = testGroup "delete unused definition action" - [ testSession "delete unused top level binding" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "f :: Int -> Int" - , "f 1 = let a = 1" - , " in a" - , "f 2 = 2" - , "" - , "some = ()" - ]) - (4, 0) - "Delete ‘f’" - (T.unlines [ - "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "some = ()" - ]) - - , testSession "delete unused top level binding defined in infix form" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "myPlus :: Int -> Int -> Int" - , "a `myPlus` b = a + b" - , "" - , "some = ()" - ]) - (4, 2) - "Delete ‘myPlus’" - (T.unlines [ - "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (some) where" - , "" - , "some = ()" - ]) - , testSession "delete unused binding in where clause" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (h, g) where" - , "" - , "h :: Int" - , "h = 3" - , "" - , "g :: Int" - , "g = 6" - , " where" - , " h :: Int" - , " h = 4" - , "" - ]) - (10, 4) - "Delete ‘h’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (h, g) where" - , "" - , "h :: Int" - , "h = 3" - , "" - , "g :: Int" - , "g = 6" - , " where" - , "" - ]) - , testSession "delete unused binding with multi-oneline signatures front" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (b, c) where" - , "" - , "a, b, c :: Int" - , "a = 3" - , "b = 4" - , "c = 5" - ]) - (4, 0) - "Delete ‘a’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (b, c) where" - , "" - , "b, c :: Int" - , "b = 4" - , "c = 5" - ]) - , testSession "delete unused binding with multi-oneline signatures mid" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, c) where" - , "" - , "a, b, c :: Int" - , "a = 3" - , "b = 4" - , "c = 5" - ]) - (5, 0) - "Delete ‘b’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, c) where" - , "" - , "a, c :: Int" - , "a = 3" - , "c = 5" - ]) - , testSession "delete unused binding with multi-oneline signatures end" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, b) where" - , "" - , "a, b, c :: Int" - , "a = 3" - , "b = 4" - , "c = 5" - ]) - (6, 0) - "Delete ‘c’" - (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (a, b) where" - , "" - , "a, b :: Int" - , "a = 3" - , "b = 4" - ]) - ] - where - testFor source pos expectedTitle expectedResult = do - docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ] - - (action, title) <- extractCodeAction docId "Delete" pos - - liftIO $ title @?= expectedTitle - executeCodeAction action - contentAfterAction <- documentContents docId - liftIO $ contentAfterAction @?= expectedResult - - extractCodeAction docId actionPrefix (l, c) = do - [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l c) [actionPrefix] - return (action, actionTitle) - -addTypeAnnotationsToLiteralsTest :: TestTree -addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy constraints" - [ - testSession "add default type to satisfy one constraint" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A (f) where" - , "" - , "f = 1" - ]) - [ (DsWarning, (3, 4), "Defaulting the following constraint") ] - "Add type annotation ‘Integer’ to ‘1’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A (f) where" - , "" - , "f = (1 :: Integer)" - ]) - - , testSession "add default type to satisfy one constraint in nested expressions" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = 3" - , " in x" - ]) - [ (DsWarning, (4, 12), "Defaulting the following constraint") ] - "Add type annotation ‘Integer’ to ‘3’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = (3 :: Integer)" - , " in x" - ]) - , testSession "add default type to satisfy one constraint in more nested expressions" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = let y = 5 in y" - , " in x" - ]) - [ (DsWarning, (4, 20), "Defaulting the following constraint") ] - "Add type annotation ‘Integer’ to ‘5’" - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "module A where" - , "" - , "f =" - , " let x = let y = (5 :: Integer) in y" - , " in x" - ]) - , testSession "add default type to satisfy one constraint with duplicate literals" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq \"debug\" traceShow \"debug\"" - ]) - [ (DsWarning, (6, 8), "Defaulting the following constraint") - , (DsWarning, (6, 16), "Defaulting the following constraint") - ] - ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\"" - ]) - , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ - testSession "add default type to satisfy two constraints" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f a = traceShow \"debug\" a" - ]) - [ (DsWarning, (6, 6), "Defaulting the following constraint") ] - ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a" - ]) - , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ - testSession "add default type to satisfy two constraints with duplicate literals" $ - testFor - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" - ]) - [ (DsWarning, (6, 54), "Defaulting the following constraint") ] - ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") - (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" - , "{-# LANGUAGE OverloadedStrings #-}" - , "module A (f) where" - , "" - , "import Debug.Trace" - , "" - , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: " <> listOfChar <> ")))" - ]) - ] - where - testFor source diag expectedTitle expectedResult = do - docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", diag) ] - - let cursors = map snd3 diag - (action, title) <- extractCodeAction docId "Add type annotation" (minimum cursors) (maximum cursors) - - liftIO $ title @?= expectedTitle - executeCodeAction action - contentAfterAction <- documentContents docId - liftIO $ contentAfterAction @?= expectedResult - - extractCodeAction docId actionPrefix (l,c) (l', c')= do - [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l' c') [actionPrefix] - return (action, actionTitle) - - -fixConstructorImportTests :: TestTree -fixConstructorImportTests = testGroup "fix import actions" - [ testSession "fix constructor import" $ template - (T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA(Constructor)" - ]) - (Range (Position 1 10) (Position 1 11)) - "Fix import of A(Constructor)" - (T.unlines - [ "module ModuleB where" - , "import ModuleA(A(Constructor))" - ]) - ] - where - template contentA contentB range expectedAction expectedContentB = do - _docA <- createDoc "ModuleA.hs" "haskell" contentA - docB <- createDoc "ModuleB.hs" "haskell" contentB - _diags <- waitForDiagnostics - InR action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB range - liftIO $ expectedAction @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ expectedContentB @=? contentAfterAction - -importRenameActionTests :: TestTree -importRenameActionTests = testGroup "import rename actions" - [ testSession "Data.Mape -> Data.Map" $ check "Map" - , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where - check modname = do - let content = T.unlines - [ "module Testing where" - , "import Data.Mape" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 1 8) (Position 1 16)) - let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] - executeCodeAction changeToMap - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "import Data." <> modname - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - -fillTypedHoleTests :: TestTree -fillTypedHoleTests = let - - sourceCode :: T.Text -> T.Text -> T.Text -> T.Text - sourceCode a b c = T.unlines - [ "module Testing where" - , "" - , "globalConvert :: Int -> String" - , "globalConvert = undefined" - , "" - , "globalInt :: Int" - , "globalInt = 3" - , "" - , "bar :: Int -> Int -> String" - , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where" - , " localConvert = (flip replicate) 'x'" - , "" - , "foo :: () -> Int -> String" - , "foo = undefined" - - ] - - check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree - check actionTitle - oldA oldB oldC - newA newB newC = testSession (T.unpack actionTitle) $ do - let originalCode = sourceCode oldA oldB oldC - let expectedCode = sourceCode newA newB newC - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "fill typed holes" - [ check "replace _ with show" - "_" "n" "n" - "show" "n" "n" - - , check "replace _ with globalConvert" - "_" "n" "n" - "globalConvert" "n" "n" - - , check "replace _convertme with localConvert" - "_convertme" "n" "n" - "localConvert" "n" "n" - - , check "replace _b with globalInt" - "_a" "_b" "_c" - "_a" "globalInt" "_c" - - , check "replace _c with globalInt" - "_a" "_b" "_c" - "_a" "_b" "globalInt" - - , check "replace _c with parameterInt" - "_a" "_b" "_c" - "_a" "_b" "parameterInt" - , check "replace _ with foo _" - "_" "n" "n" - "(foo _)" "n" "n" - , testSession "replace _toException with E.toException" $ do - let mkDoc x = T.unlines - [ "module Testing where" - , "import qualified Control.Exception as E" - , "ioToSome :: E.IOException -> E.SomeException" - , "ioToSome = " <> x ] - doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" - _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound)) - chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions - executeCodeAction chosen - modifiedCode <- documentContents doc - liftIO $ mkDoc "E.toException" @=? modifiedCode - , testSession "filling infix type hole uses prefix notation" $ do - let mkDoc x = T.unlines - [ "module Testing where" - , "data A = A" - , "foo :: A -> A -> A" - , "foo A A = A" - , "test :: A -> A -> A" - , "test a1 a2 = a1 " <> x <> " a2" - ] - doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" - _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19)) - chosen <- liftIO $ pickActionWithTitle "replace _ with foo" actions - executeCodeAction chosen - modifiedCode <- documentContents doc - liftIO $ mkDoc "`foo`" @=? modifiedCode - , testSession "postfix hole uses postfix notation of infix operator" $ do - let mkDoc x = T.unlines - [ "module Testing where" - , "test :: Int -> Int -> Int" - , "test a1 a2 = " <> x <> " a1 a2" - ] - doc <- createDoc "Test.hs" "haskell" $ mkDoc "_" - _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14)) - chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions - executeCodeAction chosen - modifiedCode <- documentContents doc - liftIO $ mkDoc "(+)" @=? modifiedCode - , testSession "filling infix type hole uses infix operator" $ do - let mkDoc x = T.unlines - [ "module Testing where" - , "test :: Int -> Int -> Int" - , "test a1 a2 = a1 " <> x <> " a2" - ] - doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" - _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19)) - chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions - executeCodeAction chosen - modifiedCode <- documentContents doc - liftIO $ mkDoc "+" @=? modifiedCode - ] - -addInstanceConstraintTests :: TestTree -addInstanceConstraintTests = let - missingConstraintSourceCode :: Maybe T.Text -> T.Text - missingConstraintSourceCode mConstraint = - let constraint = maybe "" (<> " => ") mConstraint - in T.unlines - [ "module Testing where" - , "" - , "data Wrap a = Wrap a" - , "" - , "instance " <> constraint <> "Eq (Wrap a) where" - , " (Wrap x) == (Wrap y) = x == y" - ] - - incompleteConstraintSourceCode :: Maybe T.Text -> T.Text - incompleteConstraintSourceCode mConstraint = - let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")") mConstraint - in T.unlines - [ "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "instance " <> constraint <> " => Eq (Pair a b) where" - , " (Pair x y) == (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text - incompleteConstraintSourceCode2 mConstraint = - let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")") mConstraint - in T.unlines - [ "module Testing where" - , "" - , "data Three a b c = Three a b c" - , "" - , "instance " <> constraint <> " => Eq (Three a b c) where" - , " (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'" - ] - - check :: T.Text -> T.Text -> T.Text -> TestTree - check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - - in testGroup "add instance constraint" - [ check - "Add `Eq a` to the context of the instance declaration" - (missingConstraintSourceCode Nothing) - (missingConstraintSourceCode $ Just "Eq a") - , check - "Add `Eq b` to the context of the instance declaration" - (incompleteConstraintSourceCode Nothing) - (incompleteConstraintSourceCode $ Just "Eq b") - , check - "Add `Eq c` to the context of the instance declaration" - (incompleteConstraintSourceCode2 Nothing) - (incompleteConstraintSourceCode2 $ Just "Eq c") - ] - -addFunctionConstraintTests :: TestTree -addFunctionConstraintTests = let - missingConstraintSourceCode :: T.Text -> T.Text - missingConstraintSourceCode constraint = - T.unlines - [ "module Testing where" - , "" - , "eq :: " <> constraint <> "a -> a -> Bool" - , "eq x y = x == y" - ] - - missingConstraintWithForAllSourceCode :: T.Text -> T.Text - missingConstraintWithForAllSourceCode constraint = - T.unlines - [ "{-# LANGUAGE ExplicitForAll #-}" - , "module Testing where" - , "" - , "eq :: forall a. " <> constraint <> "a -> a -> Bool" - , "eq x y = x == y" - ] - - incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text - incompleteConstraintWithForAllSourceCode constraint = - T.unlines - [ "{-# LANGUAGE ExplicitForAll #-}" - , "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCode :: T.Text -> T.Text - incompleteConstraintSourceCode constraint = - T.unlines - [ "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCode2 :: T.Text -> T.Text - incompleteConstraintSourceCode2 constraint = - T.unlines - [ "module Testing where" - , "" - , "data Three a b c = Three a b c" - , "" - , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool" - , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'" - ] - - incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text - incompleteConstraintSourceCodeWithExtraCharsInContext constraint = - T.unlines - [ "module Testing where" - , "" - , "data Pair a b = Pair a b" - , "" - , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text - incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint = - T.unlines - [ "module Testing where" - , "data Pair a b = Pair a b" - , "eq " - , " :: (" <> constraint <> ")" - , " => Pair a b -> Pair a b -> Bool" - , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" - ] - - missingMonadConstraint constraint = T.unlines - [ "module Testing where" - , "f :: " <> constraint <> "m ()" - , "f = do " - , " return ()" - ] - - in testGroup "add function constraint" - [ checkCodeAction - "no preexisting constraint" - "Add `Eq a` to the context of the type signature for `eq`" - (missingConstraintSourceCode "") - (missingConstraintSourceCode "Eq a => ") - , checkCodeAction - "no preexisting constraint, with forall" - "Add `Eq a` to the context of the type signature for `eq`" - (missingConstraintWithForAllSourceCode "") - (missingConstraintWithForAllSourceCode "Eq a => ") - , checkCodeAction - "preexisting constraint, no parenthesis" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCode "Eq a") - (incompleteConstraintSourceCode "(Eq a, Eq b)") - , checkCodeAction - "preexisting constraints in parenthesis" - "Add `Eq c` to the context of the type signature for `eq`" - (incompleteConstraintSourceCode2 "(Eq a, Eq b)") - (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") - , checkCodeAction - "preexisting constraints with forall" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintWithForAllSourceCode "Eq a") - (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") - , checkCodeAction - "preexisting constraint, with extra spaces in context" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") - (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") - , checkCodeAction - "preexisting constraint, with newlines in type signature" - "Add `Eq b` to the context of the type signature for `eq`" - (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") - (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") - , checkCodeAction - "missing Monad constraint" - "Add `Monad m` to the context of the type signature for `f`" - (missingMonadConstraint "") - (missingMonadConstraint "Monad m => ") - ] - -checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree -checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - -addImplicitParamsConstraintTests :: TestTree -addImplicitParamsConstraintTests = - testGroup - "add missing implicit params constraints" - [ testGroup - "introduced" - [ let ex ctxtA = exampleCode "?a" ctxtA "" - in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"), - let ex ctxA = exampleCode "x where x = ?a" ctxA "" - in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()") - ], - testGroup - "inherited" - [ let ex = exampleCode "()" "?a::()" - in checkCodeAction - "with preexisting context" - "Add `?a::()` to the context of the type signature for `fCaller`" - (ex "Eq ()") - (ex "Eq (), ?a::()"), - let ex = exampleCode "()" "?a::()" - in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()") - ] - ] - where - mkContext "" = "" - mkContext contents = "(" <> contents <> ") => " - - exampleCode bodyBase contextBase contextCaller = - T.unlines - [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}", - "module Testing where", - "fBase :: " <> mkContext contextBase <> "()", - "fBase = " <> bodyBase, - "fCaller :: " <> mkContext contextCaller <> "()", - "fCaller = fBase" - ] - -removeRedundantConstraintsTests :: TestTree -removeRedundantConstraintsTests = let - header = - [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" - , "module Testing where" - , "" - ] - - headerExt :: [T.Text] -> [T.Text] - headerExt exts = - redunt : extTxt ++ ["module Testing where"] - where - redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}" - extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts - - redundantConstraintsCode :: Maybe T.Text -> T.Text - redundantConstraintsCode mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "foo :: " <> constraint <> "a -> a" - , "foo = id" - ] - - redundantMixedConstraintsCode :: Maybe T.Text -> T.Text - redundantMixedConstraintsCode mConstraint = - let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint - in T.unlines $ header <> - [ "foo :: " <> constraint <> " => a -> Bool" - , "foo x = x == 1" - ] - - typeSignatureSpaces :: Maybe T.Text -> T.Text - typeSignatureSpaces mConstraint = - let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint - in T.unlines $ header <> - [ "foo :: " <> constraint <> " => a -> Bool" - , "foo x = x == 1" - ] - - redundantConstraintsForall :: Maybe T.Text -> T.Text - redundantConstraintsForall mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ headerExt ["RankNTypes"] <> - [ "foo :: forall a. " <> constraint <> "a -> a" - , "foo = id" - ] - - typeSignatureDo :: Maybe T.Text -> T.Text - typeSignatureDo mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "f :: Int -> IO ()" - , "f n = do" - , " let foo :: " <> constraint <> "a -> IO ()" - , " foo _ = return ()" - , " r n" - ] - - typeSignatureNested :: Maybe T.Text -> T.Text - typeSignatureNested mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "f :: Int -> ()" - , "f = g" - , " where" - , " g :: " <> constraint <> "a -> ()" - , " g _ = ()" - ] - - typeSignatureNested' :: Maybe T.Text -> T.Text - typeSignatureNested' mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "f :: Int -> ()" - , "f =" - , " let" - , " g :: Int -> ()" - , " g = h" - , " where" - , " h :: " <> constraint <> "a -> ()" - , " h _ = ()" - , " in g" - ] - - typeSignatureNested'' :: Maybe T.Text -> T.Text - typeSignatureNested'' mConstraint = - let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint - in T.unlines $ header <> - [ "f :: Int -> ()" - , "f = g" - , " where" - , " g :: Int -> ()" - , " g = " - , " let" - , " h :: " <> constraint <> "a -> ()" - , " h _ = ()" - , " in h" - ] - - typeSignatureLined1 = T.unlines $ header <> - [ "foo :: Eq a =>" - , " a -> Bool" - , "foo _ = True" - ] - - typeSignatureLined2 = T.unlines $ header <> - [ "foo :: (Eq a, Show a)" - , " => a -> Bool" - , "foo _ = True" - ] - - typeSignatureOneLine = T.unlines $ header <> - [ "foo :: a -> Bool" - , "foo _ = True" - ] - - typeSignatureLined3 = T.unlines $ header <> - [ "foo :: ( Eq a" - , " , Show a" - , " )" - , " => a -> Bool" - , "foo x = x == x" - ] - - typeSignatureLined3' = T.unlines $ header <> - [ "foo :: ( Eq a" - , " )" - , " => a -> Bool" - , "foo x = x == x" - ] - - - check :: T.Text -> T.Text -> T.Text -> TestTree - check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - - in testGroup "remove redundant function constraints" - [ check - "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" - (redundantConstraintsCode $ Just "Eq a") - (redundantConstraintsCode Nothing) - , check - "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`" - (redundantConstraintsCode $ Just "(Eq a, Monoid a)") - (redundantConstraintsCode Nothing) - , check - "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" - (redundantMixedConstraintsCode $ Just "Monoid a, Show a") - (redundantMixedConstraintsCode Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `g`" - (typeSignatureNested $ Just "Eq a") - (typeSignatureNested Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `h`" - (typeSignatureNested' $ Just "Eq a") - (typeSignatureNested' Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `h`" - (typeSignatureNested'' $ Just "Eq a") - (typeSignatureNested'' Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" - (redundantConstraintsForall $ Just "Eq a") - (redundantConstraintsForall Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" - (typeSignatureDo $ Just "Eq a") - (typeSignatureDo Nothing) - , check - "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" - (typeSignatureSpaces $ Just "Monoid a, Show a") - (typeSignatureSpaces Nothing) - , check - "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" - typeSignatureLined1 - typeSignatureOneLine - , check - "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`" - typeSignatureLined2 - typeSignatureOneLine - , check - "Remove redundant constraint `Show a` from the context of the type signature for `foo`" - typeSignatureLined3 - typeSignatureLined3' - ] - -addSigActionTests :: TestTree -addSigActionTests = let - header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" - , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}" - , "module Sigs where" - , "data T1 a where" - , " MkT1 :: (Show b) => a -> b -> T1 a" - ] - before def = T.unlines $ header ++ [def] - after' def sig = T.unlines $ header ++ [sig, def] - - def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do - let originalCode = before def - let expectedCode = after' def sig - doc <- createDoc "Sigs.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "add signature" - [ "abc = True" >:: "abc :: Bool" - , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a" - , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String" - , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool" - , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" - , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" - , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a" - , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a" - , "pattern Some a <- Just a\n where Some a = Just a" >:: "pattern Some :: a -> Maybe a" - , "pattern Some a <- Just !a\n where Some !a = Just a" >:: "pattern Some :: a -> Maybe a" - , "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" - , "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)" - , "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" - , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" - , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" - , "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" - ] - -exportUnusedTests :: TestTree -exportUnusedTests = testGroup "export unused actions" - [ testGroup "don't want suggestion" - [ testSession "implicit exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# OPTIONS_GHC -Wmissing-signatures #-}" - , "module A where" - , "foo = id"]) - (R 3 0 3 3) - "Export ‘foo’" - Nothing -- codeaction should not be available - , testSession "not top-level" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# OPTIONS_GHC -Wunused-binds #-}" - , "module A (foo,bar) where" - , "foo = ()" - , " where bar = ()" - , "bar = ()"]) - (R 2 0 2 11) - "Export ‘bar’" - Nothing - , ignoreForGHC92 "Diagnostic message has no suggestions" $ - testSession "type is exported but not the constructor of same name" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo) where" - , "data Foo = Foo"]) - (R 2 0 2 8) - "Export ‘Foo’" - Nothing -- codeaction should not be available - , testSession "unused data field" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(Foo)) where" - , "data Foo = Foo {foo :: ()}"]) - (R 2 0 2 20) - "Export ‘foo’" - Nothing -- codeaction should not be available - ] - , testGroup "want suggestion" - [ testSession "empty exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (" - , ") where" - , "foo = id"]) - (R 3 0 3 3) - "Export ‘foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (" - , "foo) where" - , "foo = id"]) - , testSession "single line explicit exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (foo) where" - , "foo = id" - , "bar = foo"]) - (R 3 0 3 3) - "Export ‘bar’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (foo, bar) where" - , "foo = id" - , "bar = foo"]) - , testSession "multi line explicit exports" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (" - , " foo) where" - , "foo = id" - , "bar = foo"]) - (R 5 0 5 3) - "Export ‘bar’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (" - , " foo, bar) where" - , "foo = id" - , "bar = foo"]) - , testSession "export list ends in comma" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (foo," - , " ) where" - , "foo = id" - , "bar = foo"]) - (R 5 0 5 3) - "Export ‘bar’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " (foo," - , " bar) where" - , "foo = id" - , "bar = foo"]) - , testSession "style of multiple exports is preserved 1" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " ( foo" - , " , bar" - , " ) where" - , "foo = id" - , "bar = foo" - , "baz = bar" - ]) - (R 7 0 7 3) - "Export ‘baz’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " ( foo" - , " , bar" - , " , baz" - , " ) where" - , "foo = id" - , "bar = foo" - , "baz = bar" - ]) - , testSession "style of multiple exports is preserved 2" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " ( foo," - , " bar" - , " ) where" - , "foo = id" - , "bar = foo" - , "baz = bar" - ]) - (R 7 0 7 3) - "Export ‘baz’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " ( foo," - , " bar," - , " baz" - , " ) where" - , "foo = id" - , "bar = foo" - , "baz = bar" - ]) - , testSession "style of multiple exports is preserved and selects smallest export separator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " ( foo" - , " , bar" - , " -- * For testing" - , " , baz" - , " ) where" - , "foo = id" - , "bar = foo" - , "baz = bar" - , "quux = bar" - ]) - (R 10 0 10 4) - "Export ‘quux’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A" - , " ( foo" - , " , bar" - , " -- * For testing" - , " , baz" - , " , quux" - , " ) where" - , "foo = id" - , "bar = foo" - , "baz = bar" - , "quux = bar" - ]) - , testSession "unused pattern synonym" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE PatternSynonyms #-}" - , "module A () where" - , "pattern Foo a <- (a, _)"]) - (R 3 0 3 10) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE PatternSynonyms #-}" - , "module A (pattern Foo) where" - , "pattern Foo a <- (a, _)"]) - , testSession "unused data type" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "data Foo = Foo"]) - (R 2 0 2 7) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(..)) where" - , "data Foo = Foo"]) - , testSession "unused newtype" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "newtype Foo = Foo ()"]) - (R 2 0 2 10) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(..)) where" - , "newtype Foo = Foo ()"]) - , testSession "unused type synonym" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "type Foo = ()"]) - (R 2 0 2 7) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo) where" - , "type Foo = ()"]) - , testSession "unused type family" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "module A () where" - , "type family Foo p"]) - (R 3 0 3 15) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "module A (Foo) where" - , "type family Foo p"]) - , testSession "unused typeclass" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "class Foo a"]) - (R 2 0 2 8) - "Export ‘Foo’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (Foo(..)) where" - , "class Foo a"]) - , testSession "infix" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "a `f` b = ()"]) - (R 2 0 2 11) - "Export ‘f’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (f) where" - , "a `f` b = ()"]) - , testSession "function operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A () where" - , "(<|) = ($)"]) - (R 2 0 2 9) - "Export ‘<|’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A ((<|)) where" - , "(<|) = ($)"]) - , testSession "type synonym operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "type (:<) = ()"]) - (R 3 0 3 13) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A ((:<)) where" - , "type (:<) = ()"]) - , testSession "type family operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "type family (:<)"]) - (R 4 0 4 15) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeFamilies #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)) where" - , "type family (:<)"]) - , testSession "typeclass operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "class (:<) a"]) - (R 3 0 3 11) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "class (:<) a"]) - , testSession "newtype operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "newtype (:<) = Foo ()"]) - (R 3 0 3 20) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "newtype (:<) = Foo ()"]) - , testSession "data type operator" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A () where" - , "data (:<) = Foo ()"]) - (R 3 0 3 17) - "Export ‘:<’" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" - , "data (:<) = Foo ()"]) - ] - ] - where - template doc range = exportTemplate (Just range) doc - -exportTemplate :: Maybe Range -> T.Text -> T.Text -> Maybe T.Text -> Session () -exportTemplate mRange initialContent expectedAction expectedContents = do - doc <- createDoc "A.hs" "haskell" initialContent - _ <- waitForDiagnostics - actions <- case mRange of - Nothing -> getAllCodeActions doc - Just range -> getCodeActions doc range - case expectedContents of - Just content -> do - action <- liftIO $ pickActionWithTitle expectedAction actions - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ content @=? contentAfterAction - Nothing -> - liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= [] - -removeExportTests :: TestTree -removeExportTests = testGroup "remove export actions" - [ testSession "single export" $ template - (T.unlines - [ "module A ( a ) where" - , "b :: ()" - , "b = ()"]) - "Remove ‘a’ from export" - (Just $ T.unlines - [ "module A ( ) where" - , "b :: ()" - , "b = ()"]) - , testSession "ending comma" $ template - (T.unlines - [ "module A ( a, ) where" - , "b :: ()" - , "b = ()"]) - "Remove ‘a’ from export" - (Just $ T.unlines - [ "module A ( ) where" - , "b :: ()" - , "b = ()"]) - , testSession "multiple exports" $ template - (T.unlines - [ "module A (a , c, b ) where" - , "a, c :: ()" - , "a = ()" - , "c = ()"]) - "Remove ‘b’ from export" - (Just $ T.unlines - [ "module A (a , c ) where" - , "a, c :: ()" - , "a = ()" - , "c = ()"]) - , testSession "not in scope constructor" $ template - (T.unlines - [ "module A (A (X,Y,Z,(:<)), ab) where" - , "data A = X Int | Y | (:<) Int" - , "ab :: ()" - , "ab = ()" - ]) - "Remove ‘Z’ from export" - (Just $ T.unlines - [ "module A (A (X,Y,(:<)), ab) where" - , "data A = X Int | Y | (:<) Int" - , "ab :: ()" - , "ab = ()"]) - , testSession "multiline export" $ template - (T.unlines - [ "module A (a" - , " , b" - , " , (:*:)" - , " , ) where" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - "Remove ‘:*:’ from export" - (Just $ T.unlines - [ "module A (a" - , " , b" - , " " - , " , ) where" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - , testSession "qualified re-export" $ template - (T.unlines - [ "module A (M.x,a) where" - , "import qualified Data.List as M" - , "a :: ()" - , "a = ()"]) - "Remove ‘M.x’ from export" - (Just $ T.unlines - [ "module A (a) where" - , "import qualified Data.List as M" - , "a :: ()" - , "a = ()"]) - , testSession "qualified re-export ending in '.'" $ template - (T.unlines - [ "module A ((M.@.),a) where" - , "import qualified Data.List as M" - , "a :: ()" - , "a = ()"]) - "Remove ‘M.@.’ from export" - (Just $ T.unlines - [ "module A (a) where" - , "import qualified Data.List as M" - , "a :: ()" - , "a = ()"]) - , testSession "export module" $ template - (T.unlines - [ "module A (module B) where" - , "a :: ()" - , "a = ()"]) - "Remove ‘module B’ from export" - (Just $ T.unlines - [ "module A () where" - , "a :: ()" - , "a = ()"]) - , testSession "dodgy export" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (A (..)) where" - , "data X = X" - , "type A = X"]) - "Remove ‘A(..)’ from export" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A () where" - , "data X = X" - , "type A = X"]) - , testSession "dodgy export" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (A (..)) where" - , "data X = X" - , "type A = X"]) - "Remove ‘A(..)’ from export" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A () where" - , "data X = X" - , "type A = X"]) - , testSession "duplicate module export" $ template - (T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (module L,module L) where" - , "import Data.List as L" - , "a :: ()" - , "a = ()"]) - "Remove ‘Module L’ from export" - (Just $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A (module L) where" - , "import Data.List as L" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports single" $ template - (T.unlines - [ "module A (x) where" - , "a :: ()" - , "a = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A () where" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports two" $ template - (T.unlines - [ "module A (x,y) where" - , "a :: ()" - , "a = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A () where" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports three" $ template - (T.unlines - [ "module A (a,x,y) where" - , "a :: ()" - , "a = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A (a) where" - , "a :: ()" - , "a = ()"]) - , testSession "remove all exports composite" $ template - (T.unlines - [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where" - , "data A = X {getV :: Int} | Y {getV :: Int}" - , "data B = B" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - "Remove all redundant exports" - (Just $ T.unlines - [ "module A (b, a, A(X, Y,getV), B(B)) where" - , "data A = X {getV :: Int} | Y {getV :: Int}" - , "data B = B" - , "a,b :: ()" - , "a = ()" - , "b = ()"]) - ] - where - template = exportTemplate Nothing - addSigLensesTests :: TestTree addSigLensesTests = let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" @@ -4826,55 +1502,6 @@ completionTest name src pos expected = testSessionWait name $ do when expectedDocs $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) -completionCommandTest :: - String -> - [T.Text] -> - Position -> - T.Text -> - [T.Text] -> - TestTree -completionCommandTest name src pos wanted expected = testSession name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- skipManyTill anyMessage (getCompletions docId pos) - let wantedC = find ( \case - CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x - _ -> False - ) compls - case wantedC of - Nothing -> - liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] - Just CompletionItem {..} -> do - c <- assertJust "Expected a command" _command - executeCommand c - if src /= expected - then do - void $ skipManyTill anyMessage loggingNotification - modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) - liftIO $ modifiedCode @?= T.unlines expected - else do - expectMessages SWorkspaceApplyEdit 1 $ \edit -> - liftIO $ assertFailure $ "Expected no edit but got: " <> show edit - -completionNoCommandTest :: - String -> - [T.Text] -> - Position -> - T.Text -> - TestTree -completionNoCommandTest name src pos wanted = testSession name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- getCompletions docId pos - let wantedC = find ( \case - CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x - _ -> False - ) compls - case wantedC of - Nothing -> - liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] - Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command - topLevelCompletionTests :: [TestTree] topLevelCompletionTests = [ @@ -5069,120 +1696,6 @@ nonLocalCompletionTests = (Position 2 10) [("readFile", CiFunction, "readFile ${1:FilePath}", True, True, Nothing)] ], - testGroup "auto import snippets" - [ completionCommandTest - "show imports not in list - simple" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (msum)", "f = joi"] - (Position 3 6) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (msum, join)", "f = joi"] - , completionCommandTest - "show imports not in list - multi-line" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (\n msum)", "f = joi"] - (Position 4 6) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (\n msum, join)", "f = joi"] - , completionCommandTest - "show imports not in list - names with _" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"] - (Position 3 11) - "mapM_" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"] - , completionCommandTest - "show imports not in list - initial empty list" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "f = M.joi"] - (Position 3 10) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (join)", "f = M.joi"] - , testGroup "qualified imports" - [ completionCommandTest - "single" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad ()", "f = Control.Monad.joi"] - (Position 3 22) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"] - , completionCommandTest - "as" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "f = M.joi"] - (Position 3 10) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M (join)", "f = M.joi"] - , completionCommandTest - "multiple" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"] - (Position 4 10) - "join" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"] - ] - , testGroup "Data constructor" - [ completionCommandTest - "not imported" - ["module A where", "import Text.Printf ()", "ZeroPad"] - (Position 2 4) - "ZeroPad" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - , completionCommandTest - "parent imported abs" - ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"] - (Position 2 4) - "ZeroPad" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - , completionNoCommandTest - "parent imported all" - ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"] - (Position 2 4) - "ZeroPad" - , completionNoCommandTest - "already imported" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - (Position 2 4) - "ZeroPad" - , completionNoCommandTest - "function from Prelude" - ["module A where", "import Data.Maybe ()", "Nothing"] - (Position 2 4) - "Nothing" - , completionCommandTest - "type operator parent" - ["module A where", "import Data.Type.Equality ()", "f = Ref"] - (Position 2 8) - "Refl" - ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"] - ] - , testGroup "Record completion" - [ completionCommandTest - "not imported" - ["module A where", "import Text.Printf ()", "FormatParse"] - (Position 2 10) - "FormatParse {" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - , completionCommandTest - "parent imported" - ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] - (Position 2 10) - "FormatParse {" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - , completionNoCommandTest - "already imported" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - (Position 2 10) - "FormatParse {" - ] - ], -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls completionTest "do not show pragma completions" @@ -5329,21 +1842,6 @@ packageCompletionTests = ] liftIO $ take 3 compls' @?= map Just ["fromList ${1:([Item l])}"] - , testGroup "auto import snippets" - [ completionCommandTest - "import Data.Sequence" - ["module A where", "foo :: Seq"] - (Position 1 9) - "Seq" - ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"] - - , completionCommandTest - "qualified import" - ["module A where", "foo :: Seq.Seq"] - (Position 1 13) - "Seq" - ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"] - ] ] projectCompletionTests :: [TestTree] @@ -6336,9 +2834,9 @@ asyncTests = testGroup "async" , "foo = id" ] void waitForDiagnostics - actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) - liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? - [ "add signature: foo :: a -> a" ] + codeLenses <- getCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] , testSession "request" $ do -- Execute a custom request that will block for 1000 seconds void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 @@ -6348,9 +2846,9 @@ asyncTests = testGroup "async" , "foo = id" ] void waitForDiagnostics - actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) - liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? - [ "add signature: foo :: a -> a" ] + codeLenses <- getCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] ] @@ -6564,21 +3062,6 @@ testSessionWait name = testSession name . -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. ( >> expectNoMoreDiagnostics 0.5) -pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction -pickActionWithTitle title actions = do - assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches) - return $ head matches - where - titles = - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - matches = - [ action - | InR action@CodeAction { _title = actionTitle } <- actions - , title == actionTitle - ] - mkRange :: UInt -> UInt -> UInt -> UInt -> Range mkRange a b c d = Range (Position a b) (Position c d) @@ -6670,35 +3153,6 @@ openTestDataDoc path = do source <- liftIO $ readFileUtf8 $ "test/data" path createDoc path "haskell" source -findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActions = findCodeActions' (==) "is not a superset of" - -findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of" - -findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActions' op errMsg doc range expectedTitles = do - actions <- getCodeActions doc range - let matches = sequence - [ listToMaybe - [ action - | InR action@CodeAction { _title = actionTitle } <- actions - , expectedTitle `op` actionTitle] - | expectedTitle <- expectedTitles] - let msg = show - [ actionTitle - | InR CodeAction { _title = actionTitle } <- actions - ] - ++ " " <> errMsg <> " " - ++ show expectedTitles - liftIO $ case matches of - Nothing -> assertFailure msg - Just _ -> pure () - return (fromJust matches) - -findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction -findCodeAction doc range t = head <$> findCodeActions doc range [t] - unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree unitTests recorder logger = do testGroup "Unit" @@ -7047,11 +3501,6 @@ withTempDir f = System.IO.Extra.withTempDir $ \dir -> do dir' <- canonicalizePath dir f dir' --- | Assert that a value is not 'Nothing', and extract the value. -assertJust :: MonadIO m => String -> Maybe a -> m a -assertJust s = \case - Nothing -> liftIO $ assertFailure s - Just x -> pure x -- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String listOfChar :: T.Text diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 694f057534..6ea7ad476e 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -228,6 +228,11 @@ flag brittany default: True manual: True +flag refactor + description: Enable refactor plugin + default: True + manual: True + flag dynamic description: Build with the dyn rts default: True @@ -360,6 +365,11 @@ common brittany build-depends: hls-brittany-plugin ^>= 1.0 cpp-options: -Dhls_brittany +common refactor + if flag(refactor) + build-depends: hls-refactor-plugin ^>= 1.0 + cpp-options: -Dhls_refactor + library plugins import: common-deps -- configuration @@ -391,6 +401,7 @@ library plugins , ormolu , stylishHaskell , brittany + , refactor exposed-modules: HlsPlugins hs-source-dirs: src diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs index 7470c0e33e..97ea11eff7 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs @@ -46,7 +46,7 @@ addRule f = do runRule :: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value) runRule rules key@(Key t) bs mode = case Map.lookup (typeOf t) rules of - Nothing -> liftIO $ errorIO "Could not find key" + Nothing -> liftIO $ errorIO $ "Could not find key: " ++ show key Just x -> unwrapDynamic x key bs mode runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()]) diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 209569a2bd..617b898fcb 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -31,7 +31,7 @@ module Ide.PluginUtils pluginResponse, handleMaybe, handleMaybeM, - throwPluginError + throwPluginError, ) where @@ -44,6 +44,7 @@ import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Bifunctor (Bifunctor (first)) import qualified Data.HashMap.Strict as H +import Data.List (find) import Data.String (IsString (fromString)) import qualified Data.Text as T import Ide.Plugin.Config @@ -233,6 +234,7 @@ allLspCmdIds pid commands = concatMap go commands where go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds + -- --------------------------------------------------------------------- getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 4877b5271b..e9fbe8a28d 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -45,6 +45,7 @@ module Ide.Types , getProcessID, getPid , installSigUsr1Handler , responseError +, lookupCommandProvider ) where @@ -66,7 +67,7 @@ import Data.GADT.Compare import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List.Extra (sortOn) +import Data.List.Extra (sortOn, find) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map import Data.Maybe @@ -106,19 +107,36 @@ import Options.Applicative (ParserInfo) import System.FilePath import System.IO.Unsafe import Text.Regex.TDFA.Text () +import Control.Applicative ((<|>)) -- --------------------------------------------------------------------- -newtype IdePlugins ideState = IdePlugins_ { ipMap_ :: HashMap PluginId (PluginDescriptor ideState)} - deriving newtype (Semigroup, Monoid) +data IdePlugins ideState = IdePlugins_ + { ipMap_ :: HashMap PluginId (PluginDescriptor ideState) + , lookupCommandProvider :: CommandId -> Maybe PluginId + } -- | Smart constructor that deduplicates plugins pattern IdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState -pattern IdePlugins{ipMap} <- IdePlugins_ (sortOn (Down . pluginPriority) . HashMap.elems -> ipMap) +pattern IdePlugins{ipMap} <- IdePlugins_ (sortOn (Down . pluginPriority) . HashMap.elems -> ipMap) _ where - IdePlugins ipMap = IdePlugins_{ipMap_ = HashMap.fromList $ (pluginId &&& id) <$> ipMap} + IdePlugins ipMap = IdePlugins_{ipMap_ = HashMap.fromList $ (pluginId &&& id) <$> ipMap + , lookupCommandProvider = lookupPluginId ipMap + } {-# COMPLETE IdePlugins #-} +instance Semigroup (IdePlugins a) where + (IdePlugins_ a f) <> (IdePlugins_ b g) = IdePlugins_ (a <> b) (\x -> f x <|> g x) + +instance Monoid (IdePlugins a) where + mempty = IdePlugins_ mempty (const Nothing) + +-- | Lookup the plugin that exposes a particular command +lookupPluginId :: [PluginDescriptor a] -> CommandId -> Maybe PluginId +lookupPluginId ls cmd = pluginId <$> find go ls + where + go desc = cmd `elem` map commandId (pluginCommands desc) + -- | Hooks for modifying the 'DynFlags' at different times of the compilation -- process. Plugins can install a 'DynFlagsModifications' via -- 'pluginModifyDynflags' in their 'PluginDescriptor'. diff --git a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal index e51ad55268..d726b48ee8 100644 --- a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal +++ b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal @@ -38,6 +38,7 @@ library , ghcide ^>=1.6 || ^>=1.7 , hashable , hls-plugin-api ^>=1.3 || ^>=1.4 + , hls-refactor-plugin , lens , lsp , mtl diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs index 0a48a3467b..23a02cfb60 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -31,6 +31,8 @@ import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentPosition, toCurrentRange) import Development.IDE.Types.Logger (Pretty (..)) +import qualified Development.IDE.GHC.ExactPrint as E +import Development.IDE.Plugin.CodeAction import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), codeRangeRule) @@ -55,7 +57,7 @@ import Language.LSP.Types (List (List), import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) +descriptor recorder plId = mkExactprintPluginDescriptor (cmapWithPrio LogExactPrint recorder) $ (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler -- TODO @sloorush add folding range -- <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler @@ -63,10 +65,12 @@ descriptor recorder plId = (defaultPluginDescriptor plId) } data Log = LogRules Rules.Log + | LogExactPrint E.Log instance Pretty Log where pretty log = case log of LogRules codeRangeLog -> pretty codeRangeLog + LogExactPrint exactPrintLog -> pretty exactPrintLog selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index 8a573d9ebb..fcd96ffea1 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -44,7 +44,8 @@ import qualified Data.Vector as V import Development.IDE import Development.IDE.Core.Rules (toIdeResult) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (Annotated, HieAST (..), +import Development.IDE.GHC.Compat.ExactPrint (Annotated) +import Development.IDE.GHC.Compat (HieAST (..), HieASTs (getAsts), ParsedSource, RefMap) import Development.IDE.GHC.Compat.Util diff --git a/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal b/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal index 23fac32e33..f109ea05d3 100644 --- a/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal +++ b/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal @@ -30,6 +30,7 @@ library , ghc-boot-th , ghc-exactprint , hls-plugin-api ^>= 1.4 + , hls-refactor-plugin , lens , lsp >=1.2.0.1 , mtl diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs index 1a59ec2089..fe4ea1876c 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs @@ -16,6 +16,7 @@ import Data.List.Extra (stripInfix) import qualified Data.Text as T import Development.IDE import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.ExactPrint import Ide.PluginUtils (subRange) import Language.Haskell.GHC.ExactPrint.Parsers (parseDecl) diff --git a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal index 9acc5e916c..6de352816b 100644 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal @@ -35,6 +35,7 @@ library , ghc-exactprint < 1 , ghcide ^>=1.6 || ^>=1.7 , hls-plugin-api ^>=1.3 || ^>=1.4 + , hls-refactor-plugin , lsp-types , text , unordered-containers diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 4b162ac574..2993219893 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -15,7 +15,10 @@ import qualified Data.Map as Map import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) import Development.IDE.GHC.Compat +import Development.IDE.Plugin.CodeAction +import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (..)) +import qualified Development.IDE.GHC.ExactPrint as E import Ide.Types import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) @@ -23,8 +26,8 @@ import Language.Haskell.GHC.ExactPrint.Utils import Language.LSP.Types ----------------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = +descriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider } diff --git a/plugins/hls-haddock-comments-plugin/test/Main.hs b/plugins/hls-haddock-comments-plugin/test/Main.hs index 3eadb93416..22189c2590 100644 --- a/plugins/hls-haddock-comments-plugin/test/Main.hs +++ b/plugins/hls-haddock-comments-plugin/test/Main.hs @@ -19,7 +19,7 @@ main :: IO () main = defaultTestRunner tests haddockCommentsPlugin :: PluginDescriptor IdeState -haddockCommentsPlugin = HaddockComments.descriptor "haddockComments" +haddockCommentsPlugin = HaddockComments.descriptor mempty "haddockComments" tests :: TestTree tests = diff --git a/plugins/hls-refactor-plugin/LICENSE b/plugins/hls-refactor-plugin/LICENSE new file mode 100644 index 0000000000..261eeb9e9f --- /dev/null +++ b/plugins/hls-refactor-plugin/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal new file mode 100644 index 0000000000..9461819f08 --- /dev/null +++ b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal @@ -0,0 +1,116 @@ +cabal-version: 3.0 +name: hls-refactor-plugin +version: 1.0.0.0 +synopsis: Exactprint refactorings for Haskell Language Server +description: + Please see the README on GitHub at + +license: Apache-2.0 +license-file: LICENSE +author: The Haskell IDE Team +copyright: The Haskell IDE Team +maintainer: zubin.duggal@gmail.com +category: Development +build-type: Simple +extra-source-files: + LICENSE + test/data/**/*.hs + test/data/**/*.yaml + +library + exposed-modules: Development.IDE.GHC.ExactPrint + Development.IDE.GHC.Compat.ExactPrint + Development.IDE.Plugin.CodeAction + Development.IDE.Plugin.CodeAction.Util + Development.IDE.GHC.Dump + other-modules: Development.IDE.Plugin.CodeAction.Args + Development.IDE.Plugin.CodeAction.ExactPrint + Development.IDE.Plugin.CodeAction.PositionIndexed + default-extensions: + BangPatterns + CPP + DataKinds + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + TypeApplications + TypeOperators + ViewPatterns + hs-source-dirs: src + build-depends: + , aeson + , base >=4.12 && <5 + , ghc + , bytestring + , ghc-boot + , regex-tdfa + , text-rope + , ghcide ^>=1.7 + , hls-plugin-api ^>=1.3 || ^>=1.4 + , lsp + , text + , transformers + , unordered-containers + , containers + , ghc-exactprint < 1 || >= 1.4 + , extra + , retrie + , syb + , hls-graph + , dlist + , deepseq + , mtl + , lens + , data-default + , time + ghc-options: -Wall -Wno-name-shadowing + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -O0 -threaded -rtsopts -with-rtsopts=-N -Wunused-imports + build-depends: + , base + , filepath + , hls-refactor-plugin + , hls-test-utils ^>=1.3 + , lens + , lsp-types + , text + , aeson + , hls-plugin-api + , parser-combinators + , data-default + , extra + , text-rope + , containers + , ghcide + , ghcide:ghcide-test-utils + , shake + , hls-plugin-api + , lsp-test + , network-uri + , directory + , async + , regex-tdfa + , tasty-rerun + , tasty-hunit + , tasty-expected-failure + , tasty diff --git a/ghcide/src/Development/IDE/GHC/Compat/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs similarity index 91% rename from ghcide/src/Development/IDE/GHC/Compat/ExactPrint.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs index a071ef4606..a80f251998 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} - -- | This module contains compatibility constructs to write type signatures across -- multiple ghc-exactprint versions, accepting that anything more ambitious is -- pretty much impossible with the GHC 9.2 redesign of ghc-exactprint diff --git a/ghcide/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs similarity index 99% rename from ghcide/src/Development/IDE/GHC/Dump.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs index a81d6e1215..abaaa81cfb 100644 --- a/ghcide/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -2,6 +2,7 @@ module Development.IDE.GHC.Dump(showAstDataHtml) where import Data.Data hiding (Fixity) import Development.IDE.GHC.Compat hiding (NameAnn) +import Development.IDE.GHC.Compat.ExactPrint #if MIN_VERSION_ghc(8,10,1) import GHC.Hs.Dump #else diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs similarity index 98% rename from ghcide/src/Development/IDE/GHC/ExactPrint.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index f7a67d75bc..a0d8ce135e 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} -- | This module hosts various abstractions and utility functions to work with ghc-exactprint. module Development.IDE.GHC.ExactPrint @@ -49,6 +44,7 @@ where import Control.Applicative (Alternative) import Control.Arrow (right, (***)) +import Control.DeepSeq import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO) @@ -72,6 +68,7 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (parseImport, parsePattern, parseType) +import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location @@ -112,6 +109,12 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +instance Show (Annotated ParsedSource) where + show _ = "" + +instance NFData (Annotated ParsedSource) where + rnf = rwhnf + data GetAnnotatedParsedSource = GetAnnotatedParsedSource deriving (Eq, Show, Typeable, GHC.Generic) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs similarity index 93% rename from ghcide/src/Development/IDE/Plugin/CodeAction.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 35f89ac108..d883e84e89 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -1,20 +1,17 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} module Development.IDE.Plugin.CodeAction ( + mkExactprintPluginDescriptor, iePluginDescriptor, typeSigsPluginDescriptor, bindingsPluginDescriptor, fillHolePluginDescriptor, - newImport, - newImportToEdit + extendImportPluginDescriptor, -- * For testing - , matchRegExMultipleImports + matchRegExMultipleImports ) where import Control.Applicative ((<|>)) @@ -22,8 +19,10 @@ import Control.Arrow (second, (&&&), (>>>)) import Control.Concurrent.STM.Stats (atomically) -import Control.Monad (guard, join) import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Extra +import Data.Aeson import Data.Char import qualified Data.DList as DL import Data.Function @@ -40,18 +39,24 @@ import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Utf16.Rope as Rope import Data.Tuple.Extra (fst3) +import Development.IDE.Types.Logger hiding (group) import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint +import qualified Development.IDE.GHC.ExactPrint as E import Development.IDE.GHC.Util (printOutputable, - printRdrName, - traceAst) + printRdrName) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Plugin.CodeAction.Args import Development.IDE.Plugin.CodeAction.ExactPrint +import Development.IDE.Plugin.CodeAction.Util import Development.IDE.Plugin.CodeAction.PositionIndexed +import Development.IDE.Plugin.Completions.Types import Development.IDE.Plugin.TypeLenses (suggestSignature) import Development.IDE.Types.Exports import Development.IDE.Types.Location @@ -60,21 +65,24 @@ import qualified GHC.LanguageExtensions as Lang import Ide.PluginUtils (subRange) import Ide.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types (CodeAction (..), +import Language.LSP.Types (ApplyWorkspaceEditParams(..), CodeAction (..), CodeActionContext (CodeActionContext, _diagnostics), CodeActionKind (CodeActionQuickFix, CodeActionUnknown), CodeActionParams (CodeActionParams), Command, Diagnostic (..), + MessageType (..), + ShowMessageParams (..), List (..), ResponseError, - SMethod (STextDocumentCodeAction), + SMethod (..), TextDocumentIdentifier (TextDocumentIdentifier), - TextEdit (TextEdit), + TextEdit (TextEdit, _range), UInt, WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), type (|?) (InR), uriToFilePath) +import GHC.Exts (fromList) import Language.LSP.VFS (VirtualFile, _file_text) import Text.Regex.TDFA (mrAfter, @@ -90,7 +98,6 @@ import GHC (AddEpAnn (Ad LEpaComment, LocatedA) -import Control.Monad (msum) #else import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), DeltaPos, @@ -121,8 +128,8 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod ------------------------------------------------------------------------------------------------- -iePluginDescriptor :: PluginId -> PluginDescriptor IdeState -iePluginDescriptor plId = +iePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +iePluginDescriptor recorder plId = let old = mkGhcideCAsPlugin [ wrap suggestExtendImport @@ -135,10 +142,10 @@ iePluginDescriptor plId = , wrap suggestExportUnusedTopBinding ] plId - in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction} + in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction } -typeSigsPluginDescriptor :: PluginId -> PluginDescriptor IdeState -typeSigsPluginDescriptor = +typeSigsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +typeSigsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ mkGhcideCAsPlugin [ wrap $ suggestSignature True , wrap suggestFillTypeWildcard @@ -146,18 +153,107 @@ typeSigsPluginDescriptor = , wrap suggestAddTypeAnnotationToSatisfyContraints , wrap suggestConstraint ] + plId -bindingsPluginDescriptor :: PluginId -> PluginDescriptor IdeState -bindingsPluginDescriptor = +bindingsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ mkGhcideCAsPlugin [ wrap suggestReplaceIdentifier , wrap suggestImplicitParameter , wrap suggestNewDefinition , wrap suggestDeleteUnusedBinding ] + plId + +fillHolePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +fillHolePluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder (mkGhcideCAPlugin (wrap suggestFillHole) plId) + +extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +extendImportPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId) + { pluginCommands = [extendImportCommand] } -fillHolePluginDescriptor :: PluginId -> PluginDescriptor IdeState -fillHolePluginDescriptor = mkGhcideCAPlugin $ wrap suggestFillHole + +-- | Add the ability for a plugin to call GetAnnotatedParsedSource +mkExactprintPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginDescriptor a -> PluginDescriptor a +mkExactprintPluginDescriptor recorder desc = desc { pluginRules = pluginRules desc >> getAnnotatedParsedSourceRule recorder } + +------------------------------------------------------------------------------------------------- + + +extendImportCommand :: PluginCommand IdeState +extendImportCommand = + PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler + +extendImportHandler :: CommandFunction IdeState ExtendImport +extendImportHandler ideState edit@ExtendImport {..} = do + res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit + whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do + let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . Map.toList + srcSpan = rangeToSrcSpan nfp _range + LSP.sendNotification SWindowShowMessage $ + ShowMessageParams MtInfo $ + "Import " + <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent + <> "’ from " + <> importName + <> " (at " + <> printOutputable srcSpan + <> ")" + void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right Null + +extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) +extendImportHandler' ideState ExtendImport {..} + | Just fp <- uriToFilePath doc, + nfp <- toNormalizedFilePath' fp = + do + (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $ + runAction "extend import" ideState $ + runMaybeT $ do + -- We want accurate edits, so do not use stale data here + msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp + ps <- MaybeT $ use GetAnnotatedParsedSource nfp + (_, contents) <- MaybeT $ use GetFileContents nfp + return (msr, ps, contents) + let df = ms_hspp_opts msrModSummary + wantedModule = mkModuleName (T.unpack importName) + wantedQual = mkModuleName . T.unpack <$> importQual + existingImport = find (isWantedModule wantedModule wantedQual) msrImports + case existingImport of + Just imp -> do + fmap (nfp,) $ liftEither $ + rewriteToWEdit df doc +#if !MIN_VERSION_ghc(9,2,0) + (annsA ps) +#endif + $ + extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp) + + Nothing -> do + let n = newImport importName sym importQual False + sym = if isNothing importQual then Just it else Nothing + it = case thingParent of + Nothing -> newThing + Just p -> p <> "(" <> newThing <> ")" + t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents) + return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) + | otherwise = + mzero + +isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool +isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) = + not (isQualifiedImport it) && unLoc ideclName == wantedModule +isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) = + unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual) +isWantedModule _ _ _ = False + + +liftMaybe :: Monad m => Maybe a -> MaybeT m a +liftMaybe a = MaybeT $ pure a + +liftEither :: Monad m => Either e a -> MaybeT m a +liftEither (Left _) = mzero +liftEither (Right x) = return x ------------------------------------------------------------------------------------------------- @@ -278,7 +374,7 @@ suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} | otherwise = [] where L _ HsModule {hsmodImports} = astA ps - + suggests identifier modName s | Just tcM <- mTcM, Just har <- mHar, diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs similarity index 99% rename from ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 85f100ca66..59c0ac868f 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} - module Development.IDE.Plugin.CodeAction.Args ( CodeActionTitle, CodeActionPreferred, @@ -27,6 +24,7 @@ import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.Shake import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.ExactPrint import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, rewriteToEdit) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs similarity index 99% rename from ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 4b516a16ab..57da3ee2f6 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -1,11 +1,5 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} module Development.IDE.Plugin.CodeAction.ExactPrint ( Rewrite (..), rewriteToEdit, @@ -40,6 +34,8 @@ import GHC.Stack (HasCallStack) import Language.Haskell.GHC.ExactPrint import Language.LSP.Types +import Development.IDE.Plugin.CodeAction.Util + -- GHC version specific imports. For any supported GHC version, make sure there is no warning in imports. #if MIN_VERSION_ghc(9,2,0) import Control.Lens (_head, _last, over) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs similarity index 100% rename from ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs similarity index 96% rename from ghcide/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs index 05d6a7f33a..c338903d35 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} module Development.IDE.Plugin.CodeAction.RuleTypes (PackageExports(..) ,IdentInfo(..) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs new file mode 100644 index 0000000000..bfcb0d7a37 --- /dev/null +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Util.hs @@ -0,0 +1,56 @@ +module Development.IDE.Plugin.CodeAction.Util where + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Utils.Outputable +#else +import Development.IDE.GHC.Util +import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Compat +#endif +import Data.Data (Data) +import qualified Data.Unique as U +import Debug.Trace +import Development.IDE.GHC.Compat.ExactPrint as GHC +import GHC.Stack +import System.Environment.Blank (getEnvDefault) +import System.IO.Unsafe +import Text.Printf +import Development.IDE.GHC.Dump (showAstDataHtml) +import Data.Time.Clock.POSIX (POSIXTime, getCurrentTime, + utcTimeToPOSIXSeconds) +-------------------------------------------------------------------------------- +-- Tracing exactprint terms + +-- Should in `Development.IDE.GHC.Orphans`, +-- leave it here to prevent cyclic module dependency + +{-# NOINLINE timestamp #-} +timestamp :: POSIXTime +timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime + +debugAST :: Bool +debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1" + +-- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection +traceAst :: (Data a, ExactPrint a, Outputable a, HasCallStack) => String -> a -> a +traceAst lbl x + | debugAST = trace doTrace x + | otherwise = x + where +#if MIN_VERSION_ghc(9,2,0) + renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True} +#else + renderDump = showSDocUnsafe . ppr +#endif + htmlDump = showAstDataHtml x + doTrace = unsafePerformIO $ do + u <- U.newUnique + let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u) + writeFile htmlDumpFileName $ renderDump htmlDump + return $ unlines + [prettyCallStack callStack ++ ":" +#if MIN_VERSION_ghc(9,2,0) + , exactPrint x +#endif + , "file://" ++ htmlDumpFileName] + diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs new file mode 100644 index 0000000000..dafbd1e843 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -0,0 +1,3747 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} + +module Main + ( main + ) where + +import Control.Applicative.Combinators +import Control.Monad +import Data.Default +import Data.Foldable +import Data.List.Extra +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.Test +import Development.IDE.GHC.Util +import Development.IDE.Plugin.Completions.Types (extendImportCommandId) +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import Language.LSP.Test +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start), + mkRange) +import qualified Language.LSP.Types.Lens as L +import Language.LSP.Types.Capabilities +import System.Directory +import System.FilePath +import System.Info.Extra (isMac, isWindows) +import qualified System.IO.Extra +import System.IO.Extra hiding (withTempDir) +import Control.Lens ((^.)) +import Data.Tuple.Extra +import Ide.Types +import qualified Language.LSP.Types as LSP +import System.Time.Extra +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Text.Regex.TDFA ((=~)) + + +import Test.Hls +import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) + +import qualified Development.IDE.Plugin.CodeAction as Refactor +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde + +main :: IO () +main = defaultTestRunner tests + +refactorPlugin :: [PluginDescriptor IdeState] +refactorPlugin = + [ Refactor.iePluginDescriptor mempty "ghcide-code-actions-imports-exports" + , Refactor.typeSigsPluginDescriptor mempty "ghcide-code-actions-type-signatures" + , Refactor.bindingsPluginDescriptor mempty "ghcide-code-actions-bindings" + , Refactor.fillHolePluginDescriptor mempty "ghcide-code-actions-fill-holes" + , Refactor.extendImportPluginDescriptor mempty "ghcide-completions-1" + ] ++ GhcIde.descriptors mempty + +tests :: TestTree +tests = + testGroup "refactor" + [ initializeTests + , codeActionTests + , codeActionHelperFunctionTests + , completionTests + ] + +initializeTests = withResource acquire release tests + where + tests :: IO (ResponseMessage Initialize) -> TestTree + tests getInitializeResponse = testGroup "initialize response capabilities" + [ chk " code action" _codeActionProvider (Just $ InL True) + , che " execute command" _executeCommandProvider [extendImportCommandId] + ] + where + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title doTest + where + doTest = do + ir <- getInitializeResponse + let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands + + acquire :: IO (ResponseMessage Initialize) + acquire = run initializeResponse + + + release :: ResponseMessage Initialize -> IO () + release = const $ pure () + + innerCaps :: ResponseMessage Initialize -> ServerCapabilities + innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" + +completionTests :: TestTree +completionTests = + testGroup "auto import snippets" + [ completionCommandTest + "show imports not in list - simple" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (msum)", "f = joi"] + (Position 3 6) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (msum, join)", "f = joi"] + , completionCommandTest + "show imports not in list - multi-line" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (\n msum)", "f = joi"] + (Position 4 6) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (\n msum, join)", "f = joi"] + , completionCommandTest + "show imports not in list - names with _" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"] + (Position 3 11) + "mapM_" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"] + , completionCommandTest + "show imports not in list - initial empty list" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "f = M.joi"] + (Position 3 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (join)", "f = M.joi"] + , testGroup "qualified imports" + [ completionCommandTest + "single" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad ()", "f = Control.Monad.joi"] + (Position 3 22) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"] + , completionCommandTest + "as" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "f = M.joi"] + (Position 3 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M (join)", "f = M.joi"] + , completionCommandTest + "multiple" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"] + (Position 4 10) + "join" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"] + ] + , testGroup "Data constructor" + [ completionCommandTest + "not imported" + ["module A where", "import Text.Printf ()", "ZeroPad"] + (Position 2 4) + "ZeroPad" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + , completionCommandTest + "parent imported abs" + ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"] + (Position 2 4) + "ZeroPad" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + , completionNoCommandTest + "parent imported all" + ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"] + (Position 2 4) + "ZeroPad" + , completionNoCommandTest + "already imported" + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + (Position 2 4) + "ZeroPad" + , completionNoCommandTest + "function from Prelude" + ["module A where", "import Data.Maybe ()", "Nothing"] + (Position 2 4) + "Nothing" + , completionCommandTest + "type operator parent" + ["module A where", "import Data.Type.Equality ()", "f = Ref"] + (Position 2 8) + "Refl" + ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"] + ] + , testGroup "Record completion" + [ completionCommandTest + "not imported" + ["module A where", "import Text.Printf ()", "FormatParse"] + (Position 2 10) + "FormatParse {" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + , completionCommandTest + "parent imported" + ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] + (Position 2 10) + "FormatParse {" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + , completionNoCommandTest + "already imported" + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + (Position 2 10) + "FormatParse {" + ] + , testGroup "Package completion" + [ completionCommandTest + "import Data.Sequence" + ["module A where", "foo :: Seq"] + (Position 1 9) + "Seq" + ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"] + + , completionCommandTest + "qualified import" + ["module A where", "foo :: Seq.Seq"] + (Position 1 13) + "Seq" + ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"] + ] + ] + +completionCommandTest :: + String -> + [T.Text] -> + Position -> + T.Text -> + [T.Text] -> + TestTree +completionCommandTest name src pos wanted expected = testSession name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- skipManyTill anyMessage (getCompletions docId pos) + let wantedC = find ( \case + CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x + _ -> False + ) compls + case wantedC of + Nothing -> + liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] + Just CompletionItem {..} -> do + c <- assertJust "Expected a command" _command + executeCommand c + if src /= expected + then do + void $ skipManyTill anyMessage loggingNotification + modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) + liftIO $ modifiedCode @?= T.unlines expected + else do + expectMessages SWorkspaceApplyEdit 1 $ \edit -> + liftIO $ assertFailure $ "Expected no edit but got: " <> show edit + +completionNoCommandTest :: + String -> + [T.Text] -> + Position -> + T.Text -> + TestTree +completionNoCommandTest name src pos wanted = testSession name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- getCompletions docId pos + let wantedC = find ( \case + CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x + _ -> False + ) compls + case wantedC of + Nothing -> + liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] + Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command + + +codeActionTests :: TestTree +codeActionTests = testGroup "code actions" + [ suggestImportDisambiguationTests + , insertImportTests + , extendImportTests + , renameActionTests + , typeWildCardActionTests + , removeImportTests + , suggestImportClassMethodTests + , suggestImportTests + , suggestHideShadowTests + , fixConstructorImportTests + , fixModuleImportTypoTests + , importRenameActionTests + , fillTypedHoleTests + , addSigActionTests + , insertNewDefinitionTests + , deleteUnusedDefinitionTests + , addInstanceConstraintTests + , addFunctionConstraintTests + , removeRedundantConstraintsTests + , addTypeAnnotationsToLiteralsTest + , exportUnusedTests + , addImplicitParamsConstraintTests + , removeExportTests + ] + +insertImportTests :: TestTree +insertImportTests = testGroup "insert import" + [ checkImport + "module where keyword lower in file no exports" + "WhereKeywordLowerInFileNoExports.hs" + "WhereKeywordLowerInFileNoExports.expected.hs" + "import Data.Int" + , checkImport + "module where keyword lower in file with exports" + "WhereDeclLowerInFile.hs" + "WhereDeclLowerInFile.expected.hs" + "import Data.Int" + , checkImport + "module where keyword lower in file with comments before it" + "WhereDeclLowerInFileWithCommentsBeforeIt.hs" + "WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs" + "import Data.Int" + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" + (checkImport + "Shebang not at top with spaces" + "ShebangNotAtTopWithSpaces.hs" + "ShebangNotAtTopWithSpaces.expected.hs" + "import Data.Monoid") + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" + (checkImport + "Shebang not at top no space" + "ShebangNotAtTopNoSpace.hs" + "ShebangNotAtTopNoSpace.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case " + ++ "when OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "OPTIONS_GHC pragma not at top with spaces" + "OptionsNotAtTopWithSpaces.hs" + "OptionsNotAtTopWithSpaces.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for " + ++ "case when shebang is not placed at top of file") + (checkImport + "Shebang not at top of file" + "ShebangNotAtTop.hs" + "ShebangNotAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case " + ++ "when OPTIONS_GHC is not placed at top of file") + (checkImport + "OPTIONS_GHC pragma not at top of file" + "OptionsPragmaNotAtTop.hs" + "OptionsPragmaNotAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case when " + ++ "OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "pragma not at top with comment at top" + "PragmaNotAtTopWithCommentsAtTop.hs" + "PragmaNotAtTopWithCommentsAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case when " + ++ "OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "pragma not at top multiple comments" + "PragmaNotAtTopMultipleComments.hs" + "PragmaNotAtTopMultipleComments.expected.hs" + "import Data.Monoid") + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case of multiline pragmas" + (checkImport + "after multiline language pragmas" + "MultiLinePragma.hs" + "MultiLinePragma.expected.hs" + "import Data.Monoid") + , checkImport + "pragmas not at top with module declaration" + "PragmaNotAtTopWithModuleDecl.hs" + "PragmaNotAtTopWithModuleDecl.expected.hs" + "import Data.Monoid" + , checkImport + "pragmas not at top with imports" + "PragmaNotAtTopWithImports.hs" + "PragmaNotAtTopWithImports.expected.hs" + "import Data.Monoid" + , checkImport + "above comment at top of module" + "CommentAtTop.hs" + "CommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above multiple comments below" + "CommentAtTopMultipleComments.hs" + "CommentAtTopMultipleComments.expected.hs" + "import Data.Monoid" + , checkImport + "above curly brace comment" + "CommentCurlyBraceAtTop.hs" + "CommentCurlyBraceAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above multi-line comment" + "MultiLineCommentAtTop.hs" + "MultiLineCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above comment with no module explicit exports" + "NoExplicitExportCommentAtTop.hs" + "NoExplicitExportCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above two-dash comment with no pipe" + "TwoDashOnlyComment.hs" + "TwoDashOnlyComment.expected.hs" + "import Data.Monoid" + , checkImport + "above comment with no (module .. where) decl" + "NoModuleDeclarationCommentAtTop.hs" + "NoModuleDeclarationCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top with no (module .. where) decl" + "NoModuleDeclaration.hs" + "NoModuleDeclaration.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top (data dec is)" + "DataAtTop.hs" + "DataAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top (newtype is)" + "NewTypeAtTop.hs" + "NewTypeAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with no explicit module exports" + "NoExplicitExports.hs" + "NoExplicitExports.expected.hs" + "import Data.Monoid" + , checkImport + "add to correctly placed exisiting import" + "ImportAtTop.hs" + "ImportAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "add to multiple correctly placed exisiting imports" + "MultipleImportsAtTop.hs" + "MultipleImportsAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma at top of module" + "LangPragmaModuleAtTop.hs" + "LangPragmaModuleAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma and explicit module exports" + "LangPragmaModuleWithComment.hs" + "LangPragmaModuleWithComment.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma at top and no module declaration" + "LanguagePragmaAtTop.hs" + "LanguagePragmaAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with multiple lang pragmas and no module declaration" + "MultipleLanguagePragmasNoModuleDeclaration.hs" + "MultipleLanguagePragmasNoModuleDeclaration.expected.hs" + "import Data.Monoid" + , checkImport + "with pragmas and shebangs" + "LanguagePragmasThenShebangs.hs" + "LanguagePragmasThenShebangs.expected.hs" + "import Data.Monoid" + , checkImport + "with pragmas and shebangs but no comment at top" + "PragmasAndShebangsNoComment.hs" + "PragmasAndShebangsNoComment.expected.hs" + "import Data.Monoid" + , checkImport + "module decl no exports under pragmas and shebangs" + "PragmasShebangsAndModuleDecl.hs" + "PragmasShebangsAndModuleDecl.expected.hs" + "import Data.Monoid" + , checkImport + "module decl with explicit import under pragmas and shebangs" + "PragmasShebangsModuleExplicitExports.hs" + "PragmasShebangsModuleExplicitExports.expected.hs" + "import Data.Monoid" + , checkImport + "module decl and multiple imports" + "ModuleDeclAndImports.hs" + "ModuleDeclAndImports.expected.hs" + "import Data.Monoid" + ] + +checkImport :: String -> FilePath -> FilePath -> T.Text -> TestTree +checkImport testComment originalPath expectedPath action = + testSessionWithExtraFiles "import-placement" testComment $ \dir -> + check (dir originalPath) (dir expectedPath) action + where + check :: FilePath -> FilePath -> T.Text -> Session () + check originalPath expectedPath action = do + oSrc <- liftIO $ readFileUtf8 originalPath + eSrc <- liftIO $ readFileUtf8 expectedPath + originalDoc <- createDoc originalPath "haskell" oSrc + _ <- waitForDiagnostics + shouldBeDoc <- createDoc expectedPath "haskell" eSrc + actionsOrCommands <- getAllCodeActions originalDoc + chosenAction <- liftIO $ pickActionWithTitle action actionsOrCommands + executeCodeAction chosenAction + originalDocAfterAction <- documentContents originalDoc + shouldBeDocContents <- documentContents shouldBeDoc + liftIO $ T.replace "\r\n" "\n" shouldBeDocContents @=? T.replace "\r\n" "\n" originalDocAfterAction + +renameActionTests :: TestTree +renameActionTests = testGroup "rename actions" + [ testSession "change to local variable name" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argNme" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’" + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argName" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "change to name of imported function" $ do + let content = T.unlines + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybToList" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’" + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybeToList" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "suggest multiple local variable names" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Char -> Char -> Char -> Char" + , "foo argument1 argument2 argument3 = argumentX" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45)) + ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"] + return() + , testSession "change infix function" $ do + let content = T.unlines + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monnus` y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) + [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] + executeCodeAction fixTypo + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monus` y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +typeWildCardActionTests :: TestTree +typeWildCardActionTests = testGroup "type wildcard actions" + [ testUseTypeSignature "global signature" + [ "func :: _" + , "func x = x" + ] + [ "func :: p -> p" + , "func x = x" + ] + , testUseTypeSignature "local signature" + [ "func :: Int -> Int" + , "func x =" + , " let y :: _" + , " y = x * 2" + , " in y" + ] + [ "func :: Int -> Int" + , "func x =" + , " let y :: Int" + , " y = x * 2" + , " in y" + ] + , testUseTypeSignature "multi-line message 1" + [ "func :: _" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "type in parentheses" + [ "func :: a -> _" + , "func x = (x, const x)" + ] + [ "func :: a -> (a, b -> a)" + , "func x = (x, const x)" + ] + , testUseTypeSignature "type in brackets" + [ "func :: _ -> Maybe a" + , "func xs = head xs" + ] + [ "func :: [Maybe a] -> Maybe a" + , "func xs = head xs" + ] + , testUseTypeSignature "unit type" + [ "func :: IO _" + , "func = putChar 'H'" + ] + [ "func :: IO ()" + , "func = putChar 'H'" + ] + , testUseTypeSignature "no spaces around '::'" + [ "func::_" + , "func x y = x + y" + ] + [ "func::Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testGroup "add parens if hole is part of bigger type" + [ testUseTypeSignature "subtype 1" + [ "func :: _ -> Integer -> Integer" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "subtype 2" + [ "func :: Integer -> _ -> Integer" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "subtype 3" + [ "func :: Integer -> Integer -> _" + , "func x y = x + y" + ] + [ "func :: Integer -> Integer -> Integer" + , "func x y = x + y" + ] + , testUseTypeSignature "subtype 4" + [ "func :: Integer -> _" + , "func x y = x + y" + ] + [ "func :: Integer -> (Integer -> Integer)" + , "func x y = x + y" + ] + ] + ] + where + -- | Test session of given name, checking action "Use type signature..." + -- on a test file with given content and comparing to expected result. + testUseTypeSignature name textIn textOut = testSession name $ do + let fileStart = "module Testing where" + content = T.unlines $ fileStart : textIn + expectedContentAfterAction = T.unlines $ fileStart : textOut + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + liftIO $ expectedContentAfterAction @=? contentAfterAction + +{-# HLINT ignore "Use nubOrd" #-} +removeImportTests :: TestTree +removeImportTests = testGroup "remove import actions" + [ testSession "redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "qualified redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant binding" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "stuffA = False" + , "stuffB :: Integer" + , "stuffB = 123" + , "stuffC = ()" + , "_stuffD = '_'" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffA, stuffB, _stuffD, stuffC, stuffA)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove _stuffD, stuffA, stuffC from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant binding - unicode regression " $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data A = A" + , "ε :: Double" + , "ε = 0.5" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..), ε)" + , "a = A" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove ε from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..))" + , "a = A" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant operator" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "a !! _b = a" + , "a _b = a" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A ((), stuffB, (!!))" + , "main = print A.stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove !!, from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print A.stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant all import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data A = A" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..), stuffB)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant constructor import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data D = A | B" + , "data E = F" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(A,B), E(F))" + , "main = B" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A, E, F from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(B))" + , "main = B" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "import containing the identifier Strict" $ do + let contentA = T.unlines + [ "module Strict where" + ] + _docA <- createDoc "Strict.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import Strict" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "remove all" $ do + let content = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix, (&))" + , "import qualified Data.Functor.Const" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL, InR))" + , "import qualified Data.Kind as K (Constraint, Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + doc <- createDoc "ModuleC.hs" "haskell" content + _ <- waitForDiagnostics + [_, _, _, _, InR action@CodeAction { _title = actionTitle }] + <- nub <$> getAllCodeActions doc + liftIO $ "Remove all redundant imports" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleA where" + , "import Data.Function (fix)" + , "import Data.Functor.Identity" + , "import Data.Functor.Sum (Sum (InL))" + , "import qualified Data.Kind as K (Type)" + , "x = InL (Identity 123)" + , "y = fix id" + , "type T = K.Type" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "remove unused operators whose name ends with '.'" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "(@.) = 0 -- Must have an operator whose name ends with '.'" + , "a = 1 -- .. but also something else" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (a, (@.))" + , "x = a -- Must use something from module A, but not (@.)" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove @. from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (a)" + , "x = a -- Must use something from module A, but not (@.)" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +extendImportTests :: TestTree +extendImportTests = testGroup "extend import actions" + [ testGroup "with checkAll" $ tests True + , testGroup "without checkAll" $ tests False + ] + where + tests overrideCheckProject = + [ testSession "extend all constructors for record field" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = B { a :: Int }" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A(B))" + , "f = a" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(a) to the import list of ModuleA" + , "Add a to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A(..))" + , "f = a" + ]) + , testSession "extend all constructors with sibling" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo" + , "data Bar" + , "data A = B | C" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (C) , Bar ) " + , "f = B" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(B) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (..) , Bar ) " + , "f = B" + ]) + , testSession "extend all constructors with comment" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo" + , "data Bar" + , "data A = B | C" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (C{-comment--}) , Bar ) " + , "f = B" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(B) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (..{-comment--}) , Bar ) " + , "f = B" + ]) + , testSession "extend all constructors for type operator" $ template + [] + ("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + (Range (Position 3 17) (Position 3 18)) + [ "Add (:~:)(..) to the import list of Data.Type.Equality" + , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"] + (T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:) (..))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + , testSession "extend all constructors for class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add C(..) to the import list of ModuleA" + , "Add C(m2) to the import list of ModuleA" + , "Add m2 to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(..))" + , "b = m2" + ]) + , testSession "extend single line import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 2 17) (Position 2 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB, stuffA)" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with operator" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "(.*) :: Integer -> Integer -> Integer" + , "x .* y = x * y" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffB .* stuffB)" + ]) + (Range (Position 2 17) (Position 2 18)) + ["Add (.*) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB, (.*))" + , "main = print (stuffB .* stuffB)" + ]) + , testSession "extend single line import with infix constructor" $ template + [] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import Data.List.NonEmpty (fromList)" + , "main = case (fromList []) of _ :| _ -> pure ()" + ]) + (Range (Position 2 5) (Position 2 6)) + [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty" + , "Add NonEmpty(..) to the import list of Data.List.NonEmpty" + ] + (T.unlines + [ "module ModuleB where" + , "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))" + , "main = case (fromList []) of _ :| _ -> pure ()" + ]) + , testSession "extend single line import with prefix constructor" $ template + [] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import Prelude hiding (Maybe(..))" + , "import Data.Maybe (catMaybes)" + , "x = Just 10" + ]) + (Range (Position 3 5) (Position 2 6)) + [ "Add Maybe(Just) to the import list of Data.Maybe" + , "Add Maybe(..) to the import list of Data.Maybe" + ] + (T.unlines + [ "module ModuleB where" + , "import Prelude hiding (Maybe(..))" + , "import Data.Maybe (catMaybes, Maybe (Just))" + , "x = Just 10" + ]) + , testSession "extend single line import with type" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "type A = Double" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + , "b :: A" + , "b = 0" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add A to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = 0" + ]) + , testSession "extend single line import with constructor" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 3 5) (Position 3 5)) + [ "Add A(Constructor) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (Constructor))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line import with constructor (with comments)" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A ({-Constructor-}))" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 3 5) (Position 3 5)) + [ "Add A(Constructor) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (Constructor{-Constructor-}))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line import with mixed constructors" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data A = ConstructorFoo | ConstructorBar" + , "a = 1" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A (ConstructorBar), a)" + , "b :: A" + , "b = ConstructorFoo" + ]) + (Range (Position 3 5) (Position 3 5)) + [ "Add A(ConstructorFoo) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)" + , "b :: A" + , "b = ConstructorFoo" + ]) + , testSession "extend single line qualified import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print (A.stuffA, A.stuffB)" + ]) + (Range (Position 2 17) (Position 2 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB, stuffA)" + , "main = print (A.stuffA, A.stuffB)" + ]) + , testSession "extend multi line import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB" + , " )" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB, stuffA" + , " )" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend multi line import with trailing comma" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB," + , " )" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add stuffA to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB, stuffA," + , " )" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with method within class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add C(m2) to the import list of ModuleA" + , "Add m2 to the import list of ModuleA" + , "Add C(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1, m2))" + , "b = m2" + ]) + , testSession "extend single line import with method without class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add m2 to the import list of ModuleA" + , "Add C(m2) to the import list of ModuleA" + , "Add C(..) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1), m2)" + , "b = m2" + ]) + , testSession "extend import list with multiple choices" $ template + [("ModuleA.hs", T.unlines + -- this is just a dummy module to help the arguments needed for this test + [ "module ModuleA (bar) where" + , "bar = 10" + ]), + ("ModuleB.hs", T.unlines + -- this is just a dummy module to help the arguments needed for this test + [ "module ModuleB (bar) where" + , "bar = 10" + ])] + ("ModuleC.hs", T.unlines + [ "module ModuleC where" + , "import ModuleB ()" + , "import ModuleA ()" + , "foo = bar" + ]) + (Range (Position 3 17) (Position 3 18)) + ["Add bar to the import list of ModuleA", + "Add bar to the import list of ModuleB"] + (T.unlines + [ "module ModuleC where" + , "import ModuleB ()" + , "import ModuleA (bar)" + , "foo = bar" + ]) + , testSession "extend import list with constructor of type operator" $ template + [] + ("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + (Range (Position 3 17) (Position 3 18)) + [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality" + , "Add (:~:)(..) to the import list of Data.Type.Equality"] + (T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:) (Refl))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + , expectFailBecause "importing pattern synonyms is unsupported" + $ testSession "extend import list with pattern synonym" $ template + [("ModuleA.hs", T.unlines + [ "{-# LANGUAGE PatternSynonyms #-}" + , "module ModuleA where" + , "pattern Some x = Just x" + ]) + ] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import A ()" + , "k (Some x) = x" + ]) + (Range (Position 2 3) (Position 2 7)) + ["Add pattern Some to the import list of A"] + (T.unlines + [ "module ModuleB where" + , "import A (pattern Some)" + , "k (Some x) = x" + ]) + , ignoreForGHC92 "Diagnostic message has no suggestions" $ + testSession "type constructor name same as data constructor name" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "newtype Foo = Foo Int" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo)" + , "f :: Foo" + , "f = Foo 1" + ]) + (Range (Position 3 4) (Position 3 6)) + ["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo (Foo))" + , "f :: Foo" + , "f = Foo 1" + ]) + , testSession "type constructor name same as data constructor name, data constructor extraneous" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo = Foo" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA()" + , "f :: Foo" + , "f = undefined" + ]) + (Range (Position 2 4) (Position 2 6)) + ["Add Foo to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo)" + , "f :: Foo" + , "f = undefined" + ]) + ] + where + codeActionTitle CodeAction{_title=x} = x + + template setUpModules moduleUnderTest range expectedTitles expectedContentB = do + configureCheckProject overrideCheckProject + + mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules + docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) + _ <- waitForDiagnostics + waitForProgressDone + actionsOrCommands <- getCodeActions docB range + let codeActions = + filter + (T.isPrefixOf "Add" . codeActionTitle) + [ca | InR ca <- actionsOrCommands] + actualTitles = codeActionTitle <$> codeActions + -- Note that we are not testing the order of the actions, as the + -- order of the expected actions indicates which one we'll execute + -- in this test, i.e., the first one. + liftIO $ sort expectedTitles @=? sort actualTitles + + -- Execute the action with the same title as the first expected one. + -- Since we tested that both lists have the same elements (possibly + -- in a different order), this search cannot fail. + let firstTitle:_ = expectedTitles + action = fromJust $ + find ((firstTitle ==) . codeActionTitle) codeActions + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +fixModuleImportTypoTests :: TestTree +fixModuleImportTypoTests = testGroup "fix module import typo" + [ testSession "works when single module suggested" $ do + doc <- createDoc "A.hs" "haskell" "import Data.Cha" + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ <- getCodeActions doc (R 0 0 0 10) + liftIO $ actionTitle @?= "replace with Data.Char" + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= "import Data.Char" + , testSession "works when multiple modules suggested" $ do + doc <- createDoc "A.hs" "haskell" "import Data.I" + _ <- waitForDiagnostics + actions <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions doc (R 0 0 0 10) + let actionTitles = [ title | InR CodeAction{_title=title} <- actions ] + liftIO $ actionTitles @?= [ "replace with Data.Eq" + , "replace with Data.Int" + , "replace with Data.Ix" + ] + let InR replaceWithDataEq : _ = actions + executeCodeAction replaceWithDataEq + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= "import Data.Eq" + ] + +suggestImportClassMethodTests :: TestTree +suggestImportClassMethodTests = + testGroup + "suggest import class methods" + [ testGroup + "new" + [ testSession "via parent" $ + template' + "import Data.Semigroup (Semigroup(stimes))" + (Range (Position 4 2) (Position 4 8)), + testSession "top level" $ + template' + "import Data.Semigroup (stimes)" + (Range (Position 4 2) (Position 4 8)), + testSession "all" $ + template' + "import Data.Semigroup" + (Range (Position 4 2) (Position 4 8)) + ], + testGroup + "extend" + [ testSession "via parent" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add Semigroup(stimes) to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (Semigroup (stimes))" + ], + testSession "top level" $ + template + [ "module A where", + "", + "import Data.Semigroup ()" + ] + (Range (Position 6 2) (Position 6 8)) + "Add stimes to the import list of Data.Semigroup" + [ "module A where", + "", + "import Data.Semigroup (stimes)" + ] + ] + ] + where + decls = + [ "data X = X", + "instance Semigroup X where", + " (<>) _ _ = X", + " stimes _ _ = X" + ] + template beforeContent range executeTitle expectedContent = do + doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls) + _ <- waitForDiagnostics + waitForProgressDone + actions <- getCodeActions doc range + let actions' = [x | InR x <- actions] + titles = [_title | CodeAction {_title} <- actions'] + liftIO $ executeTitle `elem` titles @? T.unpack executeTitle <> " does not in " <> show titles + executeCodeAction $ fromJust $ find (\CodeAction {_title} -> _title == executeTitle) actions' + content <- documentContents doc + liftIO $ T.unlines (expectedContent <> decls) @=? content + template' executeTitle range = let c = ["module A where"] in template c range executeTitle $ c <> [executeTitle] + +suggestImportTests :: TestTree +suggestImportTests = testGroup "suggest import actions" + [ testGroup "Dont want suggestion" + [ -- extend import + test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + -- data constructor + , test False [] "f = First" [] "import Data.Monoid (First)" + -- internal module + , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)" + -- package not in scope + , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" + -- don't omit the parent data type of a constructor + , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" + -- don't suggest data constructor when we only need the type + , test False [] "f :: Bar" [] "import Bar (Bar(Bar))" + -- don't suggest all data constructors for the data type + , test False [] "f :: Bar" [] "import Bar (Bar(..))" + ] + , testGroup "want suggestion" + [ wantWait [] "f = foo" [] "import Foo (foo)" + , wantWait [] "f = Bar" [] "import Bar (Bar(Bar))" + , wantWait [] "f :: Bar" [] "import Bar (Bar)" + , wantWait [] "f = Bar" [] "import Bar (Bar(..))" + , test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))" + , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)" + , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural" + , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)" + , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty" + , test True [] "f = First" [] "import Data.Monoid (First(First))" + , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))" + , test True [] "f = Version" [] "import Data.Version (Version(Version))" + , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))" + , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))" + , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)" + , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative" + , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))" + , test True [] "f = empty" [] "import Control.Applicative (empty)" + , test True [] "f = empty" [] "import Control.Applicative" + , test True [] "f = (&)" [] "import Data.Function ((&))" + , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" + , test True [] "f = Data.List.NonEmpty.nonEmpty" [] "import qualified Data.List.NonEmpty" + , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" + , test True [] "f = pack" [] "import Data.Text (pack)" + , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" + , test True [] "f = [] & id" [] "import Data.Function ((&))" + , test True [] "f = (&) [] id" [] "import Data.Function ((&))" + , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" + , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" + , test True [] "f :: a ~~ b" [] "import Data.Type.Equality (type (~~))" + , test True + ["qualified Data.Text as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True + [ "qualified Data.Text as T" + , "qualified Data.Function as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True + [ "qualified Data.Text as T" + , "qualified Data.Function as T" + , "qualified Data.Functor as T" + , "qualified Data.Data as T" + ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True [] "f = (.|.)" [] "import Data.Bits (Bits(..))" + , test True [] "f = empty" [] "import Control.Applicative (Alternative(..))" + ] + , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" + ] + where + test = test' False + wantWait = test' True True + + test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do + configureCheckProject waitForCheckProject + let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other + after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other + cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}" + liftIO $ writeFileUTF8 (dir "hie.yaml") cradle + liftIO $ writeFileUTF8 (dir "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"] + doc <- createDoc "Test.hs" "haskell" before + waitForProgressDone + _ <- waitForDiagnostics + -- there isn't a good way to wait until the whole project is checked atm + when waitForCheckProject $ liftIO $ sleep 0.5 + let defLine = fromIntegral $ length imps + 1 + range = Range (Position defLine 0) (Position defLine maxBound) + actions <- getCodeActions doc range + if wanted + then do + action <- liftIO $ pickActionWithTitle newImp actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ after @=? contentAfterAction + else + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= [] + +suggestImportDisambiguationTests :: TestTree +suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions" + [ testGroup "Hiding strategy works" + [ testGroup "fromList" + [ testCase "AVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use AVec for fromList, hiding other imports" + "HideFunction.expected.fromList.A.hs" + , testCase "BVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use BVec for fromList, hiding other imports" + "HideFunction.expected.fromList.B.hs" + ] + , testGroup "(++)" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use EVec for ++, hiding other imports" + "HideFunction.expected.append.E.hs" + , testCase "Hide functions without local" $ + compareTwo + "HideFunctionWithoutLocal.hs" [(8,8)] + "Use local definition for ++, hiding other imports" + "HideFunctionWithoutLocal.expected.hs" + , testCase "Prelude" $ + compareHideFunctionTo [(8,9),(10,8)] + "Use Prelude for ++, hiding other imports" + "HideFunction.expected.append.Prelude.hs" + , testCase "Prelude and local definition, infix" $ + compareTwo + "HidePreludeLocalInfix.hs" [(2,19)] + "Use local definition for ++, hiding other imports" + "HidePreludeLocalInfix.expected.hs" + , testCase "AVec, indented" $ + compareTwo "HidePreludeIndented.hs" [(3,8)] + "Use AVec for ++, hiding other imports" + "HidePreludeIndented.expected.hs" + + ] + , testGroup "Vec (type)" + [ testCase "AVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use AVec for Vec, hiding other imports" + "HideType.expected.A.hs" + , testCase "EVec" $ + compareTwo + "HideType.hs" [(8,15)] + "Use EVec for Vec, hiding other imports" + "HideType.expected.E.hs" + ] + ] + , testGroup "Qualify strategy" + [ testCase "won't suggest full name for qualified module" $ + withHideFunction [(8,9),(10,8)] $ \_ _ actions -> do + liftIO $ + assertBool "EVec.fromList must not be suggested" $ + "Replace with qualified: EVec.fromList" `notElem` + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + liftIO $ + assertBool "EVec.++ must not be suggested" $ + "Replace with qualified: EVec.++" `notElem` + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + , testGroup "fromList" + [ testCase "EVec" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: E.fromList" + "HideFunction.expected.qualified.fromList.E.hs" + , testCase "Hide DuplicateRecordFields" $ + compareTwo + "HideQualifyDuplicateRecordFields.hs" [(9, 9)] + "Replace with qualified: AVec.fromList" + "HideQualifyDuplicateRecordFields.expected.hs" + , testCase "Duplicate record fields should not be imported" $ do + withTarget ("HideQualifyDuplicateRecordFields" <.> ".hs") [(9, 9)] $ + \_ _ actions -> do + liftIO $ + assertBool "Hidings should not be presented while DuplicateRecordFields exists" $ + all not [ actionTitle =~ T.pack "Use ([A-Za-z][A-Za-z0-9]*) for fromList, hiding other imports" + | InR CodeAction { _title = actionTitle } <- actions] + withTarget ("HideQualifyDuplicateRecordFieldsSelf" <.> ".hs") [(4, 4)] $ + \_ _ actions -> do + liftIO $ + assertBool "ambiguity from DuplicateRecordFields should not be imported" $ + null actions + ] + , testGroup "(++)" + [ testCase "Prelude, parensed" $ + compareHideFunctionTo [(8,9),(10,8)] + "Replace with qualified: Prelude.++" + "HideFunction.expected.qualified.append.Prelude.hs" + , testCase "Prelude, infix" $ + compareTwo + "HideQualifyInfix.hs" [(4,19)] + "Replace with qualified: Prelude.++" + "HideQualifyInfix.expected.hs" + , testCase "Prelude, left section" $ + compareTwo + "HideQualifySectionLeft.hs" [(4,15)] + "Replace with qualified: Prelude.++" + "HideQualifySectionLeft.expected.hs" + , testCase "Prelude, right section" $ + compareTwo + "HideQualifySectionRight.hs" [(4,18)] + "Replace with qualified: Prelude.++" + "HideQualifySectionRight.expected.hs" + ] + ] + ] + where + compareTwo original locs cmd expected = + withTarget original locs $ \dir doc actions -> do + expected <- liftIO $ + readFileUtf8 (dir expected) + action <- liftIO $ pickActionWithTitle cmd actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction + compareHideFunctionTo = compareTwo "HideFunction.hs" + auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs", "FVec.hs"] + withTarget file locs k = runWithExtraFiles "hiding" $ \dir -> do + doc <- openDoc file "haskell" + waitForProgressDone + void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] + actions <- getAllCodeActions doc + k dir doc actions + withHideFunction = withTarget ("HideFunction" <.> "hs") + +suggestHideShadowTests :: TestTree +suggestHideShadowTests = + testGroup + "suggest hide shadow" + [ testGroup + "single" + [ testOneCodeAction + "hide unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function" + , "f on = on" + , "g on = on" + ] + [ "import Data.Function hiding (on)" + , "f on = on" + , "g on = on" + ] + , testOneCodeAction + "extend hiding unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function hiding ((&))" + , "f on = on" + ] + [ "import Data.Function hiding (on, (&))" + , "f on = on" + ] + , testOneCodeAction + "delete unsued" + "Hide on from Data.Function" + (1, 2) + (1, 4) + [ "import Data.Function ((&), on)" + , "f on = on" + ] + [ "import Data.Function ((&))" + , "f on = on" + ] + , testOneCodeAction + "hide operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function" + , "f (&) = (&)" + ] + [ "import Data.Function hiding ((&))" + , "f (&) = (&)" + ] + , testOneCodeAction + "remove operator" + "Hide & from Data.Function" + (1, 2) + (1, 5) + [ "import Data.Function ((&), on)" + , "f (&) = (&)" + ] + [ "import Data.Function ( on)" + , "f (&) = (&)" + ] + , noCodeAction + "don't remove already used" + (2, 2) + (2, 4) + [ "import Data.Function" + , "g = on" + , "f on = on" + ] + ] + , testGroup + "multi" + [ testOneCodeAction + "hide from B" + "Hide ++ from B" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from C" + "Hide ++ from C" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "hide from Prelude" + "Hide ++ from Prelude" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B" + , "import C" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testMultiCodeActions + "manual hide all" + [ "Hide ++ from Prelude" + , "Hide ++ from C" + , "Hide ++ from B" + ] + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + , testOneCodeAction + "auto hide all" + "Hide ++ from all occurence imports" + (2, 2) + (2, 6) + [ "import B" + , "import C" + , "f (++) = (++)" + ] + [ "import B hiding ((++))" + , "import C hiding ((++))" + , "import Prelude hiding ((++))" + , "f (++) = (++)" + ] + ] + ] + where + testOneCodeAction testName actionName start end origin expected = + helper testName start end origin expected $ \cas -> do + action <- liftIO $ pickActionWithTitle actionName cas + executeCodeAction action + noCodeAction testName start end origin = + helper testName start end origin origin $ \cas -> do + liftIO $ cas @?= [] + testMultiCodeActions testName actionNames start end origin expected = + helper testName start end origin expected $ \cas -> do + let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames] + liftIO $ + (length r == length actionNames) + @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset" + forM_ r executeCodeAction + helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do + void $ createDoc "B.hs" "haskell" $ T.unlines docB + void $ createDoc "C.hs" "haskell" $ T.unlines docC + doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) + void waitForDiagnostics + waitForProgressDone + cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2)) + void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] + contentAfter <- documentContents doc + liftIO $ contentAfter @?= T.unlines (header <> expected) + header = + [ "{-# OPTIONS_GHC -Wname-shadowing #-}" + , "module A where" + , "" + ] + -- for multi group + docB = + [ "module B where" + , "(++) = id" + ] + docC = + [ "module C where" + , "(++) = id" + ] + +insertNewDefinitionTests :: TestTree +insertNewDefinitionTests = testGroup "insert new definition actions" + [ testSession "insert new function definition" $ do + let txtB = + ["foo True = select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 0 0 0 50) + liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines (txtB ++ + [ "" + , "select :: [Bool] -> Bool" + , "select = _" + ] + ++ txtB') + , testSession "define a hole" $ do + let txtB = + ["foo True = _select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 0 0 0 50) + liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines ( + ["foo True = select [True]" + , "" + ,"foo False = False" + , "" + , "select :: [Bool] -> Bool" + , "select = _" + ] + ++ txtB') + , testSession "insert new function definition - Haddock comments" $ do + let start = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "-- | This is a haddock comment" + , "haddock :: Int -> Int" + , "haddock = undefined" + ] + let expected = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "select :: Int -> Bool" + , "select = _" + , "" + , "-- | This is a haddock comment" + , "haddock :: Int -> Int" + , "haddock = undefined"] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 0 50) + liftIO $ actionTitle @?= "Define select :: Int -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines expected + , testSession "insert new function definition - normal comments" $ do + let start = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "-- This is a normal comment" + , "normal :: Int -> Int" + , "normal = undefined" + ] + let expected = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "select :: Int -> Bool" + , "select = _" + , "" + , "-- This is a normal comment" + , "normal :: Int -> Int" + , "normal = undefined"] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 0 50) + liftIO $ actionTitle @?= "Define select :: Int -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines expected + ] + + +deleteUnusedDefinitionTests :: TestTree +deleteUnusedDefinitionTests = testGroup "delete unused definition action" + [ testSession "delete unused top level binding" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "f :: Int -> Int" + , "f 1 = let a = 1" + , " in a" + , "f 2 = 2" + , "" + , "some = ()" + ]) + (4, 0) + "Delete ‘f’" + (T.unlines [ + "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ]) + + , testSession "delete unused top level binding defined in infix form" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "myPlus :: Int -> Int -> Int" + , "a `myPlus` b = a + b" + , "" + , "some = ()" + ]) + (4, 2) + "Delete ‘myPlus’" + (T.unlines [ + "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (some) where" + , "" + , "some = ()" + ]) + , testSession "delete unused binding in where clause" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (h, g) where" + , "" + , "h :: Int" + , "h = 3" + , "" + , "g :: Int" + , "g = 6" + , " where" + , " h :: Int" + , " h = 4" + , "" + ]) + (10, 4) + "Delete ‘h’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (h, g) where" + , "" + , "h :: Int" + , "h = 3" + , "" + , "g :: Int" + , "g = 6" + , " where" + , "" + ]) + , testSession "delete unused binding with multi-oneline signatures front" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (b, c) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ]) + (4, 0) + "Delete ‘a’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (b, c) where" + , "" + , "b, c :: Int" + , "b = 4" + , "c = 5" + ]) + , testSession "delete unused binding with multi-oneline signatures mid" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, c) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ]) + (5, 0) + "Delete ‘b’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, c) where" + , "" + , "a, c :: Int" + , "a = 3" + , "c = 5" + ]) + , testSession "delete unused binding with multi-oneline signatures end" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, b) where" + , "" + , "a, b, c :: Int" + , "a = 3" + , "b = 4" + , "c = 5" + ]) + (6, 0) + "Delete ‘c’" + (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (a, b) where" + , "" + , "a, b :: Int" + , "a = 3" + , "b = 4" + ]) + ] + where + testFor source pos expectedTitle expectedResult = do + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ] + + (action, title) <- extractCodeAction docId "Delete" pos + + liftIO $ title @?= expectedTitle + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= expectedResult + + extractCodeAction docId actionPrefix (l, c) = do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l c) [actionPrefix] + return (action, actionTitle) + +addTypeAnnotationsToLiteralsTest :: TestTree +addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy constraints" + [ + testSession "add default type to satisfy one constraint" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A (f) where" + , "" + , "f = 1" + ]) + [ (DsWarning, (3, 4), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘1’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A (f) where" + , "" + , "f = (1 :: Integer)" + ]) + + , testSession "add default type to satisfy one constraint in nested expressions" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = 3" + , " in x" + ]) + [ (DsWarning, (4, 12), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘3’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = (3 :: Integer)" + , " in x" + ]) + , testSession "add default type to satisfy one constraint in more nested expressions" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = let y = 5 in y" + , " in x" + ]) + [ (DsWarning, (4, 20), "Defaulting the following constraint") ] + "Add type annotation ‘Integer’ to ‘5’" + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "module A where" + , "" + , "f =" + , " let x = let y = (5 :: Integer) in y" + , " in x" + ]) + , testSession "add default type to satisfy one constraint with duplicate literals" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq \"debug\" traceShow \"debug\"" + ]) + [ (DsWarning, (6, 8), "Defaulting the following constraint") + , (DsWarning, (6, 16), "Defaulting the following constraint") + ] + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\"" + ]) + , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ + testSession "add default type to satisfy two constraints" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow \"debug\" a" + ]) + [ (DsWarning, (6, 6), "Defaulting the following constraint") ] + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a" + ]) + , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ + testSession "add default type to satisfy two constraints with duplicate literals" $ + testFor + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" + ]) + [ (DsWarning, (6, 54), "Defaulting the following constraint") ] + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") + (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A (f) where" + , "" + , "import Debug.Trace" + , "" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: " <> listOfChar <> ")))" + ]) + ] + where + testFor source diag expectedTitle expectedResult = do + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [ ("A.hs", diag) ] + + let cursors = map snd3 diag + (action, title) <- extractCodeAction docId "Add type annotation" (minimum cursors) (maximum cursors) + + liftIO $ title @?= expectedTitle + executeCodeAction action + contentAfterAction <- documentContents docId + liftIO $ contentAfterAction @?= expectedResult + + extractCodeAction docId actionPrefix (l,c) (l', c')= do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l' c') [actionPrefix] + return (action, actionTitle) + + +fixConstructorImportTests :: TestTree +fixConstructorImportTests = testGroup "fix import actions" + [ testSession "fix constructor import" $ template + (T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Constructor)" + ]) + (Range (Position 1 10) (Position 1 11)) + "Fix import of A(Constructor)" + (T.unlines + [ "module ModuleB where" + , "import ModuleA(A(Constructor))" + ]) + ] + where + template contentA contentB range expectedAction expectedContentB = do + _docA <- createDoc "ModuleA.hs" "haskell" contentA + docB <- createDoc "ModuleB.hs" "haskell" contentB + _diags <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB range + liftIO $ expectedAction @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +importRenameActionTests :: TestTree +importRenameActionTests = testGroup "import rename actions" + [ testSession "Data.Mape -> Data.Map" $ check "Map" + , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where + check modname = do + let content = T.unlines + [ "module Testing where" + , "import Data.Mape" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 1 8) (Position 1 16)) + let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] + executeCodeAction changeToMap + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "import Data." <> modname + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + +fillTypedHoleTests :: TestTree +fillTypedHoleTests = let + + sourceCode :: T.Text -> T.Text -> T.Text -> T.Text + sourceCode a b c = T.unlines + [ "module Testing where" + , "" + , "globalConvert :: Int -> String" + , "globalConvert = undefined" + , "" + , "globalInt :: Int" + , "globalInt = 3" + , "" + , "bar :: Int -> Int -> String" + , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where" + , " localConvert = (flip replicate) 'x'" + , "" + , "foo :: () -> Int -> String" + , "foo = undefined" + + ] + + check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree + check actionTitle + oldA oldB oldC + newA newB newC = testSession (T.unpack actionTitle) $ do + let originalCode = sourceCode oldA oldB oldC + let expectedCode = sourceCode newA newB newC + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "fill typed holes" + [ check "replace _ with show" + "_" "n" "n" + "show" "n" "n" + + , check "replace _ with globalConvert" + "_" "n" "n" + "globalConvert" "n" "n" + + , check "replace _convertme with localConvert" + "_convertme" "n" "n" + "localConvert" "n" "n" + + , check "replace _b with globalInt" + "_a" "_b" "_c" + "_a" "globalInt" "_c" + + , check "replace _c with globalInt" + "_a" "_b" "_c" + "_a" "_b" "globalInt" + + , check "replace _c with parameterInt" + "_a" "_b" "_c" + "_a" "_b" "parameterInt" + , check "replace _ with foo _" + "_" "n" "n" + "(foo _)" "n" "n" + , testSession "replace _toException with E.toException" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "import qualified Control.Exception as E" + , "ioToSome :: E.IOException -> E.SomeException" + , "ioToSome = " <> x ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound)) + chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "E.toException" @=? modifiedCode + , testSession "filling infix type hole uses prefix notation" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "data A = A" + , "foo :: A -> A -> A" + , "foo A A = A" + , "test :: A -> A -> A" + , "test a1 a2 = a1 " <> x <> " a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19)) + chosen <- liftIO $ pickActionWithTitle "replace _ with foo" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "`foo`" @=? modifiedCode + , testSession "postfix hole uses postfix notation of infix operator" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "test :: Int -> Int -> Int" + , "test a1 a2 = " <> x <> " a1 a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14)) + chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "(+)" @=? modifiedCode + , testSession "filling infix type hole uses infix operator" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "test :: Int -> Int -> Int" + , "test a1 a2 = a1 " <> x <> " a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19)) + chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "+" @=? modifiedCode + ] + +addInstanceConstraintTests :: TestTree +addInstanceConstraintTests = let + missingConstraintSourceCode :: Maybe T.Text -> T.Text + missingConstraintSourceCode mConstraint = + let constraint = maybe "" (<> " => ") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Wrap a = Wrap a" + , "" + , "instance " <> constraint <> "Eq (Wrap a) where" + , " (Wrap x) == (Wrap y) = x == y" + ] + + incompleteConstraintSourceCode :: Maybe T.Text -> T.Text + incompleteConstraintSourceCode mConstraint = + let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "instance " <> constraint <> " => Eq (Pair a b) where" + , " (Pair x y) == (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text + incompleteConstraintSourceCode2 mConstraint = + let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")") mConstraint + in T.unlines + [ "module Testing where" + , "" + , "data Three a b c = Three a b c" + , "" + , "instance " <> constraint <> " => Eq (Three a b c) where" + , " (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'" + ] + + check :: T.Text -> T.Text -> T.Text -> TestTree + check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + + in testGroup "add instance constraint" + [ check + "Add `Eq a` to the context of the instance declaration" + (missingConstraintSourceCode Nothing) + (missingConstraintSourceCode $ Just "Eq a") + , check + "Add `Eq b` to the context of the instance declaration" + (incompleteConstraintSourceCode Nothing) + (incompleteConstraintSourceCode $ Just "Eq b") + , check + "Add `Eq c` to the context of the instance declaration" + (incompleteConstraintSourceCode2 Nothing) + (incompleteConstraintSourceCode2 $ Just "Eq c") + ] + +addFunctionConstraintTests :: TestTree +addFunctionConstraintTests = let + missingConstraintSourceCode :: T.Text -> T.Text + missingConstraintSourceCode constraint = + T.unlines + [ "module Testing where" + , "" + , "eq :: " <> constraint <> "a -> a -> Bool" + , "eq x y = x == y" + ] + + missingConstraintWithForAllSourceCode :: T.Text -> T.Text + missingConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "eq :: forall a. " <> constraint <> "a -> a -> Bool" + , "eq x y = x == y" + ] + + incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text + incompleteConstraintWithForAllSourceCode constraint = + T.unlines + [ "{-# LANGUAGE ExplicitForAll #-}" + , "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode :: T.Text -> T.Text + incompleteConstraintSourceCode constraint = + T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCode2 :: T.Text -> T.Text + incompleteConstraintSourceCode2 constraint = + T.unlines + [ "module Testing where" + , "" + , "data Three a b c = Three a b c" + , "" + , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool" + , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'" + ] + + incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text + incompleteConstraintSourceCodeWithExtraCharsInContext constraint = + T.unlines + [ "module Testing where" + , "" + , "data Pair a b = Pair a b" + , "" + , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text + incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint = + T.unlines + [ "module Testing where" + , "data Pair a b = Pair a b" + , "eq " + , " :: (" <> constraint <> ")" + , " => Pair a b -> Pair a b -> Bool" + , "eq (Pair x y) (Pair x' y') = x == x' && y == y'" + ] + + missingMonadConstraint constraint = T.unlines + [ "module Testing where" + , "f :: " <> constraint <> "m ()" + , "f = do " + , " return ()" + ] + + in testGroup "add function constraint" + [ checkCodeAction + "no preexisting constraint" + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintSourceCode "") + (missingConstraintSourceCode "Eq a => ") + , checkCodeAction + "no preexisting constraint, with forall" + "Add `Eq a` to the context of the type signature for `eq`" + (missingConstraintWithForAllSourceCode "") + (missingConstraintWithForAllSourceCode "Eq a => ") + , checkCodeAction + "preexisting constraint, no parenthesis" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode "Eq a") + (incompleteConstraintSourceCode "(Eq a, Eq b)") + , checkCodeAction + "preexisting constraints in parenthesis" + "Add `Eq c` to the context of the type signature for `eq`" + (incompleteConstraintSourceCode2 "(Eq a, Eq b)") + (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") + , checkCodeAction + "preexisting constraints with forall" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintWithForAllSourceCode "Eq a") + (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") + , checkCodeAction + "preexisting constraint, with extra spaces in context" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") + (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") + , checkCodeAction + "preexisting constraint, with newlines in type signature" + "Add `Eq b` to the context of the type signature for `eq`" + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") + (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") + , checkCodeAction + "missing Monad constraint" + "Add `Monad m` to the context of the type signature for `f`" + (missingMonadConstraint "") + (missingMonadConstraint "Monad m => ") + ] + +checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree +checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + +addImplicitParamsConstraintTests :: TestTree +addImplicitParamsConstraintTests = + testGroup + "add missing implicit params constraints" + [ testGroup + "introduced" + [ let ex ctxtA = exampleCode "?a" ctxtA "" + in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"), + let ex ctxA = exampleCode "x where x = ?a" ctxA "" + in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()") + ], + testGroup + "inherited" + [ let ex = exampleCode "()" "?a::()" + in checkCodeAction + "with preexisting context" + "Add `?a::()` to the context of the type signature for `fCaller`" + (ex "Eq ()") + (ex "Eq (), ?a::()"), + let ex = exampleCode "()" "?a::()" + in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()") + ] + ] + where + mkContext "" = "" + mkContext contents = "(" <> contents <> ") => " + + exampleCode bodyBase contextBase contextCaller = + T.unlines + [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}", + "module Testing where", + "fBase :: " <> mkContext contextBase <> "()", + "fBase = " <> bodyBase, + "fCaller :: " <> mkContext contextCaller <> "()", + "fCaller = fBase" + ] + +removeRedundantConstraintsTests :: TestTree +removeRedundantConstraintsTests = let + header = + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Testing where" + , "" + ] + + headerExt :: [T.Text] -> [T.Text] + headerExt exts = + redunt : extTxt ++ ["module Testing where"] + where + redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}" + extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts + + redundantConstraintsCode :: Maybe T.Text -> T.Text + redundantConstraintsCode mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> "a -> a" + , "foo = id" + ] + + redundantMixedConstraintsCode :: Maybe T.Text -> T.Text + redundantMixedConstraintsCode mConstraint = + let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> " => a -> Bool" + , "foo x = x == 1" + ] + + typeSignatureSpaces :: Maybe T.Text -> T.Text + typeSignatureSpaces mConstraint = + let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> " => a -> Bool" + , "foo x = x == 1" + ] + + redundantConstraintsForall :: Maybe T.Text -> T.Text + redundantConstraintsForall mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ headerExt ["RankNTypes"] <> + [ "foo :: forall a. " <> constraint <> "a -> a" + , "foo = id" + ] + + typeSignatureDo :: Maybe T.Text -> T.Text + typeSignatureDo mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> IO ()" + , "f n = do" + , " let foo :: " <> constraint <> "a -> IO ()" + , " foo _ = return ()" + , " r n" + ] + + typeSignatureNested :: Maybe T.Text -> T.Text + typeSignatureNested mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: " <> constraint <> "a -> ()" + , " g _ = ()" + ] + + typeSignatureNested' :: Maybe T.Text -> T.Text + typeSignatureNested' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f =" + , " let" + , " g :: Int -> ()" + , " g = h" + , " where" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in g" + ] + + typeSignatureNested'' :: Maybe T.Text -> T.Text + typeSignatureNested'' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: Int -> ()" + , " g = " + , " let" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in h" + ] + + typeSignatureLined1 = T.unlines $ header <> + [ "foo :: Eq a =>" + , " a -> Bool" + , "foo _ = True" + ] + + typeSignatureLined2 = T.unlines $ header <> + [ "foo :: (Eq a, Show a)" + , " => a -> Bool" + , "foo _ = True" + ] + + typeSignatureOneLine = T.unlines $ header <> + [ "foo :: a -> Bool" + , "foo _ = True" + ] + + typeSignatureLined3 = T.unlines $ header <> + [ "foo :: ( Eq a" + , " , Show a" + , " )" + , " => a -> Bool" + , "foo x = x == x" + ] + + typeSignatureLined3' = T.unlines $ header <> + [ "foo :: ( Eq a" + , " )" + , " => a -> Bool" + , "foo x = x == x" + ] + + + check :: T.Text -> T.Text -> T.Text -> TestTree + check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + + in testGroup "remove redundant function constraints" + [ check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "Eq a") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "(Eq a, Monoid a)") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (redundantMixedConstraintsCode $ Just "Monoid a, Show a") + (redundantMixedConstraintsCode Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `g`" + (typeSignatureNested $ Just "Eq a") + (typeSignatureNested Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested' $ Just "Eq a") + (typeSignatureNested' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested'' $ Just "Eq a") + (typeSignatureNested'' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsForall $ Just "Eq a") + (redundantConstraintsForall Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (typeSignatureDo $ Just "Eq a") + (typeSignatureDo Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (typeSignatureSpaces $ Just "Monoid a, Show a") + (typeSignatureSpaces Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + typeSignatureLined1 + typeSignatureOneLine + , check + "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`" + typeSignatureLined2 + typeSignatureOneLine + , check + "Remove redundant constraint `Show a` from the context of the type signature for `foo`" + typeSignatureLined3 + typeSignatureLined3' + ] + +addSigActionTests :: TestTree +addSigActionTests = let + header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}" + , "module Sigs where" + , "data T1 a where" + , " MkT1 :: (Show b) => a -> b -> T1 a" + ] + before def = T.unlines $ header ++ [def] + after' def sig = T.unlines $ header ++ [sig, def] + + def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do + let originalCode = before def + let expectedCode = after' def sig + doc <- createDoc "Sigs.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "add signature" + [ "abc = True" >:: "abc :: Bool" + , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a" + , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String" + , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool" + , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" + , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" + , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just a\n where Some a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Some a <- Just !a\n where Some !a = Just a" >:: "pattern Some :: a -> Maybe a" + , "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" + , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + ] + +exportUnusedTests :: TestTree +exportUnusedTests = testGroup "export unused actions" + [ testGroup "don't want suggestion" + [ testSession "implicit exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# OPTIONS_GHC -Wmissing-signatures #-}" + , "module A where" + , "foo = id"]) + (R 3 0 3 3) + "Export ‘foo’" + Nothing -- codeaction should not be available + , testSession "not top-level" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (foo,bar) where" + , "foo = ()" + , " where bar = ()" + , "bar = ()"]) + (R 2 0 2 11) + "Export ‘bar’" + Nothing + , ignoreForGHC92 "Diagnostic message has no suggestions" $ + testSession "type is exported but not the constructor of same name" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo) where" + , "data Foo = Foo"]) + (R 2 0 2 8) + "Export ‘Foo’" + Nothing -- codeaction should not be available + , testSession "unused data field" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(Foo)) where" + , "data Foo = Foo {foo :: ()}"]) + (R 2 0 2 20) + "Export ‘foo’" + Nothing -- codeaction should not be available + ] + , testGroup "want suggestion" + [ testSession "empty exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (" + , ") where" + , "foo = id"]) + (R 3 0 3 3) + "Export ‘foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (" + , "foo) where" + , "foo = id"]) + , testSession "single line explicit exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (foo) where" + , "foo = id" + , "bar = foo"]) + (R 3 0 3 3) + "Export ‘bar’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (foo, bar) where" + , "foo = id" + , "bar = foo"]) + , testSession "multi line explicit exports" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (" + , " foo) where" + , "foo = id" + , "bar = foo"]) + (R 5 0 5 3) + "Export ‘bar’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (" + , " foo, bar) where" + , "foo = id" + , "bar = foo"]) + , testSession "export list ends in comma" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (foo," + , " ) where" + , "foo = id" + , "bar = foo"]) + (R 5 0 5 3) + "Export ‘bar’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " (foo," + , " bar) where" + , "foo = id" + , "bar = foo"]) + , testSession "style of multiple exports is preserved 1" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ]) + (R 7 0 7 3) + "Export ‘baz’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " , baz" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ]) + , testSession "style of multiple exports is preserved 2" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo," + , " bar" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ]) + (R 7 0 7 3) + "Export ‘baz’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo," + , " bar," + , " baz" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + ]) + , testSession "style of multiple exports is preserved and selects smallest export separator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " -- * For testing" + , " , baz" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + , "quux = bar" + ]) + (R 10 0 10 4) + "Export ‘quux’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A" + , " ( foo" + , " , bar" + , " -- * For testing" + , " , baz" + , " , quux" + , " ) where" + , "foo = id" + , "bar = foo" + , "baz = bar" + , "quux = bar" + ]) + , testSession "unused pattern synonym" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A () where" + , "pattern Foo a <- (a, _)"]) + (R 3 0 3 10) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A (pattern Foo) where" + , "pattern Foo a <- (a, _)"]) + , testSession "unused data type" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "data Foo = Foo"]) + (R 2 0 2 7) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "data Foo = Foo"]) + , testSession "unused newtype" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "newtype Foo = Foo ()"]) + (R 2 0 2 10) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "newtype Foo = Foo ()"]) + , testSession "unused type synonym" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "type Foo = ()"]) + (R 2 0 2 7) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo) where" + , "type Foo = ()"]) + , testSession "unused type family" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A () where" + , "type family Foo p"]) + (R 3 0 3 15) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "module A (Foo) where" + , "type family Foo p"]) + , testSession "unused typeclass" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "class Foo a"]) + (R 2 0 2 8) + "Export ‘Foo’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (Foo(..)) where" + , "class Foo a"]) + , testSession "infix" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "a `f` b = ()"]) + (R 2 0 2 11) + "Export ‘f’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A (f) where" + , "a `f` b = ()"]) + , testSession "function operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A () where" + , "(<|) = ($)"]) + (R 2 0 2 9) + "Export ‘<|’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "module A ((<|)) where" + , "(<|) = ($)"]) + , testSession "type synonym operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "type (:<) = ()"]) + (R 3 0 3 13) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A ((:<)) where" + , "type (:<) = ()"]) + , testSession "type family operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "type family (:<)"]) + (R 4 0 4 15) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)) where" + , "type family (:<)"]) + , testSession "typeclass operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "class (:<) a"]) + (R 3 0 3 11) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "class (:<) a"]) + , testSession "newtype operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "newtype (:<) = Foo ()"]) + (R 3 0 3 20) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "newtype (:<) = Foo ()"]) + , testSession "data type operator" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A () where" + , "data (:<) = Foo ()"]) + (R 3 0 3 17) + "Export ‘:<’" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "module A (type (:<)(..)) where" + , "data (:<) = Foo ()"]) + ] + ] + where + template doc range = exportTemplate (Just range) doc + +exportTemplate :: Maybe Range -> T.Text -> T.Text -> Maybe T.Text -> Session () +exportTemplate mRange initialContent expectedAction expectedContents = do + doc <- createDoc "A.hs" "haskell" initialContent + _ <- waitForDiagnostics + actions <- case mRange of + Nothing -> getAllCodeActions doc + Just range -> getCodeActions doc range + case expectedContents of + Just content -> do + action <- liftIO $ pickActionWithTitle expectedAction actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ content @=? contentAfterAction + Nothing -> + liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= [] + +removeExportTests :: TestTree +removeExportTests = testGroup "remove export actions" + [ testSession "single export" $ template + (T.unlines + [ "module A ( a ) where" + , "b :: ()" + , "b = ()"]) + "Remove ‘a’ from export" + (Just $ T.unlines + [ "module A ( ) where" + , "b :: ()" + , "b = ()"]) + , testSession "ending comma" $ template + (T.unlines + [ "module A ( a, ) where" + , "b :: ()" + , "b = ()"]) + "Remove ‘a’ from export" + (Just $ T.unlines + [ "module A ( ) where" + , "b :: ()" + , "b = ()"]) + , testSession "multiple exports" $ template + (T.unlines + [ "module A (a , c, b ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()"]) + "Remove ‘b’ from export" + (Just $ T.unlines + [ "module A (a , c ) where" + , "a, c :: ()" + , "a = ()" + , "c = ()"]) + , testSession "not in scope constructor" $ template + (T.unlines + [ "module A (A (X,Y,Z,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()" + ]) + "Remove ‘Z’ from export" + (Just $ T.unlines + [ "module A (A (X,Y,(:<)), ab) where" + , "data A = X Int | Y | (:<) Int" + , "ab :: ()" + , "ab = ()"]) + , testSession "multiline export" $ template + (T.unlines + [ "module A (a" + , " , b" + , " , (:*:)" + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + "Remove ‘:*:’ from export" + (Just $ T.unlines + [ "module A (a" + , " , b" + , " " + , " , ) where" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + , testSession "qualified re-export" $ template + (T.unlines + [ "module A (M.x,a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + "Remove ‘M.x’ from export" + (Just $ T.unlines + [ "module A (a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + , testSession "qualified re-export ending in '.'" $ template + (T.unlines + [ "module A ((M.@.),a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + "Remove ‘M.@.’ from export" + (Just $ T.unlines + [ "module A (a) where" + , "import qualified Data.List as M" + , "a :: ()" + , "a = ()"]) + , testSession "export module" $ template + (T.unlines + [ "module A (module B) where" + , "a :: ()" + , "a = ()"]) + "Remove ‘module B’ from export" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "dodgy export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X"]) + "Remove ‘A(..)’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X"]) + , testSession "dodgy export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (A (..)) where" + , "data X = X" + , "type A = X"]) + "Remove ‘A(..)’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A () where" + , "data X = X" + , "type A = X"]) + , testSession "duplicate module export" $ template + (T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L,module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()"]) + "Remove ‘Module L’ from export" + (Just $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A (module L) where" + , "import Data.List as L" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports single" $ template + (T.unlines + [ "module A (x) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports two" $ template + (T.unlines + [ "module A (x,y) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A () where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports three" $ template + (T.unlines + [ "module A (a,x,y) where" + , "a :: ()" + , "a = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A (a) where" + , "a :: ()" + , "a = ()"]) + , testSession "remove all exports composite" $ template + (T.unlines + [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + "Remove all redundant exports" + (Just $ T.unlines + [ "module A (b, a, A(X, Y,getV), B(B)) where" + , "data A = X {getV :: Int} | Y {getV :: Int}" + , "data B = B" + , "a,b :: ()" + , "a = ()" + , "b = ()"]) + ] + where + template = exportTemplate Nothing + + +codeActionHelperFunctionTests :: TestTree +codeActionHelperFunctionTests = testGroup "code action helpers" + [ + extendImportTestsRegEx + ] + +extendImportTestsRegEx :: TestTree +extendImportTestsRegEx = testGroup "regex parsing" + [ + testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing + , testCase "parse malformed import list" $ template + "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217)" + Nothing + , testCase "parse multiple imports" $ template + "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)" + $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")]) + ] + where + template message expected = do + liftIO $ matchRegExMultipleImports message @=? expected + +pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction +pickActionWithTitle title actions = do + assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches) + return $ head matches + where + titles = + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + matches = + [ action + | InR action@CodeAction { _title = actionTitle } <- actions + , title == actionTitle + ] + +findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActions = findCodeActions' (==) "is not a superset of" + +findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of" + +findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActions' op errMsg doc range expectedTitles = do + actions <- getCodeActions doc range + let matches = sequence + [ listToMaybe + [ action + | InR action@CodeAction { _title = actionTitle } <- actions + , expectedTitle `op` actionTitle] + | expectedTitle <- expectedTitles] + let msg = show + [ actionTitle + | InR CodeAction { _title = actionTitle } <- actions + ] + ++ " " <> errMsg <> " " + ++ show expectedTitles + liftIO $ case matches of + Nothing -> assertFailure msg + Just _ -> pure () + return (fromJust matches) + +findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction +findCodeAction doc range t = head <$> findCodeActions doc range [t] + +testSession :: String -> Session () -> TestTree +testSession name = testCase name . run + +testSessionWithExtraFiles :: HasCallStack => FilePath -> String -> (FilePath -> Session ()) -> TestTree +testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix + +runWithExtraFiles :: HasCallStack => FilePath -> (FilePath -> Session a) -> IO a +runWithExtraFiles prefix s = withTempDir $ \dir -> do + copyTestDataFiles dir prefix + runInDir dir (s dir) + +copyTestDataFiles :: HasCallStack => FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile ("test/data" prefix f) (dir f) + +run :: Session a -> IO a +run s = run' (const s) + +run' :: (FilePath -> Session a) -> IO a +run' s = withTempDir $ \dir -> runInDir dir (s dir) + +runInDir :: FilePath -> Session a -> IO a +runInDir dir = runSessionWithServer' refactorPlugin def def lspTestCaps dir + +lspTestCaps :: ClientCapabilities +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path +-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or +-- @/var@ +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir' + +ignoreForGHC92 :: String -> TestTree -> TestTree +ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92]) + +data BrokenTarget = + BrokenSpecific OS [GhcVersion] + -- ^Broken for `BrokenOS` with `GhcVersion` + | BrokenForOS OS + -- ^Broken for `BrokenOS` + | BrokenForGHC [GhcVersion] + -- ^Broken for `GhcVersion` + deriving (Show) + +-- | Ignore test for specific os and ghc with reason. +ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree +ignoreFor = knownIssueFor Ignore + +-- | Deal with `IssueSolution` for specific OS and GHC. +knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree +knownIssueFor solution = go . \case + BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers + BrokenForOS bos -> isTargetOS bos + BrokenForGHC vers -> isTargetGhc vers + where + isTargetOS = \case + Windows -> isWindows + MacOS -> isMac + Linux -> not isWindows && not isMac + + isTargetGhc = elem ghcVersion + + go True = case solution of + Broken -> expectFailBecause + Ignore -> ignoreTestBecause + go False = \_ -> id + + +data IssueSolution = Broken | Ignore deriving (Show) + +-- | Assert that a value is not 'Nothing', and extract the value. +assertJust :: MonadIO m => String -> Maybe a -> m a +assertJust s = \case + Nothing -> liftIO $ assertFailure s + Just x -> pure x + +-- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String +listOfChar :: T.Text +listOfChar | ghcVersion >= GHC90 = "String" + | otherwise = "[Char]" + diff --git a/ghcide/test/data/hiding/AVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/AVec.hs similarity index 100% rename from ghcide/test/data/hiding/AVec.hs rename to plugins/hls-refactor-plugin/test/data/hiding/AVec.hs diff --git a/ghcide/test/data/hiding/BVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/BVec.hs similarity index 100% rename from ghcide/test/data/hiding/BVec.hs rename to plugins/hls-refactor-plugin/test/data/hiding/BVec.hs diff --git a/ghcide/test/data/hiding/CVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/CVec.hs similarity index 100% rename from ghcide/test/data/hiding/CVec.hs rename to plugins/hls-refactor-plugin/test/data/hiding/CVec.hs diff --git a/ghcide/test/data/hiding/DVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/DVec.hs similarity index 100% rename from ghcide/test/data/hiding/DVec.hs rename to plugins/hls-refactor-plugin/test/data/hiding/DVec.hs diff --git a/ghcide/test/data/hiding/EVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/EVec.hs similarity index 100% rename from ghcide/test/data/hiding/EVec.hs rename to plugins/hls-refactor-plugin/test/data/hiding/EVec.hs diff --git a/ghcide/test/data/hiding/FVec.hs b/plugins/hls-refactor-plugin/test/data/hiding/FVec.hs similarity index 100% rename from ghcide/test/data/hiding/FVec.hs rename to plugins/hls-refactor-plugin/test/data/hiding/FVec.hs diff --git a/ghcide/test/data/hiding/HideFunction.expected.append.E.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.E.hs similarity index 100% rename from ghcide/test/data/hiding/HideFunction.expected.append.E.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.E.hs diff --git a/ghcide/test/data/hiding/HideFunction.expected.append.Prelude.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.Prelude.hs similarity index 100% rename from ghcide/test/data/hiding/HideFunction.expected.append.Prelude.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.append.Prelude.hs diff --git a/ghcide/test/data/hiding/HideFunction.expected.fromList.A.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.A.hs similarity index 100% rename from ghcide/test/data/hiding/HideFunction.expected.fromList.A.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.A.hs diff --git a/ghcide/test/data/hiding/HideFunction.expected.fromList.B.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.B.hs similarity index 100% rename from ghcide/test/data/hiding/HideFunction.expected.fromList.B.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.fromList.B.hs diff --git a/ghcide/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs similarity index 100% rename from ghcide/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs diff --git a/ghcide/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs similarity index 100% rename from ghcide/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideFunction.expected.qualified.fromList.E.hs diff --git a/ghcide/test/data/hiding/HideFunction.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunction.hs similarity index 100% rename from ghcide/test/data/hiding/HideFunction.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideFunction.hs diff --git a/ghcide/test/data/hiding/HideFunctionWithoutLocal.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.expected.hs similarity index 100% rename from ghcide/test/data/hiding/HideFunctionWithoutLocal.expected.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.expected.hs diff --git a/ghcide/test/data/hiding/HideFunctionWithoutLocal.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.hs similarity index 100% rename from ghcide/test/data/hiding/HideFunctionWithoutLocal.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideFunctionWithoutLocal.hs diff --git a/ghcide/test/data/hiding/HidePreludeIndented.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.expected.hs similarity index 100% rename from ghcide/test/data/hiding/HidePreludeIndented.expected.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.expected.hs diff --git a/ghcide/test/data/hiding/HidePreludeIndented.hs b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.hs similarity index 100% rename from ghcide/test/data/hiding/HidePreludeIndented.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HidePreludeIndented.hs diff --git a/ghcide/test/data/hiding/HidePreludeLocalInfix.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.expected.hs similarity index 100% rename from ghcide/test/data/hiding/HidePreludeLocalInfix.expected.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.expected.hs diff --git a/ghcide/test/data/hiding/HidePreludeLocalInfix.hs b/plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.hs similarity index 100% rename from ghcide/test/data/hiding/HidePreludeLocalInfix.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HidePreludeLocalInfix.hs diff --git a/ghcide/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs similarity index 100% rename from ghcide/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs diff --git a/ghcide/test/data/hiding/HideQualifyDuplicateRecordFields.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.hs similarity index 100% rename from ghcide/test/data/hiding/HideQualifyDuplicateRecordFields.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFields.hs diff --git a/ghcide/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs similarity index 100% rename from ghcide/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs diff --git a/ghcide/test/data/hiding/HideQualifyInfix.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.expected.hs similarity index 100% rename from ghcide/test/data/hiding/HideQualifyInfix.expected.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.expected.hs diff --git a/ghcide/test/data/hiding/HideQualifyInfix.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.hs similarity index 100% rename from ghcide/test/data/hiding/HideQualifyInfix.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideQualifyInfix.hs diff --git a/ghcide/test/data/hiding/HideQualifySectionLeft.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.expected.hs similarity index 100% rename from ghcide/test/data/hiding/HideQualifySectionLeft.expected.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.expected.hs diff --git a/ghcide/test/data/hiding/HideQualifySectionLeft.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.hs similarity index 100% rename from ghcide/test/data/hiding/HideQualifySectionLeft.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionLeft.hs diff --git a/ghcide/test/data/hiding/HideQualifySectionRight.expected.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.expected.hs similarity index 100% rename from ghcide/test/data/hiding/HideQualifySectionRight.expected.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.expected.hs diff --git a/ghcide/test/data/hiding/HideQualifySectionRight.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.hs similarity index 100% rename from ghcide/test/data/hiding/HideQualifySectionRight.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideQualifySectionRight.hs diff --git a/ghcide/test/data/hiding/HideType.expected.A.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.A.hs similarity index 100% rename from ghcide/test/data/hiding/HideType.expected.A.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.A.hs diff --git a/ghcide/test/data/hiding/HideType.expected.E.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.E.hs similarity index 100% rename from ghcide/test/data/hiding/HideType.expected.E.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideType.expected.E.hs diff --git a/ghcide/test/data/hiding/HideType.hs b/plugins/hls-refactor-plugin/test/data/hiding/HideType.hs similarity index 100% rename from ghcide/test/data/hiding/HideType.hs rename to plugins/hls-refactor-plugin/test/data/hiding/HideType.hs diff --git a/ghcide/test/data/hiding/hie.yaml b/plugins/hls-refactor-plugin/test/data/hiding/hie.yaml similarity index 90% rename from ghcide/test/data/hiding/hie.yaml rename to plugins/hls-refactor-plugin/test/data/hiding/hie.yaml index 075686555e..538f854ddf 100644 --- a/ghcide/test/data/hiding/hie.yaml +++ b/plugins/hls-refactor-plugin/test/data/hiding/hie.yaml @@ -8,3 +8,4 @@ cradle: - CVec.hs - DVec.hs - EVec.hs + - FVec.hs diff --git a/plugins/hls-refactor-plugin/test/data/hover/Bar.hs b/plugins/hls-refactor-plugin/test/data/hover/Bar.hs new file mode 100644 index 0000000000..f9fde2a7cc --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/Bar.hs @@ -0,0 +1,4 @@ +module Bar (Bar(..)) where + +-- | Bar Haddock +data Bar = Bar diff --git a/plugins/hls-refactor-plugin/test/data/hover/Foo.hs b/plugins/hls-refactor-plugin/test/data/hover/Foo.hs new file mode 100644 index 0000000000..489a6ccd6b --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/Foo.hs @@ -0,0 +1,6 @@ +module Foo (Bar, foo) where + +import Bar + +-- | foo Haddock +foo = Bar diff --git a/plugins/hls-refactor-plugin/test/data/hover/GotoHover.hs b/plugins/hls-refactor-plugin/test/data/hover/GotoHover.hs new file mode 100644 index 0000000000..e1802580e2 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/GotoHover.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{- HLINT ignore -} +module GotoHover ( module GotoHover) where +import Data.Text (Text, pack) +import Foo (Bar, foo) + + +data TypeConstructor = DataConstructor + { fff :: Text + , ggg :: Int } +aaa :: TypeConstructor +aaa = DataConstructor + { fff = "dfgy" + , ggg = 832 + } +bbb :: TypeConstructor +bbb = DataConstructor "mjgp" 2994 +ccc :: (Text, Int) +ccc = (fff bbb, ggg aaa) +ddd :: Num a => a -> a -> a +ddd vv ww = vv +! ww +a +! b = a - b +hhh (Just a) (><) = a >< a +iii a b = a `b` a +jjj s = pack $ s <> s +class MyClass a where + method :: a -> Int +instance MyClass Int where + method = succ +kkk :: MyClass a => Int -> a -> Int +kkk n c = n + method c + +doBind :: Maybe () +doBind = do unwrapped <- Just () + return unwrapped + +listCompBind :: [Char] +listCompBind = [ succ c | c <- "ptfx" ] + +multipleClause :: Bool -> Char +multipleClause True = 't' +multipleClause False = 'f' + +-- | Recognizable docs: kpqz +documented :: Monad m => Either Int (m a) +documented = Left 7518 + +listOfInt = [ 8391 :: Int, 6268 ] + +outer :: Bool +outer = undefined inner where + + inner :: Char + inner = undefined + +imported :: Bar +imported = foo + +aa2 :: Bool +aa2 = $(id [| True |]) + +hole :: Int +hole = _ + +hole2 :: a -> Maybe a +hole2 = _ diff --git a/plugins/hls-refactor-plugin/test/data/hover/RecordDotSyntax.hs b/plugins/hls-refactor-plugin/test/data/hover/RecordDotSyntax.hs new file mode 100644 index 0000000000..2f43b99977 --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/RecordDotSyntax.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 902 +{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} + +module RecordDotSyntax ( module RecordDotSyntax) where + +import qualified Data.Maybe as M + +data MyRecord = MyRecord + { a :: String + , b :: Integer + , c :: MyChild + } deriving (Eq, Show) + +newtype MyChild = MyChild + { z :: String + } deriving (Eq, Show) + +x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } +y = x.a ++ show x.b ++ x.c.z +#endif diff --git a/plugins/hls-refactor-plugin/test/data/hover/hie.yaml b/plugins/hls-refactor-plugin/test/data/hover/hie.yaml new file mode 100644 index 0000000000..e2b3e97c5d --- /dev/null +++ b/plugins/hls-refactor-plugin/test/data/hover/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/ghcide/test/data/import-placement/CommentAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/CommentAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/CommentAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/CommentAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTop.hs diff --git a/ghcide/test/data/import-placement/CommentAtTopMultipleComments.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/CommentAtTopMultipleComments.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.expected.hs diff --git a/ghcide/test/data/import-placement/CommentAtTopMultipleComments.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.hs similarity index 100% rename from ghcide/test/data/import-placement/CommentAtTopMultipleComments.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/CommentAtTopMultipleComments.hs diff --git a/ghcide/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/CommentCurlyBraceAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/CommentCurlyBraceAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/CommentCurlyBraceAtTop.hs diff --git a/ghcide/test/data/import-placement/DataAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/DataAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/DataAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/DataAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/DataAtTop.hs diff --git a/ghcide/test/data/import-placement/ImportAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/ImportAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/ImportAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/ImportAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ImportAtTop.hs diff --git a/ghcide/test/data/import-placement/LangPragmaModuleAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/LangPragmaModuleAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/LangPragmaModuleAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/LangPragmaModuleAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleAtTop.hs diff --git a/ghcide/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs diff --git a/ghcide/test/data/import-placement/LangPragmaModuleExplicitExports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.hs similarity index 100% rename from ghcide/test/data/import-placement/LangPragmaModuleExplicitExports.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleExplicitExports.hs diff --git a/ghcide/test/data/import-placement/LangPragmaModuleWithComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/LangPragmaModuleWithComment.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.expected.hs diff --git a/ghcide/test/data/import-placement/LangPragmaModuleWithComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.hs similarity index 100% rename from ghcide/test/data/import-placement/LangPragmaModuleWithComment.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LangPragmaModuleWithComment.hs diff --git a/ghcide/test/data/import-placement/LanguagePragmaAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/LanguagePragmaAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/LanguagePragmaAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/LanguagePragmaAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTop.hs diff --git a/ghcide/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs diff --git a/ghcide/test/data/import-placement/LanguagePragmaAtTopWithComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.hs similarity index 100% rename from ghcide/test/data/import-placement/LanguagePragmaAtTopWithComment.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmaAtTopWithComment.hs diff --git a/ghcide/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.expected.hs diff --git a/ghcide/test/data/import-placement/LanguagePragmasThenShebangs.hs b/plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.hs similarity index 100% rename from ghcide/test/data/import-placement/LanguagePragmasThenShebangs.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/LanguagePragmasThenShebangs.hs diff --git a/ghcide/test/data/import-placement/ModuleDeclAndImports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/ModuleDeclAndImports.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.expected.hs diff --git a/ghcide/test/data/import-placement/ModuleDeclAndImports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.hs similarity index 100% rename from ghcide/test/data/import-placement/ModuleDeclAndImports.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ModuleDeclAndImports.hs diff --git a/ghcide/test/data/import-placement/MultiLineCommentAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/MultiLineCommentAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/MultiLineCommentAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/MultiLineCommentAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/MultiLineCommentAtTop.hs diff --git a/ghcide/test/data/import-placement/MultiLinePragma.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/MultiLinePragma.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs diff --git a/ghcide/test/data/import-placement/MultiLinePragma.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.hs similarity index 100% rename from ghcide/test/data/import-placement/MultiLinePragma.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.hs diff --git a/ghcide/test/data/import-placement/MultipleImportsAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/MultipleImportsAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/MultipleImportsAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/MultipleImportsAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/MultipleImportsAtTop.hs diff --git a/ghcide/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs diff --git a/ghcide/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs similarity index 100% rename from ghcide/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs diff --git a/ghcide/test/data/import-placement/NewTypeAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/NewTypeAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/NewTypeAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/NewTypeAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NewTypeAtTop.hs diff --git a/ghcide/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/NoExplicitExportCommentAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/NoExplicitExportCommentAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExportCommentAtTop.hs diff --git a/ghcide/test/data/import-placement/NoExplicitExports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/NoExplicitExports.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.expected.hs diff --git a/ghcide/test/data/import-placement/NoExplicitExports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.hs similarity index 100% rename from ghcide/test/data/import-placement/NoExplicitExports.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NoExplicitExports.hs diff --git a/ghcide/test/data/import-placement/NoModuleDeclaration.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/NoModuleDeclaration.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.expected.hs diff --git a/ghcide/test/data/import-placement/NoModuleDeclaration.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.hs similarity index 100% rename from ghcide/test/data/import-placement/NoModuleDeclaration.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclaration.hs diff --git a/ghcide/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/NoModuleDeclarationCommentAtTop.hs diff --git a/ghcide/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs diff --git a/ghcide/test/data/import-placement/OptionsNotAtTopWithSpaces.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.hs similarity index 100% rename from ghcide/test/data/import-placement/OptionsNotAtTopWithSpaces.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.hs diff --git a/ghcide/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/OptionsPragmaNotAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/OptionsPragmaNotAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.hs diff --git a/ghcide/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs diff --git a/ghcide/test/data/import-placement/PragmaNotAtTopMultipleComments.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmaNotAtTopMultipleComments.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.hs diff --git a/ghcide/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs diff --git a/ghcide/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs diff --git a/ghcide/test/data/import-placement/PragmaNotAtTopWithImports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmaNotAtTopWithImports.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithImports.hs diff --git a/ghcide/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs diff --git a/ghcide/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs diff --git a/ghcide/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.expected.hs diff --git a/ghcide/test/data/import-placement/PragmasAndShebangsNoComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmasAndShebangsNoComment.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmasAndShebangsNoComment.hs diff --git a/ghcide/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs diff --git a/ghcide/test/data/import-placement/PragmasShebangsAndModuleDecl.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmasShebangsAndModuleDecl.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsAndModuleDecl.hs diff --git a/ghcide/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs diff --git a/ghcide/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmasShebangsModuleExplicitExports.hs diff --git a/ghcide/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs diff --git a/ghcide/test/data/import-placement/PragmasThenShebangsMultilineComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.hs similarity index 100% rename from ghcide/test/data/import-placement/PragmasThenShebangsMultilineComment.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/PragmasThenShebangsMultilineComment.hs diff --git a/ghcide/test/data/import-placement/ShebangNotAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/ShebangNotAtTop.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs diff --git a/ghcide/test/data/import-placement/ShebangNotAtTop.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.hs similarity index 100% rename from ghcide/test/data/import-placement/ShebangNotAtTop.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.hs diff --git a/ghcide/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs diff --git a/ghcide/test/data/import-placement/ShebangNotAtTopNoSpace.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.hs similarity index 100% rename from ghcide/test/data/import-placement/ShebangNotAtTopNoSpace.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.hs diff --git a/ghcide/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs diff --git a/ghcide/test/data/import-placement/ShebangNotAtTopWithSpaces.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.hs similarity index 100% rename from ghcide/test/data/import-placement/ShebangNotAtTopWithSpaces.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.hs diff --git a/ghcide/test/data/import-placement/TwoDashOnlyComment.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/TwoDashOnlyComment.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.expected.hs diff --git a/ghcide/test/data/import-placement/TwoDashOnlyComment.hs b/plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.hs similarity index 100% rename from ghcide/test/data/import-placement/TwoDashOnlyComment.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/TwoDashOnlyComment.hs diff --git a/ghcide/test/data/import-placement/WhereDeclLowerInFile.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/WhereDeclLowerInFile.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.expected.hs diff --git a/ghcide/test/data/import-placement/WhereDeclLowerInFile.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.hs similarity index 100% rename from ghcide/test/data/import-placement/WhereDeclLowerInFile.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFile.hs diff --git a/ghcide/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs diff --git a/ghcide/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs similarity index 100% rename from ghcide/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/WhereDeclLowerInFileWithCommentsBeforeIt.hs diff --git a/ghcide/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs similarity index 100% rename from ghcide/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs diff --git a/ghcide/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs b/plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs similarity index 100% rename from ghcide/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs rename to plugins/hls-refactor-plugin/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index c6f20198fe..e0c295dc12 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -29,6 +29,7 @@ library , hashable , hiedb , hls-plugin-api ^>= 1.3 || ^>=1.4 + , hls-refactor-plugin , lsp , lsp-types , mod diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index b83423254a..c6c1238b61 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -29,6 +29,7 @@ import qualified Data.Map as M import Data.Maybe import Data.Mod.Word import qualified Data.Text as T +import Development.IDE (Recorder, WithPriority) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service @@ -39,8 +40,10 @@ import Development.IDE.GHC.Compat.Parser import Development.IDE.GHC.Compat.Units import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint +import qualified Development.IDE.GHC.ExactPrint as E import Development.IDE.Spans.AtPoint import Development.IDE.Types.Location +import Development.IDE.Plugin.CodeAction import HieDb.Query import Ide.Plugin.Properties import Ide.PluginUtils @@ -50,8 +53,8 @@ import Language.LSP.Types instance Hashable (Mod a) where hash n = hash (unMod n) -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor pluginId = (defaultPluginDescriptor pluginId) +descriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor pluginId) { pluginHandlers = mkPluginHandler STextDocumentRename renameProvider , pluginConfigDescriptor = defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties } diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 21151dec1a..5d662b1ad6 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -13,7 +13,7 @@ main :: IO () main = defaultTestRunner tests renamePlugin :: PluginDescriptor IdeState -renamePlugin = Rename.descriptor "rename" +renamePlugin = Rename.descriptor mempty "rename" -- See https://github.com/wz1000/HieDb/issues/45 recordConstructorIssue :: String diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index ae13452eaa..4dc8f7fdd9 100644 --- a/plugins/hls-splice-plugin/hls-splice-plugin.cabal +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -40,6 +40,7 @@ library , ghc-exactprint , ghcide ^>=1.6 || ^>=1.7 , hls-plugin-api ^>=1.3 || ^>=1.4 + , hls-refactor-plugin , lens , lsp , retrie diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 14ce391783..41b5774706 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -47,6 +47,7 @@ import Data.Maybe (fromMaybe, listToMaybe, import qualified Data.Text as T import Development.IDE import Development.IDE.GHC.Compat as Compat hiding (getLoc) +import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint import GHC.Exts diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index 781c39028a..14faae448e 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -85,6 +85,7 @@ library , ghcide ^>=1.7 , hls-graph , hls-plugin-api ^>=1.4 + , hls-refactor-plugin , hyphenation , lens , lsp diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index ed896a99eb..d80e336864 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -34,6 +34,7 @@ import Development.IDE.Core.Shake (IdeState (..), uses, define, use, a import qualified Development.IDE.Core.Shake as IDE import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (empty) +import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.GHC.Error (realSrcSpanToRange) import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 6473a725d5..b55ee31ae3 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -3,6 +3,8 @@ module Wingman.Plugin where import Control.Monad import Development.IDE.Core.Shake (IdeState (..)) +import Development.IDE.Plugin.CodeAction +import qualified Development.IDE.GHC.ExactPrint as E import Ide.Types import Language.LSP.Types import Prelude hiding (span) @@ -15,17 +17,20 @@ import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) -newtype Log +data Log = LogWingmanLanguageServer WingmanLanguageServer.Log + | LogExactPrint E.Log deriving Show instance Pretty Log where pretty = \case LogWingmanLanguageServer log -> pretty log + LogExactPrint exactPrintLog -> pretty exactPrintLog descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId - = installInteractions + = mkExactprintPluginDescriptor (cmapWithPrio LogExactPrint recorder) + $ installInteractions ( emptyCaseInteraction : fmap makeTacticInteraction [minBound .. maxBound] ) diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 2fc1e41235..2adef201dc 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -115,6 +115,10 @@ import qualified Ide.Plugin.StylishHaskell as StylishHaskell import qualified Ide.Plugin.Brittany as Brittany #endif +#if hls_refactor +import qualified Development.IDE.Plugin.CodeAction as Refactor +#endif + data Log = forall a. (Pretty a) => Log a instance Pretty Log where @@ -152,7 +156,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins StylishHaskell.descriptor "stylish-haskell" : #endif #if hls_rename - Rename.descriptor "rename" : + Rename.descriptor pluginRecorder "rename" : #endif #if hls_retrie Retrie.descriptor "retrie" : @@ -167,7 +171,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins Class.descriptor pluginRecorder "class" : #endif #if hls_haddockComments - HaddockComments.descriptor "haddockComments" : + HaddockComments.descriptor pluginRecorder "haddockComments" : #endif #if hls_eval Eval.descriptor pluginRecorder "eval" : @@ -204,6 +208,13 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #endif #if hls_gadt GADT.descriptor "gadt" : +#endif +#if hls_refactor + Refactor.iePluginDescriptor pluginRecorder "ghcide-code-actions-imports-exports" : + Refactor.typeSigsPluginDescriptor pluginRecorder "ghcide-code-actions-type-signatures" : + Refactor.bindingsPluginDescriptor pluginRecorder "ghcide-code-actions-bindings" : + Refactor.fillHolePluginDescriptor pluginRecorder "ghcide-code-actions-fill-holes" : + Refactor.extendImportPluginDescriptor pluginRecorder "ghcide-extend-import-action" : #endif GhcIde.descriptors pluginRecorder #if explicitFixity diff --git a/stack-lts16.yaml b/stack-lts16.yaml index bbc53ea853..6660850114 100644 --- a/stack-lts16.yaml +++ b/stack-lts16.yaml @@ -33,6 +33,7 @@ packages: - ./plugins/hls-change-type-signature-plugin - ./plugins/hls-gadt-plugin - ./plugins/hls-explicit-fixity-plugin + - ./plugins/hls-refactor-plugin ghc-options: "$everything": -haddock diff --git a/stack-lts19.yaml b/stack-lts19.yaml index 3c9bd98508..3a1e1278ea 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -32,6 +32,7 @@ packages: - ./plugins/hls-change-type-signature-plugin - ./plugins/hls-gadt-plugin - ./plugins/hls-explicit-fixity-plugin + - ./plugins/hls-refactor-plugin ghc-options: "$everything": -haddock diff --git a/stack.yaml b/stack.yaml index 923990c885..2d11b73c05 100644 --- a/stack.yaml +++ b/stack.yaml @@ -32,6 +32,7 @@ packages: - ./plugins/hls-change-type-signature-plugin - ./plugins/hls-gadt-plugin - ./plugins/hls-explicit-fixity-plugin +- ./plugins/hls-refactor-plugin extra-deps: - floskell-0.10.6@sha256:e77d194189e8540abe2ace2c7cb8efafc747ca35881a2fefcbd2d40a1292e036,3819 From 6f3382460886dc13a6a28a8577433b18833e617c Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 30 Aug 2022 16:51:49 +0530 Subject: [PATCH 2/4] Move ghcide-test-utils to its own package --- cabal.project | 1 + ghcide-bench/ghcide-bench.cabal | 3 +- .../src/Development/IDE/Test/Diagnostic.hs | 48 ----- ghcide/ghcide.cabal | 5 +- ghcide/test/LICENSE | 201 ++++++++++++++++++ ghcide/test/ghcide-test-utils.cabal | 59 +++++ .../hls-refactor-plugin.cabal | 2 +- stack-lts16.yaml | 1 + stack-lts19.yaml | 1 + stack.yaml | 1 + 10 files changed, 268 insertions(+), 54 deletions(-) delete mode 100644 ghcide-bench/src/Development/IDE/Test/Diagnostic.hs create mode 100644 ghcide/test/LICENSE create mode 100644 ghcide/test/ghcide-test-utils.cabal diff --git a/cabal.project b/cabal.project index 91d017ccdf..4022fb1c0c 100644 --- a/cabal.project +++ b/cabal.project @@ -5,6 +5,7 @@ packages: ./hls-graph ./ghcide ./ghcide-bench + ./ghcide/test ./hls-plugin-api ./hls-test-utils ./plugins/hls-tactics-plugin diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal index 89a9fc1080..450aadba50 100644 --- a/ghcide-bench/ghcide-bench.cabal +++ b/ghcide-bench/ghcide-bench.cabal @@ -63,8 +63,6 @@ library exposed-modules: Experiments.Types Experiments - other-modules: - Development.IDE.Test.Diagnostic build-depends: aeson, async, @@ -76,6 +74,7 @@ library extra, filepath, ghcide, + ghcide-test-utils, hashable, lens, lsp-test, diff --git a/ghcide-bench/src/Development/IDE/Test/Diagnostic.hs b/ghcide-bench/src/Development/IDE/Test/Diagnostic.hs deleted file mode 100644 index a1ea88ec28..0000000000 --- a/ghcide-bench/src/Development/IDE/Test/Diagnostic.hs +++ /dev/null @@ -1,48 +0,0 @@ --- Duplicate of ghcide/test/Development/IDE/Test/Diagnostic.hs -module Development.IDE.Test.Diagnostic where - -import Control.Lens ((^.)) -import qualified Data.Text as T -import GHC.Stack (HasCallStack) -import Language.LSP.Types -import Language.LSP.Types.Lens as Lsp - --- | (0-based line number, 0-based column number) -type Cursor = (UInt, UInt) - -cursorPosition :: Cursor -> Position -cursorPosition (line, col) = Position line col - -type ErrorMsg = String - -requireDiagnostic - :: (Foldable f, Show (f Diagnostic), HasCallStack) - => f Diagnostic - -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) - -> Maybe ErrorMsg -requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) - | any match actuals = Nothing - | otherwise = Just $ - "Could not find " <> show expected <> - " in " <> show actuals - where - match :: Diagnostic -> Bool - match d = - Just severity == _severity d - && cursorPosition cursor == d ^. range . start - && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` - standardizeQuotes (T.toLower $ d ^. message) - && hasTag expectedTag (d ^. tags) - - hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool - hasTag Nothing _ = True - hasTag (Just _) Nothing = False - hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags - -standardizeQuotes :: T.Text -> T.Text -standardizeQuotes msg = let - repl '‘' = '\'' - repl '’' = '\'' - repl '`' = '\'' - repl c = c - in T.map repl msg diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index e3a7a89ca0..0160398733 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -349,7 +349,7 @@ test-suite ghcide-tests ghc, -------------------------------------------------------------- ghcide, - ghcide-test-utils, + ghcide-test-utils-internal, ghc-typelits-knownnat, lsp, lsp-types, @@ -402,8 +402,7 @@ test-suite ghcide-tests TypeApplications ViewPatterns -library ghcide-test-utils - visibility: public +library ghcide-test-utils-internal default-language: Haskell2010 build-depends: aeson, diff --git a/ghcide/test/LICENSE b/ghcide/test/LICENSE new file mode 100644 index 0000000000..d1f5c9033f --- /dev/null +++ b/ghcide/test/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2019 Digital Asset (Switzerland) GmbH and/or its affiliates + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/ghcide/test/ghcide-test-utils.cabal b/ghcide/test/ghcide-test-utils.cabal new file mode 100644 index 0000000000..3bdac32071 --- /dev/null +++ b/ghcide/test/ghcide-test-utils.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.0 +-- This library is a copy of the sublibrary ghcide-test-utils until stack and hackage support public sublibraries +build-type: Simple +category: Development +name: ghcide-test-utils +version: 1.7.0.1 +license: Apache-2.0 +license-file: LICENSE +author: Digital Asset and Ghcide contributors +maintainer: Ghcide contributors +copyright: Digital Asset and Ghcide contributors 2018-2022 +synopsis: Test utils for ghcide +description: + Test utils for ghcide +homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme +bug-reports: https://github.com/haskell/haskell-language-server/issues +tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4 + +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server.git + + +library + default-language: Haskell2010 + build-depends: + aeson, + base, + containers, + data-default, + directory, + extra, + filepath, + ghcide, + lsp-types, + hls-plugin-api, + lens, + lsp-test ^>= 0.14, + tasty-hunit >= 0.10, + text, + hs-source-dirs: src + exposed-modules: + Development.IDE.Test + Development.IDE.Test.Diagnostic + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns diff --git a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal index 9461819f08..da2d1683c1 100644 --- a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal +++ b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal @@ -102,7 +102,7 @@ test-suite tests , text-rope , containers , ghcide - , ghcide:ghcide-test-utils + , ghcide-test-utils , shake , hls-plugin-api , lsp-test diff --git a/stack-lts16.yaml b/stack-lts16.yaml index 6660850114..50120b1841 100644 --- a/stack-lts16.yaml +++ b/stack-lts16.yaml @@ -5,6 +5,7 @@ packages: - ./hie-compat - ./hls-graph - ./ghcide/ + - ./ghcide/test - ./shake-bench - ./hls-plugin-api - ./hls-test-utils diff --git a/stack-lts19.yaml b/stack-lts19.yaml index 3a1e1278ea..c13433ac13 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -5,6 +5,7 @@ packages: - ./hie-compat - ./hls-graph - ./ghcide/ + - ./ghcide/test - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench diff --git a/stack.yaml b/stack.yaml index 2d11b73c05..5a0649322a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,6 +5,7 @@ packages: - ./hie-compat - ./hls-graph - ./ghcide/ +- ./ghcide/test - ./hls-plugin-api - ./hls-test-utils - ./shake-bench From a10adf8add6e76d44508624a344413b4c3f3e3db Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 30 Aug 2022 16:57:26 +0530 Subject: [PATCH 3/4] Update hlint ignore --- .hlint.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.hlint.yaml b/.hlint.yaml index bb41a16e64..8caaebd8f6 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -54,6 +54,7 @@ within: - Development.IDE.Core.Shake - Development.IDE.GHC.Util + - Development.IDE.Plugin.CodeAction.Util - Development.IDE.Graph.Internal.Database - Development.IDE.Graph.Internal.Paths - Development.IDE.Graph.Internal.Profile @@ -184,6 +185,7 @@ - Development.IDE.Core.Shake - Development.IDE.Plugin.Completions - Development.IDE.Plugin.CodeAction.ExactPrint + - Development.IDE.Plugin.CodeAction - Development.IDE.Test - Development.IDE.Graph.Internal.Profile - Development.IDE.Graph.Internal.Rules @@ -221,6 +223,7 @@ - Development.IDE.Core.Compile - Development.IDE.Graph.Internal.Database - Development.IDE.GHC.Util + - Development.IDE.Plugin.CodeAction.Util - Wingman.Debug # We really do not want novel usages of restricted functions, and mere From 36d66ec60aa24864bb38925930c96fb3db766903 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 30 Aug 2022 17:31:38 +0530 Subject: [PATCH 4/4] Fix benchmarks --- bench/config.yaml | 5 +++-- ghcide-bench/src/Experiments.hs | 14 ++++++++------ 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/bench/config.yaml b/bench/config.yaml index 19e014a485..4e99f1c8db 100644 --- a/bench/config.yaml +++ b/bench/config.yaml @@ -108,12 +108,13 @@ configurations: - ghcide-type-lenses - pragmas - Ghcide: + - ghcide-completions + - ghcide-type-lenses +- Refactor: - ghcide-code-actions-bindings - ghcide-code-actions-fill-holes - ghcide-code-actions-imports-exports - ghcide-code-actions-type-signatures - - ghcide-completions - - ghcide-type-lenses - All: - alternateNumberFormat - callHierarchy diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 2d756d73fd..1d8d6f6c5b 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -139,7 +139,7 @@ experiments = not . null <$> getCompletions doc (fromJust identifierP), --------------------------------------------------------------------------------------- benchWithSetup - "code lens" + "code actions" ( \docs -> do unless (any (isJust . identifierP) docs) $ error "None of the example modules is suitable for this experiment" @@ -148,12 +148,13 @@ experiments = waitForProgressStart waitForProgressDone ) - ( \docs -> not . null <$> forM docs (\DocumentPositions{..} -> - getCodeLenses doc) + ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> + forM identifierP $ \p -> + getCodeActions doc (Range p p)) ), --------------------------------------------------------------------------------------- benchWithSetup - "code lens after edit" + "code actions after edit" ( \docs -> do unless (any (isJust . identifierP) docs) $ error "None of the example modules is suitable for this experiment" @@ -165,8 +166,9 @@ experiments = changeDoc doc [charEdit stringLiteralP] waitForProgressStart waitForProgressDone - not . null <$> forM docs (\DocumentPositions{..} -> do - getCodeLenses doc) + not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do + forM identifierP $ \p -> + getCodeActions doc (Range p p)) ), --------------------------------------------------------------------------------------- benchWithSetup