mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
Share ModuleGraphs for all files (#3232)
* Remove GetDependencyInformation in favour of GetModuleGraph. Computing and storing GetDependencyInformation for each file essentially individually means that we perform downsweep on each file individually, wasting a lot of work and using an excessive amount of memory to store all these duplicated graphs individually. However, we already have the `GetModuleGraph` rule, which we need to compute before compiling files any way due to being depended on by `NeedsCompilation`, which needs to know if any reverse dependencies of the module we are compiling requires TH, which meant that each file already depends on the results of downsweep for the whole project. Instead, we can compute the whole graph once when we execute the `GetModuleGraph` rule and even use this inside `HscEnv.hsc_mod_graph` to avoid reconstructing the `ModuleGraph` on each invocation of `GhcSessionDeps`. There may be concerns about excessive build churn due to any change to the result of `GetModuleGraph` invalidating the result of `GhcSessionDeps` too often, but note that this only happens when something in the header of a module changes, and this could be solved easily be re-introducing a version of `GetDependencyInformation` with early cutoff that essentially returns the result of `GetModuleGraph` but includes the hash of only the `ModSummary`s in the downward dependency closure of the file. * module graph early cutoff early cutoff for eval plugin * allow running benchmarks on examples generated via a script * Add new benchmarks to config * Allow pathToId to fail * Errors --------- Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
This commit is contained in:
parent
202295ba88
commit
9effc56ef8
34
bench/MultiLayerModules.sh
Executable file
34
bench/MultiLayerModules.sh
Executable file
@ -0,0 +1,34 @@
|
||||
#!/usr/bin/env bash
|
||||
# Generate $DEPTH layers of modules with $WIDTH modules on each layer
|
||||
# Every module on layer N imports all the modules on layer N-1
|
||||
# MultiLayerModules.hs imports all the modules from the last layer
|
||||
DEPTH=15
|
||||
WIDTH=40
|
||||
cat >hie.yaml << EOF
|
||||
cradle:
|
||||
direct:
|
||||
arguments:
|
||||
EOF
|
||||
for i in $(seq -w 1 $WIDTH); do
|
||||
echo "module DummyLevel0M$i where" > DummyLevel0M$i.hs;
|
||||
echo " - DummyLevel0M$i.hs" >> hie.yaml;
|
||||
done
|
||||
for l in $(seq 1 $DEPTH); do
|
||||
for i in $(seq -w 1 $WIDTH); do
|
||||
echo "module DummyLevel${l}M$i where" > DummyLevel${l}M$i.hs;
|
||||
echo " - DummyLevel${l}M$i.hs" >> hie.yaml;
|
||||
for j in $(seq -w 1 $WIDTH); do
|
||||
echo "import DummyLevel$((l-1))M$j" >> DummyLevel${l}M$i.hs;
|
||||
done
|
||||
done
|
||||
done
|
||||
case "$1" in
|
||||
'--th')
|
||||
echo "{-# LANGUAGE TemplateHaskell #-}" > MultiLayerModules.hs
|
||||
;;
|
||||
esac
|
||||
echo "module MultiLayerModules where" >> MultiLayerModules.hs
|
||||
echo " - MultiLayerModules.hs" >> hie.yaml;
|
||||
for j in $(seq -w 1 $WIDTH); do
|
||||
echo "import DummyLevel${DEPTH}M$j" >> MultiLayerModules.hs;
|
||||
done
|
@ -33,6 +33,50 @@ examples:
|
||||
modules:
|
||||
- src/Language/LSP/Types/WatchedFiles.hs
|
||||
- src/Language/LSP/Types/CallHierarchy.hs
|
||||
|
||||
- name: MultiLayerModules
|
||||
path: bench/MultiLayerModules.sh
|
||||
script: True
|
||||
script-args: ["--th"]
|
||||
modules:
|
||||
- MultiLayerModules.hs
|
||||
- DummyLevel0M01.hs
|
||||
- DummyLevel1M01.hs
|
||||
- name: MultiLayerModulesNoTH
|
||||
path: bench/MultiLayerModules.sh
|
||||
script: True
|
||||
script-args: []
|
||||
modules:
|
||||
- MultiLayerModules.hs
|
||||
- DummyLevel0M01.hs
|
||||
- DummyLevel1M01.hs
|
||||
|
||||
- name: DummyLevel0M01
|
||||
path: bench/MultiLayerModules.sh
|
||||
script: True
|
||||
script-args: ["--th"]
|
||||
modules:
|
||||
- DummyLevel0M01.hs
|
||||
- name: DummyLevel0M01NoTH
|
||||
path: bench/MultiLayerModules.sh
|
||||
script: True
|
||||
script-args: []
|
||||
modules:
|
||||
- DummyLevel0M01.hs
|
||||
|
||||
- name: DummyLevel1M01
|
||||
path: bench/MultiLayerModules.sh
|
||||
script: True
|
||||
script-args: ["--th"]
|
||||
modules:
|
||||
- DummyLevel1M01.hs
|
||||
- name: DummyLevel1M01NoTH
|
||||
path: bench/MultiLayerModules.sh
|
||||
script: True
|
||||
script-args: []
|
||||
modules:
|
||||
- DummyLevel1M01.hs
|
||||
|
||||
# Small but heavily multi-component example
|
||||
# Disabled as it is far to slow. hie-bios >0.7.2 should help
|
||||
# - name: HLS
|
||||
@ -47,6 +91,7 @@ examples:
|
||||
|
||||
# The set of experiments to execute
|
||||
experiments:
|
||||
- "edit-header"
|
||||
- "edit"
|
||||
- "hover"
|
||||
- "hover after edit"
|
||||
|
@ -79,6 +79,12 @@ charEdit p =
|
||||
.+ #rangeLength .== Nothing
|
||||
.+ #text .== "a"
|
||||
|
||||
headerEdit :: TextDocumentContentChangeEvent
|
||||
headerEdit =
|
||||
TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 0)
|
||||
.+ #rangeLength .== Nothing
|
||||
.+ #text .== "-- header comment \n"
|
||||
|
||||
data DocumentPositions = DocumentPositions {
|
||||
-- | A position that can be used to generate non null goto-def and completion responses
|
||||
identifierP :: Maybe Position,
|
||||
@ -112,6 +118,16 @@ experiments =
|
||||
waitForProgressDone
|
||||
return True,
|
||||
---------------------------------------------------------------------------------------
|
||||
bench "edit-header" $ \docs -> do
|
||||
forM_ docs $ \DocumentPositions{..} -> do
|
||||
changeDoc doc [headerEdit]
|
||||
-- wait for a fresh build start
|
||||
waitForProgressStart
|
||||
-- wait for the build to be finished
|
||||
output "edit: waitForProgressDone"
|
||||
waitForProgressDone
|
||||
return True,
|
||||
---------------------------------------------------------------------------------------
|
||||
bench "hover after edit" $ \docs -> do
|
||||
forM_ docs $ \DocumentPositions{..} ->
|
||||
changeDoc doc [charEdit stringLiteralP]
|
||||
@ -276,23 +292,26 @@ configP =
|
||||
<*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))
|
||||
<*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")
|
||||
<*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")
|
||||
<*> ( Example "name"
|
||||
<$> (Right <$> packageP)
|
||||
<*> ( Example
|
||||
<$> exampleName
|
||||
<*> (ExampleHackage <$> packageP)
|
||||
<*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])
|
||||
<*> pure []
|
||||
<|>
|
||||
Example "name"
|
||||
<$> (Left <$> pathP)
|
||||
<*> some moduleOption
|
||||
<*> pure [])
|
||||
<|> Example
|
||||
<$> exampleName
|
||||
<*> pathOrScriptP
|
||||
<*> some moduleOption
|
||||
<*> pure [])
|
||||
<*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input")
|
||||
where
|
||||
moduleOption = strOption (long "example-module" <> metavar "PATH")
|
||||
exampleName = strOption (long "example-name" <> metavar "NAME")
|
||||
|
||||
packageP = ExamplePackage
|
||||
<$> strOption (long "example-package-name" <> value "Cabal")
|
||||
<*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))
|
||||
pathP = strOption (long "example-path")
|
||||
pathOrScriptP = ExamplePath <$> strOption (long "example-path")
|
||||
<|> ExampleScript <$> strOption (long "example-script") <*> many (strOption (long "example-script-args" <> help "arguments for the example generation script"))
|
||||
|
||||
versionP :: ReadM Version
|
||||
versionP = maybeReader $ extract . readP_to_S parseVersion
|
||||
@ -581,13 +600,25 @@ setup :: HasConfig => IO SetupResult
|
||||
setup = do
|
||||
-- when alreadyExists $ removeDirectoryRecursive examplesPath
|
||||
benchDir <- case exampleDetails(example ?config) of
|
||||
Left examplePath -> do
|
||||
ExamplePath examplePath -> do
|
||||
let hieYamlPath = examplePath </> "hie.yaml"
|
||||
alreadyExists <- doesFileExist hieYamlPath
|
||||
unless alreadyExists $
|
||||
cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)
|
||||
return examplePath
|
||||
Right ExamplePackage{..} -> do
|
||||
ExampleScript examplePath' scriptArgs -> do
|
||||
let exampleDir = examplesPath </> exampleName (example ?config)
|
||||
alreadySetup <- doesDirectoryExist exampleDir
|
||||
unless alreadySetup $ do
|
||||
createDirectoryIfMissing True exampleDir
|
||||
examplePath <- makeAbsolute examplePath'
|
||||
cmd_ (Cwd exampleDir) examplePath scriptArgs
|
||||
let hieYamlPath = exampleDir </> "hie.yaml"
|
||||
alreadyExists <- doesFileExist hieYamlPath
|
||||
unless alreadyExists $
|
||||
cmd_ (Cwd exampleDir) (FileStdout hieYamlPath) ("gen-hie"::String)
|
||||
return exampleDir
|
||||
ExampleHackage ExamplePackage{..} -> do
|
||||
let path = examplesPath </> package
|
||||
package = packageName <> "-" <> showVersion packageVersion
|
||||
hieYamlPath = path </> "hie.yaml"
|
||||
@ -633,8 +664,9 @@ setup = do
|
||||
whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
|
||||
|
||||
let cleanUp = case exampleDetails(example ?config) of
|
||||
Right _ -> removeDirectoryRecursive examplesPath
|
||||
Left _ -> return ()
|
||||
ExampleHackage _ -> removeDirectoryRecursive examplesPath
|
||||
ExampleScript _ _ -> removeDirectoryRecursive examplesPath
|
||||
ExamplePath _ -> return ()
|
||||
|
||||
runBenchmarks = runBenchmarksFun benchDir
|
||||
|
||||
|
@ -40,12 +40,20 @@ data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion ::
|
||||
|
||||
data Example = Example
|
||||
{ exampleName :: !String
|
||||
, exampleDetails :: Either FilePath ExamplePackage
|
||||
, exampleDetails :: ExampleDetails
|
||||
, exampleModules :: [FilePath]
|
||||
, exampleExtraArgs :: [String]}
|
||||
deriving (Eq, Generic, Show)
|
||||
deriving anyclass (Binary, Hashable, NFData)
|
||||
|
||||
data ExampleDetails
|
||||
= ExamplePath FilePath -- ^ directory where the package is located
|
||||
| ExampleHackage ExamplePackage -- ^ package from hackage
|
||||
| ExampleScript FilePath -- ^ location of the script we are running
|
||||
[String] -- ^ extra arguments for the script
|
||||
deriving (Eq, Generic, Show)
|
||||
deriving anyclass (Binary, Hashable, NFData)
|
||||
|
||||
instance FromJSON Example where
|
||||
parseJSON = withObject "example" $ \x -> do
|
||||
exampleName <- x .: "name"
|
||||
@ -55,24 +63,39 @@ instance FromJSON Example where
|
||||
path <- x .:? "path"
|
||||
case path of
|
||||
Just examplePath -> do
|
||||
let exampleDetails = Left examplePath
|
||||
script <- fromMaybe False <$> x.:? "script"
|
||||
args <- fromMaybe [] <$> x .:? "script-args"
|
||||
let exampleDetails
|
||||
| script = ExampleScript examplePath args
|
||||
| otherwise = ExamplePath examplePath
|
||||
return Example{..}
|
||||
Nothing -> do
|
||||
packageName <- x .: "package"
|
||||
packageVersion <- x .: "version"
|
||||
let exampleDetails = Right ExamplePackage{..}
|
||||
let exampleDetails = ExampleHackage ExamplePackage{..}
|
||||
return Example{..}
|
||||
|
||||
exampleToOptions :: Example -> [String] -> [String]
|
||||
exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =
|
||||
exampleToOptions Example{exampleDetails = ExampleHackage ExamplePackage{..}, ..} extraArgs =
|
||||
["--example-package-name", packageName
|
||||
,"--example-package-version", showVersion packageVersion
|
||||
,"--example-name", exampleName
|
||||
] ++
|
||||
["--example-module=" <> m | m <- exampleModules
|
||||
] ++
|
||||
["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
|
||||
exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs =
|
||||
exampleToOptions Example{exampleDetails = ExamplePath examplePath, ..} extraArgs =
|
||||
["--example-path", examplePath
|
||||
,"--example-name", exampleName
|
||||
] ++
|
||||
["--example-module=" <> m | m <- exampleModules
|
||||
] ++
|
||||
["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
|
||||
exampleToOptions Example{exampleDetails = ExampleScript examplePath exampleArgs, ..} extraArgs =
|
||||
["--example-script", examplePath
|
||||
,"--example-name", exampleName
|
||||
] ++
|
||||
["--example-script-args=" <> o | o <- exampleArgs
|
||||
] ++
|
||||
["--example-module=" <> m | m <- exampleModules
|
||||
] ++
|
||||
|
@ -137,6 +137,7 @@ import GHC (Anchor (anchor),
|
||||
import qualified GHC as G
|
||||
import GHC.Hs (LEpaComment)
|
||||
import qualified GHC.Types.Error as Error
|
||||
import Development.IDE.Import.DependencyInformation
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,5,0)
|
||||
@ -1052,25 +1053,19 @@ handleGenerationErrors' dflags source action =
|
||||
-- Add the current ModSummary to the graph, along with the
|
||||
-- HomeModInfo's of all direct dependencies (by induction hypothesis all
|
||||
-- transitive dependencies will be contained in envs)
|
||||
mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
|
||||
mergeEnvs env mg ms extraMods envs = do
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
|
||||
mergeEnvs env (ms, deps) extraMods envs = do
|
||||
let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
|
||||
ifr = InstalledFound (ms_location ms) im
|
||||
curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr
|
||||
-- Very important to force this as otherwise the hsc_mod_graph field is not
|
||||
-- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
|
||||
-- this new one, which in turn leads to the EPS referencing the HPT.
|
||||
module_graph_nodes =
|
||||
nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs)
|
||||
|
||||
newFinderCache <- concatFC curFinderCache (map hsc_FC envs)
|
||||
liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
|
||||
return $! loadModulesHome extraMods $
|
||||
let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in
|
||||
(hscUpdateHUG (const newHug) env){
|
||||
hsc_FC = newFinderCache,
|
||||
hsc_mod_graph = mkModuleGraph module_graph_nodes
|
||||
})
|
||||
hsc_mod_graph = mg
|
||||
}
|
||||
|
||||
where
|
||||
mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b
|
||||
@ -1096,30 +1091,16 @@ mergeEnvs env (ms, deps) extraMods envs = do
|
||||
pure $ FinderCache fcModules' fcFiles'
|
||||
|
||||
#else
|
||||
mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
|
||||
mergeEnvs env ms extraMods envs = do
|
||||
prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
|
||||
let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
|
||||
ifr = InstalledFound (ms_location ms) im
|
||||
-- Very important to force this as otherwise the hsc_mod_graph field is not
|
||||
-- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
|
||||
-- this new one, which in turn leads to the EPS referencing the HPT.
|
||||
module_graph_nodes =
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
-- We don't do any instantiation for backpack at this point of time, so it is OK to use
|
||||
-- 'extendModSummaryNoDeps'.
|
||||
-- This may have to change in the future.
|
||||
map extendModSummaryNoDeps $
|
||||
#endif
|
||||
nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs)
|
||||
|
||||
newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr
|
||||
liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
|
||||
return $! loadModulesHome extraMods $
|
||||
env{
|
||||
hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,
|
||||
hsc_FC = newFinderCache,
|
||||
hsc_mod_graph = mkModuleGraph module_graph_nodes
|
||||
})
|
||||
hsc_mod_graph = mg
|
||||
}
|
||||
|
||||
where
|
||||
mergeUDFM = plusUDFM_C combineModules
|
||||
@ -1534,8 +1515,8 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do
|
||||
let runtime_deps
|
||||
| not (mi_used_th iface) = emptyModuleEnv
|
||||
| otherwise = parseRuntimeDeps (md_anns details)
|
||||
-- Perform the fine grained recompilation check for TH
|
||||
maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps
|
||||
-- Peform the fine grained recompilation check for TH
|
||||
maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps
|
||||
case maybe_recomp of
|
||||
Just msg -> do_regenerate msg
|
||||
Nothing
|
||||
@ -1572,13 +1553,21 @@ parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns
|
||||
-- the runtime dependencies of the module, to check if any of them are out of date
|
||||
-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH
|
||||
-- See Note [Recompilation avoidance in the presence of TH]
|
||||
checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
|
||||
checkLinkableDependencies get_linkable_hashes graph runtime_deps = do
|
||||
let hs_files = mapM go (moduleEnvToList runtime_deps)
|
||||
go (mod, hash) = do
|
||||
ms <- mgLookupModule graph mod
|
||||
let hs = fromJust $ ml_hs_file $ ms_location ms
|
||||
pure (toNormalizedFilePath' hs, hash)
|
||||
checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
|
||||
checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)
|
||||
#else
|
||||
moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)
|
||||
#endif
|
||||
let go (mod, hash) = do
|
||||
ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod)
|
||||
case ifr of
|
||||
InstalledFound loc _ -> do
|
||||
hs <- ml_hs_file loc
|
||||
pure (toNormalizedFilePath' hs,hash)
|
||||
_ -> Nothing
|
||||
hs_files = mapM go (moduleEnvToList runtime_deps)
|
||||
case hs_files of
|
||||
Nothing -> error "invalid module graph"
|
||||
Just fs -> do
|
||||
|
@ -69,11 +69,6 @@ type instance RuleResult GetParsedModule = ParsedModule
|
||||
-- all comments included using Opt_KeepRawTokenStream
|
||||
type instance RuleResult GetParsedModuleWithComments = ParsedModule
|
||||
|
||||
-- | The dependency information produced by following the imports recursively.
|
||||
-- This rule will succeed even if there is an error, e.g., a module could not be located,
|
||||
-- a module could not be parsed or an import cycle.
|
||||
type instance RuleResult GetDependencyInformation = DependencyInformation
|
||||
|
||||
type instance RuleResult GetModuleGraph = DependencyInformation
|
||||
|
||||
data GetKnownTargets = GetKnownTargets
|
||||
@ -262,8 +257,8 @@ type instance RuleResult GhcSessionDeps = HscEnvEq
|
||||
-- | Resolve the imports in a module to the file path of a module in the same package
|
||||
type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)]
|
||||
|
||||
-- | This rule is used to report import cycles. It depends on GetDependencyInformation.
|
||||
-- We cannot report the cycles directly from GetDependencyInformation since
|
||||
-- | This rule is used to report import cycles. It depends on GetModuleGraph.
|
||||
-- We cannot report the cycles directly from GetModuleGraph since
|
||||
-- we can only report diagnostics for the current file.
|
||||
type instance RuleResult ReportImportCycles = ()
|
||||
|
||||
@ -401,11 +396,6 @@ data NeedsCompilation = NeedsCompilation
|
||||
instance Hashable NeedsCompilation
|
||||
instance NFData NeedsCompilation
|
||||
|
||||
data GetDependencyInformation = GetDependencyInformation
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetDependencyInformation
|
||||
instance NFData GetDependencyInformation
|
||||
|
||||
data GetModuleGraph = GetModuleGraph
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetModuleGraph
|
||||
|
@ -23,7 +23,6 @@ module Development.IDE.Core.Rules(
|
||||
defineEarlyCutOffNoFile,
|
||||
mainRule,
|
||||
RulesConfig(..),
|
||||
getDependencies,
|
||||
getParsedModule,
|
||||
getParsedModuleWithComments,
|
||||
getClientConfigAction,
|
||||
@ -34,7 +33,6 @@ module Development.IDE.Core.Rules(
|
||||
getParsedModuleRule,
|
||||
getParsedModuleWithCommentsRule,
|
||||
getLocatedImportsRule,
|
||||
getDependencyInformationRule,
|
||||
reportImportCyclesRule,
|
||||
typeCheckRule,
|
||||
getDocMapRule,
|
||||
@ -68,6 +66,7 @@ import Control.Concurrent.Async (concurrently)
|
||||
import Control.Concurrent.Strict
|
||||
import Control.DeepSeq
|
||||
import Control.Exception.Safe
|
||||
import Control.Exception (evaluate)
|
||||
import Control.Monad.Extra
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
@ -90,6 +89,7 @@ import Control.Concurrent.STM.TVar
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import qualified Data.IntMap.Strict as IntMap
|
||||
import Data.List
|
||||
import Data.List.Extra (nubOrdOn)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Proxy
|
||||
@ -160,6 +160,7 @@ import qualified Development.IDE.Types.Shake as Shake
|
||||
import Development.IDE.GHC.CoreFile
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
import Control.Monad.IO.Unlift
|
||||
import qualified Data.IntMap as IM
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
import GHC.Unit.Module.Graph
|
||||
import GHC.Unit.Env
|
||||
@ -167,6 +168,8 @@ import GHC.Unit.Env
|
||||
#if MIN_VERSION_ghc(9,5,0)
|
||||
import GHC.Unit.Home.ModInfo
|
||||
#endif
|
||||
import GHC (mgModSummaries)
|
||||
import GHC.Fingerprint
|
||||
|
||||
data Log
|
||||
= LogShake Shake.Log
|
||||
@ -212,12 +215,6 @@ toIdeResult = either (, Nothing) (([],) . Just)
|
||||
------------------------------------------------------------
|
||||
-- Exposed API
|
||||
------------------------------------------------------------
|
||||
-- | Get all transitive file dependencies of a given module.
|
||||
-- Does not include the file itself.
|
||||
getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
|
||||
getDependencies file =
|
||||
fmap transitiveModuleDeps . (`transitiveDeps` file) <$> use_ GetDependencyInformation file
|
||||
|
||||
getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
|
||||
getSourceFileSource nfp = do
|
||||
(_, msource) <- getFileContents nfp
|
||||
@ -422,17 +419,17 @@ type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Act
|
||||
execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
|
||||
execRawDepM act =
|
||||
execStateT act
|
||||
( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty
|
||||
( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
|
||||
, IntMap.empty
|
||||
)
|
||||
|
||||
-- | Given a target file path, construct the raw dependency results by following
|
||||
-- imports recursively.
|
||||
rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
|
||||
rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap)
|
||||
rawDependencyInformation fs = do
|
||||
(rdi, ss) <- execRawDepM (goPlural fs)
|
||||
let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
|
||||
return (rdi { rawBootMap = bm })
|
||||
return (rdi, bm)
|
||||
where
|
||||
goPlural ff = do
|
||||
mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff
|
||||
@ -451,9 +448,9 @@ rawDependencyInformation fs = do
|
||||
fId <- getFreshFid al
|
||||
-- Record this module and its location
|
||||
whenJust msum $ \ms ->
|
||||
modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId)
|
||||
(ShowableModuleName (moduleName $ ms_mod ms))
|
||||
(rawModuleNameMap rd)})
|
||||
modifyRawDepInfo (\rd -> rd { rawModuleMap = IntMap.insert (getFilePathId fId)
|
||||
(ShowableModule $ ms_mod ms)
|
||||
(rawModuleMap rd)})
|
||||
-- Adding an edge to the bootmap so we can make sure to
|
||||
-- insert boot nodes before the real files.
|
||||
addBootMap al fId
|
||||
@ -525,27 +522,24 @@ rawDependencyInformation fs = do
|
||||
dropBootSuffix :: FilePath -> FilePath
|
||||
dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src
|
||||
|
||||
getDependencyInformationRule :: Recorder (WithPriority Log) -> Rules ()
|
||||
getDependencyInformationRule recorder =
|
||||
define (cmapWithPrio LogShake recorder) $ \GetDependencyInformation file -> do
|
||||
rawDepInfo <- rawDependencyInformation [file]
|
||||
pure ([], Just $ processDependencyInformation rawDepInfo)
|
||||
|
||||
reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules ()
|
||||
reportImportCyclesRule recorder =
|
||||
define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do
|
||||
DependencyInformation{..} <- use_ GetDependencyInformation file
|
||||
let fileId = pathToId depPathIdMap file
|
||||
case IntMap.lookup (getFilePathId fileId) depErrorNodes of
|
||||
Nothing -> pure []
|
||||
Just errs -> do
|
||||
let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)
|
||||
-- Convert cycles of files into cycles of module names
|
||||
forM cycles $ \(imp, files) -> do
|
||||
modNames <- forM files $ \fileId -> do
|
||||
let file = idToPath depPathIdMap fileId
|
||||
getModuleName file
|
||||
pure $ toDiag imp $ sort modNames
|
||||
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do
|
||||
DependencyInformation{..} <- useNoFile_ GetModuleGraph
|
||||
case pathToId depPathIdMap file of
|
||||
-- The header of the file does not parse, so it can't be part of any import cycles.
|
||||
Nothing -> pure []
|
||||
Just fileId ->
|
||||
case IntMap.lookup (getFilePathId fileId) depErrorNodes of
|
||||
Nothing -> pure []
|
||||
Just errs -> do
|
||||
let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)
|
||||
-- Convert cycles of files into cycles of module names
|
||||
forM cycles $ \(imp, files) -> do
|
||||
modNames <- forM files $ \fileId -> do
|
||||
let file = idToPath depPathIdMap fileId
|
||||
getModuleName file
|
||||
pure $ toDiag imp $ sort modNames
|
||||
where cycleErrorInFile f (PartOfCycle imp fs)
|
||||
| f `elem` fs = Just (imp, fs)
|
||||
cycleErrorInFile _ _ = Nothing
|
||||
@ -681,10 +675,37 @@ knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorde
|
||||
pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs)
|
||||
|
||||
getModuleGraphRule :: Recorder (WithPriority Log) -> Rules ()
|
||||
getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do
|
||||
getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do
|
||||
fs <- toKnownFiles <$> useNoFile_ GetKnownTargets
|
||||
rawDepInfo <- rawDependencyInformation (HashSet.toList fs)
|
||||
pure $ processDependencyInformation rawDepInfo
|
||||
dependencyInfoForFiles (HashSet.toList fs)
|
||||
|
||||
dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation)
|
||||
dependencyInfoForFiles fs = do
|
||||
(rawDepInfo, bm) <- rawDependencyInformation fs
|
||||
let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo
|
||||
msrs <- uses GetModSummaryWithoutTimestamps all_fs
|
||||
let mss = map (fmap msrModSummary) msrs
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids
|
||||
nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss
|
||||
mns = catMaybes $ zipWith go mss deps
|
||||
go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms
|
||||
where this_dep_ids = mapMaybe snd xs
|
||||
this_dep_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids
|
||||
go (Just ms) _ = Just $ ModuleNode [] ms
|
||||
go _ _ = Nothing
|
||||
mg = mkModuleGraph mns
|
||||
#else
|
||||
let mg = mkModuleGraph $
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
-- We don't do any instantiation for backpack at this point of time, so it is OK to use
|
||||
-- 'extendModSummaryNoDeps'.
|
||||
-- This may have to change in the future.
|
||||
map extendModSummaryNoDeps $
|
||||
#endif
|
||||
(catMaybes mss)
|
||||
#endif
|
||||
pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg)
|
||||
|
||||
-- This is factored out so it can be directly called from the GetModIface
|
||||
-- rule. Directly calling this rule means that on the initial load we can
|
||||
@ -754,11 +775,11 @@ loadGhcSession recorder ghcSessionDepsConfig = do
|
||||
ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file
|
||||
|
||||
newtype GhcSessionDepsConfig = GhcSessionDepsConfig
|
||||
{ checkForImportCycles :: Bool
|
||||
{ fullModuleGraph :: Bool
|
||||
}
|
||||
instance Default GhcSessionDepsConfig where
|
||||
def = GhcSessionDepsConfig
|
||||
{ checkForImportCycles = True
|
||||
{ fullModuleGraph = True
|
||||
}
|
||||
|
||||
-- | Note [GhcSessionDeps]
|
||||
@ -777,7 +798,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
|
||||
case mbdeps of
|
||||
Nothing -> return Nothing
|
||||
Just deps -> do
|
||||
when checkForImportCycles $ void $ uses_ ReportImportCycles deps
|
||||
when fullModuleGraph $ void $ use_ ReportImportCycles file
|
||||
ms <- msrModSummary <$> if fullModSummary
|
||||
then use_ GetModSummary file
|
||||
else use_ GetModSummaryWithoutTimestamps file
|
||||
@ -785,19 +806,33 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
|
||||
depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
|
||||
ifaces <- uses_ GetModIface deps
|
||||
let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces
|
||||
mg <- do
|
||||
if fullModuleGraph
|
||||
then depModuleGraph <$> useNoFile_ GetModuleGraph
|
||||
else do
|
||||
let mgs = map hsc_mod_graph depSessions
|
||||
#if MIN_VERSION_ghc(9,3,0)
|
||||
-- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph
|
||||
-- also points to all the direct descendants of the current module. To get the keys for the descendants
|
||||
-- we must get their `ModSummary`s
|
||||
!final_deps <- do
|
||||
dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps
|
||||
-- Don't want to retain references to the entire ModSummary when just the key will do
|
||||
return $!! map (NodeKey_Module . msKey) dep_mss
|
||||
let moduleNode = (ms, final_deps)
|
||||
-- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph
|
||||
-- also points to all the direct descendants of the current module. To get the keys for the descendants
|
||||
-- we must get their `ModSummary`s
|
||||
!final_deps <- do
|
||||
dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps
|
||||
return $!! map (NodeKey_Module . msKey) dep_mss
|
||||
let module_graph_nodes =
|
||||
nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs)
|
||||
#else
|
||||
let moduleNode = ms
|
||||
let module_graph_nodes =
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
-- We don't do any instantiation for backpack at this point of time, so it is OK to use
|
||||
-- 'extendModSummaryNoDeps'.
|
||||
-- This may have to change in the future.
|
||||
map extendModSummaryNoDeps $
|
||||
#endif
|
||||
session' <- liftIO $ mergeEnvs hsc moduleNode inLoadOrder depSessions
|
||||
nubOrdOn ms_mod (ms : concatMap mgModSummaries mgs)
|
||||
#endif
|
||||
liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes
|
||||
return $ mkModuleGraph module_graph_nodes
|
||||
session' <- liftIO $ mergeEnvs hsc mg ms inLoadOrder depSessions
|
||||
|
||||
-- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new
|
||||
-- ExportsMap when it is called. We only need to create the ExportsMap once per
|
||||
@ -1201,8 +1236,16 @@ newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (Mod
|
||||
instance IsIdeGlobal CompiledLinkables
|
||||
|
||||
data RulesConfig = RulesConfig
|
||||
{ -- | Disable import cycle checking for improved performance in large codebases
|
||||
checkForImportCycles :: Bool
|
||||
{ -- | Share the computation for the entire module graph
|
||||
-- We usually compute the full module graph for the project
|
||||
-- and share it for all files.
|
||||
-- However, in large projects it might not be desirable to wait
|
||||
-- for computing the entire module graph before starting to
|
||||
-- typecheck a particular file.
|
||||
-- Disabling this drastically decreases sharing and is likely to
|
||||
-- increase memory usage if you have multiple files open
|
||||
-- Disabling this also disables checking for import cycles
|
||||
fullModuleGraph :: Bool
|
||||
-- | Disable TH for improved performance in large codebases
|
||||
, enableTemplateHaskell :: Bool
|
||||
-- | Warning to show when TH is not supported by the current HLS binary
|
||||
@ -1236,11 +1279,10 @@ mainRule recorder RulesConfig{..} = do
|
||||
getParsedModuleRule recorder
|
||||
getParsedModuleWithCommentsRule recorder
|
||||
getLocatedImportsRule recorder
|
||||
getDependencyInformationRule recorder
|
||||
reportImportCyclesRule recorder
|
||||
typeCheckRule recorder
|
||||
getDocMapRule recorder
|
||||
loadGhcSession recorder def{checkForImportCycles}
|
||||
loadGhcSession recorder def{fullModuleGraph}
|
||||
getModIfaceFromDiskRule recorder
|
||||
getModIfaceFromDiskAndIndexRule recorder
|
||||
getModIfaceRule recorder
|
||||
|
@ -40,6 +40,7 @@ import Data.String (IsString (fromString))
|
||||
import Data.Text (unpack)
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import GHC.ByteCode.Types
|
||||
import GHC (ModuleGraph)
|
||||
#else
|
||||
import ByteCodeTypes
|
||||
#endif
|
||||
@ -216,6 +217,9 @@ instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getU
|
||||
|
||||
instance Show HomeModInfo where show = show . mi_module . hm_iface
|
||||
|
||||
instance Show ModuleGraph where show _ = "ModuleGraph {..}"
|
||||
instance NFData ModuleGraph where rnf = rwhnf
|
||||
|
||||
instance NFData HomeModInfo where
|
||||
rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link
|
||||
|
||||
|
@ -10,8 +10,9 @@ module Development.IDE.Import.DependencyInformation
|
||||
, TransitiveDependencies(..)
|
||||
, FilePathId(..)
|
||||
, NamedModuleDep(..)
|
||||
, ShowableModuleName(..)
|
||||
, PathIdMap
|
||||
, ShowableModule(..)
|
||||
, ShowableModuleEnv(..)
|
||||
, PathIdMap (..)
|
||||
, emptyPathIdMap
|
||||
, getPathId
|
||||
, lookupPathToId
|
||||
@ -23,7 +24,7 @@ module Development.IDE.Import.DependencyInformation
|
||||
, transitiveDeps
|
||||
, transitiveReverseDependencies
|
||||
, immediateReverseDependencies
|
||||
|
||||
, lookupModuleFile
|
||||
, BootIdMap
|
||||
, insertBootId
|
||||
) where
|
||||
@ -53,6 +54,7 @@ import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
import GHC
|
||||
import Development.IDE.GHC.Compat
|
||||
|
||||
-- | The imports for a given module.
|
||||
newtype ModuleImports = ModuleImports
|
||||
@ -103,8 +105,8 @@ getPathId path m@PathIdMap{..} =
|
||||
insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
|
||||
insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
|
||||
|
||||
pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
|
||||
pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
|
||||
pathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
|
||||
pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.!? path
|
||||
|
||||
lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
|
||||
lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap
|
||||
@ -128,15 +130,14 @@ data RawDependencyInformation = RawDependencyInformation
|
||||
-- corresponding hs file. It is used when topologically sorting as we
|
||||
-- need to add edges between .hs-boot and .hs so that the .hs files
|
||||
-- appear later in the sort.
|
||||
, rawBootMap :: !BootIdMap
|
||||
, rawModuleNameMap :: !(FilePathIdMap ShowableModuleName)
|
||||
, rawModuleMap :: !(FilePathIdMap ShowableModule)
|
||||
} deriving Show
|
||||
|
||||
data DependencyInformation =
|
||||
DependencyInformation
|
||||
{ depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))
|
||||
-- ^ Nodes that cannot be processed correctly.
|
||||
, depModuleNames :: !(FilePathIdMap ShowableModuleName)
|
||||
, depModules :: !(FilePathIdMap ShowableModule)
|
||||
, depModuleDeps :: !(FilePathIdMap FilePathIdSet)
|
||||
-- ^ For a non-error node, this contains the set of module immediate dependencies
|
||||
-- in the same package.
|
||||
@ -146,13 +147,24 @@ data DependencyInformation =
|
||||
-- ^ Map from FilePath to FilePathId
|
||||
, depBootMap :: !BootIdMap
|
||||
-- ^ Map from hs-boot file to the corresponding hs file
|
||||
, depModuleFiles :: !(ShowableModuleEnv FilePathId)
|
||||
-- ^ Map from Module to the corresponding non-boot hs file
|
||||
, depModuleGraph :: !ModuleGraph
|
||||
} deriving (Show, Generic)
|
||||
|
||||
newtype ShowableModuleName =
|
||||
ShowableModuleName {showableModuleName :: ModuleName}
|
||||
newtype ShowableModule =
|
||||
ShowableModule {showableModule :: Module}
|
||||
deriving NFData
|
||||
|
||||
instance Show ShowableModuleName where show = moduleNameString . showableModuleName
|
||||
newtype ShowableModuleEnv a =
|
||||
ShowableModuleEnv {showableModuleEnv :: ModuleEnv a}
|
||||
|
||||
instance Show a => Show (ShowableModuleEnv a) where
|
||||
show (ShowableModuleEnv x) = show (moduleEnvToList x)
|
||||
instance NFData a => NFData (ShowableModuleEnv a) where
|
||||
rnf = rwhnf
|
||||
|
||||
instance Show ShowableModule where show = moduleNameString . moduleName . showableModule
|
||||
|
||||
reachableModules :: DependencyInformation -> [NormalizedFilePath]
|
||||
reachableModules DependencyInformation{..} =
|
||||
@ -215,15 +227,17 @@ instance Semigroup NodeResult where
|
||||
SuccessNode _ <> ErrorNode errs = ErrorNode errs
|
||||
SuccessNode a <> SuccessNode _ = SuccessNode a
|
||||
|
||||
processDependencyInformation :: RawDependencyInformation -> DependencyInformation
|
||||
processDependencyInformation RawDependencyInformation{..} =
|
||||
processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> DependencyInformation
|
||||
processDependencyInformation RawDependencyInformation{..} rawBootMap mg =
|
||||
DependencyInformation
|
||||
{ depErrorNodes = IntMap.fromList errorNodes
|
||||
, depModuleDeps = moduleDeps
|
||||
, depReverseModuleDeps = reverseModuleDeps
|
||||
, depModuleNames = rawModuleNameMap
|
||||
, depModules = rawModuleMap
|
||||
, depPathIdMap = rawPathIdMap
|
||||
, depBootMap = rawBootMap
|
||||
, depModuleFiles = ShowableModuleEnv reverseModuleMap
|
||||
, depModuleGraph = mg
|
||||
}
|
||||
where resultGraph = buildResultGraph rawImports
|
||||
(errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
|
||||
@ -240,6 +254,7 @@ processDependencyInformation RawDependencyInformation{..} =
|
||||
foldr (\(p, cs) res ->
|
||||
let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))
|
||||
in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges
|
||||
reverseModuleMap = mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModuleMap
|
||||
|
||||
|
||||
-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
|
||||
@ -328,7 +343,7 @@ immediateReverseDependencies file DependencyInformation{..} = do
|
||||
-- | returns all transitive dependencies in topological order.
|
||||
transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
|
||||
transitiveDeps DependencyInformation{..} file = do
|
||||
let !fileId = pathToId depPathIdMap file
|
||||
!fileId <- pathToId depPathIdMap file
|
||||
reachableVs <-
|
||||
-- Delete the starting node
|
||||
IntSet.delete (getFilePathId fileId) .
|
||||
@ -351,6 +366,10 @@ transitiveDeps DependencyInformation{..} file = do
|
||||
|
||||
vs = topSort g
|
||||
|
||||
lookupModuleFile :: Module -> DependencyInformation -> Maybe NormalizedFilePath
|
||||
lookupModuleFile mod DependencyInformation{..}
|
||||
= idToPath depPathIdMap <$> lookupModuleEnv (showableModuleEnv depModuleFiles) mod
|
||||
|
||||
newtype TransitiveDependencies = TransitiveDependencies
|
||||
{ transitiveModuleDeps :: [NormalizedFilePath]
|
||||
-- ^ Transitive module dependencies in topological order.
|
||||
|
@ -55,6 +55,7 @@ library
|
||||
build-depends:
|
||||
, aeson
|
||||
, base >=4.12 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, data-default
|
||||
, deepseq
|
||||
|
@ -25,7 +25,7 @@ module Ide.Plugin.Eval.CodeLens (
|
||||
|
||||
import Control.Applicative (Alternative ((<|>)))
|
||||
import Control.Arrow (second, (>>>))
|
||||
import Control.Exception (try)
|
||||
import Control.Exception (try, bracket_)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Lens (_1, _3, ix, (%~),
|
||||
(<&>), (^.))
|
||||
@ -53,6 +53,8 @@ import Development.IDE.Core.RuleTypes (LinkableResult (l
|
||||
NeedsCompilation (NeedsCompilation),
|
||||
TypeCheck (..),
|
||||
tmrTypechecked)
|
||||
import Development.IDE.Core.Shake (useWithStale_, useNoFile_,
|
||||
use_, uses_)
|
||||
import Development.IDE.GHC.Compat hiding (typeKind,
|
||||
unitState)
|
||||
import Development.IDE.GHC.Compat.Util (GhcException,
|
||||
@ -60,7 +62,7 @@ import Development.IDE.GHC.Compat.Util (GhcException,
|
||||
import Development.IDE.GHC.Util (evalGhcEnv,
|
||||
modifyDynFlags,
|
||||
printOutputable)
|
||||
import Development.IDE.Import.DependencyInformation (reachableModules)
|
||||
import Development.IDE.Import.DependencyInformation (transitiveDeps, transitiveModuleDeps)
|
||||
import Development.IDE.Types.Location (toNormalizedFilePath',
|
||||
uriToFilePath')
|
||||
import GHC (ClsInst,
|
||||
@ -80,7 +82,7 @@ import GHC (ClsInst,
|
||||
typeKind)
|
||||
|
||||
|
||||
import Development.IDE.Core.RuleTypes (GetDependencyInformation (GetDependencyInformation),
|
||||
import Development.IDE.Core.RuleTypes (GetModuleGraph (GetModuleGraph),
|
||||
GetLinkable (GetLinkable),
|
||||
GetModSummary (GetModSummary),
|
||||
GhcSessionDeps (GhcSessionDeps),
|
||||
@ -118,7 +120,7 @@ import Ide.Plugin.Eval.GHC (addImport,
|
||||
showDynFlags)
|
||||
import Ide.Plugin.Eval.Parse.Comments (commentsToSections)
|
||||
import Ide.Plugin.Eval.Parse.Option (parseSetFlags)
|
||||
import Ide.Plugin.Eval.Rules (queueForEvaluation)
|
||||
import Ide.Plugin.Eval.Rules (queueForEvaluation, unqueueForEvaluation)
|
||||
import Ide.Plugin.Eval.Types
|
||||
import Ide.Plugin.Eval.Util (gStrictTry,
|
||||
isLiterate,
|
||||
@ -215,12 +217,12 @@ runEvalCmd plId st EvalParams{..} =
|
||||
mdlText <- moduleText _uri
|
||||
|
||||
-- enable codegen for the module which we need to evaluate.
|
||||
liftIO $ queueForEvaluation st nfp
|
||||
liftIO $ setSomethingModified VFSUnmodified st [toKey NeedsCompilation nfp] "Eval"
|
||||
-- Setup a session with linkables for all dependencies and GHCi specific options
|
||||
final_hscEnv <- initialiseSessionForEval
|
||||
(needsQuickCheck tests)
|
||||
st nfp
|
||||
final_hscEnv <- liftIO $ bracket_
|
||||
(do queueForEvaluation st nfp
|
||||
setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")
|
||||
(do unqueueForEvaluation st nfp
|
||||
setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")
|
||||
(initialiseSessionForEval (needsQuickCheck tests) st nfp)
|
||||
|
||||
evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId
|
||||
|
||||
@ -244,21 +246,21 @@ runEvalCmd plId st EvalParams{..} =
|
||||
-- also be loaded into the environment.
|
||||
--
|
||||
-- The interactive context and interactive dynamic flags are also set appropiately.
|
||||
initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> ExceptT PluginError (LspM Config) HscEnv
|
||||
initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv
|
||||
initialiseSessionForEval needs_quickcheck st nfp = do
|
||||
(ms, env1) <- runActionE "runEvalCmd" st $ do
|
||||
(ms, env1) <- runAction "runEvalCmd" st $ do
|
||||
|
||||
ms <- msrModSummary <$> useE GetModSummary nfp
|
||||
deps_hsc <- hscEnv <$> useE GhcSessionDeps nfp
|
||||
ms <- msrModSummary <$> use_ GetModSummary nfp
|
||||
deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp
|
||||
|
||||
linkables_needed <- reachableModules <$> useE GetDependencyInformation nfp
|
||||
linkables <- usesE GetLinkable linkables_needed
|
||||
linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp
|
||||
linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed)
|
||||
-- We unset the global rdr env in mi_globals when we generate interfaces
|
||||
-- See Note [Clearing mi_globals after generating an iface]
|
||||
-- However, the eval plugin (setContext specifically) requires the rdr_env
|
||||
-- for the current module - so get it from the Typechecked Module and add
|
||||
-- it back to the iface for the current module.
|
||||
rdr_env <- tcg_rdr_env . tmrTypechecked <$> useE TypeCheck nfp
|
||||
rdr_env <- tcg_rdr_env . tmrTypechecked <$> use_ TypeCheck nfp
|
||||
let linkable_hsc = loadModulesHome (map (addRdrEnv . linkableHomeMod) linkables) deps_hsc
|
||||
addRdrEnv hmi
|
||||
| iface <- hm_iface hmi
|
||||
|
@ -5,7 +5,7 @@
|
||||
|
||||
-- To avoid warning "Pattern match has inaccessible right hand side"
|
||||
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
|
||||
module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log) where
|
||||
module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, unqueueForEvaluation, Log) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Data.HashSet (HashSet)
|
||||
@ -24,7 +24,8 @@ import Development.IDE (GetModSummaryWithoutTimes
|
||||
fromNormalizedFilePath,
|
||||
msrModSummary,
|
||||
realSrcSpanToRange,
|
||||
useWithStale_)
|
||||
useWithStale_,
|
||||
use_)
|
||||
import Development.IDE.Core.PositionMapping (toCurrentRange)
|
||||
import Development.IDE.Core.Rules (computeLinkableTypeForDynFlags,
|
||||
needsCompilationRule)
|
||||
@ -46,6 +47,8 @@ import GHC.Parser.Annotation
|
||||
#endif
|
||||
import Ide.Plugin.Eval.Types
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
newtype Log = LogShake Shake.Log deriving Show
|
||||
|
||||
instance Pretty Log where
|
||||
@ -56,6 +59,7 @@ rules :: Recorder (WithPriority Log) -> Rules ()
|
||||
rules recorder = do
|
||||
evalParsedModuleRule recorder
|
||||
redefinedNeedsCompilation recorder
|
||||
isEvaluatingRule recorder
|
||||
addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty)
|
||||
|
||||
newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))
|
||||
@ -64,7 +68,13 @@ instance IsIdeGlobal EvaluatingVar
|
||||
queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
|
||||
queueForEvaluation ide nfp = do
|
||||
EvaluatingVar var <- getIdeGlobalState ide
|
||||
modifyIORef var (Set.insert nfp)
|
||||
atomicModifyIORef' var (\fs -> (Set.insert nfp fs, ()))
|
||||
|
||||
unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
|
||||
unqueueForEvaluation ide nfp = do
|
||||
EvaluatingVar var <- getIdeGlobalState ide
|
||||
-- remove the module from the Evaluating state, so that next time it won't evaluate to True
|
||||
atomicModifyIORef' var $ \fs -> (Set.delete nfp fs, ())
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
#if MIN_VERSION_ghc(9,5,0)
|
||||
@ -133,6 +143,13 @@ evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorde
|
||||
fingerPrint = fromString $ if nullComments comments then "" else "1"
|
||||
return (Just fingerPrint, Just comments)
|
||||
|
||||
isEvaluatingRule :: Recorder (WithPriority Log) -> Rules ()
|
||||
isEvaluatingRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsEvaluating f -> do
|
||||
alwaysRerun
|
||||
EvaluatingVar var <- getIdeGlobalAction
|
||||
b <- liftIO $ (f `Set.member`) <$> readIORef var
|
||||
return (Just (if b then BS.singleton 1 else BS.empty), Just b)
|
||||
|
||||
-- Redefine the NeedsCompilation rule to set the linkable type to Just _
|
||||
-- whenever the module is being evaluated
|
||||
-- This will ensure that the modules are loaded with linkables
|
||||
@ -140,11 +157,7 @@ evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorde
|
||||
-- leading to much better performance of the evaluate code lens
|
||||
redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules ()
|
||||
redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do
|
||||
alwaysRerun
|
||||
|
||||
EvaluatingVar var <- getIdeGlobalAction
|
||||
isEvaluating <- liftIO $ (f `elem`) <$> readIORef var
|
||||
|
||||
isEvaluating <- use_ IsEvaluating f
|
||||
|
||||
if not isEvaluating then needsCompilationRule f else do
|
||||
ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps f
|
||||
@ -152,7 +165,4 @@ redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake re
|
||||
linkableType = computeLinkableTypeForDynFlags df'
|
||||
fp = encodeLinkableType $ Just linkableType
|
||||
|
||||
-- remove the module from the Evaluating state
|
||||
liftIO $ modifyIORef var (Set.delete f)
|
||||
|
||||
pure (Just fp, Just (Just linkableType))
|
||||
|
@ -28,8 +28,9 @@ module Ide.Plugin.Eval.Types
|
||||
unLoc,
|
||||
Txt,
|
||||
EvalParams(..),
|
||||
GetEvalComments(..)
|
||||
,nullComments)
|
||||
GetEvalComments(..),
|
||||
IsEvaluating(..),
|
||||
nullComments)
|
||||
where
|
||||
|
||||
import Control.DeepSeq (deepseq)
|
||||
@ -96,6 +97,13 @@ data Test
|
||||
| Property {testline :: Txt, testOutput :: [Txt], testRange :: Range}
|
||||
deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)
|
||||
|
||||
data IsEvaluating = IsEvaluating
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable IsEvaluating
|
||||
instance NFData IsEvaluating
|
||||
|
||||
type instance RuleResult IsEvaluating = Bool
|
||||
|
||||
data GetEvalComments = GetEvalComments
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetEvalComments
|
||||
|
Loading…
Reference in New Issue
Block a user