diff --git a/hls-explicit-imports-plugin.cabal b/hls-explicit-imports-plugin.cabal --- a/hls-explicit-imports-plugin.cabal +++ b/hls-explicit-imports-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hls-explicit-imports-plugin -version: 1.0.1.0 +version: 1.0.1.1 synopsis: Explicit imports plugin for Haskell Language Server description: Please see the README on GitHub at @@ -21,30 +21,27 @@ , containers , deepseq , ghc - , ghcide ^>=1.4 + , ghcide ^>=1.4 || ^>=1.5 , hls-graph , hls-plugin-api >=1.1 && <1.3 , lsp , text , unordered-containers - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - default-language: Haskell2010 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/src/Ide/Plugin/ExplicitImports.hs b/src/Ide/Plugin/ExplicitImports.hs --- a/src/Ide/Plugin/ExplicitImports.hs +++ b/src/Ide/Plugin/ExplicitImports.hs @@ -23,7 +23,8 @@ 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) @@ -35,16 +36,6 @@ import Ide.Types import Language.LSP.Server import Language.LSP.Types -#if MIN_VERSION_ghc(9,0,0) -import GHC.Builtin.Names (pRELUDE) -#else -import PrelNames (pRELUDE) -#endif -import RnNames (findImportUsage, - getMinimalImports) -import qualified SrcLoc -import TcRnMonad (initTcWithGbl) -import TcRnTypes (TcGblEnv (tcg_used_gres)) importCommandId :: CommandId importCommandId = "ImportLensCommand" @@ -176,8 +167,6 @@ instance NFData MinimalImports -instance Binary MinimalImports - type instance RuleResult MinimalImports = MinimalImportsResult newtype MinimalImportsResult = MinimalImportsResult @@ -187,6 +176,13 @@ 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 @@ -197,13 +193,13 @@ (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr let importsMap = Map.fromList - [ (SrcLoc.realSrcSpanStart l, T.pack (prettyPrint i)) - | L (OldRealSrcSpan l) i <- fromMaybe [] mbMinImports + [ (realSrcSpanStart l, T.pack (prettyPrint i)) + | L (RealSrcSpan l _) i <- fromMaybe [] mbMinImports ] res = - [ (i, Map.lookup (SrcLoc.realSrcSpanStart l) importsMap) + [ (i, Map.lookup (realSrcSpanStart l) importsMap) | i <- imports - , OldRealSrcSpan l <- [getLoc i] + , RealSrcSpan l _ <- [getLoc i] ] return ([], MinimalImportsResult res <$ mbMinImports) @@ -219,19 +215,29 @@ 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 @@ -240,7 +246,7 @@ | ImportDecl {ideclHiding = Just (False, _)} <- imp = Nothing | not (isQualifiedImport imp), - OldRealSrcSpan l <- src, + RealSrcSpan l _ <- src, L _ mn <- ideclName imp, -- (almost) no one wants to see an explicit import list for Prelude pred mn, diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/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)