diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs index fb4c9b1cb..aee7536ec 100644 --- 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 index ac8cde1e7..652559173 100644 --- 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 index de4a7224c..2eb5511e2 100644 --- 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 index c5ee5b6e8..7ad78e987 100644 --- 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 index b4244b74b..ea69db60c 100644 --- 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 index 0d7db454a..439a852ac 100644 --- 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 index 81da1caa3..4f16abb1d 100644 --- 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,7 +1745,7 @@ 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" @@ -1749,7 +1753,7 @@ exportUnusedTests = testGroup "export unused actions" , "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,7 +1762,7 @@ 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" @@ -1766,83 +1770,83 @@ exportUnusedTests = testGroup "export unused actions" , "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"