diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index ce5f809305..524b3362d6 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -208,6 +208,10 @@ jobs: name: Test hls-refine-imports-plugin test suite run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" + - if: matrix.test + name: Test hls-explicit-imports-plugin test suite + run: cabal test hls-explicit-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-explicit-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-explicit-imports-plugin --test-options="-j1 --rerun" + - if: matrix.test name: Test hls-call-hierarchy-plugin test suite run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index f4b8fd0641..b74f2a556c 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -32,3 +32,16 @@ library default-extensions: DataKinds TypeOperators + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , base + , filepath + , hls-explicit-imports-plugin + , hls-test-utils + , text diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 1170861b2b..94213dc183 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -23,7 +23,8 @@ import Data.Aeson.Types (FromJSON) import qualified Data.HashMap.Strict as HashMap import Data.IORef (readIORef) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, + isJust) import qualified Data.Text as T import Development.IDE hiding (pluginHandlers, pluginRules) @@ -175,6 +176,13 @@ instance Show MinimalImportsResult where show _ = "" instance NFData MinimalImportsResult where rnf = rwhnf +exportedModuleStrings :: ParsedModule -> [String] +exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} + | Just export <- hsmodExports, + exports <- unLoc export + = map show exports +exportedModuleStrings _ = [] + minimalImportsRule :: Rules () minimalImportsRule = define $ \MinimalImports nfp -> do -- Get the typechecking artifacts from the module @@ -207,19 +215,29 @@ extractMinimalImports (Just hsc) (Just TcModuleResult {..}) = do let tcEnv = tmrTypechecked (_, imports, _, _) = tmrRenamed ParsedModule {pm_parsed_source = L loc _} = tmrParsed + emss = exportedModuleStrings tmrParsed span = fromMaybe (error "expected real") $ realSpan loc + -- Don't make suggestions for modules which are also exported, the user probably doesn't want this! + -- See https://github.com/haskell/haskell-language-server/issues/2079 + let notExportedImports = filter (notExported emss) imports -- GHC is secretly full of mutable state gblElts <- readIORef (tcg_used_gres tcEnv) -- call findImportUsage does exactly what we need -- GHC is full of treats like this - let usage = findImportUsage imports gblElts + let usage = findImportUsage notExportedImports gblElts (_, minimalImports) <- initTcWithGbl (hscEnv hsc) tcEnv span $ getMinimalImports usage -- return both the original imports and the computed minimal ones return (imports, minimalImports) + where + notExported :: [String] -> LImportDecl GhcRn -> Bool + notExported [] _ = True + notExported exports (L _ ImportDecl{ideclName = L _ name}) = + not $ any (\e -> ("module " ++ moduleNameString name) == e) exports + notExported _ _ = False extractMinimalImports _ _ = return ([], Nothing) mkExplicitEdit :: (ModuleName -> Bool) -> PositionMapping -> LImportDecl pass -> T.Text -> Maybe TextEdit diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs new file mode 100644 index 0000000000..f944e23c62 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Main + ( main + ) where + +import Data.Foldable (find, forM_) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Ide.Plugin.ExplicitImports as ExplicitImports +import System.FilePath ((<.>), ()) +import Test.Hls + +explicitImportsPlugin :: PluginDescriptor IdeState +explicitImportsPlugin = ExplicitImports.descriptor "explicitImports" + + +main :: IO () +main = defaultTestRunner $ + testGroup + "Refine Imports" + [ codeActionGoldenTest "UsualCase" 3 0 + , codeLensGoldenTest "UsualCase" 0 + , testCase "No CodeAction when exported" $ + runSessionWithServer explicitImportsPlugin testDataDir $ do + doc <- openDoc "Exported.hs" "haskell" + action <- getCodeActions doc (pointRange 3 0) + liftIO $ action @?= [] + , testCase "No CodeLens when exported" $ + runSessionWithServer explicitImportsPlugin testDataDir $ do + doc <- openDoc "Exported.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ lenses @?= [] + ] + +-- code action tests + +codeActionGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionGoldenTest fp l c = goldenWithExplicitImports fp $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make all imports explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +caTitle :: (Command |? CodeAction) -> Maybe Text +caTitle (InR CodeAction {_title}) = Just _title +caTitle _ = Nothing + +-- code lens tests + +codeLensGoldenTest :: FilePath -> Int -> TestTree +codeLensGoldenTest fp codeLensIdx = goldenWithExplicitImports fp $ \doc -> do + codeLens <- (!! codeLensIdx) <$> getCodeLensesBy isExplicitImports doc + mapM_ executeCmd + [c | CodeLens{_command = Just c} <- [codeLens]] + +getCodeLensesBy :: (CodeLens -> Bool) -> TextDocumentIdentifier -> Session [CodeLens] +getCodeLensesBy f doc = filter f <$> getCodeLenses doc + +isExplicitImports :: CodeLens -> Bool +isExplicitImports (CodeLens _ (Just (Command _ cmd _)) _) + | ":explicitImports:" `T.isInfixOf` cmd = True +isExplicitImports _ = False + +-- Execute command and wait for result +executeCmd :: Command -> Session () +executeCmd cmd = do + executeCommand cmd + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) + -- liftIO $ print _resp + return () + +-- helpers + +goldenWithExplicitImports :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithExplicitImports fp = goldenWithHaskellDoc explicitImportsPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" + +testDataDir :: String +testDataDir = "test" "testdata" + +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> line) + (subtract 1 -> col) = + Range (Position line col) (Position line $ col + 1) diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/A.hs b/plugins/hls-explicit-imports-plugin/test/testdata/A.hs new file mode 100644 index 0000000000..28768c69d4 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/A.hs @@ -0,0 +1,7 @@ +module A where + +a1 :: String +a1 = "a1" + +a2 :: String +a2 = "a2" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/Exported.hs b/plugins/hls-explicit-imports-plugin/test/testdata/Exported.hs new file mode 100644 index 0000000000..7ccaa5c3d4 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/Exported.hs @@ -0,0 +1,6 @@ +module Exported (module A) where + +import A + +main :: IO () +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs new file mode 100644 index 0000000000..8355eafde2 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs @@ -0,0 +1,6 @@ +module Main where + +import A ( a1 ) + +main :: IO () +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs new file mode 100644 index 0000000000..b5c65ba8ea --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs @@ -0,0 +1,6 @@ +module Main where + +import A + +main :: IO () +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..c1a3993dc4 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: + - UsualCase.hs + - Exported.hs + - A.hs