diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index c504aa87bdd..567e0c01f4b 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -163,6 +163,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 bb14019d99e..7476f9cd386 100644 --- a/cabal.project +++ b/cabal.project @@ -30,6 +30,7 @@ packages: ./plugins/hls-change-type-signature-plugin ./plugins/hls-stan-plugin ./plugins/hls-gadt-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/exe/Plugins.hs b/exe/Plugins.hs index 561c8541a88..f62c33e665a 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -113,6 +113,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 @@ -205,6 +209,13 @@ idePlugins recorder includeExamples = 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 -- The ghcide descriptors should come last so that the notification handlers -- (which restart the Shake build) run after everything else diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index e91c296f360..f3bf5dd9a25 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.0 build-type: Simple category: Development name: ghcide @@ -59,7 +59,6 @@ library filepath, fingertree, focus, - ghc-exactprint < 1 || >= 1.4, ghc-trace-events, Glob, haddock-library >= 1.8 && < 1.11, @@ -71,18 +70,14 @@ library hiedb == 0.4.1.*, lsp-types ^>= 1.4.0.1, lsp ^>= 1.4.0.0 , - monoid-subclasses, mtl, - network-uri, optparse-applicative, parallel, prettyprinter-ansi-terminal, prettyprinter >= 1.6, random, regex-tdfa >= 1.3.1.0, - retrie, rope-utf16-splay, - safe, safe-exceptions, hls-graph ^>= 1.7, sorted-list, @@ -94,9 +89,7 @@ library time, transformers, unordered-containers >= 0.2.10.0, - utf8-string, vector, - vector-algorithms, hslogger, Diff ^>=0.4.0, vector, @@ -113,9 +106,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 @@ -171,7 +161,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 @@ -183,7 +172,6 @@ library 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 @@ -212,8 +200,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 @@ -225,8 +211,6 @@ library Development.IDE.GHC.CPP Development.IDE.GHC.Warnings Development.IDE.LSP.Notifications - Development.IDE.Plugin.CodeAction.PositionIndexed - Development.IDE.Plugin.CodeAction.Args Development.IDE.Plugin.Completions.Logic Development.IDE.Session.VersionCheck Development.IDE.Types.Action @@ -405,6 +389,7 @@ test-suite ghcide-tests ghc, -------------------------------------------------------------- ghcide, + ghcide-test-utils, ghc-typelits-knownnat, haddock-library, lsp, @@ -442,12 +427,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 Experiments Experiments.Types @@ -470,6 +453,45 @@ test-suite ghcide-tests 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 + flag bench-exe description: Build the ghcide-bench executable default: True diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 786a4ae156c..6b6419843d2 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 8ef090e84e1..9118dc68d74 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 cd37c1b26f3..7bfa04f3ad9 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 8bb3c5fd1c0..43cb5242562 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/Dump.hs b/ghcide/src/Development/IDE/GHC/Dump.hs index a81d6e12158..8368a291259 100644 --- a/ghcide/src/Development/IDE/GHC/Dump.hs +++ b/ghcide/src/Development/IDE/GHC/Dump.hs @@ -21,18 +21,18 @@ import GhcPlugins import Prelude hiding ((<>)) -- | Show a GHC syntax tree in HTML. -#if MIN_VERSION_ghc(9,2,1) -showAstDataHtml :: (Data a, ExactPrint a, Outputable a) => a -> SDoc -#else showAstDataHtml :: (Data a, Outputable a) => a -> SDoc -#endif showAstDataHtml a0 = html $ header $$ body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat [ +-- #if MIN_VERSION_ghc(9,2,1) + +-- #else #if MIN_VERSION_ghc(9,2,1) - li (pre $ text (exactPrint a0)), - li (showAstDataHtml' a0), +-- li (pre $ text (exactPrint a0)), +-- li (showAstDataHtml' a0), +-- li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0) li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0) #else li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan a0) @@ -56,6 +56,7 @@ showAstDataHtml a0 = html $ header = tag "head" $ tag "style" $ text css html = tag "html" pre = tag "pre" +{- #if MIN_VERSION_ghc(9,2,1) showAstDataHtml' :: Data a => a -> SDoc showAstDataHtml' = @@ -281,6 +282,7 @@ showAstDataHtml a0 = html $ Nothing -> text "locatedAnn:unmatched" <+> tag <+> (text (showConstr (toConstr ss))) #endif +-} normalize_newlines :: String -> String diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 9ec6bfb5b88..3d506fbe4ae 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 0ddd12faf6e..bafd74f1e78 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -289,7 +289,7 @@ 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 :: (Data a, Outputable a, HasCallStack) => String -> a -> a traceAst lbl x | debugAST = trace doTrace x | otherwise = x @@ -306,9 +306,9 @@ traceAst lbl x writeFile htmlDumpFileName $ renderDump htmlDump return $ unlines [prettyCallStack callStack ++ ":" -#if MIN_VERSION_ghc(9,2,0) - , exactPrint x -#endif +-- #if MIN_VERSION_ghc(9,2,0) + -- , exactPrint x +-- #endif , "file://" ++ htmlDumpFileName] -- Should in `Development.IDE.GHC.Orphans`, diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 585a2badb76..fa7e8949f9b 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -374,6 +374,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig + argsHlsPlugins rules (Just env) logger @@ -418,7 +419,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) @@ -471,7 +472,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 c0a76bc360d..8f93e6d9ca4 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -26,12 +26,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 @@ -61,7 +57,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} } @@ -149,8 +144,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 []) @@ -195,76 +191,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 2269cb3914a..5aebdef76d3 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -57,9 +57,9 @@ import GHC.Plugins (Depth (AllTheWay), renderWithContext, sdocStyle) #endif -import Ide.PluginUtils (mkLspCommand) +import Ide.PluginUtils (mkLspCommand, lookupPluginId) import Ide.Types (CommandId (..), - PluginId) + IdePlugins) import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.VFS as VFS @@ -161,9 +161,9 @@ occNameToComKind ty oc showModName :: ModuleName -> T.Text showModName = T.pack . moduleNameString -mkCompl :: PluginId -> IdeOptions -> CompItem -> CompletionItem +mkCompl :: IdePlugins a -> IdeOptions -> CompItem -> CompletionItem mkCompl - pId + plugins IdeOptions {..} CI { compKind, @@ -175,7 +175,7 @@ mkCompl docs, additionalTextEdits } = do - let mbCommand = mkAdditionalEditsCommand pId `fmap` additionalTextEdits + let mbCommand = mkAdditionalEditsCommand plugins =<< additionalTextEdits let ci = CompletionItem {_label = label, _kind = kind, @@ -217,9 +217,12 @@ 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 :: IdePlugins a -> ExtendImport -> Maybe Command +mkAdditionalEditsCommand plugins edits = case lookupPluginId extendImportCommand plugins of + Just pId -> Just $ mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) + Nothing -> Nothing + where + extendImportCommand = CommandId extendImportCommandId 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 +556,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 +566,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 +666,7 @@ 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 plugins ideOpts) uniqueFiltCompls 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 bd192f18e8b..78799ac8b03 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -128,7 +128,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 83f1f071309..7e6d924d162 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/data/multi/b/test b/ghcide/test/data/multi/b/test new file mode 100644 index 00000000000..2426874ebe8 --- /dev/null +++ b/ghcide/test/data/multi/b/test @@ -0,0 +1,38 @@ +-fbuilding-cabal-package +-O0 +-outputdir +/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build +-odir +/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build +-hidir +/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build +-stubdir +/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build +-i +-i/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build +-i. +-i/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen +-i/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/global-autogen +-I/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen +-I/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/global-autogen +-I/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build +-optP-include +-optP/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/cabal_macros.h +-this-unit-id +b-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-db +/home/zubin/.cabal/store/ghc-9.4.0.20220623/package.db +-package-db +/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/packagedb/ghc-9.4.0.20220623 +-package-db +/home/zubin/haskell-language-server/ghcide/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/package.conf.inplace +-package-id +a-1.0.0-inplace +-package-id +base-4.17.0.0 +-XHaskell98 +B +-working-dir /home/zubin/haskell-language-server/ghcide/test/data/multi/b diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 24669ad7a5e..082ad3622ca 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 (..), @@ -193,7 +190,6 @@ main = do waitForProgressBegin closeDoc doc waitForProgressDone - , codeActionTests , initializeResponseTests , completionTests , cppTests @@ -221,7 +217,6 @@ main = do , rootUriTests , asyncTests , clientSettingsTest - , codeActionHelperFunctionTests , referenceTests , garbageCollectionTests , HieDbRetry.tests @@ -251,7 +246,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 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" @@ -262,7 +257,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 @@ -812,40 +807,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 @@ -900,3291 +861,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 #-}" @@ -4821,55 +1497,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 = [ @@ -5064,120 +1691,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" @@ -5324,21 +1837,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] @@ -6350,9 +2848,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 @@ -6362,9 +2860,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" ] ] @@ -6577,21 +3075,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) @@ -6683,35 +3166,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" @@ -7061,11 +3515,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 4618e156e46..7f31538e996 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -223,6 +223,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 @@ -356,6 +361,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 + executable haskell-language-server import: common-deps -- configuration @@ -387,6 +397,7 @@ executable haskell-language-server , ormolu , stylishHaskell , brittany + , refactor main-is: Main.hs hs-source-dirs: exe diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs index 7470c0e33e0..97ea11eff78 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 1f10b1cc705..541814ba760 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -31,7 +31,8 @@ module Ide.PluginUtils pluginResponse, handleMaybe, handleMaybeM, - throwPluginError + throwPluginError, + lookupPluginId ) where @@ -44,6 +45,7 @@ import Data.Algorithm.DiffOutput import Data.Bifunctor (Bifunctor (first)) import Data.Containers.ListUtils (nubOrdOn) 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 @@ -241,6 +243,13 @@ allLspCmdIds pid commands = concatMap go commands where go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds + +-- | Lookup the plugin that exposes a particular command +lookupPluginId :: CommandId -> IdePlugins a -> Maybe PluginId +lookupPluginId cmd (IdePlugins ls) = fst <$> find go ls + where + go (_, desc) = cmd `elem` map commandId (pluginCommands desc) + -- --------------------------------------------------------------------- getNormalizedFilePath :: Monad m => PluginId -> Uri -> ExceptT String m NormalizedFilePath 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 e51ad552681..d726b48ee86 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/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index 8a573d9ebb9..fcd96ffea12 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 23fac32e331..f109ea05d3c 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 1a59ec20890..fe4ea1876ce 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-refactor-plugin/LICENSE b/plugins/hls-refactor-plugin/LICENSE new file mode 100644 index 00000000000..261eeb9e9f8 --- /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 00000000000..1e7d13a57ab --- /dev/null +++ b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal @@ -0,0 +1,88 @@ +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/testdata/*.hs + test/testdata/*.yaml + +library + exposed-modules: Development.IDE.GHC.ExactPrint + Development.IDE.GHC.Compat.ExactPrint + Development.IDE.Plugin.CodeAction + other-modules: Development.IDE.Plugin.CodeAction.Args + Development.IDE.Plugin.CodeAction.ExactPrint + Development.IDE.Plugin.CodeAction.PositionIndexed + hs-source-dirs: src + build-depends: + , aeson + , base >=4.12 && <5 + , ghc + , ghc-boot + , regex-tdfa + , rope-utf16-splay + , 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 + 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 + , rope-utf16-splay + , 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 94% rename from ghcide/src/Development/IDE/GHC/Compat/ExactPrint.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs index a071ef46066..7a8976a518a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- | This module contains compatibility constructs to write type signatures across -- multiple ghc-exactprint versions, accepting that anything more ambitious is diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs similarity index 97% rename from ghcide/src/Development/IDE/GHC/ExactPrint.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index f7a67d75bce..d90f90dca64 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -5,6 +5,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} -- | This module hosts various abstractions and utility functions to work with ghc-exactprint. module Development.IDE.GHC.ExactPrint @@ -49,6 +57,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 +81,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 +122,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 a3eb4f47749..ec57ab5881c 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -4,6 +4,20 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} module Development.IDE.Plugin.CodeAction ( @@ -11,10 +25,9 @@ module Development.IDE.Plugin.CodeAction typeSigsPluginDescriptor, bindingsPluginDescriptor, fillHolePluginDescriptor, - newImport, - newImportToEdit + extendImportPluginDescriptor, -- * For testing - , matchRegExMultipleImports + matchRegExMultipleImports ) where import Control.Applicative ((<|>)) @@ -22,8 +35,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 +55,24 @@ import qualified Data.Rope.UTF16 as Rope import qualified Data.Set as S import qualified Data.Text as T 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) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Plugin.CodeAction.Args import Development.IDE.Plugin.CodeAction.ExactPrint 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 +81,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 import Text.Regex.TDFA (mrAfter, (=~), (=~~)) @@ -89,7 +113,6 @@ import GHC (AddEpAnn (Ad LEpaComment, LocatedA) -import Control.Monad (msum) #else import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), DeltaPos, @@ -120,8 +143,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 @@ -134,29 +157,117 @@ iePluginDescriptor plId = , wrap suggestExportUnusedTopBinding ] plId - in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction} + in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction + , pluginRules = getAnnotatedParsedSourceRule recorder + } -typeSigsPluginDescriptor :: PluginId -> PluginDescriptor IdeState -typeSigsPluginDescriptor = - mkGhcideCAsPlugin [ +typeSigsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +typeSigsPluginDescriptor recorder plId = + (mkGhcideCAsPlugin [ wrap $ suggestSignature True , wrap suggestFillTypeWildcard , wrap removeRedundantConstraints , wrap suggestAddTypeAnnotationToSatisfyContraints , wrap suggestConstraint ] + plId) { pluginRules = getAnnotatedParsedSourceRule recorder } -bindingsPluginDescriptor :: PluginId -> PluginDescriptor IdeState -bindingsPluginDescriptor = - mkGhcideCAsPlugin [ +bindingsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +bindingsPluginDescriptor recorder plId = + (mkGhcideCAsPlugin [ wrap suggestReplaceIdentifier , wrap suggestImplicitParameter , wrap suggestNewDefinition , wrap suggestDeleteUnusedBinding ] + plId) { pluginRules = getAnnotatedParsedSourceRule recorder } + +fillHolePluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +fillHolePluginDescriptor recorder plId = (mkGhcideCAPlugin (wrap suggestFillHole) plId) { pluginRules = getAnnotatedParsedSourceRule recorder } -fillHolePluginDescriptor :: PluginId -> PluginDescriptor IdeState -fillHolePluginDescriptor = mkGhcideCAPlugin $ wrap suggestFillHole +extendImportPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState +extendImportPluginDescriptor recorder plId = (defaultPluginDescriptor plId) + { pluginCommands = [extendImportCommand] + , pluginRules = 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 ------------------------------------------------------------------------------------------------- @@ -277,7 +388,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 97% rename from ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 85f100ca665..d13ceb82365 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -1,5 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} module Development.IDE.Plugin.CodeAction.Args ( CodeActionTitle, @@ -27,6 +34,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 4b516a16ab9..bb25bdbd9c3 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -5,6 +5,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} module Development.IDE.Plugin.CodeAction.ExactPrint ( Rewrite (..), 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 98% rename from ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs index 305a08a5355..a072658fd56 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -- | Position indexed streams of characters module Development.IDE.Plugin.CodeAction.PositionIndexed ( PositionIndexed 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 100% rename from ghcide/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs rename to plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs new file mode 100644 index 00000000000..dafbd1e843a --- /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 075686555ea..538f854ddf8 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 00000000000..f9fde2a7ccb --- /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 00000000000..489a6ccd6b2 --- /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 00000000000..e1802580e27 --- /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 00000000000..2f43b99977f --- /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 00000000000..e2b3e97c5d2 --- /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 c6f20198fe5..e0c295dc126 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