hls-explicit-imports-plugin 1.0.1.0 → 1.0.1.1
raw patch · 3 files changed
+129/−37 lines, 3 filesdep +filepathdep +hls-explicit-imports-plugindep +hls-test-utilsdep −ghc-api-compatdep ~basedep ~ghcidePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: filepath, hls-explicit-imports-plugin, hls-test-utils
Dependencies removed: ghc-api-compat
Dependency ranges changed: base, ghcide
API changes (from Hackage documentation)
- Ide.Plugin.ExplicitImports: instance Data.Binary.Class.Binary Ide.Plugin.ExplicitImports.MinimalImports
Files
- hls-explicit-imports-plugin.cabal +15/−18
- src/Ide/Plugin/ExplicitImports.hs +25/−19
- test/Main.hs +89/−0
hls-explicit-imports-plugin.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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
src/Ide/Plugin/ExplicitImports.hs view
@@ -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,
+ test/Main.hs view
@@ -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)