diff --git a/flake.nix b/flake.nix index 1002eb87b5..2fcdec6b00 100644 --- a/flake.nix +++ b/flake.nix @@ -60,7 +60,7 @@ chmod +x $dest ''; - mkDevShell = hpkgs: with pkgs; mkShell { + mkDevShell = hpkgs: with pkgs; pkgs.mkShell { name = "haskell-language-server-dev-ghc${hpkgs.ghc.version}"; # For binary Haskell tools, we use the default Nixpkgs GHC version. # This removes a rebuild with a different GHC version. The drawback of @@ -106,7 +106,9 @@ in { # Developement shell with only dev tools devShells = { - default = mkDevShell pkgs.haskellPackages; + default = pkgs.mkShell { + buildInputs = with pkgs; [zlib haskell.compiler.ghc910 cabal-install]; + }; shell-ghc96 = mkDevShell pkgs.haskell.packages.ghc96; shell-ghc98 = mkDevShell pkgs.haskell.packages.ghc98; shell-ghc910 = mkDevShell pkgs.haskell.packages.ghc910; diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index 8c44173bd6..9d11efec5e 100644 --- a/ghcide-test/exe/CompletionTests.hs +++ b/ghcide-test/exe/CompletionTests.hs @@ -32,6 +32,7 @@ import Test.Hls.FileSystem (file, text) import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit +import Debug.Pretty.Simple tests :: TestTree tests diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index b217012bec..43a67f81e3 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -107,6 +107,7 @@ library , unliftio-core , unordered-containers >=0.2.10.0 , vector + , pretty-simple if os(windows) build-depends: Win32 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index dde1cfdea5..16f49d2c00 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -476,8 +476,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- If we don't generate a TargetFile for each potential location, we will only have -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' -- and also not find 'TargetModule Foo'. - fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) + pure $ do + file <- nubOrd (f:targetLocations) + pure $ (TargetFile file, Set.singleton file) TargetModule _ -> do found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations return [(targetTarget, Set.fromList found)] @@ -764,6 +765,7 @@ data TargetDetails = TargetDetails targetDepends :: !DependencyInfo, targetLocations :: ![NormalizedFilePath] } + deriving (Show) fromTargetId :: [FilePath] -- ^ import paths -> [String] -- ^ extensions to consider diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 8798068b45..7b5ddb6afc 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -412,6 +412,9 @@ type instance RuleResult GetModSummary = ModSummaryResult -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult +type instance RuleResult GetModulesPaths = (M.Map ModuleName (UnitId, NormalizedFilePath), + M.Map ModuleName (UnitId, NormalizedFilePath)) + data GetParsedModule = GetParsedModule deriving (Eq, Show, Generic) instance Hashable GetParsedModule @@ -524,6 +527,13 @@ data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps instance Hashable GetModSummaryWithoutTimestamps instance NFData GetModSummaryWithoutTimestamps +-- | Scan all the import directory for existing modules and build a map from +-- module name to paths +data GetModulesPaths = GetModulesPaths + deriving (Eq, Show, Generic) +instance Hashable GetModulesPaths +instance NFData GetModulesPaths + data GetModSummary = GetModSummary deriving (Eq, Show, Generic) instance Hashable GetModSummary diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index daaa28c5da..d37852c291 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -4,6 +4,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PartialTypeSignatures #-} -- | A Shake implementation of the compiler service, built -- using the "Shaker" abstraction layer for in-memory use. @@ -55,6 +56,7 @@ module Development.IDE.Core.Rules( GhcSessionDepsConfig(..), Log(..), DisplayTHWarning(..), + extendModuleMapWithKnownTargets, ) where import Control.Applicative @@ -175,6 +177,10 @@ import System.Info.Extra (isWindows) import qualified Data.IntMap as IM import GHC.Fingerprint +import qualified Data.Map.Strict as Map +import System.FilePath (takeExtension, takeFileName, normalise, dropExtension, splitDirectories) +import Data.Char (isUpper) +import System.Directory.Extra (listFilesInside) data Log = LogShake Shake.Log @@ -313,30 +319,22 @@ getParsedModuleDefinition packageState opt file ms = do getLocatedImportsRule :: Recorder (WithPriority Log) -> Rules () getLocatedImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do + ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file - (KnownTargets targets targetsMap) <- useNoFile_ GetKnownTargets + -- TODO: should we reverse this concatenation, there are way less + -- source import than normal import in theory, so it should be faster let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env_eq <- use_ GhcSession file let env = hscEnv env_eq let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env let dflags = hsc_dflags env opt <- getIdeOptions - let getTargetFor modName nfp - | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do - -- reuse the existing NormalizedFilePath in order to maximize sharing - itExists <- getFileExists nfp' - return $ if itExists then Just nfp' else Nothing - | Just tt <- HM.lookup (TargetModule modName) targets = do - -- reuse the existing NormalizedFilePath in order to maximize sharing - let ttmap = HM.mapWithKey const (HashSet.toMap tt) - nfp' = HM.lookupDefault nfp nfp ttmap - itExists <- getFileExists nfp' - return $ if itExists then Just nfp' else Nothing - | otherwise = do - itExists <- getFileExists nfp - return $ if itExists then Just nfp else Nothing + + moduleMaps <- extendModuleMapWithKnownTargets file + (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do - diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource + + diagOrImp <- locateModule moduleMaps (hscSetFlags dflags env) import_dirs (optExtensions opt) modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path)) @@ -626,6 +624,103 @@ getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake rec fs <- toKnownFiles <$> useNoFile_ GetKnownTargets dependencyInfoForFiles (HashSet.toList fs) +getModulesPathsRule :: Recorder (WithPriority Log) -> Rules () +getModulesPathsRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModulesPaths file -> do + env_eq <- use_ GhcSession file + + ShakeExtras{moduleToPathCache} <- getShakeExtras + + cache <- liftIO (readTVarIO moduleToPathCache) + case Map.lookup (envUnique env_eq) cache of + Just res -> pure (mempty, ([], Just res)) + Nothing -> do + let env = hscEnv env_eq + let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env + opt <- getIdeOptions + let exts = (optExtensions opt) + let acceptedExtensions = concatMap (\x -> ['.':x, '.':x <> "-boot"]) exts + + (unzip -> (a, b)) <- flip mapM import_dirs $ \(u, dyn) -> do + (unzip -> (a, b)) <- flip mapM (importPaths dyn) $ \dir' -> do + let dir = normalise dir' + let predicate path = pure (normalise path == dir || case takeFileName path of + [] -> False + (x:_) -> isUpper x) + let dir_number_directories = length (splitDirectories dir) + let toModule file = mkModuleName (intercalate "." $ drop dir_number_directories (splitDirectories (dropExtension file))) + + -- TODO: we are taking/dropping extension, this could be factorized to save a few cpu cycles ;) + -- TODO: do acceptedextensions needs to be a set ? or a vector? + -- If the directory is empty, we return an empty list of modules + -- using 'catch' instead of an exception which would kill the LSP + modules <- (fmap (\path -> (toModule path, toNormalizedFilePath' path)) . filter (\y -> takeExtension y `elem` acceptedExtensions) <$> liftIO (listFilesInside predicate dir)) + `catch` (\(_ :: IOException) -> pure []) + let isSourceModule (_, path) = "-boot" `isSuffixOf` fromNormalizedFilePath path + let (sourceModules, notSourceModules) = partition isSourceModule modules + pure $ (Map.fromList notSourceModules, Map.fromList sourceModules) + pure (fmap (u,) $ mconcat a, fmap (u, ) $ mconcat b) + + let res = (mconcat a, mconcat b) + liftIO $ atomically $ modifyTVar' moduleToPathCache (Map.insert (envUnique env_eq) res) + + pure (mempty, ([], Just res)) + +-- | Extend the map from module name to filepath (exiting on the drive) with +-- the list of known targets provided by HLS +-- +-- These known targets are files which were recently created and not yet saved +-- to the filesystem. +-- +-- TODO: for now the implementation is O(number_of_known_files * +-- number_of_include_path) which is inacceptable and should be addressed. +extendModuleMapWithKnownTargets + :: NormalizedFilePath + -> Action (Map.Map ModuleName (UnitId, NormalizedFilePath), Map.Map ModuleName (UnitId, NormalizedFilePath)) +extendModuleMapWithKnownTargets file = do + (notSourceModules, sourceModules) <- use_ GetModulesPaths file + KnownTargets targetsMap <- useNoFile_ GetKnownTargets + + env_eq <- use_ GhcSession file + let env = hscEnv env_eq + let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env + opt <- getIdeOptions + let exts = (optExtensions opt) + let acceptedExtensions = concatMap (\x -> ['.':x, '.':x <> "-boot"]) exts + + let (unzip -> (catMaybes -> a, catMaybes -> b)) = do + (u, dyn) <- import_dirs + -- TODO: avoid using so much `FilePath` logic AND please please, + -- normalize earlier. + -- + -- The normalise here is in order to remove the trailing `.` which + -- could break the comparison later. + (normalise -> dir') <- importPaths dyn + let dirComponents = splitDirectories dir' + let dir_number_directories = length dirComponents + -- TODO: the _target may represents something different than the path + -- stored in paths. This need to be investigated. + (_target, paths) <- HM.toList targetsMap + path <- HashSet.toList paths + let pathString = fromNormalizedFilePath path + let pathComponents = splitDirectories pathString + + -- Ensure this file is in the directory + guard $ dirComponents `isPrefixOf` pathComponents + + -- Ensure that this extension is accepted + guard $ takeExtension pathString `elem` acceptedExtensions + let modName = mkModuleName (intercalate "." $ drop dir_number_directories (splitDirectories (dropExtension pathString))) + let isSourceModule = "-boot" `isSuffixOf` pathString + if isSourceModule + then + pure (Nothing, Just (modName, (u, path))) + else + pure (Just (modName, (u, path)), Nothing) + + + pure $ (Map.fromList a <> notSourceModules, Map.fromList b <> sourceModules) + + dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) dependencyInfoForFiles fs = do (rawDepInfo, bm) <- rawDependencyInformation fs @@ -708,6 +803,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO -- loading is always returning a absolute path now (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file + -- TODO: this is responsible for a LOT of allocations -- add the deps to the Shake graph let addDependency fp = do @@ -1229,6 +1325,7 @@ mainRule recorder RulesConfig{..} = do getModIfaceRule recorder getModSummaryRule templateHaskellWarning recorder getModuleGraphRule recorder + getModulesPathsRule recorder getFileHashRule recorder knownFilesRule recorder getClientSettingsRule recorder diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6fc9a4d00e..c6cb161c90 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -135,7 +135,7 @@ import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Compat (NameCache, NameCacheUpdater, initNameCache, - knownKeyNames) + knownKeyNames, ModuleName, UnitId) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue, action) @@ -178,6 +178,7 @@ import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra import UnliftIO (MonadUnliftIO (withRunInIO)) +import Data.Map.Strict (Map) data Log @@ -310,6 +311,10 @@ data ShakeExtras = ShakeExtras ,ideNc :: NameCache -- | A mapping of module name to known target (or candidate targets, if missing) ,knownTargetsVar :: TVar (Hashed KnownTargets) + ,moduleToPathCache :: TVar (Map + Unique + (Map ModuleName (UnitId, NormalizedFilePath), + Map ModuleName (UnitId, NormalizedFilePath))) -- | A mapping of exported identifiers for local modules. Updated on kick ,exportsMap :: TVar ExportsMap -- | A work queue for actions added via 'runInShakeSession' @@ -704,6 +709,8 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv + + moduleToPathCache <- newTVarIO mempty pure ShakeExtras{shakeRecorder = recorder, ..} shakeDb <- shakeNewDatabase @@ -1481,3 +1488,5 @@ runWithSignal msgStart msgEnd files rule = do kickSignal testing lspEnv files msgStart void $ uses rule files kickSignal testing lspEnv files msgEnd + + diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index 7c4046a63a..4ba1585724 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -5,7 +5,6 @@ module Development.IDE.Import.FindImports ( locateModule - , locateModuleFile , Import(..) , ArtifactsLocation(..) , modSummaryToArtifactsLocation @@ -14,9 +13,8 @@ module Development.IDE.Import.FindImports ) where import Control.DeepSeq -import Control.Monad.Extra import Control.Monad.IO.Class -import Data.List (find, isSuffixOf) +import Data.List (isSuffixOf) import Data.Maybe import qualified Data.Set as S import Development.IDE.GHC.Compat as Compat @@ -25,8 +23,8 @@ import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Types.PkgQual -import GHC.Unit.State -import System.FilePath +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map #if MIN_VERSION_ghc(9,11,0) @@ -70,31 +68,6 @@ data LocateResult | LocateFoundReexport UnitId | LocateFoundFile UnitId NormalizedFilePath --- | locate a module in the file system. Where we go from *daml to Haskell -locateModuleFile :: MonadIO m - => [(UnitId, [FilePath], S.Set ModuleName)] - -> [String] - -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) - -> Bool - -> ModuleName - -> m LocateResult -locateModuleFile import_dirss exts targetFor isSource modName = do - let candidates import_dirs = - [ toNormalizedFilePath' (prefix moduleNameSlashes modName <.> maybeBoot ext) - | prefix <- import_dirs , ext <- exts] - mf <- firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs, _) <- import_dirss]) - case mf of - Nothing -> - case find (\(_ , _, reexports) -> S.member modName reexports) import_dirss of - Just (uid,_,_) -> pure $ LocateFoundReexport uid - Nothing -> pure LocateNotFound - Just (uid,file) -> pure $ LocateFoundFile uid file - where - go (uid, candidate) = fmap ((uid,) <$>) $ targetFor modName candidate - maybeBoot ext - | isSource = ext ++ "-boot" - | otherwise = ext - -- | This function is used to map a package name to a set of import paths. -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components @@ -110,40 +83,58 @@ mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules fl -- Haskell locateModule :: MonadIO m - => HscEnv + => (Map ModuleName (UnitId, NormalizedFilePath),Map ModuleName (UnitId, NormalizedFilePath)) + -> HscEnv -> [(UnitId, DynFlags)] -- ^ Import directories -> [String] -- ^ File extensions - -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name -> PkgQual -- ^ Package name -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) -locateModule env comp_info exts targetFor modName mbPkgName isSource = do +locateModule moduleMaps@(moduleMap, moduleMapSource) env comp_info exts modName mbPkgName isSource = do case mbPkgName of -- 'ThisPkg' just means some home module, not the current unit ThisPkg uid + -- TODO: there are MANY lookup on import_paths, which is a problem considering that it can be large. | Just (dirs, reexports) <- lookup uid import_paths - -> lookupLocal uid dirs reexports + -> lookupLocal moduleMaps reexports | otherwise -> return $ Left $ notFoundErr env modName $ LookupNotFound [] -- if a package name is given we only go look for a package OtherPkg uid | Just (dirs, reexports) <- lookup uid import_paths - -> lookupLocal uid dirs reexports + -> lookupLocal moduleMaps reexports | otherwise -> lookupInPackageDB NoPkgQual -> do -- Reexports for current unit have to be empty because they only apply to other units depending on the -- current unit. If we set the reexports to be the actual reexports then we risk looping forever trying -- to find the module from the perspective of the current unit. - mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags, S.empty) : other_imports) exts targetFor isSource $ unLoc modName + -- + -- TODO: handle the other imports, the unit id, ..., reexport. + -- - TODO: should we look for file existence now? If the file was + -- removed from the disk, how will it behaves? How do we invalidate + -- that? + -- + -- [About The reexported module] + -- + -- A package (or unit) A can reexport a module from another package/unit. + -- + -- When it happen, it means two things: + -- + -- - This module must appear in 'moduleMaps', using the correct package/unit + -- - What about "conflict". Right now the moduleMaps maps a module name to a unique package/unit. + let mbFile = case Map.lookup (unLoc modName) (if isSource then moduleMapSource else moduleMap) of + Nothing -> LocateNotFound + Just (uid, file) -> LocateFoundFile uid file case mbFile of LocateNotFound -> lookupInPackageDB -- Lookup again with the perspective of the unit reexporting the file - LocateFoundReexport uid -> locateModule (hscSetActiveUnitId uid env) comp_info exts targetFor modName noPkgQual isSource + LocateFoundReexport uid -> locateModule moduleMaps (hscSetActiveUnitId uid env) comp_info exts modName noPkgQual isSource LocateFoundFile uid file -> toModLocation uid file where dflags = hsc_dflags env import_paths = mapMaybe (mkImportDirs env) comp_info + {- other_imports = -- Instead of bringing all the units into scope, only bring into scope the units -- this one depends on. @@ -162,19 +153,22 @@ locateModule env comp_info exts targetFor modName mbPkgName isSource = do units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue hpt_deps :: [UnitId] hpt_deps = homeUnitDepends units + -} toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod) - lookupLocal uid dirs reexports = do - mbFile <- locateModuleFile [(uid, dirs, reexports)] exts targetFor isSource $ unLoc modName - case mbFile of - LocateNotFound -> return $ Left $ notFoundErr env modName $ LookupNotFound [] - -- Lookup again with the perspective of the unit reexporting the file - LocateFoundReexport uid' -> locateModule (hscSetActiveUnitId uid' env) comp_info exts targetFor modName noPkgQual isSource - LocateFoundFile uid' file -> toModLocation uid' file + lookupLocal moduleMaps@(moduleMap, moduleMapSource) reexports = do + let mbFile = case Map.lookup (unLoc modName) (if isSource then moduleMapSource else moduleMap) of + Nothing -> LocateNotFound + Just (uid, file) -> LocateFoundFile uid file + case mbFile of + LocateNotFound -> return $ Left $ notFoundErr env modName $ LookupNotFound [] + -- Lookup again with the perspective of the unit reexporting the file + LocateFoundReexport uid' -> locateModule moduleMaps (hscSetActiveUnitId uid' env) comp_info exts modName noPkgQual isSource + LocateFoundFile uid' file -> toModLocation uid' file lookupInPackageDB = do case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index c596d1fb82..63e25af56a 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -16,7 +16,7 @@ module Development.IDE.Plugin.TypeLenses ( import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) -import Control.Lens (to, (?~), (^?)) +import Control.Lens ((?~), (^?)) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -51,8 +51,8 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Error (_TcRnMessage, _TcRnMissingSignature, - msgEnvelopeErrorL, - stripTcRnMessageContext) + msgEnvelopeErrorL) + import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes import Development.IDE.Types.Location (Position (Position, _line), @@ -90,7 +90,6 @@ import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), type (|?) (..)) -import Text.Regex.TDFA ((=~)) data Log = LogShake Shake.Log deriving Show diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 1c2ed1732f..075ccfff07 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module Development.IDE.Types.HscEnvEq ( HscEnvEq, - hscEnv, newHscEnvEq, + hscEnv, newHscEnvEq, envUnique, updateHscEnvEq, envPackageExports, envVisibleModuleNames, diff --git a/ghcide/src/Development/IDE/Types/KnownTargets.hs b/ghcide/src/Development/IDE/Types/KnownTargets.hs index 6ae6d52ba3..a2eed5efff 100644 --- a/ghcide/src/Development/IDE/Types/KnownTargets.hs +++ b/ghcide/src/Development/IDE/Types/KnownTargets.hs @@ -19,49 +19,26 @@ import Development.IDE.Types.Location import GHC.Generics -- | A mapping of module name to known files -data KnownTargets = KnownTargets - { targetMap :: !(HashMap Target (HashSet NormalizedFilePath)) - -- | 'normalisingMap' is a cached copy of `HMap.mapKey const targetMap` - -- - -- At startup 'GetLocatedImports' is called on all known files. Say you have 10000 - -- modules in your project then this leads to 10000 calls to 'GetLocatedImports' - -- running concurrently. - -- - -- In `GetLocatedImports` the known targets are consulted and the targetsMap - -- is created by mapping the known targets. This map is used for introducing - -- sharing amongst filepaths. This operation copies a local copy of the `target` - -- map which is local to the rule. - -- - -- @ - -- let targetsMap = HMap.mapWithKey const targets - -- @ - -- - -- So now each rule has a 'HashMap' of size 10000 held locally to it and depending - -- on how the threads are scheduled there will be 10000^2 elements in total - -- allocated in 'HashMap's. This used a lot of memory. - -- - -- Solution: Return the 'normalisingMap' in the result of the `GetKnownTargets` rule so it is shared across threads. - , normalisingMap :: !(HashMap Target Target) } deriving Show +newtype KnownTargets = KnownTargets + { targetMap :: (HashMap Target (HashSet NormalizedFilePath)) + } deriving (Show, Eq) unionKnownTargets :: KnownTargets -> KnownTargets -> KnownTargets -unionKnownTargets (KnownTargets tm nm) (KnownTargets tm' nm') = - KnownTargets (HMap.unionWith (<>) tm tm') (HMap.union nm nm') +unionKnownTargets (KnownTargets tm) (KnownTargets tm') = + KnownTargets (HMap.unionWith (<>) tm tm') mkKnownTargets :: [(Target, HashSet NormalizedFilePath)] -> KnownTargets -mkKnownTargets vs = KnownTargets (HMap.fromList vs) (HMap.fromList [(k,k) | (k,_) <- vs ]) +mkKnownTargets vs = KnownTargets (HMap.fromList vs) instance NFData KnownTargets where - rnf (KnownTargets tm nm) = rnf tm `seq` rnf nm `seq` () - -instance Eq KnownTargets where - k1 == k2 = targetMap k1 == targetMap k2 + rnf (KnownTargets tm) = rnf tm `seq` () instance Hashable KnownTargets where - hashWithSalt s (KnownTargets hm _) = hashWithSalt s hm + hashWithSalt s (KnownTargets hm) = hashWithSalt s hm emptyKnownTargets :: KnownTargets -emptyKnownTargets = KnownTargets HMap.empty HMap.empty +emptyKnownTargets = KnownTargets HMap.empty data Target = TargetModule ModuleName | TargetFile NormalizedFilePath deriving ( Eq, Ord, Generic, Show ) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index c24b1869ba..82a579dafc 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2190,6 +2190,8 @@ test-suite ghcide-tests , text-rope , unordered-containers , hls-test-utils == 2.12.0.0 + , pretty-simple + , lsp-test if impl(ghc <9.3) build-depends: ghc-typelits-knownnat