haskell/ghcide
1
1
Fork 0
mirror of https://github.com/haskell/ghcide.git synced 2024-09-11 05:36:09 +03:00
Code Issues Projects Releases Wiki Activity

Finer dependencies for GhcSessionFun (#643)

Browse Source 
* Cache the results of loadSession until the components change

* Track the cradle dependencies

* hlint

* Add cradle to watched files test

* Add comment on sessionVersion field
This commit is contained in:
Pepe Iborra 2020-06-22 17:06:50 +01:00 committed by GitHub
parent ba4bdb2def
commit 7080db99e3
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
4 changed files with 89 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
exe/Main.hs
View File

@ -18,6 +18,7 @@ import Control.Concurrent.Extra
import Control.Exception.Safe
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Bifunctor (Bifunctor(second))
import Data.Default
import Data.Either
import Data.Foldable (for_)
@ -122,7 +123,8 @@ main = do
runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg -> do
t <- t
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
let options = (defaultIdeOptions $ loadSessionShake dir)
sessionLoader <- loadSession dir
let options = (defaultIdeOptions sessionLoader)
{ optReportProgress = clientSupportsProgress caps
, optShakeProfiling = argsShakeProfiling
, optTesting = IdeTesting argsTesting
@ -154,7 +156,8 @@ main = do
vfs <- makeVFSHandle
debouncer <- newAsyncDebouncer
let dummyWithProg _ _ f = f (const (pure ()))
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger minBound) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
sessionLoader <- loadSession dir
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger minBound) debouncer (defaultIdeOptions sessionLoader) vfs
putStrLn "\nStep 4/4: Type checking the files"
setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
@ -223,40 +226,43 @@ targetToFile _ (TargetFile f _) = do
setNameCache :: IORef NameCache -> HscEnv -> HscEnv
setNameCache nc hsc = hsc { hsc_NC = nc }
loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))
loadSessionShake fp = do
se <- getShakeExtras
IdeOptions{optTesting = IdeTesting ideTesting} <- getIdeOptions
res <- liftIO $ loadSession ideTesting se fp
return (fmap liftIO res)
-- | This is the key function which implements multi-component support. All
-- components mapping to the same hie.yaml file are mapped to the same
-- HscEnv which is updated as new components are discovered.
loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))
loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress} dir = do
loadSession :: FilePath -> IO (Action IdeGhcSession)
loadSession dir = do
-- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
hscEnvs <- newVar Map.empty :: IO (Var HieMap)
-- Mapping from a Filepath to HscEnv
fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)
-- Version of the mappings above
version <- newVar 0
let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)
let invalidateShakeCache = do
modifyVar_ version (return . succ)
-- This caches the mapping from Mod.hs -> hie.yaml
cradleLoc <- liftIO $ memoIO $ \v -> do
res <- findCradle v
-- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
-- try and normalise that
-- e.g. see https://github.com/digital-asset/ghcide/issues/126
res' <- traverse IO.makeAbsolute res
return $ normalise <$> res'
libdir <- getLibdir
installationCheck <- ghcVersionChecker libdir
dummyAs <- async $ return (error "Uninitialised")
runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))
case installationCheck of
InstallationNotFound{..} ->
error $ "GHC installation not found in libdir: " <> libdir
InstallationMismatch{..} ->
return $ \fp -> return ([renderPackageSetupException compileTime fp GhcVersionMismatch{..}], Nothing)
InstallationChecked compileTime ghcLibCheck -> do
-- This caches the mapping from Mod.hs -> hie.yaml
cradleLoc <- memoIO $ \v -> do
res <- findCradle v
-- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
-- try and normalise that
-- e.g. see https://github.com/digital-asset/ghcide/issues/126
res' <- traverse IO.makeAbsolute res
return $ normalise <$> res'
return $ returnWithVersion $ \fp -> return (([renderPackageSetupException compileTime fp GhcVersionMismatch{..}], Nothing),[])
InstallationChecked compileTime ghcLibCheck -> return $ do
ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress} <- getShakeExtras
IdeOptions{optTesting = IdeTesting optTesting} <- getIdeOptions
-- Create a new HscEnv from a hieYaml root and a set of options
-- If the hieYaml file already has an HscEnv, the new component is
@ -269,7 +275,8 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
hscEnv <- emptyHscEnv
(df, targets) <- evalGhcEnv hscEnv $
setOptions opts (hsc_dflags hscEnv)
dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)
let deps = componentDependencies opts ++ maybeToList hieYaml
dep_info <- getDependencyInfo deps
-- Now lookup to see whether we are combining with an existing HscEnv
-- or making a new one. The lookup returns the HscEnv and a list of
-- information about other components loaded into the HscEnv
@ -329,7 +336,8 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
-- existing packages
pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq)
let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq,[FilePath])
session (hieYaml, cfp, opts) = do
(hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)
-- Make a map from unit-id to DynFlags, this is used when trying to
@ -350,11 +358,12 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
-- Invalidate all the existing GhcSession build nodes by restarting the Shake session
invalidateShakeCache
restartShakeSession [kick]
return (fst res)
return (second Map.keys res)
let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)
let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
consultCradle hieYaml cfp = do
when optTesting $ eventer $ notifyCradleLoaded cfp
logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)
@ -379,10 +388,11 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
let res = (map (renderCradleError ncfp) err, Nothing)
modifyVar_ fileToFlags $ \var -> do
pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
return res
return (res,[])
-- This caches the mapping from hie.yaml + Mod.hs -> [String]
let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq)
-- Returns the Ghc session and the cradle dependencies
let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath])
sessionOpts (hieYaml, file) = do
v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
cfp <- canonicalizePath file
@ -397,30 +407,26 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
-- Keep the same name cache
modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )
consultCradle hieYaml cfp
else return opts
else return (opts, Map.keys old_di)
Nothing -> consultCradle hieYaml cfp
dummyAs <- async $ return (error "Uninitialised")
runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq)))
-- The main function which gets options for a file. We only want one of these running
-- at a time. Therefore the IORef contains the currently running cradle, if we try
-- to get some more options then we wait for the currently running action to finish
-- before attempting to do so.
let getOptions :: FilePath -> IO (IdeResult HscEnvEq)
let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
getOptions file = do
hieYaml <- cradleLoc file
sessionOpts (hieYaml, file) `catch` \e ->
return ([renderPackageSetupException compileTime file e], Nothing)
return (([renderPackageSetupException compileTime file e], Nothing),[])
return $ \file -> do
join $ mask_ $ modifyVar runningCradle $ \as -> do
returnWithVersion $ \file -> do
liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do
-- If the cradle is not finished, then wait for it to finish.
void $ wait as
as <- async $ getOptions file
return (as, wait as)
-- | Create a mapping from FilePaths to HscEnvEqs
newComponentCache
:: Logger

48
src/Development/IDE/Core/Rules.hs
View File

@ -12,12 +12,14 @@
--
module Development.IDE.Core.Rules(
IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
Priority(..), GhcSessionIO(..), GhcSessionFun(..),
Priority(..), GhcSessionIO(..),
priorityTypeCheck,
priorityGenerateCore,
priorityFilesOfInterest,
runAction, useE, useNoFileE, usesE,
toIdeResult, defineNoFile,
toIdeResult,
defineNoFile,
defineEarlyCutOffNoFile,
mainRule,
getAtPoint,
getDefinition,
@ -103,6 +105,11 @@ defineNoFile f = define $ \k file -> do
if file == emptyFilePath then do res <- f k; return ([], Just res) else
fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (ByteString, v)) -> Rules ()
defineEarlyCutOffNoFile f = defineEarlyCutoff $ \k file -> do
if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, ([], Just res)) else
fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
------------------------------------------------------------
-- Exposed API
@ -535,33 +542,36 @@ generateByteCodeRule =
-- A local rule type to get caching. We want to use newCache, but it has
-- thread killed exception issues, so we lift it to a full rule.
-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
type instance RuleResult GhcSessionIO = GhcSessionFun
type instance RuleResult GhcSessionIO = IdeGhcSession
data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
instance Hashable GhcSessionIO
instance NFData GhcSessionIO
instance Binary GhcSessionIO
newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))
instance Show GhcSessionFun where show _ = "GhcSessionFun"
instance NFData GhcSessionFun where rnf !_ = ()
loadGhcSession :: Rules ()
loadGhcSession = do
defineNoFile $ \GhcSessionIO -> do
opts <- getIdeOptions
GhcSessionFun <$> optGhcSession opts
-- This function should always be rerun because it consults a cache to
-- see what HscEnv needs to be used for the file, which can change.
-- However, it should also cut-off early if it's the same HscEnv as
-- last time
defineEarlyCutoff $ \GhcSession file -> do
GhcSessionFun fun <- useNoFile_ GhcSessionIO
-- This function should always be rerun because it tracks changes
-- to the version of the collection of HscEnv's.
defineEarlyCutOffNoFile $ \GhcSessionIO -> do
alwaysRerun
val <- fun $ fromNormalizedFilePath file
opts <- getIdeOptions
res <- optGhcSession opts
let fingerprint = hash (sessionVersion res)
return (BS.pack (show fingerprint), res)
defineEarlyCutoff $ \GhcSession file -> do
IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO
(val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file
-- add the deps to the Shake graph
let addDependency fp = do
let nfp = toNormalizedFilePath' fp
itExists <- getFileExists nfp
when itExists $ void $ use_ GetModificationTime nfp
mapM_ addDependency deps
-- TODO: What was this doing before?
opts <- getIdeOptions
let cutoffHash =
case optShakeFiles opts of

16
src/Development/IDE/Types/Options.hs
View File

@ -14,6 +14,7 @@ module Development.IDE.Types.Options
, IdePkgLocationOptions(..)
, defaultIdeOptions
, IdeResult
, IdeGhcSession(..)
) where
import Development.Shake
@ -23,12 +24,23 @@ import GhcPlugins as GHC hiding (fst3, (<>))
import qualified Language.Haskell.LSP.Types.Capabilities as LSP
import qualified Data.Text as T
import Development.IDE.Types.Diagnostics
import Control.DeepSeq (NFData(..))
data IdeGhcSession = IdeGhcSession
{ loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
-- ^ Returns the Ghc session and the cradle dependencies
, sessionVersion :: !Int
-- ^ Used as Shake key, versions must be unique and not reused
}
instance Show IdeGhcSession where show _ = "IdeGhcSession"
instance NFData IdeGhcSession where rnf !_ = ()
data IdeOptions = IdeOptions
{ optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
-- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
-- and a list of errors, along with a new parse tree.
, optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))
, optGhcSession :: Action IdeGhcSession
-- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
-- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.
-- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
@ -80,7 +92,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
clientSupportsProgress caps = IdeReportProgress $ Just True ==
(LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))
defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions
defaultIdeOptions :: Action IdeGhcSession -> IdeOptions
defaultIdeOptions session = IdeOptions
{optPreprocessor = IdePreprocessedSource [] []
,optGhcSession = session

6
test/exe/Main.hs
View File

@ -494,11 +494,12 @@ watchedFilesTests = testGroup "watched files"
watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
-- Expect 4 subscriptions (A does not get any because it's VFS):
-- - /path-to-workspace/hie.yaml
-- - /path-to-workspace/WatchedFilesMissingModule.hs
-- - /path-to-workspace/WatchedFilesMissingModule.lhs
-- - /path-to-workspace/src/WatchedFilesMissingModule.hs
-- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
liftIO $ length watchedFileRegs @?= 4
liftIO $ length watchedFileRegs @?= 5
, testSession' "non workspace file" $ \sessionDir -> do
liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
@ -506,9 +507,10 @@ watchedFilesTests = testGroup "watched files"
watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
-- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
-- - /path-to-workspace/hie.yaml
-- - /path-to-workspace/WatchedFilesMissingModule.hs
-- - /path-to-workspace/WatchedFilesMissingModule.lhs
liftIO $ length watchedFileRegs @?= 2
liftIO $ length watchedFileRegs @?= 3
-- TODO add a test for didChangeWorkspaceFolder
]