From 55c6624a6a28fe325a8228f716ef87e8b7a9669a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 3 Feb 2021 00:02:32 +0000 Subject: [PATCH 1/9] Move PackageExports to HscEnvEq This is necessary to prevent leaking the package exports --- ghcide/ghcide.cabal | 3 +- .../session-loader/Development/IDE/Session.hs | 1 + ghcide/src/Development/IDE.hs | 1 + ghcide/src/Development/IDE/Core/RuleTypes.hs | 5 +- ghcide/src/Development/IDE/Core/Rules.hs | 1 + ghcide/src/Development/IDE/GHC/Util.hs | 85 +------------ .../src/Development/IDE/Plugin/CodeAction.hs | 18 +-- .../IDE/Plugin/CodeAction/RuleTypes.hs | 2 +- .../IDE/Plugin/CodeAction/Rules.hs | 45 ------- .../src/Development/IDE/Plugin/Completions.hs | 2 +- ghcide/src/Development/IDE/Plugin/Test.hs | 2 +- ghcide/src/Development/IDE/Types/Exports.hs | 43 ++++--- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 119 ++++++++++++++++++ ghcide/src/Development/IDE/Types/Options.hs | 2 +- .../hls-class-plugin/src/Ide/Plugin/Class.hs | 3 +- 15 files changed, 168 insertions(+), 164 deletions(-) delete mode 100644 ghcide/src/Development/IDE/Plugin/CodeAction/Rules.hs create mode 100644 ghcide/src/Development/IDE/Types/HscEnvEq.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index c85035b3b8..feadae9ee5 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -166,6 +166,7 @@ library Development.IDE.Spans.LocalBindings Development.IDE.Types.Diagnostics Development.IDE.Types.Exports + Development.IDE.Types.HscEnvEq Development.IDE.Types.KnownTargets Development.IDE.Types.Location Development.IDE.Types.Logger @@ -202,8 +203,6 @@ library Development.IDE.Import.FindImports Development.IDE.LSP.Notifications Development.IDE.Plugin.CodeAction.PositionIndexed - Development.IDE.Plugin.CodeAction.Rules - Development.IDE.Plugin.CodeAction.RuleTypes Development.IDE.Plugin.Completions.Logic Development.IDE.Plugin.HLS.Formatter Development.IDE.Types.Action diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 1367422b42..fc4f0553d5 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -49,6 +49,7 @@ import Development.IDE.GHC.Util import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports +import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEqPreserveImportPaths, newHscEnvEq) import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index b0b5ede546..e3b7f8407a 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -40,6 +40,7 @@ import Development.IDE.GHC.Error as X import Development.IDE.GHC.Util as X import Development.IDE.Plugin as X import Development.IDE.Types.Diagnostics as X +import Development.IDE.Types.HscEnvEq as X (HscEnvEq(..), hscEnv, hscEnvWithImportPaths) import Development.IDE.Types.Location as X import Development.IDE.Types.Logger as X import Development.Shake as X (Action, action, Rules, RuleResult) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index d1e1d3d178..ddee675fab 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -22,6 +22,7 @@ import Data.Binary import Development.IDE.Import.DependencyInformation import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Util +import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.KnownTargets import Data.Hashable import Data.Typeable @@ -191,10 +192,10 @@ data HieKind a where instance NFData (HieKind a) where rnf (HieFromDisk hf) = rnf hf rnf HieFresh = () - + instance NFData HieAstResult where rnf (HAR m hf _rm _tr kind) = rnf m `seq` rwhnf hf `seq` rnf kind - + instance Show HieAstResult where show = show . hieModule diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 1f8e1cc7d8..ec2a28f7de 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -112,6 +112,7 @@ import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service import Development.IDE.Core.Shake +import Development.IDE.Types.HscEnvEq import Development.Shake.Classes hiding (get, put) import Control.Monad.Trans.Except (runExceptT,ExceptT,except) import Control.Concurrent.Async (concurrently) diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 3650ac29e5..6b3aed831b 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -4,14 +4,8 @@ -- | General utility functions, mostly focused around GHC operations. module Development.IDE.GHC.Util( - -- * HcsEnv and environment - HscEnvEq, - hscEnv, newHscEnvEq, - hscEnvWithImportPaths, - envImportPaths, modifyDynFlags, evalGhcEnv, - deps, -- * GHC wrappers prettyPrint, unsafePrintSDoc, @@ -32,8 +26,7 @@ module Development.IDE.GHC.Util( setHieDir, dontWriteHieFiles, disableWarningsAsErrors, - newHscEnvEqPreserveImportPaths, - newHscEnvEqWithImportPaths) where + ) where import Control.Concurrent import Data.List.Extra @@ -56,8 +49,6 @@ import GHC.IO.Encoding import GHC.IO.Exception import GHC.IO.Handle.Types import GHC.IO.Handle.Internals -import Data.Unique -import Development.Shake.Classes import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T @@ -71,13 +62,12 @@ import Outputable (SDoc, showSDocUnsafe, ppr, Outputable, mkUserStyle, renderWit import Packages (getPackageConfigMap, lookupPackage') import SrcLoc (mkRealSrcLoc) import FastString (mkFastString) -import Module (moduleNameSlashes, InstalledUnitId) +import Module (moduleNameSlashes) import OccName (parenSymOcc) import RdrName (nameRdrName, rdrNameOcc) import Development.IDE.GHC.Compat as GHC import Development.IDE.Types.Location -import System.Directory (canonicalizePath) ---------------------------------------------------------------------- @@ -178,77 +168,6 @@ moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn fromNormalizedFilePath $ toNormalizedFilePath' $ moduleNameSlashes mn --- | An 'HscEnv' with equality. Two values are considered equal --- if they are created with the same call to 'newHscEnvEq'. -data HscEnvEq = HscEnvEq - { envUnique :: !Unique - , hscEnv :: !HscEnv - , deps :: [(InstalledUnitId, DynFlags)] - -- ^ In memory components for this HscEnv - -- This is only used at the moment for the import dirs in - -- the DynFlags - , envImportPaths :: Maybe [String] - -- ^ If Just, import dirs originally configured in this env - -- If Nothing, the env import dirs are unaltered - } - --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq cradlePath hscEnv0 deps = do - envUnique <- newUnique - let relativeToCradle = (takeDirectory cradlePath ) - hscEnv = removeImportPaths hscEnv0 - - -- Canonicalize import paths since we also canonicalize targets - importPathsCanon <- - mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) - let envImportPaths = Just importPathsCanon - - return HscEnvEq{..} - -newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do - envUnique <- newUnique - return HscEnvEq{..} - --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEqPreserveImportPaths - :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqPreserveImportPaths hscEnv deps = do - let envImportPaths = Nothing - envUnique <- newUnique - return HscEnvEq{..} - --- | Unwrap the 'HscEnv' with the original import paths. --- Used only for locating imports -hscEnvWithImportPaths :: HscEnvEq -> HscEnv -hscEnvWithImportPaths HscEnvEq{..} - | Just imps <- envImportPaths - = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = imps}} - | otherwise - = hscEnv - -removeImportPaths :: HscEnv -> HscEnv -removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}} - -instance Show HscEnvEq where - show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique) - -instance Eq HscEnvEq where - a == b = envUnique a == envUnique b - -instance NFData HscEnvEq where - rnf (HscEnvEq a b c d) = rnf (hashUnique a) `seq` b `seq` c `seq` rnf d - -instance Hashable HscEnvEq where - hashWithSalt s = hashWithSalt s . envUnique - --- Fake instance needed to persuade Shake to accept this type as a key. --- No harm done as ghcide never persists these keys currently -instance Binary HscEnvEq where - put _ = error "not really" - get = error "not really" - -- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error. readFileUtf8 :: FilePath -> IO T.Text readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 08e79e703b..d497b59eaf 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -23,10 +23,9 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.CodeAction.PositionIndexed -import Development.IDE.Plugin.CodeAction.RuleTypes -import Development.IDE.Plugin.CodeAction.Rules import Development.IDE.Plugin.TypeLenses (suggestSignature) import Development.IDE.Types.Exports +import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Data.HashMap.Strict as Map @@ -63,7 +62,7 @@ import Data.Monoid (Ap(..)) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = rulePackageExports, + { pluginRules = mempty, pluginCodeActionProvider = Just codeAction } @@ -87,7 +86,7 @@ codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_di <*> use GhcSession `traverse` mbFile <*> use GetAnnotatedParsedSource `traverse` mbFile -- This is quite expensive 0.6-0.7s on GHC - pkgExports <- runAction "CodeAction:PackageExports" state $ (useNoFile_ . PackageExports) `traverse` env + let pkgExports = envPackageExports <$> env localExports <- readVar (exportsMap $ shakeExtras state) let exportsMap = localExports <> fromMaybe mempty pkgExports @@ -694,7 +693,7 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_ | otherwise = [] lookupExportMap binding mod | Just match <- Map.lookup binding (getExportsMap exportsMap) - , [(ident, _)] <- filter (\(_,m) -> mod == m) (Set.toList match) + , [ident] <- filter (\ident -> moduleNameText ident == mod) (Set.toList match) = Just ident -- fallback to using GHC suggestion even though it is not always correct @@ -703,7 +702,8 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_ { name = binding , rendered = binding , parent = Nothing - , isDatacon = False} + , isDatacon = False + , moduleNameText = mod} data HidingMode = HideOthers [ModuleTarget] @@ -1090,10 +1090,10 @@ constructNewImportSuggestions constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrd [ suggestion | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] - , (identInfo, m) <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) + , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) , canUseIdent thingMissing identInfo - , m `notElem` fromMaybe [] notTheseModules - , suggestion <- renderNewImport identInfo m + , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules + , suggestion <- renderNewImport identInfo (moduleNameText identInfo) ] where renderNewImport :: IdentInfo -> T.Text -> [T.Text] diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs index fc154c87a6..c663e3a1a7 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs @@ -7,7 +7,7 @@ module Development.IDE.Plugin.CodeAction.RuleTypes import Data.Hashable (Hashable) import Control.DeepSeq (NFData) import Data.Binary (Binary) -import Development.IDE.GHC.Util +import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.Exports import Development.Shake (RuleResult) import Data.Typeable (Typeable) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Rules.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Rules.hs deleted file mode 100644 index ea69db60ce..0000000000 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/Rules.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Development.IDE.Plugin.CodeAction.Rules - ( rulePackageExports - ) -where - -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 ( hsc_dflags) -import LoadIface -import Maybes -import Module ( Module(..) ) -import Packages ( explicitPackages - , exposedModules - , packageConfigId - ) -import TcRnMonad ( WhereFrom(ImportByUser) - , initIfaceLoad - ) - -rulePackageExports :: Rules () -rulePackageExports = defineNoFile $ \(PackageExports session) -> do - let env = hscEnv session - pkgst = pkgState (hsc_dflags env) - depends = explicitPackages pkgst - targets = - [ (pkg, mn) - | d <- depends - , Just pkg <- [lookupPackageConfig d env] - , (mn, _) <- exposedModules pkg - ] - - modIfaces <- forM targets $ \(pkg, mn) -> do - modIface <- liftIO $ initIfaceLoad env $ loadInterface - "" - (Module (packageConfigId pkg) mn) - (ImportByUser False) - return $ case modIface of - Failed _err -> Nothing - Succeeded mi -> Just mi - return $ createExportsMap (catMaybes modIfaces) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index cdfa160ed0..ee1d61fa7f 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -28,7 +28,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint (Annotated (annsA), GetAnnotatedParsedSource (GetAnnotatedParsedSource)) -import Development.IDE.GHC.Util +import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.Completions.Types import Ide.Plugin.Config (Config (completionSnippetsOn)) diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index e4ae111e2f..d2d9c58764 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -16,7 +16,7 @@ import Data.CaseInsensitive (CI, original) import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.IDE.GHC.Compat -import Development.IDE.GHC.Util (HscEnvEq(hscEnv)) +import Development.IDE.Types.HscEnvEq (HscEnvEq(hscEnv)) import Development.IDE.LSP.Server import Development.IDE.Plugin import Development.IDE.Types.Action diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index 6c85af472a..11bcfd55f0 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -10,7 +10,7 @@ module Development.IDE.Types.Exports ) where import Avail (AvailInfo(..)) -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData(..)) import Data.Text (pack, Text) import Development.IDE.GHC.Compat import Development.IDE.GHC.Util @@ -27,41 +27,50 @@ import Data.Hashable (Hashable) import TcRnTypes(TcGblEnv(..)) newtype ExportsMap = ExportsMap - {getExportsMap :: HashMap IdentifierText (HashSet (IdentInfo,ModuleNameText))} + {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)} deriving newtype (Monoid, NFData, Show) instance Semigroup ExportsMap where ExportsMap a <> ExportsMap b = ExportsMap $ Map.unionWith (<>) a b type IdentifierText = Text -type ModuleNameText = Text data IdentInfo = IdentInfo { name :: !Text , rendered :: Text , parent :: !(Maybe Text) , isDatacon :: !Bool + , moduleNameText :: !Text } - deriving (Eq, Generic, Show) + deriving (Generic, Show) deriving anyclass Hashable -instance NFData IdentInfo +instance Eq IdentInfo where + a == b = name a == name b + && parent a == parent b + && isDatacon a == isDatacon b + && moduleNameText a == moduleNameText b -mkIdentInfos :: AvailInfo -> [IdentInfo] -mkIdentInfos (Avail n) = - [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)] -mkIdentInfos (AvailTC parent (n:nn) flds) +instance NFData IdentInfo where + rnf IdentInfo{..} = + -- deliberately skip the rendered field + rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText + +mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] +mkIdentInfos mod (Avail n) = + [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod] +mkIdentInfos mod (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) (isDataConName n) + = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) (isDataConName n) mod | n <- nn ++ map flSelector flds ] ++ - [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)] + [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod] where parentP = pack $ printName parent -mkIdentInfos (AvailTC _ nn flds) - = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) +mkIdentInfos mod (AvailTC _ nn flds) + = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod | n <- nn ++ map flSelector flds ] @@ -86,7 +95,7 @@ createExportsMapTc = ExportsMap . Map.fromListWith (<>) . concatMap doOne where mn = moduleName $ tcg_mod mi -unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])] -unpackAvail mod = - map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)])) - . mkIdentInfos +unpackAvail :: ModuleName -> IfaceExport -> [(Text, [IdentInfo])] +unpackAvail !(pack . moduleNameString -> mod) = map f . mkIdentInfos mod + where + f id@IdentInfo {..} = (name, [id]) diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs new file mode 100644 index 0000000000..a11729f787 --- /dev/null +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -0,0 +1,119 @@ +module Development.IDE.Types.HscEnvEq +( HscEnvEq, + hscEnv, newHscEnvEq, + hscEnvWithImportPaths, + newHscEnvEqPreserveImportPaths, + newHscEnvEqWithImportPaths, + envImportPaths, + envPackageExports, + deps +) where + + +import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import Data.Unique +import Development.Shake.Classes +import Module (InstalledUnitId) +import System.Directory (canonicalizePath) +import Development.IDE.GHC.Compat +import GhcPlugins(HscEnv (hsc_dflags), PackageState (explicitPackages), InstalledPackageInfo (exposedModules), Module(..), packageConfigId) +import System.FilePath +import Development.IDE.GHC.Util (lookupPackageConfig) +import Control.Monad.IO.Class +import TcRnMonad (initIfaceLoad, WhereFrom (ImportByUser)) +import LoadIface (loadInterface) +import qualified Maybes +import OpenTelemetry.Eventlog (withSpan) +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Extra (mapMaybeM) + +-- | An 'HscEnv' with equality. Two values are considered equal +-- if they are created with the same call to 'newHscEnvEq'. +data HscEnvEq = HscEnvEq + { envUnique :: !Unique + , hscEnv :: !HscEnv + , deps :: [(InstalledUnitId, DynFlags)] + -- ^ In memory components for this HscEnv + -- This is only used at the moment for the import dirs in + -- the DynFlags + , envImportPaths :: Maybe [String] + -- ^ If Just, import dirs originally configured in this env + -- If Nothing, the env import dirs are unaltered + , envPackageExports :: ExportsMap + } + +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. +newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq cradlePath hscEnv0 deps = do + let relativeToCradle = (takeDirectory cradlePath ) + hscEnv = removeImportPaths hscEnv0 + + -- Canonicalize import paths since we also canonicalize targets + importPathsCanon <- + mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + + newHscEnvEqWithImportPaths (Just importPathsCanon) hscEnv deps + +newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do + envUnique <- newUnique + + let + -- evaluate lazily, using unsafePerformIO for a pure API + envPackageExports = unsafePerformIO $ withSpan "Package Exports" $ \_sp -> do + -- compute the package imports + let pkgst = pkgState (hsc_dflags hscEnv) + depends = explicitPackages pkgst + targets = + [ (pkg, mn) + | d <- depends + , Just pkg <- [lookupPackageConfig d hscEnv] + , (mn, _) <- exposedModules pkg + ] + + doOne (pkg, mn) = do + modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface + "" + (Module (packageConfigId pkg) mn) + (ImportByUser False) + return $ case modIface of + Maybes.Failed _r -> Nothing + Maybes.Succeeded mi -> Just mi + modIfaces <- mapMaybeM doOne targets + return $ createExportsMap modIfaces + return HscEnvEq{..} + +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. +newHscEnvEqPreserveImportPaths + :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing + +-- | Unwrap the 'HscEnv' with the original import paths. +-- Used only for locating imports +hscEnvWithImportPaths :: HscEnvEq -> HscEnv +hscEnvWithImportPaths HscEnvEq{..} + | Just imps <- envImportPaths + = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = imps}} + | otherwise + = hscEnv + +removeImportPaths :: HscEnv -> HscEnv +removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}} + +instance Show HscEnvEq where + show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique) + +instance Eq HscEnvEq where + a == b = envUnique a == envUnique b + +instance NFData HscEnvEq where + rnf (HscEnvEq a b c d e) = rnf (hashUnique a) `seq` b `seq` c `seq` rnf d `seq` rnf e + +instance Hashable HscEnvEq where + hashWithSalt s = hashWithSalt s . envUnique + +-- Fake instance needed to persuade Shake to accept this type as a key. +-- No harm done as ghcide never persists these keys currently +instance Binary HscEnvEq where + put _ = error "not really" + get = error "not really" diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 9e5c25a6f9..fefd956b59 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -19,7 +19,7 @@ module Development.IDE.Types.Options import Data.Default import Development.Shake -import Development.IDE.GHC.Util +import Development.IDE.Types.HscEnvEq (HscEnvEq) import GHC hiding (parseModule, typecheckModule) import GhcPlugins as GHC hiding (fst3, (<>)) import qualified Language.Haskell.LSP.Types.Capabilities as LSP diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 327f12d389..9b79690d69 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -18,13 +18,12 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Data.Aeson import Data.Char -import qualified Data.HashMap.Strict as H import Data.List import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T import Development.IDE -import Development.IDE.Core.PositionMapping (fromCurrentRange, toCurrentRange) +import Development.IDE.Core.PositionMapping (fromCurrentRange) import Development.IDE.GHC.Compat hiding (getLoc) import Development.IDE.Spans.AtPoint import qualified GHC.Generics as Generics From 634979a20a42b1f60bafd73e766d7c95ad34340e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 31 Jan 2021 22:40:32 +0000 Subject: [PATCH 2/9] [ghcide-bench] drop redundant argument --- ghcide/bench/lib/Experiments.hs | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 44b639c9a9..3772450d8e 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -62,44 +62,44 @@ allWithIdentifierPos f docs = allM f (filter (isJust . identifierP) docs) experiments :: [Bench] experiments = [ --------------------------------------------------------------------------------------- - bench "hover" 10 $ allWithIdentifierPos $ \DocumentPositions{..} -> + bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- - bench "edit" 10 $ \docs -> do + bench "edit" $ \docs -> do forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] waitForProgressDone -- TODO check that this waits for all of them return True, --------------------------------------------------------------------------------------- - bench "hover after edit" 10 $ \docs -> do + bench "hover after edit" $ \docs -> do forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- - bench "getDefinition" 10 $ allWithIdentifierPos $ \DocumentPositions{..} -> + bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} -> not . null <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- - bench "getDefinition after edit" 10 $ \docs -> do + bench "getDefinition after edit" $ \docs -> do forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> not . null <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- - bench "documentSymbols" 100 $ allM $ \DocumentPositions{..} -> do + bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc, --------------------------------------------------------------------------------------- - bench "documentSymbols after edit" 100 $ \docs -> do + bench "documentSymbols after edit" $ \docs -> do forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] flip allM docs $ \DocumentPositions{..} -> either (not . null) (not . null) <$> getDocumentSymbols doc, --------------------------------------------------------------------------------------- - bench "completions" 10 $ \docs -> do + bench "completions" $ \docs -> do flip allWithIdentifierPos docs $ \DocumentPositions{..} -> not . null <$> getCompletions doc (fromJust identifierP), --------------------------------------------------------------------------------------- - bench "completions after edit" 10 $ \docs -> do + bench "completions after edit" $ \docs -> do forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> @@ -107,7 +107,6 @@ experiments = --------------------------------------------------------------------------------------- benchWithSetup "code actions" - 10 ( \docs -> do unless (any (isJust . identifierP) docs) $ error "None of the example modules is suitable for this experiment" @@ -122,7 +121,6 @@ experiments = --------------------------------------------------------------------------------------- benchWithSetup "code actions after edit" - 10 ( \docs -> do unless (any (isJust . identifierP) docs) $ error "None of the example modules is suitable for this experiment" @@ -208,21 +206,20 @@ select Bench {name, enabled} = benchWithSetup :: String -> - Natural -> ([DocumentPositions] -> Session ()) -> Experiment -> Bench -benchWithSetup name samples benchSetup experiment = Bench {..} +benchWithSetup name benchSetup experiment = Bench {..} where enabled = True + samples = 100 -bench :: String -> Natural -> Experiment -> Bench -bench name defSamples = - benchWithSetup name defSamples (const $ pure ()) +bench :: String -> Experiment -> Bench +bench name = benchWithSetup name (const $ pure ()) runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO () runBenchmarksFun dir allBenchmarks = do - let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) } + let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) } | b <- allBenchmarks , select b ] From eb61bb16d74ca591fe822144bb90dd6e2b188168 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 31 Jan 2021 22:41:04 +0000 Subject: [PATCH 3/9] [experiments] hover after cradle edit --- ghcide/bench/config.yaml | 1 + ghcide/bench/lib/Experiments.hs | 10 ++++++++++ 2 files changed, 11 insertions(+) diff --git a/ghcide/bench/config.yaml b/ghcide/bench/config.yaml index 25cf408006..7c14de8423 100644 --- a/ghcide/bench/config.yaml +++ b/ghcide/bench/config.yaml @@ -35,6 +35,7 @@ experiments: - "code actions" - "code actions after edit" - "documentSymbols after edit" + - "hover after cradle edit" # An ordered list of versions to analyze versions: diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 3772450d8e..dcf1720fbb 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -134,6 +134,16 @@ experiments = not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do forM identifierP $ \p -> getCodeActions doc (Range p p)) + ), + --------------------------------------------------------------------------------------- + bench + "hover after cradle edit" + (\docs -> do + Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" + liftIO $ appendFile hieYaml "##\n" + sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) ) ] From 88a040629dd8c62685724dc160139be919f4a8e8 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 4 Feb 2021 22:05:48 +0000 Subject: [PATCH 4/9] [benchmark] code actions after cradle edit --- ghcide/bench/config.yaml | 1 + ghcide/bench/lib/Experiments.hs | 21 +++++++++++++++++++++ 2 files changed, 22 insertions(+) diff --git a/ghcide/bench/config.yaml b/ghcide/bench/config.yaml index 7c14de8423..f186675a68 100644 --- a/ghcide/bench/config.yaml +++ b/ghcide/bench/config.yaml @@ -34,6 +34,7 @@ experiments: - "completions after edit" - "code actions" - "code actions after edit" + - "code actions after cradle edit" - "documentSymbols after edit" - "hover after cradle edit" diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index dcf1720fbb..f90f98ed34 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -136,6 +136,27 @@ experiments = getCodeActions doc (Range p p)) ), --------------------------------------------------------------------------------------- + benchWithSetup + "code actions after cradle edit" + ( \docs -> do + unless (any (isJust . identifierP) docs) $ + error "None of the example modules is suitable for this experiment" + forM_ docs $ \DocumentPositions{..} -> + forM_ identifierP $ \p -> changeDoc doc [charEdit p] + ) + ( \docs -> do + Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml" + liftIO $ appendFile hieYaml "##\n" + sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + waitForProgressDone + not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do + forM identifierP $ \p -> + getCodeActions doc (Range p p)) + ), + --------------------------------------------------------------------------------------- bench "hover after cradle edit" (\docs -> do From d50bd4e8cf02cf0305b7f3cb2a826bfaf107301b Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Feb 2021 12:52:45 +0000 Subject: [PATCH 5/9] Disable 'hover after cradle edit' example Expensive and already covered by 'code actions after cradle edit' --- ghcide/bench/config.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/bench/config.yaml b/ghcide/bench/config.yaml index f186675a68..b8a8f48dd8 100644 --- a/ghcide/bench/config.yaml +++ b/ghcide/bench/config.yaml @@ -29,6 +29,7 @@ experiments: - "edit" - "hover" - "hover after edit" + # - "hover after cradle edit" - "getDefinition" - "getDefinition after edit" - "completions after edit" @@ -36,7 +37,6 @@ experiments: - "code actions after edit" - "code actions after cradle edit" - "documentSymbols after edit" - - "hover after cradle edit" # An ordered list of versions to analyze versions: From 38bd0e26ea38d5c6f6ae7f1d56abdfaabb2cd88f Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 31 Jan 2021 09:31:02 +0000 Subject: [PATCH 6/9] [benchmark] add the completions experiment This was missing from the list --- ghcide/bench/config.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/bench/config.yaml b/ghcide/bench/config.yaml index b8a8f48dd8..6210a20c3e 100644 --- a/ghcide/bench/config.yaml +++ b/ghcide/bench/config.yaml @@ -32,6 +32,7 @@ experiments: # - "hover after cradle edit" - "getDefinition" - "getDefinition after edit" + - "completions" - "completions after edit" - "code actions" - "code actions after edit" From 508521a869d7e9887b7a5d2d0109d1bc6df26d0a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Feb 2021 14:57:04 +0000 Subject: [PATCH 7/9] Drop redundant argument --- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index d497b59eaf..c5f0ae6067 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -1093,11 +1093,11 @@ constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) , canUseIdent thingMissing identInfo , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules - , suggestion <- renderNewImport identInfo (moduleNameText identInfo) + , suggestion <- renderNewImport identInfo ] where - renderNewImport :: IdentInfo -> T.Text -> [T.Text] - renderNewImport identInfo m + renderNewImport :: IdentInfo -> [T.Text] + renderNewImport identInfo | Just q <- qual , asQ <- if q == m then "" else " as " <> q = ["import qualified " <> m <> asQ] @@ -1105,6 +1105,8 @@ constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = = ["import " <> m <> " (" <> renderImportStyle importStyle <> ")" | importStyle <- NE.toList $ importStyles identInfo] ++ ["import " <> m ] + where + m = moduleNameText identInfo canUseIdent :: NotInScope -> IdentInfo -> Bool canUseIdent NotInScopeDataConstructor{} = isDatacon From b60ec6f6c1dab3c2462c0c920c8524adfb07f37b Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Feb 2021 20:36:56 +0000 Subject: [PATCH 8/9] Fix ordering of completions in test --- ghcide/test/exe/Main.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index c319ea857f..e61d6382a4 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3418,7 +3418,8 @@ completionTest name src pos expected = testSessionWait name $ do let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] liftIO $ do let emptyToMaybe x = if T.null x then Nothing else Just x - compls' @?= [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + sortOn (Lens.view Lens._1) compls' @?= + sortOn (Lens.view Lens._1) [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do when expectedSig $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) @@ -3472,7 +3473,7 @@ completionNoCommandTest name src pos wanted = testSession name $ do Nothing -> liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls] Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command - + topLevelCompletionTests :: [TestTree] topLevelCompletionTests = [ @@ -3703,7 +3704,7 @@ nonLocalCompletionTests = "already imported" ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] (Position 2 4) - "ZeroPad" + "ZeroPad" , completionNoCommandTest "function from Prelude" ["module A where", "import Data.Maybe ()", "Nothing"] From 4176f9f2f6e16774bcc9c142c737d5b734367751 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 6 Feb 2021 20:37:14 +0000 Subject: [PATCH 9/9] Exclude package exports from NFData.rnf This fixes the th-linking-test because it restores the previous dynamic semantics in which the package exports are only evaluated when code actions are requested. --- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index a11729f787..7495864bb6 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -107,7 +107,9 @@ instance Eq HscEnvEq where a == b = envUnique a == envUnique b instance NFData HscEnvEq where - rnf (HscEnvEq a b c d e) = rnf (hashUnique a) `seq` b `seq` c `seq` rnf d `seq` rnf e + rnf (HscEnvEq a b c d _) = + -- deliberately skip the package exports map + rnf (hashUnique a) `seq` b `seq` c `seq` rnf d instance Hashable HscEnvEq where hashWithSalt s = hashWithSalt s . envUnique