Not suggest exported imports (#2329)

* Not suggest exported imports

* Add testing explicit-imports-plugin to github workflow

* Add comment

Co-authored-by: Michael Peyton Jones <me@michaelpj.com>

Co-authored-by: Michael Peyton Jones <me@michaelpj.com>

Author: yoshitsugu

.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"

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

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 _ = "<minimalImportsResult>"
 
 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

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)

plugins/hls-explicit-imports-plugin/test/testdata/A.hs

@@ -0,0 +1,7 @@
+module A where
+
+a1 :: String
+a1 = "a1"
+
+a2 :: String
+a2 = "a2"

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

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

plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import A
+
+main :: IO ()
+main = putStrLn $ "hello " ++ a1

plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml

@@ -0,0 +1,6 @@
+cradle:
+  direct:
+    arguments:
+    - UsualCase.hs
+    - Exported.hs
+    - A.hs