Suggestions for missing imports from local modules

pepeiborra · Aug 23, 2020 · 7538e36 · 7538e36
1 parent 64366cc
commit 7538e36
Show file tree

Hide file tree

Showing 7 changed files with 67 additions and 60 deletions.
diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs
@@ -38,6 +38,7 @@ import Development.IDE.Core.RuleTypes
 import Development.IDE.GHC.Util
 import Development.IDE.Session.VersionCheck
 import Development.IDE.Types.Diagnostics
+import Development.IDE.Types.Exports
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Types.Options
@@ -302,8 +303,12 @@ loadSession dir = do
           liftIO $ modifyVar_ knownFilesVar $ traverseHashed $ pure . HashSet.union (HashSet.fromList cfps')
           mmt <- uses GetModificationTime cfps'
           let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
-          when checkProject $
-            void $ uses GetModIface cs_exist
+          when checkProject $ do
+            modIfaces <- uses GetModIface cs_exist
+            -- update xports map
+            extras <- getShakeExtras
+            let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
+            liftIO $ modifyVar_ (exportsMap extras) $ return . (exportsMap' <>)
       pure opts
 
 -- | Run the specific cradle on a specific FilePath via hie-bios.

diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs
@@ -26,11 +26,13 @@ import qualified Data.Text as T
 import Data.Tuple.Extra
 import Development.Shake
 
+import Development.IDE.Types.Exports
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Shake
-import Control.Monad
+import Data.Maybe (mapMaybe)
+import GhcPlugins (HomeModInfo(hm_iface))
 
 newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))
 instance IsIdeGlobal OfInterestVar
@@ -91,5 +93,9 @@ kick = mkDelayedAction "kick" Debug $ do
     files <- getFilesOfInterest
     ShakeExtras{progressUpdate} <- getShakeExtras
     liftIO $ progressUpdate KickStarted
-    void $ uses TypeCheck $ HashSet.toList files
+    results <-  uses TypeCheck $ HashSet.toList files
+    ShakeExtras{exportsMap} <- getShakeExtras
+    let modIfaces = mapMaybe (fmap (hm_iface . tmrModInfo)) results
+        !exportsMap' = createExportsMap modIfaces
+    liftIO $ modifyVar_ exportsMap $ return . (exportsMap' <>)
     liftIO $ progressUpdate KickCompleted
diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs
@@ -88,6 +88,7 @@ import qualified Development.IDE.Types.Logger as Logger
 import Language.Haskell.LSP.Diagnostics
 import qualified Data.SortedList as SL
 import           Development.IDE.Types.Diagnostics
+import Development.IDE.Types.Exports
 import Development.IDE.Types.Location
 import Development.IDE.Types.Options
 import           Control.Concurrent.Async
@@ -154,6 +155,8 @@ data ShakeExtras = ShakeExtras
     -- | A work queue for actions added via 'runInShakeSession'
     ,actionQueue :: ActionQueue
     ,knownFilesVar :: Var (Hashed (HSet.HashSet NormalizedFilePath))
+    -- | A mapping of exported identifiers for local modules. Updated on kick
+    ,exportsMap :: Var ExportsMap
     }
 
 type WithProgressFunc = forall a.
@@ -410,6 +413,7 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
         progressAsync <- async $
             when reportProgress $
                 progressThread mostRecentProgressEvent inProgress
+        exportsMap <- newVar HMap.empty
 
         actionQueue <- newQueue
 

diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs
@@ -58,6 +58,7 @@ import Control.Arrow ((>>>))
 import Data.Functor
 import Control.Applicative ((<|>))
 import Safe (atMay)
+import Control.Concurrent.Extra (readVar)
 
 plugin :: Plugin c
 plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
@@ -83,10 +84,12 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag
             <*> use GhcSession `traverse` mbFile
     -- This is quite expensive 0.6-0.7s on GHC
     pkgExports <- runAction "CodeAction:PackageExports" state $ (useNoFile_ . PackageExports) `traverse` env
+    localExports <- readVar (exportsMap $ shakeExtras state)
+    let exportsMap = Map.unionWith (<>) localExports (fromMaybe mempty pkgExports)
     let dflags = hsc_dflags . hscEnv <$> env
     pure $ Right
         [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
-        | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x
+        | x <- xs, (title, tedit) <- suggestAction dflags exportsMap ideOptions ( join parsedModule ) text x
         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
         ]
 

diff --git a/src/Development/IDE/Plugin/CodeAction/Rules.hs b/src/Development/IDE/Plugin/CodeAction/Rules.hs
@@ -3,26 +3,17 @@ module Development.IDE.Plugin.CodeAction.Rules
   )
 where
 
-import           Data.HashMap.Strict            ( fromListWith )
-import           Data.Text                      ( Text
-                                                , pack
-                                                )
 import           Data.Traversable               ( forM )
 import           Development.IDE.Core.Rules
 import           Development.IDE.GHC.Util
 import           Development.IDE.Plugin.CodeAction.RuleTypes
+import           Development.IDE.Types.Exports
 import           Development.Shake
 import           GHC                            ( DynFlags(pkgState) )
-import           HscTypes                       ( IfaceExport
-                                                , hsc_dflags
-                                                , mi_exports
-                                                )
+import           HscTypes                       ( hsc_dflags)
 import           LoadIface
 import           Maybes
-import           Module                         ( Module(..)
-                                                , ModuleName
-                                                , moduleNameString
-                                                )
+import           Module                         ( Module(..) )
 import           Packages                       ( explicitPackages
                                                 , exposedModules
                                                 , packageConfigId
@@ -43,19 +34,12 @@ rulePackageExports = defineNoFile $ \(PackageExports session) -> do
         , (mn, _)  <- exposedModules pkg
         ]
 
-  results <- forM targets $ \(pkg, mn) -> do
+  modIfaces <- forM targets $ \(pkg, mn) -> do
     modIface <- liftIO $ initIfaceLoad env $ loadInterface
       ""
       (Module (packageConfigId pkg) mn)
       (ImportByUser False)
-    case modIface of
-      Failed    _err -> return mempty
-      Succeeded mi   -> do
-        let avails = mi_exports mi
-        return $ concatMap (unpackAvail mn) avails
-  return $ fromListWith (++) $ concat results
-
-unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]
-unpackAvail mod =
-  map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))
-    . mkIdentInfos
+    return $ case modIface of
+      Failed    _err -> Nothing
+      Succeeded mi   -> Just mi
+  return $ createExportsMap (catMaybes modIfaces)
diff --git a/test/data/hover/GotoHover.hs b/test/data/hover/GotoHover.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {- HLINT ignore -}
-module Testing ( module Testing ) where
+module GotoHover ( module GotoHover) where
 import Data.Text (Text, pack)
 import Foo (Bar, foo)
 

diff --git a/test/exe/Main.hs b/test/exe/Main.hs
@@ -1006,7 +1006,10 @@ suggestImportTests = testGroup "suggest import actions"
     , test False []         "f = quickCheck"              []                "import Test.QuickCheck (quickCheck)"
     ]
   , testGroup "want suggestion"
-    [ test True []          "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"
+    [ test True []          "f = foo"                     []                "import Foo (foo)"
+    , test True []          "f = Bar"                     []                "import Bar (Bar(Bar))"
+    , test True []          "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"
@@ -1033,12 +1036,13 @@ suggestImportTests = testGroup "suggest import actions"
     ]
   ]
   where
-    test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do
+    test wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do
       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, -]}}"
+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, GotoHover]}}"
       liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
       doc <- createDoc "Test.hs" "haskell" before
+      void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
       _diags <- waitForDiagnostics
       let defLine = length imps + 1
           range = Range (Position defLine 0) (Position defLine maxBound)
@@ -1677,8 +1681,8 @@ exportUnusedTests = testGroup "export unused actions"
         Nothing -- codeaction should not be available
     , testSession "not top-level" $ template
         (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
-              , "{-# OPTIONS_GHC -Wunused-binds #-}" 
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
+              , "{-# OPTIONS_GHC -Wunused-binds #-}"
               , "module A (foo,bar) where"
               , "foo = ()"
               , "  where bar = ()"
@@ -1713,26 +1717,26 @@ exportUnusedTests = testGroup "export unused actions"
         (R 3 0 3 3)
         "Export ‘foo’"
         (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
               , "module A ("
               , "foo) where"
               , "foo = id"])
     , testSession "single line explicit exports" $ template
         (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
               , "module A"
               , "  ("
               , "    foo) where"
@@ -1741,15 +1745,15 @@ exportUnusedTests = testGroup "export unused actions"
         (R 5 0 5 3)
         "Export ‘bar’"
         (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
               , "module A"
               , "  (foo,"
               , "  ) where"
@@ -1758,91 +1762,91 @@ exportUnusedTests = testGroup "export unused actions"
         (R 4 0 4 3)
         "Export ‘bar’"
         (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
               , "module A"
               , "  (foo,"
               , "  bar) where"
               , "foo = id"
               , "bar = foo"])
     , testSession "unused pattern synonym" $ template
         (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
-              , "{-# LANGUAGE PatternSynonyms #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
               , "module A (Foo(..)) where"
               , "data Foo = Foo"])
     , testSession "unused newtype" $ template
         (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
               , "module A (Foo(..)) where"
               , "newtype Foo = Foo ()"])
     , testSession "unused type synonym" $ template
         (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
               , "module A (Foo(..)) where"
               , "class Foo a"])
     , testSession "infix" $ template
         (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" 
+              [ "{-# 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 #-}" 
+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
               , "module A (f) where"
               , "a `f` b = ()"])
     ]
@@ -2265,6 +2269,7 @@ thTests =
 -- | test that TH is reevaluated on typecheck
 thReloadingTest :: TestTree
 thReloadingTest = testCase "reloading-th-test" $ withoutStackEnv $ runWithExtraFiles "TH" $ \dir -> do
+
     let aPath = dir </> "THA.hs"
         bPath = dir </> "THB.hs"
         cPath = dir </> "THC.hs"