Suggestions for missing imports from local modules (#739)

* Suggestions for missing imports from local modules * Avoid unnecessary work on InitialLoad when checkProject is off
2024-09-11 05:36:09 +03:00 · 2020-09-03 09:32:40 +01:00 · 2020-09-03 09:32:40 +01:00 · 09aa8e5f4b
commit 09aa8e5f4b
parent f8889c7112
10 changed files with 116 additions and 78 deletions
--- a/ghcide.cabal
+++ b/ghcide.cabal
@ -139,6 +139,7 @@ library
        Development.IDE.LSP.Server
        Development.IDE.Spans.Common
        Development.IDE.Types.Diagnostics
+        Development.IDE.Types.Exports
        Development.IDE.Types.Location
        Development.IDE.Types.Logger
        Development.IDE.Types.Options
--- 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
@ -300,10 +301,14 @@ loadSession dir = do
          -- files in the project so that `knownFiles` can learn about them and
          -- we can generate a complete module graph
          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
+            mmt <- uses GetModificationTime cfps'
+            let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
+            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.
--- 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
@ -88,5 +90,12 @@ kick = mkDelayedAction "kick" Debug $ do
    files <- getFilesOfInterest
    ShakeExtras{progressUpdate} <- getShakeExtras
    liftIO $ progressUpdate KickStarted
-    void $ uses TypeCheck $ HashSet.toList files
+
+    -- Update the exports map for the project
+    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
--- a/src/Development/IDE/Core/Shake.hs
+++ b/src/Development/IDE/Core/Shake.hs
@ -87,6 +87,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
@ -153,6 +154,8 @@ data ShakeExtras = ShakeExtras
    ,restartShakeSession :: [DelayedAction ()] -> IO ()
    ,ideNc :: IORef NameCache
    ,knownFilesVar :: Var (Hashed (HSet.HashSet NormalizedFilePath))
+    -- | A mapping of exported identifiers for local modules. Updated on kick
+    ,exportsMap :: Var ExportsMap
    }

 type WithProgressFunc = forall a.
@ -411,6 +414,7 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
        progressAsync <- async $
            when reportProgress $
                progressThread mostRecentProgressEvent inProgress
+        exportsMap <- newVar HMap.empty

        pure (ShakeExtras{..}, cancel progressAsync)
    (shakeDbM, shakeClose) <-
--- a/src/Development/IDE/Plugin/CodeAction.hs
+++ b/src/Development/IDE/Plugin/CodeAction.hs
@ -30,6 +30,7 @@ import Development.IDE.LSP.Server
 import Development.IDE.Plugin.CodeAction.PositionIndexed
 import Development.IDE.Plugin.CodeAction.RuleTypes
 import Development.IDE.Plugin.CodeAction.Rules
+import Development.IDE.Types.Exports
 import Development.IDE.Types.Location
 import Development.IDE.Types.Options
 import Development.Shake (Rules)
@ -58,6 +59,7 @@ import Data.Functor
 import Control.Applicative ((<|>))
 import Safe (atMay)
 import Bag (isEmptyBag)
+import Control.Concurrent.Extra (readVar)

 plugin :: Plugin c
 plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
@ -83,10 +85,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
        ]

@ -132,7 +136,7 @@ executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

 suggestAction
  :: Maybe DynFlags
-  -> PackageExportsMap
+  -> ExportsMap
  -> IdeOptions
  -> Maybe ParsedModule
  -> Maybe T.Text
@ -815,7 +819,7 @@ removeRedundantConstraints mContents Diagnostic{..}

 -------------------------------------------------------------------------------------------------

-suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}
  | msg <- unifySpaces _message
  , Just name <- extractNotInScopeName msg
@ -835,7 +839,7 @@ suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule
 suggestNewImport _ _ _ = []

 constructNewImportSuggestions
-  :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]
+  :: ExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]
 constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd
  [ suggestion
  | (identInfo, m) <- fromMaybe [] $ Map.lookup name exportsMap
--- a/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs
+++ b/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs
@ -1,57 +1,20 @@
 {-# LANGUAGE TypeFamilies #-}
 module Development.IDE.Plugin.CodeAction.RuleTypes
-    (PackageExports(..), PackageExportsMap
+    (PackageExports(..)
    ,IdentInfo(..)
-    ,mkIdentInfos
    ) where

-import Avail (AvailInfo(..))
 import Data.Hashable (Hashable)
 import Control.DeepSeq (NFData)
 import Data.Binary (Binary)
-import Data.Text (pack, Text)
 import Development.IDE.GHC.Util
+import Development.IDE.Types.Exports
 import Development.Shake (RuleResult)
-import Data.HashMap.Strict (HashMap)
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
-import Name
-import FieldLabel (flSelector)
-
-type Identifier = Text
-type ModuleName = Text
-
-data IdentInfo = IdentInfo
-    { name :: !Identifier
-    , rendered :: Text
-    , parent :: !(Maybe Text)
-    , isDatacon :: !Bool
-    }
-    deriving (Eq, Generic, Show)
-
-instance NFData IdentInfo
-
-mkIdentInfos :: AvailInfo -> [IdentInfo]
-mkIdentInfos (Avail n) =
-    [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]
-mkIdentInfos (AvailTC parent (n:nn) flds)
-    -- Following the GHC convention that parent == n if parent is exported
-    | n == parent
-    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True
-        | n <- nn ++ map flSelector flds
-      ] ++
-      [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]
-    where
-        parentP = pack $ prettyPrint parent
-
-mkIdentInfos (AvailTC _ nn flds)
-    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True
-        | n <- nn ++ map flSelector flds
-      ]

 -- Rule type for caching Package Exports
-type instance RuleResult PackageExports = PackageExportsMap
-type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]
+type instance RuleResult PackageExports = ExportsMap

 newtype PackageExports = PackageExports HscEnvEq
    deriving (Eq, Show, Typeable, Generic)
--- 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)
--- a/src/Development/IDE/Types/Exports.hs
+++ b/src/Development/IDE/Types/Exports.hs
@ -0,0 +1,63 @@
+module Development.IDE.Types.Exports
+(
+    IdentInfo(..),
+    ExportsMap,
+    createExportsMap,
+) where
+
+import Avail (AvailInfo(..))
+import Control.DeepSeq (NFData)
+import Data.Text (pack, Text)
+import Development.IDE.GHC.Compat
+import Development.IDE.GHC.Util
+import Data.HashMap.Strict (HashMap)
+import GHC.Generics (Generic)
+import Name
+import FieldLabel (flSelector)
+import qualified Data.HashMap.Strict as Map
+import GhcPlugins (IfaceExport)
+
+type ExportsMap = HashMap IdentifierText [(IdentInfo,ModuleNameText)]
+
+type IdentifierText = Text
+type ModuleNameText = Text
+
+data IdentInfo = IdentInfo
+    { name :: !Text
+    , rendered :: Text
+    , parent :: !(Maybe Text)
+    , isDatacon :: !Bool
+    }
+    deriving (Eq, Generic, Show)
+
+instance NFData IdentInfo
+
+mkIdentInfos :: AvailInfo -> [IdentInfo]
+mkIdentInfos (Avail n) =
+    [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]
+mkIdentInfos (AvailTC parent (n:nn) flds)
+    -- Following the GHC convention that parent == n if parent is exported
+    | n == parent
+    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True
+        | n <- nn ++ map flSelector flds
+      ] ++
+      [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]
+    where
+        parentP = pack $ prettyPrint parent
+
+mkIdentInfos (AvailTC _ nn flds)
+    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True
+        | n <- nn ++ map flSelector flds
+      ]
+
+createExportsMap :: [ModIface] -> ExportsMap
+createExportsMap = Map.fromListWith (++) . concatMap doOne
+  where
+    doOne mi = concatMap (unpackAvail mn) (mi_exports mi)
+      where
+        mn = moduleName $ mi_module mi
+
+unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]
+unpackAvail mod =
+  map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))
+    . mkIdentInfos
--- 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)

--- a/test/exe/Main.hs
+++ b/test/exe/Main.hs
@ -1036,7 +1036,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"
@ -1063,12 +1066,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)
@ -2380,6 +2384,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"