diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -6,14 +6,11 @@ import Arguments (Arguments (..), getArguments) -import Control.Monad.Extra (unless) import Control.Monad.IO.Class (liftIO) import Data.Default (def) import Data.Function ((&)) import Data.Version (showVersion) import Development.GitRev (gitHash) -import Development.IDE (action) -import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.Tracing (withTelemetryRecorder) @@ -21,7 +18,7 @@ import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import Development.IDE.Types.Options -import Ide.Logger (LoggingColumn (DataColumn, PriorityColumn), +import Ide.Logger (LoggingColumn (..), Pretty (pretty), Priority (Debug, Error, Info), WithPriority (WithPriority, priority), @@ -73,7 +70,7 @@ -- stderr recorder just for plugin cli commands pluginCliRecorder <- cmapWithPrio pretty - <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) + <$> makeDefaultStderrRecorder (Just [ThreadIdColumn, PriorityColumn, DataColumn]) let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder)) -- WARNING: If you write to stdout before runLanguageServer @@ -115,21 +112,16 @@ let arguments = if argsTesting - then IDEMain.testing (cmapWithPrio LogIDEMain recorder) hlsPlugins - else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsPlugins + then IDEMain.testing (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins + else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDEMain.argsProjectRoot = Just argsCwd + { IDEMain.argsProjectRoot = argsCwd , IDEMain.argCommand = argsCommand , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin] , IDEMain.argsRules = do - -- install the main and ghcide-plugin rules mainRule (cmapWithPrio LogRules recorder) def - -- install the kick action, which triggers a typecheck on every - -- Shake database restart, i.e. on every user edit. - unless argsDisableKick $ - action kick , IDEMain.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i) diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 2.8.0.0 +version: 2.9.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -14,7 +14,7 @@ https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC ==9.8.2 || ==9.6.4 || ==9.4.8 || ==9.2.8 +tested-with: GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8 || ==9.2.8 extra-source-files: CHANGELOG.md README.md @@ -35,6 +35,7 @@ common warnings ghc-options: + -Werror=incomplete-patterns -Wall -Wincomplete-uni-patterns -Wunused-packages @@ -43,6 +44,7 @@ -fno-ignore-asserts library + import: warnings default-language: GHC2021 build-depends: , aeson @@ -60,7 +62,7 @@ , deepseq , dependent-map , dependent-sum - , Diff ^>=0.4.0 + , Diff ^>=0.5 , directory , dlist , enummapset @@ -72,8 +74,6 @@ , ghc >=9.2 , ghc-boot , ghc-boot-th - , ghc-check >=0.5.0.8 - , ghc-paths , ghc-trace-events , Glob , haddock-library >=1.8 && <1.12 @@ -81,13 +81,13 @@ , hie-bios ^>=0.14.0 , hie-compat ^>=0.3.0.0 , hiedb ^>= 0.6.0.0 - , hls-graph == 2.8.0.0 - , hls-plugin-api == 2.8.0.0 + , hls-graph == 2.9.0.0 + , hls-plugin-api == 2.9.0.0 , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , list-t - , lsp ^>=2.4.0.0 - , lsp-types ^>=2.1.0.0 + , lsp ^>=2.7 + , lsp-types ^>=2.3 , mtl , opentelemetry >=0.6.1 , optparse-applicative @@ -96,7 +96,6 @@ , prettyprinter-ansi-terminal , random , regex-tdfa >=1.3.1.0 - , row-types , safe-exceptions , sorted-list , sqlite-simple @@ -147,6 +146,7 @@ Development.IDE.Core.Shake Development.IDE.Core.Tracing Development.IDE.Core.UseStale + Development.IDE.Core.WorkerThread Development.IDE.GHC.Compat Development.IDE.GHC.Compat.Core Development.IDE.GHC.Compat.CmdLine @@ -203,7 +203,6 @@ Development.IDE.Core.FileExists Development.IDE.GHC.CPP Development.IDE.GHC.Warnings - Development.IDE.Session.VersionCheck Development.IDE.Types.Action if flag(pedantic) @@ -264,36 +263,3 @@ if !flag(executable) buildable: False - -library ghcide-test-utils - import: warnings - visibility: public - default-language: GHC2021 - - hs-source-dirs: test/src test/cabal - exposed-modules: - Development.IDE.Test - Development.IDE.Test.Runfiles - Development.IDE.Test.Diagnostic - - build-depends: - aeson, - base > 4.9 && < 5, - containers, - data-default, - directory, - extra, - filepath, - ghcide, - lsp-types, - hls-plugin-api, - lens, - lsp-test ^>= 0.17, - tasty-hunit >= 0.10, - text, - - default-extensions: - LambdaCase - OverloadedStrings - RecordWildCards - ViewPatterns diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -7,133 +7,132 @@ module Development.IDE.Session (SessionLoadingOptions(..) ,CacheDirs(..) - ,loadSession ,loadSessionWithOptions ,setInitialDynFlags ,getHieDbLoc - ,runWithDb ,retryOnSqliteBusy ,retryOnException ,Log(..) + ,runWithDb ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses -- the real GHC library and the types are incompatible. Furthermore, when -- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios! -import Control.Concurrent.Async import Control.Concurrent.Strict -import Control.Exception.Safe as Safe +import Control.Exception.Safe as Safe import Control.Monad -import Control.Monad.Extra as Extra +import Control.Monad.Extra as Extra import Control.Monad.IO.Class -import qualified Crypto.Hash.SHA1 as H -import Data.Aeson hiding (Error) +import qualified Crypto.Hash.SHA1 as H +import Data.Aeson hiding (Error) import Data.Bifunctor -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as B import Data.Default import Data.Either.Extra import Data.Function -import Data.Hashable hiding (hash) -import qualified Data.HashMap.Strict as HM +import Data.Hashable hiding (hash) +import qualified Data.HashMap.Strict as HM import Data.IORef import Data.List -import Data.List.Extra as L -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map +import Data.List.Extra as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map import Data.Maybe import Data.Proxy -import qualified Data.Text as T +import qualified Data.Text as T import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (Log, Priority, - knownTargets, withHieDb) -import qualified Development.IDE.GHC.Compat as Compat -import Development.IDE.GHC.Compat.Core hiding (Target, - TargetFile, TargetModule, - Var, Warning, getOptions) -import qualified Development.IDE.GHC.Compat.Core as GHC -import Development.IDE.GHC.Compat.Env hiding (Logger) -import Development.IDE.GHC.Compat.Units (UnitId) -import qualified Development.IDE.GHC.Compat.Util as Compat +import Development.IDE.Core.Shake hiding (Log, knownTargets, + withHieDb) +import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.CmdLine +import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, + TargetModule, Var, + Warning, getOptions) +import qualified Development.IDE.GHC.Compat.Core as GHC +import Development.IDE.GHC.Compat.Env hiding (Logger) +import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util -import Development.IDE.Graph (Action) -import Development.IDE.Session.VersionCheck +import Development.IDE.Graph (Action) +import qualified Development.IDE.Session.Implicit as GhcIde import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, - newHscEnvEqPreserveImportPaths) +import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, + newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location import Development.IDE.Types.Options -import GHC.Check -import qualified HIE.Bios as HieBios -import qualified HIE.Bios.Cradle as HieBios -import HIE.Bios.Environment hiding (getCacheDir) -import HIE.Bios.Types hiding (Log) -import qualified HIE.Bios.Types as HieBios -import Ide.Logger (Pretty (pretty), - Priority (Debug, Error, Info, Warning), - Recorder, WithPriority, - cmapWithPrio, logWith, - nest, - toCologActionWithPrio, - vcat, viaShow, (<+>)) -import Ide.Types (SessionLoadingPreferenceConfig (..), - sessionLoading) +import GHC.ResponseFile +import qualified HIE.Bios as HieBios +import HIE.Bios.Environment hiding (getCacheDir) +import HIE.Bios.Types hiding (Log) +import qualified HIE.Bios.Types as HieBios +import Ide.Logger (Pretty (pretty), + Priority (Debug, Error, Info, Warning), + Recorder, WithPriority, + cmapWithPrio, logWith, + nest, + toCologActionWithPrio, + vcat, viaShow, (<+>)) +import Ide.Types (SessionLoadingPreferenceConfig (..), + sessionLoading) import Language.LSP.Protocol.Message import Language.LSP.Server import System.Directory -import qualified System.Directory.Extra as IO +import qualified System.Directory.Extra as IO import System.FilePath import System.Info -import Control.Applicative (Alternative ((<|>))) +import Control.Applicative (Alternative ((<|>))) import Data.Void -import Control.Concurrent.STM.Stats (atomically, modifyTVar', - readTVar, writeTVar) +import Control.Concurrent.STM.Stats (atomically, modifyTVar', + readTVar, writeTVar) import Control.Concurrent.STM.TQueue import Control.DeepSeq -import Control.Exception (evaluate) -import Control.Monad.IO.Unlift (MonadUnliftIO) -import Data.Foldable (for_) -import Data.HashMap.Strict (HashMap) -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set +import Control.Exception (evaluate) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Cont (ContT (ContT, runContT)) +import Data.Foldable (for_) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set import Database.SQLite.Simple -import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.Session.Diagnostics (renderCradleError) -import Development.IDE.Types.Shake (WithHieDb) +import Development.IDE.Core.Tracing (withTrace) +import Development.IDE.Core.WorkerThread (awaitRunInThread, + withWorkerQueue) +import Development.IDE.Session.Diagnostics (renderCradleError) +import Development.IDE.Types.Shake (WithHieDb, + WithHieDbShield (..), + toNoFileKey) import HieDb.Create import HieDb.Types import HieDb.Utils -import qualified System.Random as Random -import System.Random (RandomGen) - -import qualified Development.IDE.Session.Implicit as GhcIde - -import Development.IDE.GHC.Compat.CmdLine +import Ide.PluginUtils (toAbsolute) +import qualified System.Random as Random +import System.Random (RandomGen) +import Text.ParserCombinators.ReadP (readP_to_S) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if MIN_VERSION_ghc(9,3,0) -import qualified Data.Set as OS +import qualified Data.Set as OS +import qualified Development.IDE.GHC.Compat.Util as Compat +import GHC.Data.Graph.Directed import GHC.Data.Bag -import GHC.Driver.Env (hsc_all_home_unit_ids) +import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types -import GHC.Driver.Make (checkHomeUnitsClosed) -import GHC.Types.Error (errMsgDiagnostic, - singleMessage) +import GHC.Types.Error (errMsgDiagnostic, + singleMessage) import GHC.Unit.State #endif -import GHC.Data.Graph.Directed -import GHC.ResponseFile - data Log = LogSettingInitialDynFlags | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) @@ -148,7 +147,7 @@ | LogDLLLoadError !String | LogCradlePath !FilePath | LogCradleNotFound !FilePath - | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath)) + | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String)) | LogCradle !(Cradle Void) | LogNoneCradleFound FilePath | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) @@ -379,8 +378,10 @@ -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial -- by a worker thread using a dedicated database connection. -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy -runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () -runWithDb recorder fp k = do +-- +-- Also see Note [Serializing runs in separate thread] +runWithDb :: Recorder (WithPriority Log) -> FilePath -> ContT () IO (WithHieDbShield, IndexQueue) +runWithDb recorder fp = ContT $ \k -> do -- use non-deterministic seed because maybe multiple HLS start at same time -- and send bursts of requests rng <- Random.newStdGen @@ -398,18 +399,15 @@ withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb withWriteDbRetryable initConn - chan <- newTQueueIO - withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do - withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan) + -- Clear the index of any files that might have been deleted since the last run + _ <- withWriteDbRetryable deleteMissingRealFiles + _ <- withWriteDbRetryable garbageCollectTypeNames + + runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan -> + withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan)) where - writerThread :: WithHieDb -> IndexQueue -> IO () - writerThread withHieDbRetryable chan = do - -- Clear the index of any files that might have been deleted since the last run - _ <- withHieDbRetryable deleteMissingRealFiles - _ <- withHieDbRetryable garbageCollectTypeNames - forever $ do - l <- atomically $ readTQueue chan + writer withHieDbRetryable l = do -- TODO: probably should let exceptions be caught/logged/handled by top level handler l withHieDbRetryable `Safe.catch` \e@SQLError{} -> do @@ -439,11 +437,10 @@ -- 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 :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) -loadSession recorder = loadSessionWithOptions recorder def -loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) +loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do + let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef [] -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) @@ -464,20 +461,16 @@ -- 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/haskell/ghcide/issues/126 - res' <- traverse makeAbsolute res + let res' = toAbsolutePath <$> res return $ normalise <$> res' - dummyAs <- async $ return (error "Uninitialised") - runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) - return $ do clientConfig <- getClientConfigAction extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras - let invalidateShakeCache :: IO () - invalidateShakeCache = do + let invalidateShakeCache = do void $ modifyVar' version succ - join $ atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath] + return $ toNoFileKey GhcSessionIO IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject @@ -510,16 +503,15 @@ TargetModule _ -> do found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations return [(targetTarget, Set.fromList found)] - hasUpdate <- join $ atomically $ do + hasUpdate <- atomically $ do known <- readTVar knownTargetsVar - let known' = flip mapHashed known $ \k -> - HM.unionWith (<>) k $ HM.fromList knownTargets + let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets) hasUpdate = if known /= known' then Just (unhashed known') else Nothing writeTVar knownTargetsVar known' - logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath] - return (logDirtyKeys >> pure hasUpdate) + pure hasUpdate for_ hasUpdate $ \x -> - logWith recorder Debug $ LogKnownFilesUpdated x + logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) + return $ toNoFileKey GetKnownTargets -- Create a new HscEnv from a hieYaml root and a set of options let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) @@ -527,7 +519,7 @@ packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) + newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv @@ -594,7 +586,7 @@ -- HscEnv but set the active component accordingly hscEnv <- emptyHscEnv ideNc _libDir let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv - all_target_details <- new_cache old_deps new_deps + all_target_details <- new_cache old_deps new_deps rootDir this_dep_info <- getDependencyInfo $ maybeToList hieYaml let (all_targets, this_flags_map, this_options) @@ -612,18 +604,14 @@ , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" ] - void $ modifyVar' fileToFlags $ - Map.insert hieYaml this_flags_map - void $ modifyVar' filesMap $ - flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) - - void $ extendKnownTargets all_targets - - -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - invalidateShakeCache - + void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map + void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) -- The VFS doesn't change on cradle edits, re-use the old one. - restartShakeSession VFSUnmodified "new component" [] + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + keys2 <- invalidateShakeCache + restartShakeSession VFSUnmodified "new component" [] $ do + keys1 <- extendKnownTargets all_targets + return [keys1, keys2] -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -642,25 +630,20 @@ let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do - lfpLog <- flip makeRelative cfp <$> getCurrentDirectory + let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog - when (isNothing hieYaml) $ logWith recorder Warning $ LogCradleNotFound lfpLog - - cradle <- loadCradle recorder hieYaml dir - -- TODO: Why are we repeating the same command we have on line 646? - lfp <- flip makeRelative cfp <$> getCurrentDirectory - + cradle <- loadCradle recorder hieYaml rootDir when optTesting $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) - <> " (for " <> T.pack lfp <> ")" + <> " (for " <> T.pack lfpLog <> ")" eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do - addTag "file" lfp + addTag "file" lfpLog old_files <- readIORef cradle_files res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files addTag "result" (show res) @@ -670,16 +653,15 @@ case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. - Right (opts, libDir) -> do - installationCheck <- ghcVersionChecker libDir - case installationCheck of - InstallationNotFound{..} -> - error $ "GHC installation not found in libdir: " <> libdir - InstallationMismatch{..} -> - return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) - InstallationChecked _compileTime _ghcLibCheck -> do - atomicModifyIORef' cradle_files (\xs -> (cfp:xs,())) - session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + Right (opts, libDir, version) -> do + let compileTime = fullCompilerVersion + case reverse $ readP_to_S parseVersion version of + [] -> error $ "GHC version could not be parsed: " <> version + ((runTime, _):_) + | compileTime == runTime -> do + atomicModifyIORef' cradle_files (\xs -> (cfp:xs,())) + session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do dep_info <- getDependencyInfo (maybeToList hieYaml) @@ -723,7 +705,7 @@ modifyVar_ hscEnvs (const (return Map.empty)) v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags - cfp <- makeAbsolute file + let cfp = toAbsolutePath file case HM.lookup (toNormalizedFilePath' cfp) v of Just (opts, old_di) -> do deps_ok <- checkDependencyInfo old_di @@ -745,25 +727,21 @@ -- before attempting to do so. let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) getOptions file = do - ncfp <- toNormalizedFilePath' <$> makeAbsolute file + let ncfp = toNormalizedFilePath' (toAbsolutePath file) cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - opts <- join $ mask_ $ modifyVar runningCradle $ \as -> do - -- If the cradle is not finished, then wait for it to finish. - void $ wait as - asyncRes <- async $ getOptions file - return (asyncRes, wait asyncRes) - pure opts + -- see Note [Serializing runs in separate thread] + awaitRunInThread que $ getOptions file -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath] - -> IO (Either [CradleError] (ComponentOptions, FilePath)) + -> IO (Either [CradleError] (ComponentOptions, FilePath, String)) cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do -- let noneCradleFoundMessage :: FilePath -> T.Text -- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" @@ -774,9 +752,10 @@ CradleSuccess r -> do -- Now get the GHC lib dir libDirRes <- getRuntimeGhcLibDir cradle - case libDirRes of + versionRes <- getRuntimeGhcVersion cradle + case liftA2 (,) libDirRes versionRes of -- This is the successful path - CradleSuccess libDir -> pure (Right (r, libDir)) + (CradleSuccess (libDir, version)) -> pure (Right (r, libDir, version)) CradleFail err -> return (Left [err]) CradleNone -> do logWith recorder Info $ LogNoneCradleFound file @@ -832,11 +811,11 @@ , i <- is , boot <- ["", "-boot"] ] - locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps + let locs = fmap toNormalizedFilePath' fps return [TargetDetails (TargetModule modName) env dep locs] -- For a 'TargetFile' we consider all the possible module names fromTargetId _ _ (GHC.TargetFile f _) env deps = do - nf <- toNormalizedFilePath' <$> makeAbsolute f + let nf = toNormalizedFilePath' f let other | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") @@ -925,8 +904,9 @@ -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components + -> FilePath -- ^ root dir, see Note [Root Directory] -> IO [ [TargetDetails] ] -newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do +newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) -- When we have multiple components with the same uid, -- prefer the new one over the old. @@ -971,7 +951,7 @@ forM (Map.elems cis) $ \ci -> do let df = componentDynFlags ci - let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath + let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths (newHscEnvEq dir) cradlePath thisEnv <- do #if MIN_VERSION_ghc(9,3,0) -- In GHC 9.4 we have multi component support, and we have initialised all the units @@ -1181,8 +1161,13 @@ putCmdLineState (unit_str : units) -- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> m (NonEmpty (DynFlags, [GHC.Target])) -setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do +setOptions :: GhcMonad m + => NormalizedFilePath + -> ComponentOptions + -> DynFlags + -> FilePath -- ^ root dir, see Note [Root Directory] + -> m (NonEmpty (DynFlags, [GHC.Target])) +setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) case NE.nonEmpty units of Just us -> initMulti us @@ -1205,7 +1190,7 @@ -- -- If we don't end up with a target for the current file in the end, then -- we will report it as an error for that file - abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp) + let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) let special_target = Compat.mkSimpleTarget df abs_fp pure $ (df, special_target : targets) :| [] where @@ -1300,7 +1285,6 @@ { compileTime :: !Version , runTime :: !Version } - | PackageCheckFailed !NotCompatibleReason deriving (Eq, Show, Typeable) instance Exception PackageSetupException @@ -1320,21 +1304,9 @@ ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project." ] showPackageSetupException PackageSetupException{..} = unwords - [ "ghcide compiled by GHC", showVersion compilerVersion + [ "ghcide compiled by GHC", showVersion fullCompilerVersion , "failed to load packages:", message <> "." , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."] -showPackageSetupException (PackageCheckFailed PackageVersionMismatch{..}) = unwords - ["ghcide compiled with package " - , packageName <> "-" <> showVersion compileTime - ,"but project uses package" - , packageName <> "-" <> showVersion runTime - ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." - ] -showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords - ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi - ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi - ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." - ] renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) renderPackageSetupException fp e = diff --git a/session-loader/Development/IDE/Session/VersionCheck.hs b/session-loader/Development/IDE/Session/VersionCheck.hs deleted file mode 100644 --- a/session-loader/Development/IDE/Session/VersionCheck.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | This module exists to circumvent a compile time exception on Windows with --- Stack and GHC 8.10.1. It's just been pulled out from Development.IDE.Session. --- See https://github.com/haskell/ghcide/pull/697 -module Development.IDE.Session.VersionCheck (ghcVersionChecker) where - -import GHC.Check --- Only use this for checking against the compile time GHC libDir! --- Use getRuntimeGhcLibDir from hie-bios instead for everything else --- otherwise binaries will not be distributable since paths will be baked into them -import qualified GHC.Paths - -ghcVersionChecker :: GhcVersionChecker -ghcVersionChecker = $$(makeGhcVersionChecker (return GHC.Paths.libdir)) diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -31,7 +31,7 @@ defineNoDiagnostics, getClientConfig, getPluginConfigAction, - ideLogger, + ideLogger, rootDir, runIdeAction, shakeExtras, use, useNoFile, diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -1,8 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} -- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API. -- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values. @@ -38,17 +38,14 @@ , shareUsages ) where -import Prelude hiding (mod) -import Control.Monad.IO.Class import Control.Concurrent.Extra import Control.Concurrent.STM.Stats hiding (orElse) -import Control.DeepSeq (NFData (..), force, - rnf) +import Control.DeepSeq (NFData (..), force, rnf) import Control.Exception (evaluate) import Control.Exception.Safe -import Control.Lens hiding (List, (<.>), pre) -import Control.Monad.Except +import Control.Lens hiding (List, pre, (<.>)) import Control.Monad.Extra +import Control.Monad.IO.Class import Control.Monad.Trans.Except import qualified Control.Monad.Trans.State.Strict as S import Data.Aeson (toJSON) @@ -65,8 +62,8 @@ import Data.IORef import Data.List.Extra import qualified Data.Map.Strict as Map -import Data.Proxy (Proxy(Proxy)) import Data.Maybe +import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T import Data.Time (UTCTime (..)) import Data.Tuple.Extra (dupe) @@ -79,7 +76,7 @@ import Development.IDE.Core.Tracing (withTrace) import Development.IDE.GHC.Compat hiding (loadInterface, parseHeader, parseModule, - tcRnModule, writeHieFile) + tcRnModule, writeHieFile, assert) import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat as GHC import qualified Development.IDE.GHC.Compat.Util as Util @@ -97,33 +94,26 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized import HieDb hiding (withHieDb) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types (DiagnosticTag (..)) +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Language.LSP.Protocol.Types (DiagnosticTag (..)) -import qualified Language.LSP.Protocol.Types as LSP -import qualified Language.LSP.Protocol.Message as LSP +import Prelude hiding (mod) import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -import GHC.Tc.Gen.Splice - - - import qualified GHC as G - -#if !MIN_VERSION_ghc(9,3,0) -import GHC (ModuleGraph) -#endif - +import GHC.Tc.Gen.Splice import GHC.Types.ForeignStubs import GHC.Types.HpcInfo import GHC.Types.TypeEnv +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if !MIN_VERSION_ghc(9,3,0) import Data.Map (Map) -import GHC (GhcException (..)) +import GHC.Unit.Module.Graph (ModuleGraph) import Unsafe.Coerce #endif @@ -132,8 +122,8 @@ #endif #if MIN_VERSION_ghc(9,5,0) -import GHC.Driver.Config.CoreToStg.Prep import GHC.Core.Lint.Interactive +import GHC.Driver.Config.CoreToStg.Prep #endif #if MIN_VERSION_ghc(9,7,0) @@ -482,11 +472,7 @@ tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv - iface' <- mkIfaceTc hsc_env_tmp sf details ms -#if MIN_VERSION_ghc(9,5,0) - Nothing -#endif - tcGblEnv + iface' <- mkIfaceTc hsc_env_tmp sf details ms Nothing tcGblEnv let iface = iface' { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface] pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing @@ -1266,7 +1252,7 @@ PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags POk pst rdr_module -> do - let (warns, errs) = renderMessages $ getPsMessages pst dflags + let (warns, errs) = renderMessages $ getPsMessages pst -- Just because we got a `POk`, it doesn't mean there -- weren't errors! To clarify, the GHC parser @@ -1301,7 +1287,7 @@ POk pst rdr_module -> let hpm_annotations = mkApiAnns pst - psMessages = getPsMessages pst dflags + psMessages = getPsMessages pst in do let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module @@ -1310,7 +1296,7 @@ throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns - (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages + (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms hpm_annotations parsed psMessages let (warns, errors) = renderMessages msgs -- Just because we got a `POk`, it doesn't mean there diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -28,6 +28,7 @@ import Development.IDE.Graph import Development.IDE.Types.Location import Development.IDE.Types.Options +import Development.IDE.Types.Shake (toKey) import qualified Focus import Ide.Logger (Pretty (pretty), Recorder, WithPriority, @@ -105,12 +106,12 @@ FileExistsMapVar v <- getIdeGlobalAction return v --- | Modify the global store of file exists. -modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () +-- | Modify the global store of file exists and return the keys that need to be marked as dirty +modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key] modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update - join $ mask_ $ atomicallyNamed "modifyFileExists" $ do + mask_ $ atomicallyNamed "modifyFileExists" $ do forM_ changes $ \(f,c) -> case fromChange c of Just c' -> STM.focus (Focus.insert c') f var @@ -119,10 +120,10 @@ -- flush previous values let (fileModifChanges, fileExistChanges) = partition ((== FileChangeType_Changed) . snd) changes - mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges - io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges - io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges - return (io1 <> io2) + keys0 <- concat <$> mapM (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges + let keys1 = map (toKey GetFileExists . fst) fileExistChanges + let keys2 = map (toKey GetModificationTime . fst) fileModifChanges + return (keys0 <> keys1 <> keys2) fromChange :: FileChangeType -> Maybe Bool fromChange FileChangeType_Created = Just True diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -21,8 +21,7 @@ Log(..) ) where -import Control.Concurrent.STM.Stats (STM, atomically, - modifyTVar') +import Control.Concurrent.STM.Stats (STM, atomically) import Control.Concurrent.STM.TQueue (writeTQueue) import Control.Exception import Control.Monad.Extra @@ -32,10 +31,8 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HashMap import Data.IORef -import Data.List (foldl') import qualified Data.Text as T import qualified Data.Text as Text -import qualified Data.Text.Utf16.Rope as Rope import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.FileUtils @@ -49,6 +46,7 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options +import Development.IDE.Types.Shake (toKey) import HieDb.Create (deleteMissingRealFiles) import Ide.Logger (Pretty (pretty), Priority (Info), @@ -148,24 +146,24 @@ isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"] -- | Reset the GetModificationTime state of interface files -resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM () +resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM [Key] resetInterfaceStore state f = do deleteValue state GetModificationTime f -- | Reset the GetModificationTime state of watched files -- Assumes the list does not include any FOIs -resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO () +resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO [Key] resetFileStore ideState changes = mask $ \_ -> do -- we record FOIs document versions in all the stored values -- so NEVER reset FOIs to avoid losing their versions -- FOI filtering is done by the caller (LSP Notification handler) - forM_ changes $ \(nfp, c) -> do - case c of - LSP.FileChangeType_Changed - -- already checked elsewhere | not $ HM.member nfp fois - -> atomically $ - deleteValue (shakeExtras ideState) GetModificationTime nfp - _ -> pure () + fmap concat <$> + forM changes $ \(nfp, c) -> do + case c of + LSP.FileChangeType_Changed + -- already checked elsewhere | not $ HM.member nfp fois + -> atomically $ deleteValue (shakeExtras ideState) GetModificationTime nfp + _ -> pure [] modificationTime :: FileVersion -> Maybe UTCTime @@ -215,16 +213,18 @@ -> IdeState -> Bool -- ^ Was the file saved? -> NormalizedFilePath + -> IO [Key] -> IO () -setFileModified recorder vfs state saved nfp = do +setFileModified recorder vfs state saved nfp actionBefore = do ideOptions <- getIdeOptionsIO $ shakeExtras state doCheckParents <- optCheckParents ideOptions let checkParents = case doCheckParents of AlwaysCheck -> True CheckOnSave -> saved _ -> False - join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do + keys<-actionBefore + return (toKey GetModificationTime nfp:keys) when checkParents $ typecheckParents recorder state nfp @@ -244,14 +244,11 @@ -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that -- independently tracks which files are modified. -setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO () -setSomethingModified vfs state keys reason = do +setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModified vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted - atomically $ do - writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> - foldl' (flip insertKeySet) x keys - void $ restartShakeSession (shakeExtras state) vfs reason [] + atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -24,7 +24,6 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Proxy -import qualified Data.Text as T import Development.IDE.Graph import Control.Concurrent.STM.Stats (atomically, @@ -40,6 +39,7 @@ import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options (IdeTesting (..)) +import Development.IDE.Types.Shake (toKey) import GHC.TypeLits (KnownSymbol) import Ide.Logger (Pretty (pretty), Priority (..), @@ -103,24 +103,26 @@ OfInterestVar var <- getIdeGlobalAction liftIO $ readVar var -addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO () +addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] addFileOfInterest state f v = do OfInterestVar var <- getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do let (prev, new) = HashMap.alterF (, Just v) f dict pure (new, (prev, new)) - when (prev /= Just v) $ do - join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + if prev /= Just v + then do logWith (ideLogger state) Debug $ LogSetFilesOfInterest (HashMap.toList files) + return [toKey IsFileOfInterest f] + else return [] -deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO () +deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest state f = do OfInterestVar var <- getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f - join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logWith (ideLogger state) Debug $ LogSetFilesOfInterest (HashMap.toList files) + return [toKey IsFileOfInterest f] scheduleGarbageCollection :: IdeState -> IO () scheduleGarbageCollection state = do GarbageCollectVar var <- getIdeGlobalState state diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedLabels #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.Core.PositionMapping @@ -25,13 +24,14 @@ ) where import Control.DeepSeq +import Control.Lens ((^.)) import Control.Monad import Data.Algorithm.Diff import Data.Bifunctor import Data.List -import Data.Row import qualified Data.Text as T import qualified Data.Vector.Unboxed as V +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types (Position (Position), Range (Range), TextDocumentContentChangeEvent (TextDocumentContentChangeEvent), @@ -131,8 +131,8 @@ -- that was what was done with lsp* 1.6 packages applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta applyChange PositionDelta{..} (TextDocumentContentChangeEvent (InL x)) = PositionDelta - { toDelta = toCurrent (x .! #range) (x .! #text) <=< toDelta - , fromDelta = fromDelta <=< fromCurrent (x .! #range) (x .! #text) + { toDelta = toCurrent (x ^. L.range) (x ^. L.text) <=< toDelta + , fromDelta = fromDelta <=< fromCurrent (x ^. L.range) (x ^. L.text) } applyChange posMapping _ = posMapping diff --git a/src/Development/IDE/Core/ProgressReporting.hs b/src/Development/IDE/Core/ProgressReporting.hs --- a/src/Development/IDE/Core/ProgressReporting.hs +++ b/src/Development/IDE/Core/ProgressReporting.hs @@ -2,7 +2,7 @@ ( ProgressEvent(..) , ProgressReporting(..) , noProgressReporting - , delayedProgressReporting + , progressReporting -- utilities, reexported for use in Core.Shake , mRunLspT , mRunLspTCallback @@ -12,31 +12,28 @@ ) where -import Control.Concurrent.Async -import Control.Concurrent.STM.Stats (TVar, atomicallyNamed, - modifyTVar', newTVarIO, - readTVarIO) -import Control.Concurrent.Strict +import Control.Concurrent.STM.Stats (TVar, atomically, + atomicallyNamed, modifyTVar', + newTVarIO, readTVar, retry) +import Control.Concurrent.Strict (modifyVar_, newVar, + threadDelay) import Control.Monad.Extra hiding (loop) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) -import Data.Aeson (ToJSON (toJSON)) -import Data.Foldable (for_) import Data.Functor (($>)) import qualified Data.Text as T -import Data.Unique import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Focus -import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Server (ProgressAmount (..), + ProgressCancellable (..), + withProgress) import qualified Language.LSP.Server as LSP import qualified StmContainers.Map as STM -import System.Time.Extra -import UnliftIO.Exception (bracket_) +import UnliftIO (Async, async, cancel) data ProgressEvent = KickStarted @@ -64,14 +61,14 @@ -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress -updateState :: IO (Async ()) -> Transition -> State -> IO State -updateState _ _ Stopped = pure Stopped -updateState start (Event KickStarted) NotStarted = Running <$> start -updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> start -updateState _ (Event KickCompleted) (Running a) = cancel a $> NotStarted -updateState _ (Event KickCompleted) st = pure st -updateState _ StopProgress (Running a) = cancel a $> Stopped -updateState _ StopProgress st = pure st +updateState :: IO () -> Transition -> State -> IO State +updateState _ _ Stopped = pure Stopped +updateState start (Event KickStarted) NotStarted = Running <$> async start +updateState start (Event KickStarted) (Running job) = cancel job >> Running <$> async start +updateState _ (Event KickCompleted) (Running job) = cancel job $> NotStarted +updateState _ (Event KickCompleted) st = pure st +updateState _ StopProgress (Running job) = cancel job $> Stopped +updateState _ StopProgress st = pure st -- | Data structure to track progress across the project data InProgressState = InProgressState @@ -93,7 +90,7 @@ (Just 0, 0) -> pure () (Just 0, _) -> modifyTVar' doneVar pred (Just _, 0) -> modifyTVar' doneVar (+1) - (Just _, _) -> pure() + (Just _, _) -> pure () where alterPrevAndNew = do prev <- Focus.lookup @@ -102,91 +99,38 @@ return (prev, new) alter x = let x' = maybe (shift 0) shift x in Just x' --- | A 'ProgressReporting' that enqueues Begin and End notifications in a new --- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives --- before the end of the grace period). -delayedProgressReporting - :: Seconds -- ^ Grace period before starting - -> Seconds -- ^ sampling delay - -> Maybe (LSP.LanguageContextEnv c) +progressReporting + :: Maybe (LSP.LanguageContextEnv c) -> ProgressReportingStyle -> IO ProgressReporting -delayedProgressReporting _before _after Nothing _optProgressStyle = noProgressReporting -delayedProgressReporting before after (Just lspEnv) optProgressStyle = do +progressReporting Nothing _optProgressStyle = noProgressReporting +progressReporting (Just lspEnv) optProgressStyle = do inProgressState <- newInProgress progressState <- newVar NotStarted let progressUpdate event = updateStateVar $ Event event - progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (lspShakeProgress inProgressState) - + progressStop = updateStateVar StopProgress + updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState) inProgress = updateStateForFile inProgressState return ProgressReporting{..} where - lspShakeProgress InProgressState{..} = do - -- first sleep a bit, so we only show progress messages if it's going to take - -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - liftIO $ sleep before - u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique - - b <- liftIO newBarrier - void $ LSP.runLspT lspEnv $ LSP.sendRequest SMethod_WindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b - liftIO $ async $ do - ready <- waitBarrier b - LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) + lspShakeProgressNew :: InProgressState -> IO () + lspShakeProgressNew InProgressState{..} = + LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0 where - start token = LSP.sendNotification SMethod_Progress $ - LSP.ProgressParams - { _token = token - , _value = toJSON $ WorkDoneProgressBegin - { _kind = AString @"begin" - , _title = "Processing" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - stop token = LSP.sendNotification SMethod_Progress - LSP.ProgressParams - { _token = token - , _value = toJSON $ WorkDoneProgressEnd - { _kind = AString @"end" - , _message = Nothing - } - } - loop _ _ | optProgressStyle == NoProgress = - forever $ liftIO $ threadDelay maxBound - loop token prevPct = do - done <- liftIO $ readTVarIO doneVar - todo <- liftIO $ readTVarIO todoVar - liftIO $ sleep after - if todo == 0 then loop token 0 else do - let - nextFrac :: Double - nextFrac = fromIntegral done / fromIntegral todo + loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound + loop update prevPct = do + (todo, done, nextPct) <- liftIO $ atomically $ do + todo <- readTVar todoVar + done <- readTVar doneVar + let nextFrac :: Double + nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo nextPct :: UInt nextPct = floor $ 100 * nextFrac - when (nextPct /= prevPct) $ - LSP.sendNotification SMethod_Progress $ - LSP.ProgressParams - { _token = token - , _value = case optProgressStyle of - Explicit -> toJSON $ WorkDoneProgressReport - { _kind = AString @"report" - , _cancellable = Nothing - , _message = Just $ T.pack $ show done <> "/" <> show todo - , _percentage = Nothing - } - Percentage -> toJSON $ WorkDoneProgressReport - { _kind = AString @"report" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Just nextPct - } - NoProgress -> error "unreachable" - } - loop token nextPct + when (nextPct == prevPct) retry + pure (todo, done, nextPct) + _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) + loop update nextPct updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const -- This functions are deliberately eta-expanded to avoid space leaks. -- Do not remove the eta-expansion without profiling a session with at diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -16,7 +16,7 @@ ) where import Control.DeepSeq -import Control.Exception (assert) +import qualified Control.Exception as E import Control.Lens import Data.Aeson.Types (Value) import Data.Hashable @@ -188,9 +188,9 @@ mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp = - assert (case hirCoreFp of Just (CoreFile{cf_iface_hash}, _) - -> getModuleHash hirModIface == cf_iface_hash - _ -> True) + E.assert (case hirCoreFp of + Just (CoreFile{cf_iface_hash}, _) -> getModuleHash hirModIface == cf_iface_hash + _ -> True) HiFileResult{..} where hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -23,6 +23,7 @@ getParsedModuleWithComments, getClientConfigAction, usePropertyAction, + usePropertyByPathAction, getHieFile, -- * Rules CompiledLinkables(..), @@ -42,7 +43,6 @@ getHieAstsRule, getBindingsRule, needsCompilationRule, - computeLinkableTypeForDynFlags, generateCoreRule, getImportMapRule, regenerateHiFile, @@ -58,17 +58,16 @@ ) where import Control.Applicative -import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (atomically) import Control.Concurrent.STM.TVar import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception (evaluate) import Control.Exception.Safe -import Control.Monad.Extra hiding (msum) +import Control.Monad.Extra import Control.Monad.IO.Unlift -import Control.Monad.Reader hiding (msum) -import Control.Monad.State hiding (msum) +import Control.Monad.Reader +import Control.Monad.State import Control.Monad.Trans.Except (ExceptT, except, runExceptT) import Control.Monad.Trans.Maybe @@ -78,7 +77,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Coerce import Data.Default (Default, def) -import Data.Foldable hiding (msum) +import Data.Foldable import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet @@ -90,10 +89,8 @@ import qualified Data.Map as M import Data.Maybe import Data.Proxy -import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Utf16.Rope as Rope import Data.Time (UTCTime (..)) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Tuple.Extra @@ -123,7 +120,6 @@ import qualified Development.IDE.GHC.Compat as Compat hiding (nest, vcat) -import Development.IDE.GHC.Compat.Env import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util hiding @@ -151,10 +147,13 @@ import qualified Ide.Logger as Logger import Ide.Plugin.Config import Ide.Plugin.Properties (HasProperty, + HasPropertyByPath, + KeyNamePath, KeyNameProxy, Properties, ToHsType, - useProperty) + useProperty, + usePropertyByPath) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId) import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) @@ -164,8 +163,7 @@ import qualified Language.LSP.Server as LSP import Language.LSP.VFS import Prelude hiding (mod) -import System.Directory (doesFileExist, - makeAbsolute) +import System.Directory (doesFileExist) import System.Info.Extra (isWindows) @@ -227,6 +225,9 @@ ------------------------------------------------------------ -- Exposed API ------------------------------------------------------------ + +-- TODO: rename +-- TODO: return text --> return rope getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do (_, msource) <- getFileContents nfp @@ -320,8 +321,7 @@ getLocatedImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file - targets <- useNoFile_ GetKnownTargets - let targetsMap = HM.mapWithKey const targets + (KnownTargets targets targetsMap) <- useNoFile_ GetKnownTargets let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env_eq <- use_ GhcSession file let env = hscEnvWithImportPaths env_eq @@ -396,16 +396,16 @@ go :: NormalizedFilePath -- ^ Current module being processed -> Maybe ModSummary -- ^ ModSummary of the module -> RawDepM FilePathId - go f msum = do + go f mbModSum = do -- First check to see if we have already processed the FilePath -- If we have, just return its Id but don't update any of the state. -- Otherwise, we need to process its imports. checkAlreadyProcessed f $ do - let al = modSummaryToArtifactsLocation f msum + let al = modSummaryToArtifactsLocation f mbModSum -- Get a fresh FilePathId for the new file fId <- getFreshFid al -- Record this module and its location - whenJust msum $ \ms -> + whenJust mbModSum $ \ms -> modifyRawDepInfo (\rd -> rd { rawModuleMap = IntMap.insert (getFilePathId fId) (ShowableModule $ ms_mod ms) (rawModuleMap rd)}) @@ -552,8 +552,8 @@ _ | Just asts <- masts -> do source <- getSourceFileSource f let exports = tcg_exports $ tmrTypechecked tmr - msum = tmrModSummary tmr - liftIO $ writeAndIndexHieFile hsc se msum f exports asts source + modSummary = tmrModSummary tmr + liftIO $ writeAndIndexHieFile hsc se modSummary f exports asts source _ -> pure [] let refmap = Compat.generateReferencesMap . Compat.getAsts <$> masts @@ -719,13 +719,13 @@ defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO + -- loading is always returning a absolute path now (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file -- add the deps to the Shake graph let addDependency fp = do -- VSCode uses absolute paths in its filewatch notifications - afp <- liftIO $ makeAbsolute fp - let nfp = toNormalizedFilePath' afp + let nfp = toNormalizedFilePath' fp itExists <- getFileExists nfp when itExists $ void $ do use_ GetModificationTime nfp @@ -853,7 +853,7 @@ hie_loc = Compat.ml_hie_file $ ms_location ms fileHash <- liftIO $ Util.getFileHash hie_loc mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f)) - hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow + let hie_loc' = HieDb.hieModuleHieFile <$> mrow case mrow of Just row | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row) @@ -1066,6 +1066,16 @@ pluginConfig <- getPluginConfigAction plId pure $ useProperty kn p $ plcConfig pluginConfig +usePropertyByPathAction :: + (HasPropertyByPath props path t) => + KeyNamePath path -> + PluginId -> + Properties props -> + Action (ToHsType t) +usePropertyByPathAction path plId p = do + pluginConfig <- getPluginConfigAction plId + pure $ usePropertyByPath path p $ plcConfig pluginConfig + -- --------------------------------------------------------------------- getLinkableRule :: Recorder (WithPriority Log) -> Rules () @@ -1125,7 +1135,6 @@ getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f --- needsCompilationRule :: Rules () needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) needsCompilationRule file | "boot" `isSuffixOf` fromNormalizedFilePath file = @@ -1148,35 +1157,22 @@ -- that we just threw away, and thus have to recompile all dependencies once -- again, this time keeping the object code. -- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled - ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps file (modsums,needsComps) <- liftA2 (,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps) (uses NeedsCompilation revdeps) - pure $ computeLinkableType ms modsums (map join needsComps) + pure $ computeLinkableType modsums (map join needsComps) pure (Just $ encodeLinkableType res, Just res) where - computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType - computeLinkableType this deps xs + computeLinkableType :: [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType + computeLinkableType deps xs | Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we - | Just BCOLinkable `elem` xs = Just this_type -- If any dependent needs bytecode, then we need to be compiled - | any (maybe False uses_th_qq) deps = Just this_type -- If any dependent needs TH, then we need to be compiled + | Just BCOLinkable `elem` xs = Just BCOLinkable -- If any dependent needs bytecode, then we need to be compiled + | any (maybe False uses_th_qq) deps = Just BCOLinkable -- If any dependent needs TH, then we need to be compiled | otherwise = Nothing -- If none of these conditions are satisfied, we don't need to compile - where - this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this) uses_th_qq :: ModSummary -> Bool uses_th_qq (ms_hspp_opts -> dflags) = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - --- | How should we compile this module? --- (assuming we do in fact need to compile it). --- Depends on whether it uses unboxed tuples or sums -computeLinkableTypeForDynFlags :: DynFlags -> LinkableType -computeLinkableTypeForDynFlags d - = BCOLinkable - where -- unboxed_tuples_or_sums is only used in GHC < 9.2 - _unboxed_tuples_or_sums = - xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d -- | Tracks which linkables are current, so we don't need to unload them newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -53,6 +53,7 @@ LogOfInterest msg -> pretty msg LogFileExists msg -> pretty msg + ------------------------------------------------------------ -- Exposed API @@ -65,10 +66,11 @@ -> Debouncer LSP.NormalizedUri -> IdeOptions -> WithHieDb - -> IndexQueue + -> ThreadQueue -> Monitoring + -> FilePath -- ^ Root directory see Note [Root Directory] -> IO IdeState -initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do +initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics rootDir = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -86,11 +88,12 @@ hiedbChan (optShakeOptions options) metrics - $ do + (do addIdeGlobal $ GlobalIdeOptions options ofInterestRules (cmapWithPrio LogOfInterest recorder) fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv - mainRule + mainRule) + rootDir -- | Shutdown the Compiler Service. shutdown :: IdeState -> IO () diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -22,9 +22,9 @@ -- always stored as real Haskell values, whereas Shake serialises all 'A' values -- between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake( - IdeState, shakeSessionInit, shakeExtras, shakeDb, + IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, - KnownTargets, Target(..), toKnownFiles, + KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets, IdeRule, IdeResult, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, @@ -57,7 +57,7 @@ FileVersion(..), updatePositionMapping, updatePositionMappingHelper, - deleteValue, recordDirtyKeys, + deleteValue, WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -73,6 +73,7 @@ garbageCollectDirtyKeysOlderThan, Log(..), VFSModified(..), getClientConfigAction, + ThreadQueue(..) ) where import Control.Concurrent.Async @@ -123,8 +124,8 @@ import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Tracing +import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Compat (NameCache, - NameCacheUpdater (..), initNameCache, knownKeyNames) import Development.IDE.GHC.Orphans () @@ -172,14 +173,20 @@ import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra + -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) import Data.IORef -import Development.IDE.GHC.Compat (mkSplitUniqSupply, +import Development.IDE.GHC.Compat (NameCacheUpdater (NCU), + mkSplitUniqSupply, upNameCache) #endif +#if MIN_VERSION_ghc(9,3,0) +import Development.IDE.GHC.Compat (NameCacheUpdater) +#endif + data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int @@ -257,6 +264,12 @@ -- with (currently) retry functionality type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +data ThreadQueue = ThreadQueue { + tIndexQueue :: IndexQueue + , tRestartQueue :: TQueue (IO ()) + , tLoaderQueue :: TQueue (IO ()) +} + -- Note [Semantic Tokens Cache Location] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- storing semantic tokens cache for each file in shakeExtras might @@ -300,6 +313,7 @@ :: VFSModified -> String -> [DelayedAction ()] + -> IO [Key] -> IO () #if MIN_VERSION_ghc(9,3,0) ,ideNc :: NameCache @@ -328,6 +342,10 @@ -- ^ Default HLS config, only relevant if the client does not provide any Config , dirtyKeys :: TVar KeySet -- ^ Set of dirty rule keys since the last Shake run + , restartQueue :: TQueue (IO ()) + -- ^ Queue of restart actions to be run. + , loaderQueue :: TQueue (IO ()) + -- ^ Queue of loader actions to be run. } type WithProgressFunc = forall a. @@ -521,6 +539,33 @@ -- ^ Closes the Shake session } +-- Note [Root Directory] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- We keep track of the root directory explicitly, which is the directory of the project root. +-- We might be setting it via these options with decreasing priority: +-- +-- 1. from LSP workspace root, `resRootPath` in `LanguageContextEnv`. +-- 2. command line (--cwd) +-- 3. default to the current directory. +-- +-- Using `getCurrentDirectory` makes it more difficult to run the tests, as we spawn one thread of HLS per test case. +-- If we modify the global Variable CWD, via `setCurrentDirectory`, all other test threads are suddenly affected, +-- forcing us to run all integration tests sequentially. +-- +-- Also, there might be a race condition if we depend on the current directory, as some plugin might change it. +-- e.g. stylish's `loadConfig`. https://github.com/haskell/haskell-language-server/issues/4234 +-- +-- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders +-- The root dir is deprecated, that means we should cleanup dependency on the project root(Or $CWD) thing gradually, +-- so multi-workspaces can actually be supported when we use absolute path everywhere(might also need some high level design). +-- That might not be possible unless we have everything adapted to it, like 'hlint' and 'evaluation of template haskell'. +-- But we should still be working towards the goal. +-- +-- We can drop it in the future once: +-- 1. We can get rid all the usages of root directory in the codebase. +-- 2. LSP version we support actually removes the root directory from the protocol. +-- + -- | A Shake database plus persistent store. Can be thought of as storing -- mappings from @(FilePath, k)@ to @RuleResult k@. data IdeState = IdeState @@ -529,6 +574,8 @@ ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) ,stopMonitoring :: IO () + -- | See Note [Root Directory] + ,rootDir :: FilePath } @@ -557,26 +604,17 @@ -- | Delete the value stored for a given ide build key +-- and return the key that was deleted. deleteValue :: Shake.ShakeValue k => ShakeExtras -> k -> NormalizedFilePath - -> STM () -deleteValue ShakeExtras{dirtyKeys, state} key file = do + -> STM [Key] +deleteValue ShakeExtras{state} key file = do STM.delete (toKey key file) state - modifyTVar' dirtyKeys $ insertKeySet (toKey key file) + return [toKey key file] -recordDirtyKeys - :: Shake.ShakeValue k - => ShakeExtras - -> k - -> [NormalizedFilePath] - -> STM (IO ()) -recordDirtyKeys ShakeExtras{dirtyKeys} key file = do - modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file) - return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do - addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file) -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: @@ -622,15 +660,22 @@ -> IdeReportProgress -> IdeTesting -> WithHieDb - -> IndexQueue + -> ThreadQueue -> ShakeOptions -> Monitoring -> Rules () + -> FilePath + -- ^ Root directory, this one might be picking up from `LanguageContextEnv`'s `resRootPath` + -- , see Note [Root Directory] -> IO IdeState shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) - ideTesting@(IdeTesting testing) - withHieDb indexQueue opts monitoring rules = mdo + ideTesting + withHieDb threadQueue opts monitoring rules rootDir = mdo + -- see Note [Serializing runs in separate thread] + let indexQueue = tIndexQueue threadQueue + restartQueue = tRestartQueue threadQueue + loaderQueue = tLoaderQueue threadQueue #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames @@ -646,7 +691,7 @@ publishedDiagnostics <- STM.newIO semanticTokensCache <- STM.newIO positionMapping <- STM.newIO - knownTargetsVar <- newTVarIO $ hashed HMap.empty + knownTargetsVar <- newTVarIO $ hashed emptyKnownTargets let restartShakeSession = shakeRestart recorder ideState persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty @@ -663,10 +708,9 @@ atomically $ modifyTVar' exportsMap (<> em) logWith recorder Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) - progress <- do - let (before, after) = if testing then (0,0.1) else (0.1,0.1) + progress <- if reportProgress - then delayedProgressReporting before after lspEnv optProgressStyle + then progressReporting lspEnv optProgressStyle else noProgressReporting actionQueue <- newQueue @@ -715,7 +759,7 @@ -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () -shakeSessionInit recorder ide@IdeState{..} = do +shakeSessionInit recorder IdeState{..} = do -- Take a snapshot of the VFS - it should be empty as we've received no notifications -- till now, but it can't hurt to be in sync with the `lsp` library. vfs <- vfsSnapshot (lspEnv shakeExtras) @@ -756,27 +800,33 @@ extras <- ask liftIO $ shakeEnqueue extras a + -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO () -shakeRestart recorder IdeState{..} vfs reason acts = - withMVar' - shakeSession - (\runner -> do - (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - res <- shakeDatabaseProfile shakeDb - backlog <- readTVarIO $ dirtyKeys shakeExtras - queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = + void $ awaitRunInThread (restartQueue shakeExtras) $ do + withMVar' + shakeSession + (\runner -> do + (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + keys <- ioActionBetweenShakeSession + -- it is every important to update the dirty keys after we enter the critical section + -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + res <- shakeDatabaseProfile shakeDb + backlog <- readTVarIO $ dirtyKeys shakeExtras + queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras - -- this log is required by tests - logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res - ) - -- It is crucial to be masked here, otherwise we can get killed - -- between spawning the new thread and updating shakeSession. - -- See https://github.com/haskell/ghcide/issues/79 - (\() -> do - (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) + -- this log is required by tests + logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res + ) + -- It is crucial to be masked here, otherwise we can get killed + -- between spawning the new thread and updating shakeSession. + -- See https://github.com/haskell/ghcide/issues/79 + (\() -> do + (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) where logErrorAfter :: Seconds -> IO () -> IO () logErrorAfter seconds action = flip withAsync (const action) $ do @@ -1198,7 +1248,7 @@ Just (v@(Succeeded _ x), diags) -> do ver <- estimateFileVersionUnsafely key (Just x) file doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags - return $ Just $ RunResult ChangedNothing old $ A v + return $ Just $ RunResult ChangedNothing old (A v) $ return () _ -> return Nothing _ -> -- assert that a "clean" rule is never a cache miss @@ -1222,7 +1272,6 @@ Nothing -> do pure (toShakeValue ShakeStale mbBs, staleV) Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v) - liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) doDiagnostics (vfsVersion =<< ver) diags let eq = case (bs, fmap decodeShakeValue mbOld) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b @@ -1232,9 +1281,12 @@ _ -> False return $ RunResult (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) - (encodeShakeValue bs) $ - A res - liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) + (encodeShakeValue bs) + (A res) $ do + -- this hook needs to be run in the same transaction as the key is marked clean + -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] + setValues state key file res (Vector.fromList diags) + modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) return res where -- Highly unsafe helper to compute the version of a file @@ -1257,6 +1309,32 @@ -- * creating a dependency: If everything depends on GetModificationTime, we lose early cutoff -- * creating bogus "file does not exists" diagnostics | otherwise = useWithoutDependency (GetModificationTime_ False) fp + +-- Note [Housekeeping rule cache and dirty key outside of hls-graph] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Hls-graph contains its own internal running state for each key in the shakeDatabase. +-- ShakeExtras contains `state` field (rule result cache) and `dirtyKeys` (keys that became +-- dirty in between build sessions) that is not visible to the hls-graph +-- Essentially, we need to keep the rule cache and dirty key and hls-graph's internal state +-- in sync. + +-- 1. A dirty key collected in a session should not be removed from dirty keys in the same session. +-- Since if we clean out the dirty key in the same session, +-- 1.1. we will lose the chance to dirty its reverse dependencies. Since it only happens during session restart. +-- 1.2. a key might be marked as dirty in ShakeExtras while it's being recomputed by hls-graph which could lead to it's premature removal from dirtyKeys. +-- See issue https://github.com/haskell/haskell-language-server/issues/4093 for more details. + +-- 2. When a key is marked clean in the hls-graph's internal running +-- state, the rule cache and dirty keys are updated in the same transaction. +-- otherwise, some situations like the following can happen: +-- thread 1: hls-graph session run a key +-- thread 1: defineEarlyCutoff' run the action for the key +-- thread 1: the action is done, rule cache and dirty key are updated +-- thread 2: we restart the hls-graph session, thread 1 is killed, the +-- hls-graph's internal state is not updated. +-- This is problematic with early cut off because we are having a new rule cache matching the +-- old hls-graph's internal state, which might case it's reverse dependency to skip the recomputation. +-- See https://github.com/haskell/haskell-language-server/issues/4194 for more details. traceA :: A v -> String traceA (A Failed{}) = "Failed" diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -112,7 +112,7 @@ ExitCaseSuccess res -> do setTag sp "result" (pack $ result $ runValue res) setTag sp "changed" $ case res of - RunResult x _ _ -> fromString $ show x + RunResult x _ _ _ -> fromString $ show x endSpan sp) (\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics )) | otherwise = act (\_ -> return ()) diff --git a/src/Development/IDE/Core/WorkerThread.hs b/src/Development/IDE/Core/WorkerThread.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/WorkerThread.hs @@ -0,0 +1,54 @@ +{- +Module : Development.IDE.Core.WorkerThread +Author : @soulomoon +SPDX-License-Identifier: Apache-2.0 + +Description : This module provides an API for managing worker threads in the IDE. +see Note [Serializing runs in separate thread] +-} +module Development.IDE.Core.WorkerThread + (withWorkerQueue, awaitRunInThread) + where + +import Control.Concurrent.Async (withAsync) +import Control.Concurrent.STM +import Control.Concurrent.Strict (newBarrier, signalBarrier, + waitBarrier) +import Control.Monad (forever) +import Control.Monad.Cont (ContT (ContT)) + +{- +Note [Serializing runs in separate thread] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We often want to take long-running actions using some resource that cannot be shared. +In this instance it is useful to have a queue of jobs to run using the resource. +Like the db writes, session loading in session loader, shake session restarts. + +Originally we used various ways to implement this, but it was hard to maintain and error prone. +Moreover, we can not stop these threads uniformly when we are shutting down the server. +-} + +-- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker +-- thread which polls the queue for requests and runs the given worker +-- function on them. +withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t) +withWorkerQueue workerAction = ContT $ \mainAction -> do + q <- newTQueueIO + withAsync (writerThread q) $ \_ -> mainAction q + where + writerThread q = + forever $ do + l <- atomically $ readTQueue q + workerAction l + +-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, +-- and then blocks until the result is computed. +awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result +awaitRunInThread q act = do + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + barrier <- newBarrier + atomically $ writeTQueue q $ do + res <- act + signalBarrier barrier res + waitBarrier barrier diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -18,11 +18,10 @@ import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Util import GHC +import GHC.Settings -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -import GHC.Settings - #if !MIN_VERSION_ghc(9,3,0) import qualified GHC.Driver.Pipeline as Pipeline #endif @@ -35,6 +34,10 @@ import qualified GHC.SysTools.Cpp as Pipeline #endif +#if MIN_VERSION_ghc(9,11,0) +import qualified GHC.SysTools.Tasks as Pipeline +#endif + addOptP :: String -> DynFlags -> DynFlags addOptP f = alterToolSettings $ \s -> s { toolSettings_opt_P = f : toolSettings_opt_P s @@ -53,7 +56,9 @@ #if MIN_VERSION_ghc(9,5,0) let cpp_opts = Pipeline.CppOpts { cppLinePragmas = True -#if MIN_VERSION_ghc(9,9,0) +#if MIN_VERSION_ghc(9,11,0) + , sourceCodePreprocessor = Pipeline.SCPHsCpp +#elif MIN_VERSION_ghc(9,10,0) , useHsCpp = True #else , cppUseCc = False diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -1,8 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( @@ -10,34 +10,20 @@ addIncludePathsQuote, getModuleHash, setUpTypedHoles, - NameCacheUpdater(..), -#if MIN_VERSION_ghc(9,3,0) - nameEnvElts, -#else - upNameCache, -#endif lookupNameCache, disableWarningsAsErrors, reLoc, reLocA, renderMessages, pattern PFailedWithErrorMessages, - -#if !MIN_VERSION_ghc(9,3,0) - extendModSummaryNoDeps, - emsModSummary, -#endif myCoreToStgExpr, - Usage(..), - - liftZonkM, - FastStringCompat, bytesFS, mkFastStringByteString, nodeInfo', getNodeIds, + getSourceNodeIds, sourceNodeInfo, generatedNodeInfo, simpleNodeInfoCompat, @@ -45,11 +31,6 @@ nodeAnnotations, mkAstNode, combineRealSrcSpans, -#if !MIN_VERSION_ghc(9,3,0) - nonDetOccEnvElts, -#endif - nonDetFoldOccEnv, - isQualifiedImport, GhcVersion(..), ghcVersion, @@ -87,9 +68,6 @@ simplifyExpr, tidyExpr, emptyTidyEnv, -#if MIN_VERSION_ghc(9,7,0) - tcInitTidyEnv, -#endif corePrepExpr, corePrepPgm, lintInteractiveExpr, @@ -97,11 +75,6 @@ HomePackageTable, lookupHpt, loadModulesHome, -#if MIN_VERSION_ghc(9,3,0) - Dependencies(dep_direct_mods), -#else - Dependencies(dep_mods), -#endif bcoFreeNames, ModIfaceAnnotation, pattern Annotation, @@ -124,13 +97,50 @@ expectJust, extract_cons, recDotDot, + +#if !MIN_VERSION_ghc(9,3,0) + Dependencies(dep_mods), + NameCacheUpdater(NCU), + extendModSummaryNoDeps, + emsModSummary, + nonDetNameEnvElts, + nonDetOccEnvElts, + upNameCache, +#endif + +#if MIN_VERSION_ghc(9,3,0) + Dependencies(dep_direct_mods), + NameCacheUpdater, +#endif + #if MIN_VERSION_ghc(9,5,0) XModulePs(..), #endif + +#if !MIN_VERSION_ghc(9,7,0) + liftZonkM, + nonDetFoldOccEnv, +#endif + +#if MIN_VERSION_ghc(9,7,0) + tcInitTidyEnv, +#endif ) where -import Prelude hiding (mod) -import Development.IDE.GHC.Compat.Core hiding (moduleUnitId) +import Compat.HieAst (enrichHie) +import Compat.HieBin +import Compat.HieTypes hiding + (nodeAnnotations) +import qualified Compat.HieTypes as GHC (nodeAnnotations) +import Compat.HieUtils +import Control.Applicative ((<|>)) +import qualified Data.ByteString as BS +import Data.Coerce (coerce) +import Data.List (foldl') +import qualified Data.Map as Map +import qualified Data.Set as S +import Data.String (IsString (fromString)) +import Development.IDE.GHC.Compat.Core import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Iface import Development.IDE.GHC.Compat.Logger @@ -139,90 +149,81 @@ import Development.IDE.GHC.Compat.Plugins import Development.IDE.GHC.Compat.Units import Development.IDE.GHC.Compat.Util -import GHC hiding (HasSrcSpan, - ModLocation, - RealSrcSpan, exprType, - getLoc, lookupName) -import Data.Coerce (coerce) -import Data.String (IsString (fromString)) -import Compat.HieAst (enrichHie) -import Compat.HieBin -import Compat.HieTypes hiding (nodeAnnotations) -import qualified Compat.HieTypes as GHC (nodeAnnotations) -import Compat.HieUtils -import qualified Data.ByteString as BS -import Data.List (foldl') -import qualified Data.Map as Map -import qualified Data.Set as S +import GHC hiding (ModLocation, + RealSrcSpan, exprType, + getLoc, lookupName) +import Prelude hiding (mod) -import qualified GHC.Core.Opt.Pipeline as GHC -import GHC.Core.Tidy (tidyExpr) -import GHC.CoreToStg.Prep (corePrepPgm) -import qualified GHC.CoreToStg.Prep as GHC -import GHC.Driver.Hooks (hscCompileCoreExprHook) +import qualified GHC.Core.Opt.Pipeline as GHC +import GHC.Core.Tidy (tidyExpr) +import GHC.CoreToStg.Prep (corePrepPgm) +import qualified GHC.CoreToStg.Prep as GHC +import GHC.Driver.Hooks (hscCompileCoreExprHook) -import GHC.ByteCode.Asm (bcoFreeNames) -import GHC.Types.Annotations (AnnTarget (ModuleTarget), - Annotation (..), - extendAnnEnvList) -import GHC.Types.Unique.DFM as UniqDFM -import GHC.Types.Unique.DSet as UniqDSet -import GHC.Types.Unique.Set as UniqSet -import GHC.Data.FastString +import GHC.ByteCode.Asm (bcoFreeNames) import GHC.Core +import GHC.Data.FastString import GHC.Data.StringBuffer -import GHC.Driver.Session hiding (ExposePackage) +import GHC.Driver.Session hiding (ExposePackage) +import GHC.Iface.Make (mkIfaceExports) +import GHC.SysTools.Tasks (runPp, runUnlit) +import GHC.Types.Annotations (AnnTarget (ModuleTarget), + Annotation (..), + extendAnnEnvList) +import qualified GHC.Types.Avail as Avail +import GHC.Types.Unique.DFM as UniqDFM +import GHC.Types.Unique.DSet as UniqDSet +import GHC.Types.Unique.Set as UniqSet import GHC.Types.Var.Env -import GHC.Iface.Make (mkIfaceExports) -import GHC.SysTools.Tasks (runUnlit, runPp) -import qualified GHC.Types.Avail as Avail -import GHC.Iface.Env -import GHC.Types.SrcLoc (combineRealSrcSpans) -import GHC.Runtime.Context (icInteractiveModule) -import GHC.Unit.Home.ModInfo (HomePackageTable, - lookupHpt) -import GHC.Driver.Env as Env -import GHC.Unit.Module.ModIface import GHC.Builtin.Uniques import GHC.ByteCode.Types import GHC.CoreToStg import GHC.Data.Maybe -import GHC.Linker.Loader (loadDecls, loadExpr) +import GHC.Driver.Env as Env +import GHC.Iface.Env +import GHC.Linker.Loader (loadDecls, loadExpr) +import GHC.Runtime.Context (icInteractiveModule) import GHC.Stg.Pipeline import GHC.Stg.Syntax import GHC.StgToByteCode import GHC.Types.CostCentre import GHC.Types.IPE +import GHC.Types.SrcLoc (combineRealSrcSpans) +import GHC.Unit.Home.ModInfo (HomePackageTable, + lookupHpt) +import GHC.Unit.Module.ModIface -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Module.Deps (Dependencies(dep_mods), Usage(..)) -import GHC.Unit.Module.ModSummary -import GHC.Runtime.Interpreter import Data.IORef +import GHC.Runtime.Interpreter +import GHC.Unit.Module.Deps (Dependencies (dep_mods), + Usage (..)) +import GHC.Unit.Module.ModSummary #endif #if MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods), Usage(..)) -import GHC.Driver.Config.Stg.Pipeline +import GHC.Driver.Config.Stg.Pipeline +import GHC.Unit.Module.Deps (Dependencies (dep_direct_mods), + Usage (..)) #endif #if !MIN_VERSION_ghc(9,5,0) -import GHC.Core.Lint (lintInteractiveExpr) +import GHC.Core.Lint (lintInteractiveExpr) #endif #if MIN_VERSION_ghc(9,5,0) -import GHC.Core.Lint.Interactive (interactiveInScope) -import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr) -import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts) -import GHC.Driver.Config.CoreToStg (initCoreToStgOpts) -import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig) +import GHC.Core.Lint.Interactive (interactiveInScope) +import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr) +import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts) +import GHC.Driver.Config.CoreToStg (initCoreToStgOpts) +import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig) #endif #if MIN_VERSION_ghc(9,7,0) -import GHC.Tc.Zonk.TcType (tcInitTidyEnv) +import GHC.Tc.Zonk.TcType (tcInitTidyEnv) #endif #if !MIN_VERSION_ghc(9,7,0) @@ -240,9 +241,9 @@ type ModIfaceAnnotation = Annotation -#if MIN_VERSION_ghc(9,3,0) -nameEnvElts :: NameEnv a -> [a] -nameEnvElts = nonDetNameEnvElts +#if !MIN_VERSION_ghc(9,3,0) +nonDetNameEnvElts :: NameEnv a -> [a] +nonDetNameEnvElts = nameEnvElts #endif myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext @@ -334,7 +335,11 @@ return (stg_binds2, denv, cost_centre_info) - +#if MIN_VERSION_ghc(9,9,0) +reLocA :: (HasLoc (GenLocated a e), HasAnnotation b) + => GenLocated a e -> GenLocated b e +reLocA = reLoc +#endif getDependentMods :: ModIface -> [ModuleName] #if MIN_VERSION_ghc(9,3,0) @@ -434,7 +439,7 @@ dontWriteHieFiles :: DynFlags -> DynFlags dontWriteHieFiles d = gopt_unset d Opt_WriteHie -setUpTypedHoles ::DynFlags -> DynFlags +setUpTypedHoles :: DynFlags -> DynFlags setUpTypedHoles df = flip gopt_unset Opt_AbstractRefHoleFits -- too spammy $ flip gopt_unset Opt_ShowDocsOfHoleFits -- not used @@ -447,9 +452,13 @@ $ flip gopt_unset Opt_SortValidHoleFits $ flip gopt_unset Opt_UnclutterValidHoleFits $ df - { refLevelHoleFits = Just 1 -- becomes slow at higher levels - , maxRefHoleFits = Just 10 -- quantity does not impact speed - , maxValidHoleFits = Nothing -- quantity does not impact speed + { refLevelHoleFits = refLevelHoleFits df <|> Just 1 -- becomes slow at higher levels + + -- Sometimes GHC can emit a lot of hole fits, this causes editors to be slow + -- or just crash, we limit the hole fits to 10. The number was chosen + -- arbirtarily by the author. + , maxRefHoleFits = maxRefHoleFits df <|> Just 10 + , maxValidHoleFits = maxValidHoleFits df <|> Just 10 } @@ -471,7 +480,9 @@ isQualifiedImport ImportDecl{} = True isQualifiedImport _ = False - +-- | Like getNodeIds but with generated node removed +getSourceNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) +getSourceNodeIds = Map.foldl' combineNodeIds Map.empty . Map.filterWithKey (\k _ -> k == SourceInfo) . getSourcedNodeInfo . sourcedNodeInfo getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo @@ -508,13 +519,16 @@ | GHC94 | GHC96 | GHC98 - deriving (Eq, Ord, Show) + | GHC910 + deriving (Eq, Ord, Show, Enum) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,10,0,0) +ghcVersion = GHC910 +#elif MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) ghcVersion = GHC98 #elif MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) ghcVersion = GHC96 diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} -- | Compat Core module that handles the GHC module hierarchy re-organization -- by re-exporting everything we care about. @@ -117,9 +116,6 @@ pattern ConPatIn, conPatDetails, mapConPatDetail, -#if MIN_VERSION_ghc(9,5,0) - mkVisFunTys, -#endif -- * Specs ImpDeclSpec(..), ImportSpec(..), @@ -201,7 +197,9 @@ pattern RealSrcLoc, SrcLoc.SrcLoc(SrcLoc.UnhelpfulLoc), BufSpan, +#if !MIN_VERSION_ghc(9,9,0) GHC.SrcAnn, +#endif SrcLoc.leftmost_smallest, SrcLoc.containsSpan, SrcLoc.mkGeneralSrcSpan, @@ -408,99 +406,100 @@ -- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it. -- Not the greatest solution, but gets the job done -- (until the CPP extension is actually needed). -import GHC.LanguageExtensions.Type hiding (Cpp) - -import GHC.Hs.Binds - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +import GHC.LanguageExtensions.Type hiding (Cpp) -import GHC.Builtin.Names hiding (Unique, printName) +import GHC.Builtin.Names hiding (Unique, printName) import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Builtin.Utils +import GHC.Core (CoreProgram) import GHC.Core.Class import GHC.Core.Coercion import GHC.Core.ConLike -import GHC.Core.DataCon hiding (dataConExTyCoVars) -import qualified GHC.Core.DataCon as DataCon -import GHC.Core.FamInstEnv hiding (pprFamInst) +import GHC.Core.DataCon hiding (dataConExTyCoVars) +import qualified GHC.Core.DataCon as DataCon +import GHC.Core.FamInstEnv hiding (pprFamInst) import GHC.Core.InstEnv -import GHC.Types.Unique.FM import GHC.Core.PatSyn import GHC.Core.Predicate import GHC.Core.TyCo.Ppr -import qualified GHC.Core.TyCo.Rep as TyCoRep +import qualified GHC.Core.TyCo.Rep as TyCoRep import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Unify import GHC.Core.Utils -import GHC.Driver.CmdLine (Warn (..)) +import GHC.Driver.CmdLine (Warn (..)) import GHC.Driver.Hooks -import GHC.Driver.Main as GHC +import GHC.Driver.Main as GHC import GHC.Driver.Monad import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Plugins -import GHC.Driver.Session hiding (ExposePackage) -import qualified GHC.Driver.Session as DynFlags +import GHC.Driver.Session hiding (ExposePackage) +import qualified GHC.Driver.Session as DynFlags +import GHC.Hs.Binds import GHC.HsToCore.Docs import GHC.HsToCore.Expr import GHC.HsToCore.Monad import GHC.Iface.Load -import GHC.Iface.Make as GHC +import GHC.Iface.Make as GHC import GHC.Iface.Recomp import GHC.Iface.Syntax -import GHC.Iface.Tidy as GHC +import GHC.Iface.Tidy as GHC import GHC.IfaceToCore import GHC.Parser -import GHC.Parser.Header hiding (getImports) -import GHC.Rename.Fixity (lookupFixityRn) +import GHC.Parser.Header hiding (getImports) +import GHC.Rename.Fixity (lookupFixityRn) import GHC.Rename.Names import GHC.Rename.Splice -import qualified GHC.Runtime.Interpreter as GHCi +import qualified GHC.Runtime.Interpreter as GHCi import GHC.Tc.Instance.Family import GHC.Tc.Module import GHC.Tc.Types -import GHC.Tc.Types.Evidence hiding ((<.>)) +import GHC.Tc.Types.Evidence hiding ((<.>)) import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef, - MonadFix (..), MonadIO (..), - allM, anyM, concatMapM, - mapMaybeM, (<$>)) -import GHC.Tc.Utils.TcType as TcType -import qualified GHC.Types.Avail as Avail +import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef, + MonadFix (..), MonadIO (..), allM, + anyM, concatMapM, mapMaybeM, + (<$>)) +import GHC.Tc.Utils.TcType as TcType +import qualified GHC.Types.Avail as Avail import GHC.Types.Basic import GHC.Types.Id -import GHC.Types.Name hiding (varName) +import GHC.Types.Name hiding (varName) import GHC.Types.Name.Cache import GHC.Types.Name.Env -import GHC.Types.Name.Reader hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par) -import qualified GHC.Types.Name.Reader as RdrName -import GHC.Types.SrcLoc (BufPos, BufSpan, - SrcLoc (UnhelpfulLoc), - SrcSpan (UnhelpfulSpan)) -import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Name.Reader hiding (GRE, gre_imp, gre_lcl, + gre_name, gre_par) +import qualified GHC.Types.Name.Reader as RdrName +import GHC.Types.SrcLoc (BufPos, BufSpan, + SrcLoc (UnhelpfulLoc), + SrcSpan (UnhelpfulSpan)) +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import GHC.Types.Var (Var (varName), setTyVarUnique, - setVarUnique) +import GHC.Types.Var (Var (varName), setTyVarUnique, + setVarUnique) -import qualified GHC.Types.Var as TypesVar -import GHC.Unit.Info (PackageName (..)) -import GHC.Unit.Module hiding (ModLocation (..), UnitId, - moduleUnit, - toUnitId) -import qualified GHC.Unit.Module as Module -import GHC.Unit.State (ModuleOrigin (..)) -import GHC.Utils.Error (Severity (..), emptyMessages) -import GHC.Utils.Panic hiding (try) -import qualified GHC.Utils.Panic.Plain as Plain +import qualified GHC.Types.Var as TypesVar +import GHC.Unit.Info (PackageName (..)) +import GHC.Unit.Module hiding (ModLocation (..), UnitId, + moduleUnit, toUnitId) +import qualified GHC.Unit.Module as Module +import GHC.Unit.State (ModuleOrigin (..)) +import GHC.Utils.Error (Severity (..), emptyMessages) +import GHC.Utils.Panic hiding (try) +import qualified GHC.Utils.Panic.Plain as Plain -import Data.Foldable (toList) +import Data.Foldable (toList) +import GHC.Core.Multiplicity (scaledThing) import GHC.Data.Bag -import GHC.Core.Multiplicity (scaledThing) import GHC.Driver.Env -import GHC.Hs (HsModule (..), SrcSpanAnn') +import GHC.Hs (HsModule (..)) +#if !MIN_VERSION_ghc(9,9,0) +import GHC.Hs (SrcSpanAnn') +#endif import GHC.Hs.Decls hiding (FunDep) import GHC.Hs.Doc import GHC.Hs.Expr @@ -508,58 +507,63 @@ import GHC.Hs.ImpExp import GHC.Hs.Pat import GHC.Hs.Type -import GHC.Hs.Utils hiding (collectHsBindsBinders) -import qualified GHC.Linker.Loader as Linker +import GHC.Hs.Utils hiding (collectHsBindsBinders) +import qualified GHC.Linker.Loader as Linker import GHC.Linker.Types -import GHC.Parser.Lexer hiding (initParserState, getPsMessages) -import GHC.Parser.Annotation (EpAnn (..)) +import GHC.Parser.Annotation (EpAnn (..)) +import GHC.Parser.Lexer hiding (getPsMessages, + initParserState) import GHC.Platform.Ways -import GHC.Runtime.Context (InteractiveImport (..)) -#if !MIN_VERSION_ghc(9,7,0) -import GHC.Types.Avail (greNamePrintableName) -#endif -import GHC.Types.Fixity (LexicalFixity (..), Fixity (..), defaultFixity) +import GHC.Runtime.Context (InteractiveImport (..)) +import GHC.Types.Fixity (Fixity (..), LexicalFixity (..), + defaultFixity) import GHC.Types.Meta import GHC.Types.Name.Set -import GHC.Types.SourceFile (HscSource (..)) +import GHC.Types.SourceFile (HscSource (..)) import GHC.Types.SourceText -import GHC.Types.Target (Target (..), TargetId (..)) +import GHC.Types.Target (Target (..), TargetId (..)) import GHC.Types.TyThing import GHC.Types.TyThing.Ppr -import GHC.Unit.Finder hiding (mkHomeModLocation) +import GHC.Unit.Finder hiding (mkHomeModLocation) import GHC.Unit.Home.ModInfo import GHC.Unit.Module.Imported import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts -import GHC.Unit.Module.ModIface (IfaceExport, ModIface, - ModIface_ (..), mi_fix) -import GHC.Unit.Module.ModSummary (ModSummary (..)) -import Language.Haskell.Syntax hiding (FunDep) +import GHC.Unit.Module.ModIface (IfaceExport, ModIface, + ModIface_ (..), mi_fix) +import GHC.Unit.Module.ModSummary (ModSummary (..)) +import Language.Haskell.Syntax hiding (FunDep) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if !MIN_VERSION_ghc(9,3,0) -import GHC.Types.SourceFile (SourceModified(..)) -import GHC.Unit.Module.Graph (mkModuleGraph) -import qualified GHC.Unit.Finder as GHC +import GHC.Types.SourceFile (SourceModified (..)) +import qualified GHC.Unit.Finder as GHC +import GHC.Unit.Module.Graph (mkModuleGraph) #endif #if MIN_VERSION_ghc(9,3,0) -import GHC.Utils.Error (mkPlainErrorMsgEnvelope) -import GHC.Driver.Env.KnotVars -import GHC.Unit.Module.Graph -import GHC.Driver.Errors.Types -import GHC.Types.Unique.Map -import GHC.Types.Unique -import GHC.Utils.TmpFs -import GHC.Utils.Panic -import GHC.Unit.Finder.Types -import GHC.Unit.Env -import qualified GHC.Driver.Config.Tidy as GHC -import qualified GHC.Data.Strict as Strict -import GHC.Driver.Env as GHCi -import qualified GHC.Unit.Finder as GHC -import qualified GHC.Driver.Config.Finder as GHC +import qualified GHC.Data.Strict as Strict +import qualified GHC.Driver.Config.Finder as GHC +import qualified GHC.Driver.Config.Tidy as GHC +import GHC.Driver.Env as GHCi +import GHC.Driver.Env.KnotVars +import GHC.Driver.Errors.Types +import GHC.Types.Unique +import GHC.Types.Unique.Map +import GHC.Unit.Env +import qualified GHC.Unit.Finder as GHC +import GHC.Unit.Finder.Types +import GHC.Unit.Module.Graph +import GHC.Utils.Error (mkPlainErrorMsgEnvelope) +import GHC.Utils.Panic +import GHC.Utils.TmpFs #endif +#if !MIN_VERSION_ghc(9,7,0) +import GHC.Types.Avail (greNamePrintableName) +#endif + mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation #if MIN_VERSION_ghc(9,3,0) mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f @@ -627,6 +631,7 @@ pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #endif +isVisibleFunArg :: Development.IDE.GHC.Compat.Core.FunTyFlag -> Bool #if __GLASGOW_HASKELL__ >= 906 isVisibleFunArg = TypesVar.isVisibleFunArg type FunTyFlag = TypesVar.FunTyFlag @@ -651,10 +656,20 @@ instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where getLoc = GHC.getLoc +#if MIN_VERSION_ghc(9,9,0) +instance HasSrcSpan (EpAnn a) where + getLoc = GHC.getHasLoc +#endif + +#if MIN_VERSION_ghc(9,9,0) +instance HasSrcSpan (SrcLoc.GenLocated (EpAnn ann) a) where + getLoc (L l _) = getLoc l +#else instance HasSrcSpan (SrcSpanAnn' ann) where getLoc = GHC.locA instance HasSrcSpan (SrcLoc.GenLocated (SrcSpanAnn' ann) a) where getLoc (L l _) = l +#endif pattern L :: HasSrcSpan a => SrcSpan -> e -> SrcLoc.GenLocated a e pattern L l a <- GHC.L (getLoc -> l) a @@ -662,9 +677,15 @@ -- This is from the old api, but it still simplifies pattern ConPatIn :: SrcLoc.Located (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs +#if MIN_VERSION_ghc(9,9,0) +pattern ConPatIn con args <- ConPat _ (L _ (SrcLoc.noLoc -> con)) args + where + ConPatIn con args = ConPat GHC.noAnn (GHC.noLocA $ SrcLoc.unLoc con) args +#else pattern ConPatIn con args <- ConPat EpAnnNotUsed (L _ (SrcLoc.noLoc -> con)) args where ConPatIn con args = ConPat EpAnnNotUsed (GHC.noLocA $ SrcLoc.unLoc con) args +#endif conPatDetails :: Pat p -> Maybe (HsConPatDetails p) conPatDetails (ConPat _ _ args) = Just args @@ -680,8 +701,16 @@ GHCi.initObjLinker (GHCi.hscInterp env) loadDLL :: HscEnv -> String -> IO (Maybe String) -loadDLL env = - GHCi.loadDLL (GHCi.hscInterp env) +loadDLL env str = do + res <- GHCi.loadDLL (GHCi.hscInterp env) str +#if MIN_VERSION_ghc(9,11,0) + pure $ + case res of + Left err_msg -> Just err_msg + Right _ -> Nothing +#else + pure res +#endif unload :: HscEnv -> [Linkable] -> IO () unload hsc_env linkables = @@ -729,12 +758,15 @@ hsc_env #endif -mkIfaceTc hsc_env sf details _ms tcGblEnv = -- ms is only used in GHC >= 9.4 - GHC.mkIfaceTc hsc_env sf details -#if MIN_VERSION_ghc(9,3,0) - _ms +mkIfaceTc :: HscEnv -> GHC.SafeHaskellMode -> ModDetails -> ModSummary -> Maybe CoreProgram -> TcGblEnv -> IO ModIface +mkIfaceTc hscEnv shm md _ms _mcp = +#if MIN_VERSION_ghc(9,5,0) + GHC.mkIfaceTc hscEnv shm md _ms _mcp -- mcp::Maybe CoreProgram is only used in GHC >= 9.6 +#elif MIN_VERSION_ghc(9,3,0) + GHC.mkIfaceTc hscEnv shm md _ms -- ms::ModSummary is only used in GHC >= 9.4 +#else + GHC.mkIfaceTc hscEnv shm md #endif - tcGblEnv mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc session = GHC.mkBootModDetailsTc @@ -756,11 +788,12 @@ pure #endif -driverNoStop = #if MIN_VERSION_ghc(9,3,0) - NoStop +driverNoStop :: StopPhase +driverNoStop = NoStop #else - StopLn +driverNoStop :: Phase +driverNoStop = StopLn #endif #if !MIN_VERSION_ghc(9,3,0) @@ -779,15 +812,14 @@ pattern NamedFieldPuns = RecordPuns #endif +groupOrigin :: MatchGroup GhcRn body -> Origin #if MIN_VERSION_ghc(9,5,0) -mkVisFunTys = mkScaledFunctionTys mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b mapLoc = fmap groupOrigin = mg_ext #else mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b mapLoc = SrcLoc.mapLoc -groupOrigin :: MatchGroup p body -> Origin groupOrigin = mg_origin #endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs --- a/src/Development/IDE/GHC/Compat/Env.hs +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -32,7 +32,7 @@ Home.mkHomeModule, -- * Provide backwards Compatible -- types and helper functions. - Logger(..), + Logger, UnitEnv, hscSetUnitEnv, hscSetFlags, @@ -63,8 +63,6 @@ import GHC (setInteractiveDynFlags) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - import GHC.Driver.Backend as Backend import qualified GHC.Driver.Env as Env import GHC.Driver.Hooks (Hooks) @@ -78,9 +76,11 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if !MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env (HscEnv, hsc_EPS) import qualified Data.Set as S +import GHC.Driver.Env (HscEnv, hsc_EPS) #endif #if MIN_VERSION_ghc(9,3,0) diff --git a/src/Development/IDE/GHC/Compat/Iface.hs b/src/Development/IDE/GHC/Compat/Iface.hs --- a/src/Development/IDE/GHC/Compat/Iface.hs +++ b/src/Development/IDE/GHC/Compat/Iface.hs @@ -9,20 +9,18 @@ import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Outputable import GHC +import qualified GHC.Iface.Load as Iface +import GHC.Unit.Finder.Types (FindResult) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Session (targetProfile) +#endif + #if MIN_VERSION_ghc(9,7,0) import GHC.Iface.Errors.Ppr (missingInterfaceErrorDiagnostic) import GHC.Iface.Errors.Types (IfaceMessage) -#endif - - -import qualified GHC.Iface.Load as Iface -import GHC.Unit.Finder.Types (FindResult) - -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Session (targetProfile) #endif writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs --- a/src/Development/IDE/GHC/Compat/Logger.hs +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -13,11 +13,11 @@ import Development.IDE.GHC.Compat.Env as Env import Development.IDE.GHC.Compat.Outputable --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +import GHC.Utils.Logger as Logger import GHC.Utils.Outputable -import GHC.Utils.Logger as Logger +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if MIN_VERSION_ghc(9,3,0) import GHC.Types.Error diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -10,7 +10,7 @@ printSDocQualifiedUnsafe, printWithoutUniques, mkPrintUnqualifiedDefault, - PrintUnqualified(..), + PrintUnqualified, defaultUserStyle, withPprStyle, -- * Parser errors @@ -53,38 +53,39 @@ textDoc, ) where --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - - import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session import qualified GHC.Types.Error as Error -#if MIN_VERSION_ghc(9,7,0) -import GHC.Types.Error (defaultDiagnosticOpts) -#endif import GHC.Types.Name.Ppr import GHC.Types.Name.Reader import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Unit.State -import GHC.Utils.Error hiding (mkWarnMsg) import GHC.Utils.Outputable as Out import GHC.Utils.Panic +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if !MIN_VERSION_ghc(9,3,0) import GHC.Parser.Errors import qualified GHC.Parser.Errors.Ppr as Ppr +import GHC.Utils.Error hiding (mkWarnMsg) #endif #if MIN_VERSION_ghc(9,3,0) import Data.Maybe import GHC.Driver.Config.Diagnostic import GHC.Parser.Errors.Types +import GHC.Utils.Error #endif #if MIN_VERSION_ghc(9,5,0) import GHC.Driver.Errors.Types (DriverMessage, GhcMessage) +#endif + +#if MIN_VERSION_ghc(9,7,0) +import GHC.Types.Error (defaultDiagnosticOpts) #endif #if MIN_VERSION_ghc(9,5,0) diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -27,9 +27,6 @@ import Development.IDE.GHC.Compat.Core import Development.IDE.GHC.Compat.Util - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - import qualified GHC.Parser.Annotation as Anno import qualified GHC.Parser.Lexer as Lexer import GHC.Types.SrcLoc (PsSpan (..)) @@ -42,6 +39,8 @@ pm_parsed_source) import qualified GHC import GHC.Hs (hpm_module, hpm_src_files) + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) import qualified GHC.Driver.Config as Config diff --git a/src/Development/IDE/GHC/Compat/Plugins.hs b/src/Development/IDE/GHC/Compat/Plugins.hs --- a/src/Development/IDE/GHC/Compat/Plugins.hs +++ b/src/Development/IDE/GHC/Compat/Plugins.hs @@ -23,8 +23,7 @@ import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags) import Development.IDE.GHC.Compat.Parser as Parser --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - +import qualified GHC.Driver.Env as Env import GHC.Driver.Plugins (Plugin (..), PluginWithArgs (..), StaticPlugin (..), @@ -32,17 +31,11 @@ withPlugins) import qualified GHC.Runtime.Loader as Loader -#if !MIN_VERSION_ghc(9,3,0) -import Development.IDE.GHC.Compat.Outputable as Out -#endif - -import qualified GHC.Driver.Env as Env +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) import Data.Bifunctor (bimap) -#endif - -#if !MIN_VERSION_ghc(9,3,0) +import Development.IDE.GHC.Compat.Outputable as Out import Development.IDE.GHC.Compat.Util (Bag) #endif @@ -53,23 +46,20 @@ import qualified GHC.Parser.Lexer as Lexer #endif - #if !MIN_VERSION_ghc(9,3,0) type PsMessages = (Bag WarnMsg, Bag ErrMsg) #endif -getPsMessages :: PState -> DynFlags -> PsMessages -getPsMessages pst _dflags = --dfags is only used if GHC < 9.2 +getPsMessages :: PState -> PsMessages +getPsMessages pst = #if MIN_VERSION_ghc(9,3,0) uncurry PsMessages $ Lexer.getPsMessages pst #else - bimap (fmap pprWarning) (fmap pprError) $ - getMessages pst + bimap (fmap pprWarning) (fmap pprError) $ getMessages pst #endif -applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages) -applyPluginsParsedResultAction env _dflags ms hpm_annotations parsed msgs = do - -- dflags is only used in GHC < 9.2 +applyPluginsParsedResultAction :: HscEnv -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages) +applyPluginsParsedResultAction env ms hpm_annotations parsed msgs = do -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms #if MIN_VERSION_ghc(9,3,0) diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs --- a/src/Development/IDE/GHC/Compat/Units.hs +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -36,7 +36,7 @@ installedModule, -- * Module toUnitId, - Development.IDE.GHC.Compat.Units.moduleUnitId, + moduleUnitId, moduleUnit, -- * ExternalPackageState ExternalPackageState(..), @@ -53,9 +53,10 @@ import Development.IDE.GHC.Compat.Outputable import Prelude hiding (mod) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - +import qualified GHC.Data.ShortText as ST import GHC.Types.Unique.Set +import GHC.Unit.External +import qualified GHC.Unit.Finder as GHC import qualified GHC.Unit.Info as UnitInfo import GHC.Unit.State (LookupResult, UnitInfo, UnitInfoMap, @@ -67,22 +68,15 @@ unitPackageVersion) import qualified GHC.Unit.State as State import GHC.Unit.Types -import qualified GHC.Unit.Types as Unit +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) import GHC.Data.FastString - -#endif - -import qualified GHC.Data.ShortText as ST -import GHC.Unit.External -import qualified GHC.Unit.Finder as GHC - -#if !MIN_VERSION_ghc(9,3,0) import GHC.Unit.Env import GHC.Unit.Finder hiding (findImportedModule) +import qualified GHC.Unit.Types as Unit #endif #if MIN_VERSION_ghc(9,3,0) @@ -210,10 +204,10 @@ installedModule :: unit -> ModuleName -> GenModule unit installedModule = Module - +#if !MIN_VERSION_ghc(9,3,0) moduleUnitId :: Module -> UnitId -moduleUnitId = - Unit.toUnitId . Unit.moduleUnit +moduleUnitId = Unit.toUnitId . Unit.moduleUnit +#endif filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag]) filterInplaceUnits us packageFlags = diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs --- a/src/Development/IDE/GHC/Compat/Util.hs +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -66,13 +66,10 @@ atEnd, ) where --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - import Control.Exception.Safe (MonadCatch, catch, try) import GHC.Data.Bag import GHC.Data.BooleanFormula import GHC.Data.EnumSet - import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Pair @@ -83,6 +80,8 @@ import GHC.Utils.Outputable (pprHsString) import GHC.Utils.Panic hiding (try) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if !MIN_VERSION_ghc(9,3,0) import GHC.Utils.Misc #endif @@ -90,4 +89,3 @@ #if MIN_VERSION_ghc(9,3,0) import GHC.Data.Bool #endif - diff --git a/src/Development/IDE/GHC/CoreFile.hs b/src/Development/IDE/GHC/CoreFile.hs --- a/src/Development/IDE/GHC/CoreFile.hs +++ b/src/Development/IDE/GHC/CoreFile.hs @@ -21,22 +21,17 @@ import qualified Data.Text as T import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util -import GHC.Fingerprint -import Prelude hiding (mod) - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - import GHC.Core import GHC.CoreToIface +import GHC.Fingerprint import GHC.Iface.Binary import GHC.Iface.Env import GHC.Iface.Recomp.Binary (fingerprintBinMem) import GHC.IfaceToCore import GHC.Types.Id.Make -import GHC.Utils.Binary - - import GHC.Types.TypeEnv +import GHC.Utils.Binary +import Prelude hiding (mod) -- | Initial ram buffer to allocate for writing interface files @@ -202,6 +197,7 @@ name' <- newIfaceName (mkVarOcc $ getOccString name) pure $ ifid{ ifName = name' } | otherwise = pure ifid + unmangle_decl_name _ifid = error $ "tcIfaceId: got non IfaceId: " -- invariant: 'IfaceId' is always a 'IfaceId' constructor getIfaceId (AnId identifier) = identifier getIfaceId _ = error "tcIfaceId: got non Id" diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -11,34 +11,37 @@ import Development.IDE.GHC.Util import Control.DeepSeq -import Control.Monad.Trans.Reader (ReaderT (..)) +import Control.Monad.Trans.Reader (ReaderT (..)) import Data.Aeson import Data.Hashable -import Data.String (IsString (fromString)) -import Data.Text (unpack) - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +import Data.String (IsString (fromString)) +import Data.Text (unpack) import GHC.ByteCode.Types import GHC.Data.Bag import GHC.Data.FastString -import qualified GHC.Data.StringBuffer as SB +import qualified GHC.Data.StringBuffer as SB import GHC.Types.SrcLoc +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if !MIN_VERSION_ghc(9,3,0) -import GHC (ModuleGraph) -import GHC.Types.Unique (getKey) +import GHC.Types.Unique (getKey) +import GHC.Unit.Module.Graph (ModuleGraph) #endif -import Data.Bifunctor (Bifunctor (..)) +import Data.Bifunctor (Bifunctor (..)) import GHC.Parser.Annotation #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual + #endif #if MIN_VERSION_ghc(9,5,0) import GHC.Unit.Home.ModInfo +import GHC.Unit.Module.Location (ModLocation (..)) +import GHC.Unit.Module.WholeCoreBindings #endif -- Orphan instance for Shake.hs @@ -56,10 +59,22 @@ instance Show Linkable where show = unpack . printOutputable instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c instance NFData Unlinked where - rnf (DotO f) = rnf f - rnf (DotA f) = rnf f - rnf (DotDLL f) = rnf f - rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b + rnf (DotO f) = rnf f + rnf (DotA f) = rnf f + rnf (DotDLL f) = rnf f + rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b +#if MIN_VERSION_ghc(9,5,0) + rnf (CoreBindings wcb) = rnf wcb + rnf (LoadedBCOs us) = rnf us + +instance NFData WholeCoreBindings where + rnf (WholeCoreBindings bs m ml) = rnf bs `seq` rnf m `seq` rnf ml + +instance NFData ModLocation where + rnf (ModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 + +#endif + instance Show PackageFlag where show = unpack . printOutputable instance Show InteractiveImport where show = unpack . printOutputable instance Show PackageName where show = unpack . printOutputable @@ -94,13 +109,18 @@ instance Ord FastString where compare a b = if a == b then EQ else compare (fs_sbs a) (fs_sbs b) + +#if MIN_VERSION_ghc(9,9,0) +instance NFData (EpAnn a) where + rnf = rwhnf +#else instance NFData (SrcSpanAnn' a) where rnf = rwhnf +deriving instance Functor SrcSpanAnn' +#endif instance Bifunctor GenLocated where bimap f g (L l x) = L (f l) (g x) - -deriving instance Functor SrcSpanAnn' instance NFData ParsedModule where rnf = rwhnf diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -62,9 +62,6 @@ import Ide.PluginUtils (unescape) import System.FilePath --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - - import GHC.Data.EnumSet import GHC.Data.FastString import GHC.Data.StringBuffer diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -60,7 +60,7 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) -import GHC +import GHC.Unit.Module.Graph (ModuleGraph) #endif -- | The imports for a given module. diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -131,13 +131,17 @@ -> m (Either [FileDiagnostic] Import) locateModule env comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of - -- "this" means that we should only look in the current package #if MIN_VERSION_ghc(9,3,0) - ThisPkg _ -> do + -- 'ThisPkg' just means some home module, not the current unit + ThisPkg uid + | Just (dirs, reexports) <- lookup uid import_paths + -> lookupLocal uid dirs reexports + | otherwise -> return $ Left $ notFoundErr env modName $ LookupNotFound [] #else + -- "this" means that we should only look in the current package Just "this" -> do -#endif lookupLocal (homeUnitId_ dflags) (importPaths dflags) S.empty +#endif -- if a package name is given we only go look for a package #if MIN_VERSION_ghc(9,3,0) OtherPkg uid @@ -239,7 +243,7 @@ LookupUnusable unusable -> let unusables' = map get_unusable unusable #if MIN_VERSION_ghc(9,6,4) && (!MIN_VERSION_ghc(9,8,1) || MIN_VERSION_ghc(9,8,2)) - get_unusable (m, ModUnusable r) = r + get_unusable (_m, ModUnusable r) = r #else get_unusable (m, ModUnusable r) = (moduleUnit m, r) #endif diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -20,14 +20,13 @@ import Development.IDE.Core.Actions import qualified Development.IDE.Core.Rules as Shake import Development.IDE.Core.Shake (IdeAction, IdeState (..), - ideLogger, runIdeAction) + runIdeAction) import Development.IDE.Types.Location import Ide.Logger import Ide.Plugin.Error import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import qualified Language.LSP.Server as LSP import qualified Data.Text as T @@ -44,10 +43,10 @@ pretty label <+> "request at position" <+> pretty (showPosition pos) <+> "in file:" <+> pretty (fromNormalizedFilePath nfp) -gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition) -hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null) -gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition) -documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null) +gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition) +hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null) +gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition) +documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null) gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) hover = request "Hover" getAtPoint (InR Null) foundHover @@ -77,7 +76,7 @@ -> Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams - -> ExceptT PluginError (LSP.LspM c) b + -> ExceptT PluginError (HandlerM c) b request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do mbResult <- case uriToFilePath' uri of Just path -> logAndRunRequest recorder label getResults ide pos path diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -1,4 +1,4 @@ - -- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-} @@ -9,6 +9,8 @@ ( runLanguageServer , setupLSP , Log(..) + , ThreadQueue + , runWithWorkerThreads ) where import Control.Concurrent.STM @@ -33,11 +35,14 @@ import qualified Colog.Core as Colog import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake hiding (Log, Priority) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing +import Development.IDE.Core.WorkerThread (withWorkerQueue) import qualified Development.IDE.Session as Session -import Development.IDE.Types.Shake (WithHieDb) +import Development.IDE.Types.Shake (WithHieDb, + WithHieDbShield (..)) import Ide.Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, @@ -76,8 +81,6 @@ LogLspServer msg -> pretty msg LogServerShutdownMessage -> "Received shutdown message" --- used to smuggle RankNType WithHieDb through dbMVar -newtype WithHieDbShield = WithHieDbShield WithHieDb runLanguageServer :: forall config a m. (Show config) @@ -89,7 +92,7 @@ -> (config -> Value -> Either T.Text config) -> (config -> m config ()) -> (MVar () - -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), + -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)), LSP.Handlers (m config), (LanguageContextEnv config, a) -> m config <~> IO)) -> IO () @@ -126,14 +129,15 @@ setupLSP :: forall config err. Recorder (WithPriority Log) + -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do +setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available clientMsgChan :: Chan ReactorMessage <- newChan @@ -176,7 +180,7 @@ -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let doInitialize = handleInit recorder defaultRoot getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO @@ -185,19 +189,23 @@ handleInit :: Recorder (WithPriority Log) + -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) -> MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do +handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params - let root = LSP.resRootPath env - dir <- maybe getCurrentDirectory return root - dbLoc <- getHieDbLoc dir + -- only shift if lsp root is different from the rootDir + -- see Note [Root Directory] + root <- case LSP.resRootPath env of + Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot + _ -> pure defaultRoot + dbLoc <- getHieDbLoc root let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig dbMVar <- newEmptyMVar @@ -211,25 +219,27 @@ exceptionInHandler e = do logWith recorder Error $ LogReactorMessageActionException e + checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO () checkCancelled _id act k = - flip finally (clearReqId _id) $ + let sid = SomeLspId _id + in flip finally (clearReqId sid) $ catch (do -- We could optimize this by first checking if the id -- is in the cancelled set. However, this is unlikely to be a -- bottleneck and the additional check might hide -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel _id) act + cancelOrRes <- race (waitForCancel sid) act case cancelOrRes of Left () -> do - logWith recorder Debug $ LogCancelledRequest _id - k $ ResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing + logWith recorder Debug $ LogCancelledRequest sid + k $ TResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e - k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing + k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do - putMVar dbMVar (WithHieDbShield withHieDb',hieChan') + untilMVar lifetime $ runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> do + putMVar dbMVar (WithHieDbShield withHieDb',threadQueue') forever $ do msg <- readChan clientMsgChan -- We dispatch notifications synchronously and requests asynchronously @@ -239,11 +249,21 @@ ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped - (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar - ide <- getIdeState env root withHieDb hieChan + (WithHieDbShield withHieDb, threadQueue) <- takeMVar dbMVar + ide <- getIdeState env root withHieDb threadQueue registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) + +-- | runWithWorkerThreads +-- create several threads to run the session, db and session loader +-- see Note [Serializing runs in separate thread] +runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () +runWithWorkerThreads recorder dbLoc f = evalContT $ do + sessionRestartTQueue <- withWorkerQueue id + sessionLoaderTQueue <- withWorkerQueue id + (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc + liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) -- | Runs the action until it ends or until the given MVar is put. -- Rethrows any exceptions. diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -31,7 +31,7 @@ import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Core.Service hiding (Log, LogShake) -import Development.IDE.Core.Shake hiding (Log, Priority) +import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location import Ide.Logger @@ -41,7 +41,6 @@ data Log = LogShake Shake.Log | LogFileStore FileStore.Log - | LogOpenTextDocument !Uri | LogOpenedTextDocument !Uri | LogModifiedTextDocument !Uri | LogSavedTextDocument !Uri @@ -72,32 +71,32 @@ whenUriFile _uri $ \file -> do -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open - addFileOfInterest ide file Modified{firstOpen=True} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file - logWith recorder Debug $ LogOpenedTextDocument _uri + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file Modified{firstOpen=True} + logWith recorder Debug $ LogOpenedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do - addFileOfInterest ide file Modified{firstOpen=False} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file Modified{firstOpen=False} logWith recorder Debug $ LogModifiedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do - addFileOfInterest ide file OnDisk - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file $ + addFileOfInterest ide file OnDisk logWith recorder Debug $ LogSavedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do - deleteFileOfInterest ide file let msg = "Closed text document: " <> getUri _uri - scheduleGarbageCollection ide - setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg + setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do + scheduleGarbageCollection ide + deleteFileOfInterest ide file logWith recorder Debug $ LogClosedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ @@ -116,9 +115,10 @@ unless (null fileEvents') $ do let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) - modifyFileExists ide fileEvents' - resetFileStore ide fileEvents' - setSomethingModified (VFSModified vfs) ide [] msg + setSomethingModified (VFSModified vfs) ide msg $ do + ks1 <- resetFileStore ide fileEvents' + ks2 <- modifyFileExists ide fileEvents' + return (ks1 <> ks2) , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -9,8 +9,10 @@ where import Control.Monad.IO.Class +import Data.Foldable (toList) import Data.Functor import Data.Generics hiding (Prefix) +import Data.List.NonEmpty (nonEmpty) import Data.Maybe import Development.IDE.Core.Rules import Development.IDE.Core.Shake @@ -29,9 +31,6 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -import Data.List.NonEmpty (nonEmpty) -import Data.Foldable (toList) - #if !MIN_VERSION_ghc(9,3,0) import qualified Data.Text as T #endif @@ -272,7 +271,9 @@ get_flds_gadt :: HsConDeclGADTDetails GhcPs -> [LFieldOcc GhcPs] -#if MIN_VERSION_ghc(9,3,0) +#if MIN_VERSION_ghc(9,9,0) + get_flds_gadt (RecConGADT _ flds) = get_flds (reLoc flds) +#elif MIN_VERSION_ghc(9,3,0) get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) #else get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds) diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -22,7 +22,7 @@ data ReactorMessage = ReactorNotification (IO ()) - | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) + | forall m . ReactorRequest (LspId m) (IO ()) (TResponseError m -> IO ()) type ReactorChan = Chan ReactorMessage newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a } @@ -31,17 +31,17 @@ requestHandler :: forall m c. PluginMethod Request m => SMethod m - -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m))) + -> (IdeState -> MessageParams m -> LspM c (Either (TResponseError m) (MessageResult m))) -> Handlers (ServerM c) requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params} resp -> do st@(chan,ide) <- ask env <- LSP.getLspEnv - let resp' :: Either ResponseError (MessageResult m) -> LspM c () + let resp' :: Either (TResponseError m) (MessageResult m) -> LspM c () resp' = flip (runReaderT . unServerM) st . resp trace x = otTracedHandler "Request" (show _method) $ \sp -> do traceWithSpan sp _params x - writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) + writeChan chan $ ReactorRequest (_id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) notificationHandler :: forall m c. PluginMethod Notification m => diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -24,7 +24,6 @@ import qualified Data.Aeson as J import Data.Coerce (coerce) import Data.Default (Default (def)) -import Data.Foldable (traverse_) import Data.Hashable (hashed) import qualified Data.HashMap.Strict as HashMap import Data.List.Extra (intercalate, @@ -34,8 +33,7 @@ import qualified Data.Text as T import Development.IDE (Action, Priority (Debug, Error), - Rules, emptyFilePath, - hDuplicateTo') + Rules, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) import Development.IDE.Core.FileStore (isWatchSupported, @@ -55,12 +53,13 @@ runAction) import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), - IndexQueue, + ThreadQueue (tLoaderQueue), shakeSessionInit, uses) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer, + runWithWorkerThreads, setupLSP) import qualified Development.IDE.LSP.LanguageServer as LanguageServer import Development.IDE.Main.HeapStats (withHeapStats) @@ -75,7 +74,6 @@ getHieDbLoc, loadSessionWithOptions, retryOnSqliteBusy, - runWithDb, setInitialDynFlags) import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, @@ -88,7 +86,8 @@ defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (WithHieDb, toKey) +import Development.IDE.Types.Shake (WithHieDb, + toNoFileKey) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) @@ -208,7 +207,7 @@ data Arguments = Arguments - { argsProjectRoot :: Maybe FilePath + { argsProjectRoot :: FilePath , argCommand :: Command , argsRules :: Rules () , argsHlsPlugins :: IdePlugins IdeState @@ -223,13 +222,14 @@ , argsHandleOut :: IO Handle , argsThreads :: Maybe Natural , argsMonitoring :: IO Monitoring + , argsDisableKick :: Bool -- ^ flag to disable kick used for testing } -defaultArguments :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments -defaultArguments recorder plugins = Arguments - { argsProjectRoot = Nothing +defaultArguments :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments +defaultArguments recorder projectRoot plugins = Arguments + { argsProjectRoot = projectRoot -- ^ see Note [Root Directory] , argCommand = LSP - , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick + , argsRules = mainRule (cmapWithPrio LogRules recorder) def , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) <> plugins , argsSessionLoadingOptions = def @@ -237,7 +237,15 @@ { optCheckProject = pure $ checkProject config , optCheckParents = pure $ checkParents config } - , argsLspOptions = def {LSP.optCompletionTriggerCharacters = Just "."} + , argsLspOptions = def + { LSP.optCompletionTriggerCharacters = Just "." + -- Generally people start to notice that something is taking a while at about 1s, so + -- that's when we start reporting progress + , LSP.optProgressStartDelay = 1_000_000 + -- Once progress is being reported, it's nice to see that it's moving reasonably quickly, + -- but not so fast that it's ugly. This number is a bit made up + , LSP.optProgressUpdateDelay = 1_00_000 + } , argsDefaultHlsConfig = def , argsGetHieDbLoc = getHieDbLoc , argsDebouncer = newAsyncDebouncer @@ -258,14 +266,15 @@ putStr " " >> hFlush stdout return newStdout , argsMonitoring = OpenTelemetry.monitoring + , argsDisableKick = False } -testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments -testing recorder plugins = +testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments +testing recorder projectRoot plugins = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = - defaultArguments recorder plugins + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = + defaultArguments recorder projectRoot plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] @@ -274,10 +283,12 @@ defOptions = argsIdeOptions config sessionLoader in defOptions{ optTesting = IdeTesting True } + lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 } in arguments { argsHlsPlugins = hlsPlugins , argsIdeOptions = ideOptions + , argsLspOptions = lspOptions } defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () @@ -293,7 +304,13 @@ plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands } argsParseConfig = getConfigFromNotification argsHlsPlugins - rules = argsRules >> pluginRules plugins + rules = do + argsRules + unless argsDisableKick $ action kick + pluginRules plugins + -- install the main and ghcide-plugin rules + -- install the kick action, which triggers a typecheck on every + -- Shake database restart, i.e. on every user edit. debouncer <- argsDebouncer inH <- argsHandleIn @@ -308,22 +325,18 @@ logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState - getIdeState env rootPath withHieDb hieChan = do - traverse_ IO.setCurrentDirectory rootPath + let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState + getIdeState env rootPath withHieDb threadQueue = do t <- ioT logWith recorder Info $ LogLspStartDuration t - - dir <- maybe IO.getCurrentDirectory return rootPath - -- We want to set the global DynFlags right now, so that we can use -- `unsafeGlobalDynFlags` even before the project is configured _mlibdir <- - setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions + setInitialDynFlags (cmapWithPrio LogSession recorder) rootPath argsSessionLoadingOptions -- TODO: should probably catch/log/rethrow at top level instead `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue) config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -347,12 +360,13 @@ debouncer ideOptions withHieDb - hieChan + threadQueue monitoring + rootPath putMVar ideStateVar ide pure ide - let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState + let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) getIdeState -- See Note [Client configuration in Rules] onConfigChange cfg = do -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint @@ -362,16 +376,17 @@ Nothing -> pure () Just ide -> liftIO $ do let msg = T.pack $ show cfg - logWith recorder Debug $ LogConfigurationChange msg - modifyClientSettings ide (const $ Just cfgObj) - setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" + setSomethingModified Shake.VFSUnmodified ide "config change" $ do + logWith recorder Debug $ LogConfigurationChange msg + modifyClientSettings ide (const $ Just cfgObj) + return [toNoFileKey Rules.GetClientSettings] runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats Check argFiles -> do - dir <- maybe IO.getCurrentDirectory return argsProjectRoot + let dir = argsProjectRoot dbLoc <- getHieDbLoc dir - runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -392,14 +407,14 @@ putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir (tLoaderQueue threadQueue) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty dir shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -417,7 +432,7 @@ unless (null failed) (exitWith $ ExitFailure (length failed)) Db opts cmd -> do - root <- maybe IO.getCurrentDirectory return argsProjectRoot + let root = argsProjectRoot dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def @@ -427,17 +442,17 @@ Just libdir -> retryOnSqliteBusy (cmapWithPrio LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) Custom (IdeCommand c) -> do - root <- maybe IO.getCurrentDirectory return argsProjectRoot + let root = argsProjectRoot dbLoc <- getHieDbLoc root - runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue threadQueue) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty root shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -47,7 +47,6 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import qualified Language.LSP.Server as LSP import Numeric.Natural import Prelude hiding (mod) import Text.Fuzzy.Parallel (Scored (..)) @@ -56,8 +55,6 @@ import qualified Ide.Plugin.Config as Config --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - import qualified GHC.LanguageExtensions as LangExt data Log = LogShake Shake.Log deriving Show @@ -172,7 +169,7 @@ CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position ,_context=completionContext} = ExceptT $ do - contents <- LSP.getVirtualFile $ toNormalizedUri uri + contents <- pluginGetVirtualFile $ toNormalizedUri uri fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path @@ -183,7 +180,7 @@ pm <- useWithStaleFast GetParsedModule npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath knownTargets <- liftIO $ runAction "Completion" ide $ useNoFile GetKnownTargets - let localModules = maybe [] Map.keys knownTargets + let localModules = maybe [] (Map.keys . targetMap) knownTargets let lModules = mempty{importableModules = map toModueNameText localModules} -- set up the exports map including both package and project-level identifiers packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedLabels #-} -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic ( @@ -12,6 +11,7 @@ , getCompletions , fromIdentInfo , getCompletionPrefix +, getCompletionPrefixFromRope ) where import Control.Applicative @@ -23,7 +23,6 @@ import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map -import Data.Row import Prelude hiding (mod) import Data.Maybe (fromMaybe, isJust, @@ -67,13 +66,14 @@ import Development.IDE.Spans.AtPoint (pointCommand) --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] import GHC.Plugins (Depth (AllTheWay), mkUserStyle, neverQualify, sdocStyle) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if !MIN_VERSION_ghc(9,3,0) import GHC.Plugins (defaultSDocContext, renderWithContext) @@ -530,7 +530,7 @@ removeSnippetsWhen (not $ enableSnippets && supported) where supported = - Just True == (_textDocument >>= _completion >>= view L.completionItem >>= (\x -> x .! #snippetSupport)) + Just True == (_textDocument >>= _completion >>= view L.completionItem >>= view L.snippetSupport) toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing} @@ -898,7 +898,10 @@ -- |From the given cursor position, gets the prefix module or record for autocompletion getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo -getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) = +getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext + +getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo +getCompletionPrefixFromRope pos@(Position l c) ropetext = fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad let headMaybe = listToMaybe lastMaybe = headMaybe . reverse diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -21,13 +21,10 @@ import Development.IDE.Graph (RuleResult) import Development.IDE.Spans.Common () import GHC.Generics (Generic) +import qualified GHC.Types.Name.Occurrence as Occ import Ide.Plugin.Properties import Language.LSP.Protocol.Types (CompletionItemKind (..), Uri) import qualified Language.LSP.Protocol.Types as J - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] - -import qualified GHC.Types.Name.Occurrence as Occ -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -54,7 +54,7 @@ data Log = LogPluginError PluginId PluginError - | LogResponseError PluginId ResponseError + | forall m . A.ToJSON (ErrorData m) => LogResponseError PluginId (TResponseError m) | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier | ExceptionInPlugin PluginId (Some SMethod) SomeException @@ -73,10 +73,10 @@ <> pretty method <> ": " <> viaShow exception instance Show Log where show = renderString . layoutCompact . pretty -noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either ResponseError c) +noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either (TResponseError m) c) noPluginHandles recorder m fs' = do logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing + let err = TResponseError (InR ErrorCodes_MethodNotFound) msg Nothing msg = noPluginHandlesMsg m fs' return $ Left err where noPluginHandlesMsg :: SMethod m -> [(PluginId, HandleRequestResult)] -> Text @@ -112,9 +112,9 @@ "Exception in plugin " <> T.pack (show plId) <> " while processing "<> T.pack (show method) <> ": " <> T.pack (show exception) -- | Build a ResponseError and log it before returning to the caller -logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError :: A.ToJSON (ErrorData m) => Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either (TResponseError m) a) logAndReturnError recorder p errCode msg = do - let err = ResponseError errCode msg Nothing + let err = TResponseError errCode msg Nothing logWith recorder Warning $ LogResponseError p err pure $ Left err @@ -176,7 +176,7 @@ _ -> Nothing -- The parameters to the HLS command are always the first element - execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null)) + execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null)) execCmd ide (ExecuteCommandParams mtoken cmdId args) = do let cmdParams :: A.Value cmdParams = case args of @@ -196,8 +196,10 @@ -- If we have a command, continue to execute it Just (Command _ innerCmdId innerArgs) -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) + -- TODO: This should be a response error? Nothing -> return $ Right $ InR Null + -- TODO: This should be a response error? A.Error _str -> return $ Right $ InR Null -- Just an ordinary HIE command @@ -206,9 +208,9 @@ -- Couldn't parse the command identifier _ -> do logWith recorder Warning LogInvalidCommandIdentifier - return $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing + return $ Left $ TResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing - runPluginCommand :: IdeState -> PluginId -> CommandId -> Maybe ProgressToken -> A.Value -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null)) + runPluginCommand :: IdeState -> PluginId -> CommandId -> Maybe ProgressToken -> A.Value -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null)) runPluginCommand ide p com mtoken arg = case Map.lookup p pluginMap of Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (pluginDoesntExist p) @@ -217,7 +219,7 @@ Just (PluginCommand _ _ f) -> case A.fromJSON arg of A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) A.Success a -> do - res <- runExceptT (f ide mtoken a) `catchAny` -- See Note [Exception handling in plugins] + res <- runHandlerM (runExceptT (f ide mtoken a)) `catchAny` -- See Note [Exception handling in plugins] (\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e)) case res of (Left (PluginRequestRefused r)) -> @@ -252,7 +254,7 @@ Nothing -> liftIO $ noPluginHandles recorder m disabledPluginsReason Just neFs -> do let plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs - es <- runConcurrently exceptionInPlugin m plidsAndHandlers ide params + es <- runHandlerM $ runConcurrently exceptionInPlugin m plidsAndHandlers ide params caps <- LSP.getClientCapabilities let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) plidsAndHandlers es liftIO $ unless (null errs) $ logErrors recorder errs @@ -314,13 +316,13 @@ f a b -- See Note [Exception handling in plugins] `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) -combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError +combineErrors :: NonEmpty (PluginId, PluginError) -> TResponseError m combineErrors (x NE.:| []) = toResponseError x combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs -toResponseError :: (PluginId, PluginError) -> ResponseError +toResponseError :: (PluginId, PluginError) -> TResponseError m toResponseError (PluginId plId, err) = - ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing + TResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing where tPretty = T.pack . show . pretty logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO () @@ -333,7 +335,7 @@ -- | Combine the 'PluginHandler' for all plugins newtype IdeHandler (m :: Method ClientToServer Request) - = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either PluginError (MessageResult m))))] + = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))))] -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: Method ClientToServer Notification) diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -7,7 +7,7 @@ descriptors , Log(..) ) where -import Control.Monad.IO.Class + import Development.IDE import qualified Development.IDE.LSP.HoverDefinition as Hover import qualified Development.IDE.LSP.Notifications as Notifications diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -49,7 +49,6 @@ import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import qualified Language.LSP.Server as LSP import qualified "list-t" ListT import qualified StmContainers.Map as STM import System.Time.Extra @@ -91,9 +90,9 @@ testRequestHandler :: IdeState -> TestRequest - -> LSP.LspM c (Either PluginError Value) + -> HandlerM config (Either PluginError Value) testRequestHandler _ (BlockSeconds secs) = do - LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $ + pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $ toJSON secs liftIO $ sleep secs return (Right A.Null) @@ -171,6 +170,6 @@ blockCommandHandler :: CommandFunction state ExecuteCommandParams blockCommandHandler _ideState _ _params = do - lift $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null + lift $ pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null liftIO $ threadDelay maxBound pure $ InR Null diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -66,7 +66,8 @@ defaultPluginDescriptor, mkCustomConfig, mkPluginHandler, - mkResolveHandler) + mkResolveHandler, + pluginSendRequest) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens), SMethod (..)) @@ -79,7 +80,6 @@ TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), type (|?) (..)) -import qualified Language.LSP.Server as LSP import Text.Regex.TDFA ((=~)) data Log = LogShake Shake.Log deriving Show @@ -193,7 +193,7 @@ -- and applies it. commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState _ wedit = do - _ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) pure $ InR Null -------------------------------------------------------------------------------- diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -167,7 +167,7 @@ where -- We don't want to show document highlights for evidence variables, which are supposed to be invisible notEvidence = not . any isEvidenceContext . identInfo - ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getNodeIds) + ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getSourceNodeIds) highlights = do n <- ns ref <- fromMaybe [] (M.lookup (Right n) rf) diff --git a/src/Development/IDE/Spans/LocalBindings.hs b/src/Development/IDE/Spans/LocalBindings.hs --- a/src/Development/IDE/Spans/LocalBindings.hs +++ b/src/Development/IDE/Spans/LocalBindings.hs @@ -22,7 +22,8 @@ getBindSiteFromContext, getScopeFromContext, identInfo, identType, isSystemName, - nameEnvElts, realSrcSpanEnd, + nonDetNameEnvElts, + realSrcSpanEnd, realSrcSpanStart, unitNameEnv) import Development.IDE.GHC.Error @@ -99,7 +100,7 @@ -- 'RealSrcSpan', getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] getLocalScope bs rss - = nameEnvElts + = nonDetNameEnvElts $ foldMap snd $ IM.dominators (realSrcSpanToInterval rss) $ getLocalBindings bs @@ -109,7 +110,7 @@ -- 'RealSrcSpan', getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] getDefiningBindings bs rss - = nameEnvElts + = nonDetNameEnvElts $ foldMap snd $ IM.dominators (realSrcSpanToInterval rss) $ getBindingSites bs @@ -121,7 +122,7 @@ getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyScope bs a b = filter (not . isSystemName . fst) - $ nameEnvElts + $ nonDetNameEnvElts $ foldMap snd $ IM.intersections (Interval a b) $ getLocalBindings bs @@ -133,7 +134,7 @@ -- `PositionMapping` getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyDefiningBindings bs a b - = nameEnvElts + = nonDetNameEnvElts $ foldMap snd $ IM.intersections (Interval a b) $ getBindingSites bs diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -28,8 +28,8 @@ import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import Ide.PluginUtils (toAbsolute) import OpenTelemetry.Eventlog (withSpan) -import System.Directory (makeAbsolute) import System.FilePath -- | An 'HscEnv' with equality. Two values are considered equal @@ -59,14 +59,13 @@ update <$> Unique.newUnique -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq cradlePath hscEnv0 deps = do +newHscEnvEq :: FilePath -> FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq root cradlePath hscEnv0 deps = do let relativeToCradle = (takeDirectory cradlePath ) hscEnv = removeImportPaths hscEnv0 -- Make Absolute since targets are also absolute - importPathsCanon <- - mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + let importPathsCanon = toAbsolute root . relativeToCradle <$> importPaths (hsc_dflags hscEnv0) newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps diff --git a/src/Development/IDE/Types/KnownTargets.hs b/src/Development/IDE/Types/KnownTargets.hs --- a/src/Development/IDE/Types/KnownTargets.hs +++ b/src/Development/IDE/Types/KnownTargets.hs @@ -1,6 +1,11 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where +module Development.IDE.Types.KnownTargets ( KnownTargets(..) + , emptyKnownTargets + , mkKnownTargets + , unionKnownTargets + , Target(..) + , toKnownFiles) where import Control.DeepSeq import Data.Hashable @@ -14,11 +19,53 @@ import GHC.Generics -- | A mapping of module name to known files -type KnownTargets = HashMap Target (HashSet NormalizedFilePath) +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 + +unionKnownTargets :: KnownTargets -> KnownTargets -> KnownTargets +unionKnownTargets (KnownTargets tm nm) (KnownTargets tm' nm') = + KnownTargets (HMap.unionWith (<>) tm tm') (HMap.union nm nm') + +mkKnownTargets :: [(Target, HashSet NormalizedFilePath)] -> KnownTargets +mkKnownTargets vs = KnownTargets (HMap.fromList vs) (HMap.fromList [(k,k) | (k,_) <- 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 + +instance Hashable KnownTargets where + hashWithSalt s (KnownTargets hm _) = hashWithSalt s hm + +emptyKnownTargets :: KnownTargets +emptyKnownTargets = KnownTargets HMap.empty HMap.empty + data Target = TargetModule ModuleName | TargetFile NormalizedFilePath deriving ( Eq, Ord, Generic, Show ) deriving anyclass (Hashable, NFData) toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath -toKnownFiles = HSet.unions . HMap.elems +toKnownFiles = HSet.unions . HMap.elems . targetMap diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -2,7 +2,6 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} - -- | Types and functions for working with source code locations. module Development.IDE.Types.Location ( Location(..) @@ -35,8 +34,6 @@ Range (..)) import qualified Language.LSP.Protocol.Types as LSP import Text.ParserCombinators.ReadP as ReadP - --- See Note [Guidelines For Using CPP In GHCIDE Import Statements] import GHC.Data.FastString import GHC.Types.SrcLoc as GHC diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -7,12 +7,12 @@ Value (..), ValueWithDiagnostics (..), Values, - Key (..), + Key, BadDependency (..), ShakeValue(..), currentValue, isBadDependency, - toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb) + toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb,WithHieDbShield(..)) where import Control.DeepSeq @@ -41,6 +41,9 @@ -- | Intended to represent HieDb calls wrapped with (currently) retry -- functionality type WithHieDb = forall a. (HieDb -> IO a) -> IO a + +-- used to smuggle RankNType WithHieDb through dbMVar +newtype WithHieDbShield = WithHieDbShield WithHieDb data Value v = Succeeded (Maybe FileVersion) v diff --git a/test/cabal/Development/IDE/Test/Runfiles.hs b/test/cabal/Development/IDE/Test/Runfiles.hs deleted file mode 100644 --- a/test/cabal/Development/IDE/Test/Runfiles.hs +++ /dev/null @@ -1,9 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Development.IDE.Test.Runfiles - ( locateGhcideExecutable - ) where - -locateGhcideExecutable :: IO FilePath -locateGhcideExecutable = pure "ghcide" diff --git a/test/data/multi-unit/b/B.hs b/test/data/multi-unit/b/B.hs --- a/test/data/multi-unit/b/B.hs +++ b/test/data/multi-unit/b/B.hs @@ -1,3 +1,3 @@ module B(module B) where -import A +import "a" A qux = foo diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs deleted file mode 100644 --- a/test/src/Development/IDE/Test.hs +++ /dev/null @@ -1,257 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} - -module Development.IDE.Test - ( Cursor - , cursorPosition - , requireDiagnostic - , diagnostic - , expectDiagnostics - , expectDiagnosticsWithTags - , expectNoMoreDiagnostics - , expectMessages - , expectCurrentDiagnostics - , checkDiagnosticsForDoc - , canonicalizeUri - , standardizeQuotes - , flushMessages - , waitForAction - , getInterfaceFilesDir - , garbageCollectDirtyKeys - , getFilesOfInterest - , waitForTypecheck - , waitForBuildQueue - , getStoredKeys - , waitForCustomMessage - , waitForGC - , configureCheckProject - , isReferenceReady - , referenceReady) where - -import Control.Applicative.Combinators -import Control.Lens hiding (List) -import Control.Monad -import Control.Monad.IO.Class -import Data.Aeson (toJSON) -import qualified Data.Aeson as A -import Data.Bifunctor (second) -import Data.Default -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) -import Data.Proxy -import Data.Text (Text) -import qualified Data.Text as T -import Development.IDE.Plugin.Test (TestRequest (..), - WaitForIdeRuleResult, - ideResultSuccess) -import Development.IDE.Test.Diagnostic -import GHC.TypeLits (symbolVal) -import Ide.Plugin.Config (CheckParents, checkProject) -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types -import Language.LSP.Test hiding (message) -import qualified Language.LSP.Test as LspTest -import System.Directory (canonicalizePath) -import System.FilePath (equalFilePath) -import System.Time.Extra -import Test.Tasty.HUnit - -requireDiagnosticM - :: (Foldable f, Show (f Diagnostic), HasCallStack) - => f Diagnostic - -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) - -> Assertion -requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of - Nothing -> pure () - Just err -> assertFailure err - --- |wait for @timeout@ seconds and report an assertion failure --- if any diagnostic messages arrive in that period -expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session () -expectNoMoreDiagnostics timeout = - expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do - let fileUri = diagsNot ^. L.params . L.uri - actual = diagsNot ^. L.params . L.diagnostics - unless (actual == []) $ liftIO $ - assertFailure $ - "Got unexpected diagnostics for " <> show fileUri - <> " got " - <> show actual - -expectMessages :: SMethod m -> Seconds -> (TServerMessage m -> Session ()) -> Session () -expectMessages m timeout handle = do - -- Give any further diagnostic messages time to arrive. - liftIO $ sleep timeout - -- Send a dummy message to provoke a response from the server. - -- This guarantees that we have at least one message to - -- process, so message won't block or timeout. - let cm = SMethod_CustomMethod (Proxy @"test") - i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount - go cm i - where - go cm i = handleMessages - where - handleMessages = (LspTest.message m >>= handle) <|> (void $ responseForId cm i) <|> ignoreOthers - ignoreOthers = void anyMessage >> handleMessages - -flushMessages :: Session () -flushMessages = do - let cm = SMethod_CustomMethod (Proxy @"non-existent-method") - i <- sendRequest cm A.Null - void (responseForId cm i) <|> ignoreOthers cm i - where - ignoreOthers cm i = skipManyTill anyMessage (responseForId cm i) >> flushMessages - --- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics, --- only that existing diagnostics have been cleared. --- --- Rather than trying to assert the absence of diagnostics, introduce an --- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. -expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () -expectDiagnostics - = expectDiagnosticsWithTags - . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) - -unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) -unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics) - -expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () -expectDiagnosticsWithTags expected = do - let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri - next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic - expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected - expectDiagnosticsWithTags' next expected' - -expectDiagnosticsWithTags' :: - (HasCallStack, MonadIO m) => - m (Uri, [Diagnostic]) -> - Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> - m () -expectDiagnosticsWithTags' next m | null m = do - (_,actual) <- next - case actual of - [] -> - return () - _ -> - liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual - -expectDiagnosticsWithTags' next expected = go expected - where - go m - | Map.null m = pure () - | otherwise = do - (fileUri, actual) <- next - canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri - case Map.lookup canonUri m of - Nothing -> do - liftIO $ - assertFailure $ - "Got diagnostics for " <> show fileUri - <> " but only expected diagnostics for " - <> show (Map.keys m) - <> " got " - <> show actual - Just expected -> do - liftIO $ mapM_ (requireDiagnosticM actual) expected - liftIO $ - unless (length expected == length actual) $ - assertFailure $ - "Incorrect number of diagnostics for " <> show fileUri - <> ", expected " - <> show expected - <> " but got " - <> show actual - go $ Map.delete canonUri m - -expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () -expectCurrentDiagnostics doc expected = do - diags <- getCurrentDiagnostics doc - checkDiagnosticsForDoc doc expected diags - -checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () -checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do - let expected' = Map.singleton nuri (map (\(ds, c, t) -> (ds, c, t, Nothing)) expected) - nuri = toNormalizedUri _uri - expectDiagnosticsWithTags' (return (_uri, obtained)) expected' - -canonicalizeUri :: Uri -> IO Uri -canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) - -diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics) -diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics - -tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) -tryCallTestPlugin cmd = do - let cm = SMethod_CustomMethod (Proxy @"test") - waitId <- sendRequest cm (A.toJSON cmd) - TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId - return $ case _result of - Left e -> Left e - Right json -> case A.fromJSON json of - A.Success a -> Right a - A.Error e -> error e - -callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b -callTestPlugin cmd = do - res <- tryCallTestPlugin cmd - case res of - Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err - Right a -> pure a - - -waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult -waitForAction key TextDocumentIdentifier{_uri} = - callTestPlugin (WaitForIdeRule key _uri) - -getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath -getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) - -garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String] -garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age) - -getStoredKeys :: Session [Text] -getStoredKeys = callTestPlugin GetStoredKeys - -waitForTypecheck :: TextDocumentIdentifier -> Session Bool -waitForTypecheck tid = ideResultSuccess <$> waitForAction "typecheck" tid - -waitForBuildQueue :: Session () -waitForBuildQueue = callTestPlugin WaitForShakeQueue - -getFilesOfInterest :: Session [FilePath] -getFilesOfInterest = callTestPlugin GetFilesOfInterest - -waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res -waitForCustomMessage msg pred = - skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params = value}) - | symbolVal p == T.unpack msg -> pred value - _ -> Nothing - -waitForGC :: Session [T.Text] -waitForGC = waitForCustomMessage "ghcide/GC" $ \v -> - case A.fromJSON v of - A.Success x -> Just x - _ -> Nothing - -configureCheckProject :: Bool -> Session () -configureCheckProject overrideCheckProject = setConfigSection "haskell" (toJSON $ def{checkProject = overrideCheckProject}) - --- | Pattern match a message from ghcide indicating that a file has been indexed -isReferenceReady :: FilePath -> Session () -isReferenceReady p = void $ referenceReady (equalFilePath p) - -referenceReady :: (FilePath -> Bool) -> Session FilePath -referenceReady pred = satisfyMaybe $ \case - FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) - | A.Success fp <- A.fromJSON _params - , pred fp - , symbolVal p == "ghcide/reference/ready" - -> Just fp - _ -> Nothing - diff --git a/test/src/Development/IDE/Test/Diagnostic.hs b/test/src/Development/IDE/Test/Diagnostic.hs deleted file mode 100644 --- a/test/src/Development/IDE/Test/Diagnostic.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Development.IDE.Test.Diagnostic where - -import Control.Lens ((^.)) -import qualified Data.Text as T -import GHC.Stack (HasCallStack) -import Language.LSP.Protocol.Lens -import Language.LSP.Protocol.Types - --- | (0-based line number, 0-based column number) -type Cursor = (UInt, UInt) - -cursorPosition :: Cursor -> Position -cursorPosition (line, col) = Position line col - -type ErrorMsg = String - -requireDiagnostic - :: (Foldable f, Show (f Diagnostic), HasCallStack) - => f Diagnostic - -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) - -> Maybe ErrorMsg -requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) - | any match actuals = Nothing - | otherwise = Just $ - "Could not find " <> show expected <> - " in " <> show actuals - where - match :: Diagnostic -> Bool - match d = - Just severity == _severity d - && cursorPosition cursor == d ^. range . start - && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` - standardizeQuotes (T.toLower $ d ^. message) - && hasTag expectedTag (d ^. tags) - - hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool - hasTag Nothing _ = True - hasTag (Just _) Nothing = False - hasTag (Just actualTag) (Just tags) = actualTag `elem` tags - -standardizeQuotes :: T.Text -> T.Text -standardizeQuotes msg = let - repl '‘' = '\'' - repl '’' = '\'' - repl '`' = '\'' - repl c = c - in T.map repl msg