diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 6de88abcc0..d4b7f8f9fb 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -269,7 +269,8 @@ newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a } -- to shut down the LSP. launchErrorLSP :: Recorder (WithPriority (Doc ())) -> T.Text -> IO () launchErrorLSP recorder errorMsg = do - let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) (IdePlugins []) + cwd <- getCurrentDirectory + let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) cwd (IdePlugins []) inH <- Main.argsHandleIn defaultArguments diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index b3b63fbaf5..80913da190 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -112,11 +112,11 @@ main = withTelemetryRecorder $ \telemetryRecorder -> do 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] diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 71688afd1d..d6092e9bbd 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -28,7 +29,7 @@ import Control.Monad import Control.Monad.Extra as Extra import Control.Monad.IO.Class import qualified Crypto.Hash.SHA1 as H -import Data.Aeson hiding (Error) +-- import Data.Aeson hiding (Error) import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B @@ -48,6 +49,7 @@ import Data.Proxy import qualified Data.Text as T import Data.Time.Clock import Data.Version +import Debug.Trace (traceM) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, knownTargets, withHieDb) @@ -60,7 +62,7 @@ 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.Graph (Action, alwaysRerun) import qualified Development.IDE.Session.Implicit as GhcIde import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics @@ -94,25 +96,37 @@ import System.Info import Control.Applicative (Alternative ((<|>))) import Data.Void -import Control.Concurrent.STM.Stats (atomically, modifyTVar', - readTVar, writeTVar) +import Control.Concurrent.STM (STM) +import Control.Concurrent.STM.Stats (TVar, atomically, + modifyTVar', newTVar, + newTVarIO, readTVar, + readTVarIO, stateTVar, + swapTVar, writeTVar) import Control.Concurrent.STM.TQueue import Control.DeepSeq import Control.Exception (evaluate) import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Aeson (ToJSON (toJSON)) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as Set +import Data.Traversable (for) import Database.SQLite.Simple +import Development.IDE (RuleResult, Rules, + getFileExists) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Session.Diagnostics (renderCradleError) -import Development.IDE.Types.Shake (WithHieDb, toNoFileKey) +import Development.IDE.Types.Shake (Key, WithHieDb, + toNoFileKey) import HieDb.Create import HieDb.Types import HieDb.Utils +import Ide.PluginUtils (toAbsolute) import qualified System.Random as Random import System.Random (RandomGen) +import qualified UnliftIO as UnliftIO -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -121,6 +135,9 @@ import qualified Data.Set as OS import qualified Development.IDE.GHC.Compat.Util as Compat import GHC.Data.Graph.Directed +import Control.Monad.Cont (ContT (ContT, runContT), + cont, evalContT, runCont) +import Control.Monad.Trans.Class (lift) import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types @@ -130,7 +147,9 @@ import GHC.Unit.State #endif data Log + = LogSettingInitialDynFlags + | LogShake Shake.Log | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) | LogGetInitialGhcLibDirDefaultCradleNone | LogHieDbRetry !Int !Int !Int !SomeException @@ -149,10 +168,15 @@ data Log | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged + | LogCacheVersion NormalizedFilePath !Int + | LogClearingCache !NormalizedFilePath deriving instance Show Log + instance Pretty Log where pretty = \case + LogClearingCache path -> + "Clearing cache for" <+> pretty (fromNormalizedFilePath path) LogNoneCradleFound path -> "None cradle found for" <+> pretty path <+> ", ignoring the file" LogSettingInitialDynFlags -> @@ -221,6 +245,9 @@ instance Pretty Log where LogHieBios msg -> pretty msg LogSessionLoadingChanged -> "Session Loading config changed, reloading the full session." + LogShake msg -> pretty msg + LogCacheVersion path version -> + "Cache version for" <+> pretty (fromNormalizedFilePath path) <+> "is" <+> pretty version -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -370,48 +397,73 @@ makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> Hie makeWithHieDbRetryable recorder rng hieDb f = retryOnSqliteBusy recorder rng (f hieDb) --- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for --- 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 - -- use non-deterministic seed because maybe multiple HLS start at same time - -- and send bursts of requests - rng <- Random.newStdGen - -- Delete the database if it has an incompatible schema version - retryOnSqliteBusy - recorder - rng - (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) - - withHieDb fp $ \writedb -> do - -- the type signature is necessary to avoid concretizing the tyvar - -- e.g. `withWriteDbRetryable initConn` without type signature will - -- instantiate tyvar `a` to `()` - let withWriteDbRetryable :: WithHieDb - withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb - withWriteDbRetryable initConn - - chan <- newTQueueIO - - withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do - withHieDb fp (\readDb -> k (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 - -- TODO: probably should let exceptions be caught/logged/handled by top level handler - l withHieDbRetryable + +data ThreadRun input threadResource resource arg = ThreadRun { + tCreateResource :: + input -- ^ input of running + -> (threadResource -> resource -> IO ()) -- ^ function to run with reader resource + -> IO (), + tRunner -- ^ run a single action with writer resource + :: input -- ^ input of running + -> threadResource -- ^ writer resource + -> arg -- ^ argument to run + -> IO () +} + +runWithThreadRun :: ThreadRun input threadResource resource arg -> input -> (resource -> TQueue arg -> IO ()) -> IO () +runWithThreadRun ThreadRun{..} ip f = do + tCreateResource ip $ \w r -> do + q <- newTQueueIO + withAsync (writerThread w q) $ \_ -> f r q + where + writerThread r q = + forever $ do + l <- atomically $ readTQueue q + tRunner ip r l +newtype HieDbAction = HieDbAction { runHieDbAction :: WithHieDb } +sessionRestartRun :: ThreadRun (Recorder (WithPriority Log)) () () (IO ()) +sessionRestartRun = ThreadRun { + tRunner = \recorder _ _ -> do + logWith recorder Debug LogSessionLoadingChanged + , + tCreateResource = \_ f -> do f () () +} + + +dbThreadRun :: + ThreadRun + (Recorder (WithPriority Log), FilePath) + HieDbAction + HieDbAction + (((HieDb -> IO a) -> IO a) -> IO ()) +dbThreadRun = ThreadRun { + tRunner = \(recorder, _fp) withWriter l -> l (runHieDbAction withWriter) `Safe.catch` \e@SQLError{} -> do logWith recorder Error $ LogHieDbWriterThreadSQLiteError e `Safe.catchAny` \f -> do logWith recorder Error $ LogHieDbWriterThreadException f + , + tCreateResource = \(recorder, fp) f -> do + rng <- Random.newStdGen + retryOnSqliteBusy + recorder + rng + (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) + evalContT $ do + writedb <- ContT $ withHieDb fp + readDb <- ContT $ withHieDb fp + let withWriteDbRetryable :: WithHieDb + withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb + liftIO $ withWriteDbRetryable initConn + lift $ f (HieDbAction withWriteDbRetryable) (HieDbAction (makeWithHieDbRetryable recorder rng readDb)) +} +-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for +-- 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 = runWithThreadRun dbThreadRun (recorder, fp) (\db chan -> k (runHieDbAction db) chan) getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do @@ -434,55 +486,193 @@ getHieDbLoc dir = do -- 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 (WithPriority Log) -> FilePath -> IO (Rules (), Action IdeGhcSession) loadSession recorder = loadSessionWithOptions recorder def -loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do +type instance RuleResult HieYaml = (IdeResult HscEnvEq, [FilePath], [NormalizedFilePath], [Key]) + +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Rules (), Action IdeGhcSession) +loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do + let toAbsolutePath = toAbsolute rootDir cradle_files <- newIORef [] -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file - hscEnvs <- newVar Map.empty :: IO (Var HieMap) + hscEnvs <- newTVarIO Map.empty :: IO (TVar HieMap) -- Mapping from a Filepath to HscEnv - fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) + fileToFlags <- newTVarIO Map.empty :: IO (TVar FlagsMap) -- Mapping from a Filepath to its 'hie.yaml' location. -- Should hold the same Filepaths as 'fileToFlags', otherwise -- they are inconsistent. So, everywhere you modify 'fileToFlags', -- you have to modify 'filesMap' as well. - filesMap <- newVar HM.empty :: IO (Var FilesMap) + filesMap <- newTVarIO HM.empty :: IO (TVar FilesMap) + -- Version of the mappings above - version <- newVar 0 + version <- newTVarIO 0 + restartKeys <- newTVarIO [] + -- version of the whole rebuild + cacheVersion <- newTVarIO 0 + cradleLock <- newMVar () biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) - let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) - -- This caches the mapping from Mod.hs -> hie.yaml - cradleLoc <- liftIO $ memoIO $ \v -> do - res <- findCradle v - -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path - -- try and normalise that - -- e.g. see https://github.com/haskell/ghcide/issues/126 - res' <- traverse makeAbsolute 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 = do - void $ modifyVar' version succ - return $ toNoFileKey GhcSessionIO - IdeOptions{ optTesting = IdeTesting optTesting - , optCheckProject = getCheckProject - , optExtensions - } <- getIdeOptions + let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readTVarIO version) + + + let clearCache = do + atomically $ modifyTVar' restartKeys ([toNoFileKey SessionCacheVersion] ++) + atomically $ modifyTVar' cacheVersion succ + atomically $ modifyTVar' hscEnvs $ \_ -> Map.empty + atomically $ modifyTVar' fileToFlags $ \_ -> Map.empty + atomically $ modifyTVar' filesMap $ \_ -> HM.empty + let + -- | We allow users to specify a loading strategy. + -- Check whether this config was changed since the last time we have loaded + -- a session. + -- + -- If the loading configuration changed, we likely should restart the session + -- in its entirety. + -- todo install it as a rule + didSessionLoadingPreferenceConfigChange :: Action Bool + didSessionLoadingPreferenceConfigChange = do + clientConfig <- getClientConfigAction + mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar + case mLoadingConfig of + Nothing -> do + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure False + Just loadingConfig -> do + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure (loadingConfig /= sessionLoading clientConfig) + + let typecheckAll cfps' = + mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) + +-- let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) +-- -> Action (IdeResult HscEnvEq,[FilePath]) + let session args@(hieYaml, _cfp, _opts, _libDir) = do + ShakeExtras{knownTargetsVar, ideNc} <- getShakeExtras + IdeOptions{optExtensions } <- getIdeOptions + hscEnv <- liftIO $ emptyHscEnv ideNc _libDir + (new_deps, old_deps) <- packageSetup args $ const (return ()) + -- For each component, now make a new HscEnvEq which contains the + -- HscEnv for the hie.yaml file but the DynFlags for that component + -- For GHC's supporting multi component sessions, we create a shared + -- HscEnv but set the active component accordingly + all_target_details <- liftIO $ newComponentCache recorder optExtensions hieYaml _cfp hscEnv old_deps new_deps rootDir + this_dep_info <- liftIO $ getDependencyInfo $ maybeToList hieYaml + -- this should be added to deps + let (all_targets, this_flags_map, this_options) + = case HM.lookup _cfp flags_map' of + Just this -> (all_targets', flags_map', this) + Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) + where all_targets' = concat all_target_details + flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] + this_flags = (this_error_env, this_dep_info) + this_error_env = ([this_error], Nothing) + this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp + $ T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ] + (keys1, knownTargets) <- extendKnownTargets all_targets + (hasUpdate, keys2) <- liftIO $ atomically $ do + modifyTVar' fileToFlags $ Map.insert hieYaml this_flags_map + modifyTVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + known <- readTVar knownTargetsVar + let known' = flip mapHashed known $ \k -> + HM.unionWith (<>) k $ HM.fromList knownTargets + hasUpdate = if known /= known' then Just (unhashed known') else Nothing + writeTVar knownTargetsVar known' + keys2 <- invalidateShakeCache + pure (hasUpdate, keys2) + -- The VFS doesn't change on cradle edits, re-use the old one. + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + for_ hasUpdate $ \x -> + logWith recorder Debug $ LogKnownFilesUpdated x + -- Typecheck all files in the project on startup + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + let (x, y) = this_options + return (x, Map.keys y, cfps', [keys1, keys2]) + + -- Create a new HscEnv from a hieYaml root and a set of options + packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) + -> (([ComponentInfo], [ComponentInfo]) -> STM ()) -> Action ([ComponentInfo], [ComponentInfo]) + packageSetup (hieYaml, cfp, opts, libDir) cont = do + ShakeExtras{ideNc} <- getShakeExtras + -- Parse DynFlags for the newly discovered component + hscEnv <- liftIO $ emptyHscEnv ideNc libDir + newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir + let deps = componentDependencies opts ++ maybeToList hieYaml + dep_info <- liftIO $ getDependencyInfo deps + -- Now lookup to see whether we are combining with an existing HscEnv + -- or making a new one. The lookup returns the HscEnv and a list of + -- information about other components loaded into the HscEnv + -- (unitId, DynFlag, Targets) + -- move hscEnvs + hieDirRoot <- liftIO $ getCacheDirsRoot + liftIO $ atomically $ do + result <- stateTVar hscEnvs $ \m -> do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newTargetDfs + all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps + -- Get all the unit-ids for things in this component + _inplace = map rawComponentUnitId $ NE.toList all_deps + + let all_deps' = flip fmap all_deps $ \RawComponentInfo{..} -> + -- Remove all inplace dependencies from package flags for + -- components in this HscEnv + let (df2, uids) = +#if MIN_VERSION_ghc(9,3,0) + (rawComponentDynFlags, []) +#else + _removeInplacePackages fakeUid _inplace rawComponentDynFlags +#endif + prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + hscComponents = sort $ map show uids + cacheDirOpts = hscComponents ++ componentOptions opts + cacheDirs = getCacheDirsWithRoot hieDirRoot prefix cacheDirOpts + processed_df = setCacheDirs cacheDirs df2 + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + in ComponentInfo + { componentUnitId = rawComponentUnitId + , componentDynFlags = processed_df + , componentInternalUnits = uids + , componentTargets = rawComponentTargets + , componentFP = rawComponentFP + , componentCOptions = rawComponentCOptions + , componentDependencyInfo = rawComponentDependencyInfo + } + -- Modify the map so the hieYaml now maps to the newly updated + -- ComponentInfos + -- Returns + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + let (new,old) = NE.splitAt (NE.length new_deps) all_deps' + ((new,old), Map.insert hieYaml (NE.toList all_deps) m) + cont result + return result -- populate the knownTargetsVar with all the -- files in the project so that `knownFiles` can learn about them and -- we can generate a complete module graph - let extendKnownTargets newTargets = do - knownTargets <- concatForM newTargets $ \TargetDetails{..} -> + extendKnownTargets newTargets = do + knownTargets <- concatForM newTargets $ \TargetDetails{..} -> case targetTarget of TargetFile f -> do -- If a target file has multiple possible locations, then we @@ -499,255 +689,148 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- If we don't generate a TargetFile for each potential location, we will only have -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' -- and also not find 'TargetModule Foo'. - fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + fs <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) TargetModule _ -> do - found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + found <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations return [(targetTarget, Set.fromList found)] - hasUpdate <- atomically $ do - known <- readTVar knownTargetsVar - let known' = flip mapHashed known $ \k -> - HM.unionWith (<>) k $ HM.fromList knownTargets - hasUpdate = if known /= known' then Just (unhashed known') else Nothing - writeTVar knownTargetsVar known' - pure hasUpdate - for_ hasUpdate $ \x -> - logWith recorder Debug $ LogKnownFilesUpdated x - return $ toNoFileKey GetKnownTargets - - -- Create a new HscEnv from a hieYaml root and a set of options - let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ([ComponentInfo], [ComponentInfo]) - 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) - let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps - -- Now lookup to see whether we are combining with an existing HscEnv - -- or making a new one. The lookup returns the HscEnv and a list of - -- information about other components loaded into the HscEnv - -- (unitId, DynFlag, Targets) - modifyVar hscEnvs $ \m -> do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newTargetDfs - all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps - -- Get all the unit-ids for things in this component - _inplace = map rawComponentUnitId $ NE.toList all_deps - - all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do - -- Remove all inplace dependencies from package flags for - -- components in this HscEnv -#if MIN_VERSION_ghc(9,3,0) - let (df2, uids) = (rawComponentDynFlags, []) -#else - let (df2, uids) = _removeInplacePackages fakeUid _inplace rawComponentDynFlags -#endif - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - let hscComponents = sort $ map show uids - cacheDirOpts = hscComponents ++ componentOptions opts - cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs recorder cacheDirs df2 - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo - { componentUnitId = rawComponentUnitId - , componentDynFlags = processed_df - , componentInternalUnits = uids - , componentTargets = rawComponentTargets - , componentFP = rawComponentFP - , componentCOptions = rawComponentCOptions - , componentDependencyInfo = rawComponentDependencyInfo - } - -- Modify the map so the hieYaml now maps to the newly updated - -- ComponentInfos - -- Returns - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - let (new,old) = NE.splitAt (NE.length new_deps) all_deps' - pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) - - - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (IdeResult HscEnvEq,[FilePath]) - session args@(hieYaml, _cfp, _opts, _libDir) = do - (new_deps, old_deps) <- packageSetup args - - -- For each component, now make a new HscEnvEq which contains the - -- HscEnv for the hie.yaml file but the DynFlags for that component - -- For GHC's supporting multi component sessions, we create a shared - -- 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 - - this_dep_info <- getDependencyInfo $ maybeToList hieYaml - let (all_targets, this_flags_map, this_options) - = case HM.lookup _cfp flags_map' of - Just this -> (all_targets', flags_map', this) - Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) - where all_targets' = concat all_target_details - flags_map' = HM.fromList (concatMap toFlagsMap all_targets') - this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] - this_flags = (this_error_env, this_dep_info) - this_error_env = ([this_error], Nothing) - this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp - $ T.unlines - [ "No cradle target found. Is this file listed in the targets of your cradle?" - , "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)) - -- The VFS doesn't change on cradle edits, re-use the old one. - -- 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 - unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - - return $ second Map.keys this_options - - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - consultCradle hieYaml cfp = do - lfpLog <- flip makeRelative cfp <$> getCurrentDirectory - 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 - - 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 <> ")" - eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ + return (toNoFileKey GetKnownTargets, knownTargets) + + + -- -- This caches the mapping from hie.yaml + Mod.hs -> [String] + -- -- Returns the Ghc session and the cradle dependencies + -- consultCradle :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) + consultCradle cfp = do + clientConfig <- getClientConfigAction + ShakeExtras{lspEnv, restartShakeSession } <- getShakeExtras + IdeOptions{ optTesting = IdeTesting optTesting, optCheckProject = getCheckProject } <- getIdeOptions + hieYamlOld <- use_ CradleLoc cfp + cachedHieYamlLocation <- join <$> liftIO (HM.lookup cfp <$> readTVarIO filesMap) + let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld) + let lfpLog = makeRelative rootDir (fromNormalizedFilePath cfp) + logWith recorder Info $ LogCradlePath lfpLog + when (isNothing hieYaml) $ + logWith recorder Warning $ LogCradleNotFound lfpLog + cradle <- liftIO $ loadCradle recorder hieYaml rootDir + when optTesting $ mRunLspT lspEnv $ + sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON $ fromNormalizedFilePath 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 lfpLog <> ")" + eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do - addTag "file" lfp - old_files <- readIORef cradle_files - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files + addTag "file" lfpLog + old_files <- liftIO $ readIORef cradle_files + res <- liftIO $ cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle (fromNormalizedFilePath cfp) old_files addTag "result" (show res) return res - logWith recorder Debug $ LogSessionLoadingResult eopts - 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) - -- Failure case, either a cradle error or the none cradle - Left err -> do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) - - let - -- | We allow users to specify a loading strategy. - -- Check whether this config was changed since the last time we have loaded - -- a session. - -- - -- If the loading configuration changed, we likely should restart the session - -- in its entirety. - didSessionLoadingPreferenceConfigChange :: IO Bool - didSessionLoadingPreferenceConfigChange = do - mLoadingConfig <- readVar biosSessionLoadingVar - case mLoadingConfig of - Nothing -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure False - Just loadingConfig -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure (loadingConfig /= sessionLoading clientConfig) - - -- This caches the mapping from hie.yaml + Mod.hs -> [String] - -- Returns the Ghc session and the cradle dependencies - let sessionOpts :: (Maybe FilePath, FilePath) - -> IO (IdeResult HscEnvEq, [FilePath]) - sessionOpts (hieYaml, file) = do - Extra.whenM didSessionLoadingPreferenceConfigChange $ do - logWith recorder Info LogSessionLoadingChanged - -- If the dependencies are out of date then clear both caches and start - -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) - -- Don't even keep the name cache, we start from scratch here! - modifyVar_ hscEnvs (const (return Map.empty)) - - v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags - cfp <- makeAbsolute file - case HM.lookup (toNormalizedFilePath' cfp) v of - Just (opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di - if not deps_ok - then do - -- If the dependencies are out of date then clear both caches and start - -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) - -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) - consultCradle hieYaml cfp - else return (opts, Map.keys old_di) - Nothing -> consultCradle hieYaml cfp - + logWith recorder Debug $ LogSessionLoadingResult eopts + + result <-do + -- clear cache if the cradle is changed + checkCache cfp $ + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right (opts, libDir) -> do + installationCheck <- liftIO $ ghcVersionChecker libDir + case installationCheck of + InstallationNotFound{..} -> + error $ "GHC installation not found in libdir: " <> libdir + InstallationMismatch{..} -> + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) + InstallationChecked _compileTime _ghcLibCheck -> do + UnliftIO.wait =<< (UnliftIO.async $ ( do + liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) + result@(_, _, files, keys) <- session (hieYaml, cfp, opts, libDir) + liftIO $ when (notNull files || notNull keys) $ do + checkProject <- getCheckProject + -- think of not to restart a second time + restartShakeSession VFSUnmodified "new component" + (if checkProject then return (typecheckAll files) else mempty) + (pure keys) + return result)) + -- Failure case, either a cradle error or the none cradle + Left err -> do + dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) + let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) + liftIO $ atomically $ do + modifyTVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) + modifyTVar' filesMap $ HM.insert cfp hieYaml + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) + return result + + sessionCacheVersionRule :: Rules () + sessionCacheVersionRule = defineNoFile (cmapWithPrio LogShake recorder) $ \SessionCacheVersion -> do + alwaysRerun + v <- liftIO $ readTVarIO cacheVersion + pure v + + hieYamlRule :: Rules () + hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> Just <$> hieYamlRuleImpl file + + + checkCache file run = do + hieYaml <- use_ CradleLoc file + -- check the reason we are called + v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) + res <- case HM.lookup file v of + -- we already have the cache but it is still called, it must be deps changed + -- clear the cache and reconsult + -- we bump the version of the cache to inform others + Just (opts, old_di) -> do + -- need to differ two kinds of invocation, one is the file is changed + -- other is the cache version bumped + deps_ok <- liftIO $ checkDependencyInfo old_di + if not deps_ok + then do + logWith recorder Debug $ LogClearingCache file + liftIO clearCache + return Nothing + else do + return $ Just (opts, Map.keys old_di, [], []) + Nothing -> return Nothing + maybe run return res + + hieYamlRuleImpl file = checkCache file $ consultCradle file + where + catchError file hieYaml f = + f `Safe.catch` \e -> do + -- install dep so it can be recorvered + mapM_ addDependency hieYaml + return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml, [], []) + addDependency fp = do + -- VSCode uses absolute paths in its filewatch notifications + let nfp = toNormalizedFilePath' fp + itExists <- getFileExists nfp + when itExists $ void $ do use_ GetModificationTime nfp + + cradleLocRule :: Rules () + cradleLocRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do + res <- liftIO $ HieBios.findCradle $ fromNormalizedFilePath file + -- 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 + return $ Just (normalise . toAbsolutePath <$> res) + + invalidateShakeCache = do + void $ modifyTVar' version succ + return $ toNoFileKey GhcSessionIO + return (cradleLocRule <> hieYamlRule <> sessionCacheVersionRule, do -- The main function which gets options for a file. We only want one of these running -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - getOptions file = do - ncfp <- toNormalizedFilePath' <$> makeAbsolute 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 + -- do + -- only one cradle consult at a time + -- we need to find a way to get rid of the (files, keys) + _opts@(a, b, _files, _keys) <- (hieYamlRuleImpl file) + pure (a, fmap toAbsolutePath b) + ) + -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the @@ -814,19 +897,20 @@ fromTargetId :: [FilePath] -- ^ import paths -> TargetId -> IdeResult HscEnvEq -> DependencyInfo + -> FilePath -> IO [TargetDetails] -- For a target module we consider all the import paths -fromTargetId is exts (GHC.TargetModule modName) env dep = do +fromTargetId is exts (GHC.TargetModule modName) env dep dir = do let fps = [i moduleNameSlashes modName -<.> ext <> boot | ext <- exts , i <- is , boot <- ["", "-boot"] ] - locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps + let locs = fmap (toNormalizedFilePath' . toAbsolute dir) 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 +fromTargetId _ _ (GHC.TargetFile f _) env deps dir = do + let nf = toNormalizedFilePath' $ toAbsolute dir f let other | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") @@ -915,8 +999,9 @@ newComponentCache -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components + -> FilePath -- ^ root dir -> 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. @@ -932,7 +1017,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do #if MIN_VERSION_ghc(9,3,0) let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs + multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) "" . T.pack . Compat.printWithoutUniques) closure_errs bad_units = OS.fromList $ concat $ do x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs DriverHomePackagesNotClosed us <- pure x @@ -961,7 +1046,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do 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 @@ -986,7 +1071,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) evaluate $ liftRnf rwhnf $ componentTargets ci - let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends + let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends dir ctargets <- concatMapM mk (componentTargets ci) return (L.nubOrdOn targetTarget ctargets) @@ -1046,14 +1131,17 @@ should be filtered out, such that we dont have to re-compile everything. -- | Set the cache-directory based on the ComponentOptions and a list of -- internal packages. -- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags -setCacheDirs recorder CacheDirs{..} dflags = do - logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) - pure $ dflags +setCacheDirs :: CacheDirs -> DynFlags -> DynFlags +setCacheDirs CacheDirs{..} dflags = do + dflags & maybe id setHiDir hiCacheDir & maybe id setHieDir hieCacheDir & maybe id setODir oCacheDir +-- tug this into shake later +-- we can make rule to build all the map +-- we can then make a rule to build each entry in the map + -- See Note [Multi Cradle Dependency Info] type DependencyInfo = Map.Map FilePath (Maybe UTCTime) type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] @@ -1063,6 +1151,17 @@ type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResu -- It aims to be the reverse of 'FlagsMap'. type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath) +-- file1 -> hie1.yaml -> (opts, deps) +-- file2 -> hie1.yaml -> (opts, deps) +-- file3 -> hie1.yaml -> (opts, deps) +-- if some new file4 should be in hie1.yaml, + -- we need to recompute the hie1.yaml + +-- hieRule file +-- get corresponding hie.yaml + + + -- This is pristine information about a component data RawComponentInfo = RawComponentInfo { rawComponentUnitId :: UnitId @@ -1102,6 +1201,7 @@ data ComponentInfo = ComponentInfo } -- | Check if any dependency has been modified lately. +-- it depend on the last result checkDependencyInfo :: DependencyInfo -> IO Bool checkDependencyInfo old_di = do di <- getDependencyInfo (Map.keys old_di) @@ -1145,23 +1245,6 @@ _removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ where (uids, ps) = Compat.filterInplaceUnits us (packageFlags df) --- | Memoize an IO function, with the characteristics: --- --- * If multiple people ask for a result simultaneously, make sure you only compute it once. --- --- * If there are exceptions, repeatedly reraise them. --- --- * If the caller is aborted (async exception) finish computing it anyway. -memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b) -memoIO op = do - ref <- newVar Map.empty - return $ \k -> join $ mask_ $ modifyVar ref $ \mp -> - case Map.lookup k mp of - Nothing -> do - res <- onceFork $ op k - return (Map.insert k res mp, res) - Just res -> return (mp, res) - unit_flags :: [Flag (CmdLineP [String])] unit_flags = [defFlag "unit" (SepArg addUnit)] @@ -1171,8 +1254,8 @@ addUnit unit_str = liftEwM $ do 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 -> m (NonEmpty (DynFlags, [GHC.Target])) +setOptions cfp (ComponentOptions theOpts compRoot _) dflags dir = do ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) case NE.nonEmpty units of Just us -> initMulti us @@ -1195,7 +1278,7 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do -- -- 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 dir (fromNormalizedFilePath cfp) let special_target = Compat.mkSimpleTarget df abs_fp pure $ (df, special_target : targets) :| [] where @@ -1276,6 +1359,19 @@ getCacheDirsDefault prefix opts = do -- GHC options will create incompatible interface files. opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) +getCacheDirsRoot :: IO String +getCacheDirsRoot = getXdgDirectory XdgCache cacheDir + +getCacheDirsWithRoot :: String -> String -> [String] -> CacheDirs +getCacheDirsWithRoot root prefix opts = do + let dir = Just (root prefix ++ "-" ++ opts_hash) + CacheDirs dir dir dir + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) + + -- | Sub directory for the cache path cacheDir :: String cacheDir = "ghcide" @@ -1326,6 +1422,6 @@ showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwo ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." ] -renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) +renderPackageSetupException :: NormalizedFilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) renderPackageSetupException fp e = - ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) fp (T.pack $ showPackageSetupException e) diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index 15cee28f04..547ac9a115 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -31,7 +31,7 @@ import Development.IDE.Core.Shake as X (FastResult (..), defineNoDiagnostics, getClientConfig, getPluginConfigAction, - ideLogger, + ideLogger, rootDir, runIdeAction, shakeExtras, use, useNoFile, diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 605420d3b6..b56eaba2be 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -492,6 +492,19 @@ data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic) instance Hashable AddWatchedFile instance NFData AddWatchedFile +data CradleLoc = CradleLoc deriving (Eq, Show, Typeable, Generic) +instance Hashable CradleLoc +instance NFData CradleLoc +type instance RuleResult CradleLoc = Maybe FilePath + +data HieYaml = HieYaml deriving (Eq, Show, Typeable, Generic) +instance Hashable HieYaml +instance NFData HieYaml + +data SessionCacheVersion = SessionCacheVersion deriving (Eq, Show, Typeable, Generic) +instance Hashable SessionCacheVersion +instance NFData SessionCacheVersion +type instance RuleResult SessionCacheVersion = Int -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule. @@ -499,7 +512,7 @@ instance NFData AddWatchedFile type instance RuleResult GhcSessionIO = IdeGhcSession data IdeGhcSession = IdeGhcSession - { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + { loadSessionFun :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) -- ^ Returns the Ghc session and the cradle dependencies , sessionVersion :: !Int -- ^ Used as Shake key, versions must be unique and not reused diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 5b975ef058..1fcda9099d 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -164,8 +164,7 @@ import Language.LSP.Server (LspT) 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) @@ -179,6 +178,8 @@ import GHC (mgModSummaries) #if MIN_VERSION_ghc(9,3,0) import qualified Data.IntMap as IM +import HIE.Bios (findCradle) +import System.FilePath (normalise) #endif @@ -192,6 +193,7 @@ data Log | LogTypecheckedFOI !NormalizedFilePath deriving Show + instance Pretty Log where pretty = \case LogShake msg -> pretty msg @@ -719,13 +721,13 @@ loadGhcSession recorder ghcSessionDepsConfig = do defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO - (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file + -- loading is always returning a absolute path now + (val,deps) <- loadSessionFun 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 +855,7 @@ getModIfaceFromDiskAndIndexRule recorder = 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) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index cdb5ba72cb..f59d0b4afa 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -67,8 +67,9 @@ initialise :: Recorder (WithPriority Log) -> WithHieDb -> IndexQueue -> Monitoring + -> FilePath -> 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 +87,12 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with 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/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 2b95df4ed0..21ac5f9e19 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -22,7 +22,7 @@ -- 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, IdeRule, IdeResult, @@ -535,6 +535,7 @@ data IdeState = IdeState ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) ,stopMonitoring :: IO () + ,rootDir :: FilePath } @@ -623,11 +624,12 @@ shakeOpen :: Recorder (WithPriority Log) -> ShakeOptions -> Monitoring -> Rules () + -> FilePath -> IO IdeState shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) - withHieDb indexQueue opts monitoring rules = mdo + withHieDb indexQueue opts monitoring rules rootDir = mdo #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2a4994f5b9..de8eb3a6ab 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -127,14 +127,15 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh setupLSP :: forall config err. Recorder (WithPriority Log) + -> FilePath -- ^ 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 -> IndexQueue -> 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 @@ -177,7 +178,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do -- 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 @@ -186,19 +187,22 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do handleInit :: Recorder (WithPriority Log) + -> FilePath -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> 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 + 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 diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 7424b4b371..2967c174de 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -208,7 +208,7 @@ commandP plugins = data Arguments = Arguments - { argsProjectRoot :: Maybe FilePath + { argsProjectRoot :: FilePath , argCommand :: Command , argsRules :: Rules () , argsHlsPlugins :: IdePlugins IdeState @@ -226,9 +226,9 @@ data Arguments = Arguments , 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 fp plugins = Arguments + { argsProjectRoot = fp , argCommand = LSP , argsRules = mainRule (cmapWithPrio LogRules recorder) def , argsGhcidePlugin = mempty @@ -271,11 +271,11 @@ defaultArguments recorder plugins = Arguments } -testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments -testing recorder plugins = +testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments +testing recorder fp plugins = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = - defaultArguments recorder plugins + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = + defaultArguments recorder fp plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] @@ -326,22 +326,18 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState + let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState getIdeState env rootPath withHieDb hieChan = do - traverse_ IO.setCurrentDirectory rootPath 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 + (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -360,17 +356,18 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins - rules + (rules <> sessionLoaderRule) (Just env) debouncer ideOptions withHieDb hieChan 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 @@ -388,7 +385,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re 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 -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error @@ -411,14 +408,14 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re 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 + (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir 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 <> sessionLoaderRule) Nothing debouncer ideOptions hiedb hieChan mempty dir shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -436,7 +433,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re 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 @@ -446,17 +443,17 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re 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 "." + (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." 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 <> sessionLoaderRule) Nothing debouncer ideOptions hiedb hieChan mempty root shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 502c265077..ddd5a2e214 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -28,8 +28,8 @@ import Development.IDE.GHC.Error (catchSrcErrors) 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,14 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do 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) + mapM (return . toAbsolute root) $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs index 0d92dbe136..078281d391 100644 --- a/ghcide/test/exe/BootTests.hs +++ b/ghcide/test/exe/BootTests.hs @@ -16,6 +16,7 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test +import System.FilePath (()) import Test.Hls.FileSystem (toAbsFp) import Test.Tasty import Test.Tasty.HUnit @@ -24,7 +25,7 @@ import Test.Tasty.HUnit tests :: TestTree tests = testGroup "boot" [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir `toAbsFp` "C.hs" + let cPath = dir "C.hs" cSource <- liftIO $ readFileUtf8 cPath -- Dirty the cache liftIO $ runInDir dir $ do @@ -51,6 +52,6 @@ tests = testGroup "boot" let floc = mkR 9 0 9 1 checkDefs locs (pure [floc]) , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do - _ <- openDoc (dir `toAbsFp` "A.hs") "haskell" + _ <- openDoc (dir "A.hs") "haskell" expectNoMoreDiagnostics 2 ] diff --git a/ghcide/test/exe/CPPTests.hs b/ghcide/test/exe/CPPTests.hs index da9f564fe4..91a59adc76 100644 --- a/ghcide/test/exe/CPPTests.hs +++ b/ghcide/test/exe/CPPTests.hs @@ -9,14 +9,14 @@ import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokensEdit (..), mkRange) import Language.LSP.Test -- import Test.QuickCheck.Instances () +import Config import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "cpp" - [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do + [ testCase "cpp-error" $ do let content = T.unlines [ "{-# LANGUAGE CPP #-}", @@ -32,7 +32,7 @@ tests = let _ = e :: HUnitFailure run $ expectError content (2, 1) ) - , testSessionWait "cpp-ghcide" $ do + , testWithDummyPluginEmpty "cpp-ghcide" $ do _ <- createDoc "A.hs" "haskell" $ T.unlines ["{-# LANGUAGE CPP #-}" ,"main =" diff --git a/ghcide/test/exe/ClientSettingsTests.hs b/ghcide/test/exe/ClientSettingsTests.hs index 6d964d3542..698e0af165 100644 --- a/ghcide/test/exe/ClientSettingsTests.hs +++ b/ghcide/test/exe/ClientSettingsTests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} module ClientSettingsTests (tests) where +import Config (lspTestCaps, testWithConfig) import Control.Applicative.Combinators import Control.Monad import Data.Aeson (toJSON) @@ -14,13 +15,14 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import Test.Hls (waitForProgressDone) +import Test.Hls (testConfigCaps, + waitForProgressDone) import Test.Tasty import TestUtils tests :: TestTree tests = testGroup "client settings handling" - [ testSession "ghcide restarts shake session on config changes" $ do + [ testWithConfig "ghcide restarts shake session on config changes" def {testConfigCaps = lspTestCaps} $ do setIgnoringLogNotifications False void $ createDoc "A.hs" "haskell" "module A where" waitForProgressDone diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index 6bebeda002..c5f320f5c7 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -2,6 +2,7 @@ module CodeLensTests (tests) where +import Config import Control.Applicative.Combinators import Control.Lens ((^.)) import Control.Monad (void) @@ -18,10 +19,9 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import Test.Hls (waitForProgressDone) +import Test.Hls (mkRange, waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "code lenses" @@ -46,7 +46,7 @@ addSigLensesTests = after' enableGHCWarnings exported (def, sig) others = T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]] - sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do + sigSession testName enableGHCWarnings waitForDiags mode exported def others = testWithDummyPluginEmpty testName $ do let originalCode = before enableGHCWarnings exported def others let expectedCode = after' enableGHCWarnings exported def others setConfigSection "haskell" (createConfig mode) @@ -100,7 +100,7 @@ addSigLensesTests = [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) [] , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) [] ] - , testSession "keep stale lens" $ do + , testWithDummyPluginEmpty "keep stale lens" $ do let content = T.unlines [ "module Stale where" , "f = _" diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 0a7751fc4b..8297436781 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -11,33 +11,37 @@ module Config( , testWithDummyPluginEmpty , testWithDummyPlugin' , testWithDummyPluginEmpty' - , testWithDummyPluginAndCap' + , testWithConfig + , testWithExtraFiles , runWithExtraFiles , runInDir - , testWithExtraFiles + , run - -- * utilities for testing definition and hover + -- * utilities for testing , Expect(..) , pattern R , mkR , checkDefs , mkL + , withLongTimeout , lspTestCaps , lspTestCapsNoFileWatches ) where +import Control.Exception (bracket_) import Control.Lens.Setter ((.~)) import Data.Foldable (traverse_) import Data.Function ((&)) import qualified Data.Text as T +import Development.IDE (Pretty) import Development.IDE.Test (canonicalizeUri) import Ide.Types (defaultPluginDescriptor) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types (Null (..)) +import System.Environment.Blank (setEnv, unsetEnv) import System.FilePath (()) import Test.Hls import qualified Test.Hls.FileSystem as FS -import Test.Hls.FileSystem (FileSystem, fsRoot) testDataDir :: FilePath testDataDir = "ghcide" "test" "data" @@ -52,37 +56,50 @@ dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dum runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin -runWithDummyPlugin' :: FS.VirtualFileTree -> (FileSystem -> Session a) -> IO a -runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin +testWithConfig :: String -> TestConfig () -> Session () -> TestTree +testWithConfig name conf s = testCase name $ runSessionWithTestConfig conf $ const s -runWithDummyPluginAndCap' :: ClientCapabilities -> (FileSystem -> Session ()) -> IO () -runWithDummyPluginAndCap' cap = runSessionWithServerAndCapsInTmpDirCont def dummyPlugin cap (mkIdeTestFs []) - -testWithDummyPluginAndCap' :: String -> ClientCapabilities -> (FileSystem -> Session ()) -> TestTree -testWithDummyPluginAndCap' caseName cap = testCase caseName . runWithDummyPluginAndCap' cap +runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a +runWithDummyPlugin' fs = runSessionWithTestConfig def { + testPluginDescriptor = dummyPlugin + , testDirLocation = Right fs + , testConfigCaps = lspTestCaps + , testShiftRoot = True + } testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const -testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FileSystem -> Session ()) -> TestTree +testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FilePath -> Session ()) -> TestTree testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs testWithDummyPluginEmpty :: String -> Session () -> TestTree testWithDummyPluginEmpty caseName = testWithDummyPlugin caseName $ mkIdeTestFs [] -testWithDummyPluginEmpty' :: String -> (FileSystem -> Session ()) -> TestTree +testWithDummyPluginEmpty' :: String -> (FilePath -> Session ()) -> TestTree testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs [] -runWithExtraFiles :: String -> (FileSystem -> Session a) -> IO a +runWithExtraFiles :: String -> (FilePath -> Session a) -> IO a runWithExtraFiles dirName action = do let vfs = mkIdeTestFs [FS.copyDir dirName] runWithDummyPlugin' vfs action -testWithExtraFiles :: String -> String -> (FileSystem -> Session ()) -> TestTree +testWithExtraFiles :: String -> String -> (FilePath -> Session ()) -> TestTree testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFiles dirName action -runInDir :: FileSystem -> Session a -> IO a -runInDir fs = runSessionWithServerNoRootLock False dummyPlugin def def def (fsRoot fs) +runInDir :: FilePath -> Session a -> IO a +runInDir fs = runSessionWithServer def dummyPlugin fs + +testSession' :: TestName -> (FilePath -> Session ()) -> TestTree +testSession' name = testCase name . run' + +run :: Session a -> IO a +run = runSessionWithTestConfig def + {testDirLocation=Right (mkIdeTestFs []), testPluginDescriptor=dummyPlugin} + . const + +run' :: (FilePath -> Session a) -> IO a +run' = runSessionWithTestConfig def {testDirLocation=Right (mkIdeTestFs []), testPluginDescriptor=dummyPlugin} pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') @@ -146,3 +163,6 @@ lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) N lspTestCapsNoFileWatches :: ClientCapabilities lspTestCapsNoFileWatches = lspTestCaps & L.workspace . traverse . L.didChangeWatchedFiles .~ Nothing + +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index 196bea95e6..ca922d53cc 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -25,13 +25,14 @@ import Language.LSP.Test import System.FilePath import System.IO.Extra hiding (withTempDir) -- import Test.QuickCheck.Instances () +import Config import Config (checkDefs, mkL) import Control.Lens ((^.)) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import GHC.TypeLits (symbolVal) +import Test.Hls (ignoreForGhcVersions) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree @@ -40,17 +41,17 @@ tests = testGroup "cradle" ,testGroup "ignore-fatal" [ignoreFatalWarning] ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] ,testGroup "multi" (multiTests "multi") - ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2" + ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2" $ testGroup "multi-unit" (multiTests "multi-unit") ,testGroup "sub-directory" [simpleSubDirectoryTest] - ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2" + ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2" $ testGroup "multi-unit-rexport" [multiRexportTest] ] loadCradleOnlyonce :: TestTree loadCradleOnlyonce = testGroup "load cradle only once" - [ testSession' "implicit" implicit - , testSession' "direct" direct + [ testWithDummyPluginEmpty' "implicit" implicit + , testWithDummyPluginEmpty' "direct" direct ] where direct dir = do @@ -70,7 +71,7 @@ loadCradleOnlyonce = testGroup "load cradle only once" liftIO $ length msgs @?= 0 retryFailedCradle :: TestTree -retryFailedCradle = testSession' "retry failed" $ \dir -> do +retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do -- The false cradle always fails let hieContents = "cradle: {bios: {shell: \"false\"}}" hiePath = dir "hie.yaml" @@ -124,7 +125,7 @@ multiTestName :: FilePath -> String -> String multiTestName dir name = "simple-" ++ dir ++ "-" ++ name simpleMultiTest :: FilePath -> TestTree -simpleMultiTest variant = testCase (multiTestName variant "test") $ withLongTimeout $ runWithExtraFiles variant $ \dir -> do +simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtraFiles variant $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" adoc <- openDoc aPath "haskell" @@ -201,7 +202,7 @@ multiRexportTest = expectNoMoreDiagnostics 0.5 sessionDepsArePickedUp :: TestTree -sessionDepsArePickedUp = testSession' +sessionDepsArePickedUp = testWithDummyPluginEmpty' "session-deps-are-picked-up" $ \dir -> do liftIO $ diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index dc55ff80d3..fe67647155 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -4,7 +4,6 @@ module DependentFileTest (tests) where import Config -import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Development.IDE.Test (expectDiagnostics) import Development.IDE.Types.Location @@ -15,19 +14,23 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import Test.Hls.FileSystem (FileSystem, toAbsFp) -import Test.Tasty +import Test.Hls + tests :: TestTree tests = testGroup "addDependentFile" - [testGroup "file-changed" [testWithDummyPluginEmpty' "test" test] + [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def + {testShiftRoot=True + , testDirLocation=Right (mkIdeTestFs []) + , testPluginDescriptor = dummyPlugin + } test] ] where - test :: FileSystem -> Session () - test dir = do + test :: FilePath -> Session () + test _ = do -- If the file contains B then no type error -- otherwise type error - let depFilePath = toAbsFp dir "dep-file.txt" + let depFilePath = "dep-file.txt" liftIO $ writeFile depFilePath "A" let fooContent = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" @@ -35,8 +38,8 @@ tests = testGroup "addDependentFile" , "import Language.Haskell.TH.Syntax" , "foo :: Int" , "foo = 1 + $(do" - , " qAddDependentFile \"dep-file.txt\"" - , " f <- qRunIO (readFile \"dep-file.txt\")" + , " qAddDependentFile \"" <> T.pack depFilePath <> "\"" + , " f <- qRunIO (readFile \"" <> T.pack depFilePath <> "\")" , " if f == \"B\" then [| 1 |] else lift f)" ] let bazContent = T.unlines ["module Baz where", "import Foo ()"] @@ -47,7 +50,7 @@ tests = testGroup "addDependentFile" -- Now modify the dependent file liftIO $ writeFile depFilePath "B" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams - [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] + [FileEvent (filePathToUri depFilePath) FileChangeType_Changed ] -- Modifying Baz will now trigger Foo to be rebuilt as well let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 1c5adff70d..52dbb5068b 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -36,10 +36,10 @@ import Control.Monad.Extra (whenJust) import Data.Default (def) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import System.Time.Extra -import Test.Hls (runSessionWithServerInTmpDirCont, +import Test.Hls (TestConfig (testConfigCaps, testDirLocation, testDisableKick, testPluginDescriptor), + runSessionWithTestConfig, waitForProgressBegin) -import Test.Hls.FileSystem (directCradle, file, text, - toAbsFp) +import Test.Hls.FileSystem (directCradle, file, text) import Test.Tasty import Test.Tasty.HUnit @@ -169,7 +169,13 @@ tests = testGroup "diagnostics" let contentA = T.unlines [ "module ModuleA where" ] _ <- createDoc "ModuleA.hs" "haskell" contentA expectDiagnostics [("ModuleB.hs", [])] - , testWithDummyPluginAndCap' "add missing module (non workspace)" lspTestCapsNoFileWatches $ \tmpDir -> do + , testCase "add missing module (non workspace)" $ + runSessionWithTestConfig def { + testPluginDescriptor = dummyPlugin + , testConfigCaps = lspTestCapsNoFileWatches + , testDirLocation = Right (mkIdeTestFs []) + } + $ \tmpDir -> do -- By default lsp-test sends FileWatched notifications for all files, which we don't want -- as non workspace modules will not be watched by the LSP server. -- To work around this, we tell lsp-test that our client doesn't have the @@ -178,11 +184,11 @@ tests = testGroup "diagnostics" [ "module ModuleB where" , "import ModuleA ()" ] - _ <- createDoc (tmpDir `toAbsFp` "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir `toAbsFp` "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB + expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc (tmpDir `toAbsFp` "ModuleA.hs") "haskell" contentA - expectDiagnostics [(tmpDir `toAbsFp` "ModuleB.hs", [])] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] , testWithDummyPluginEmpty "cyclic module dependency" $ do let contentA = T.unlines [ "module ModuleA where" @@ -452,9 +458,9 @@ tests = testGroup "diagnostics" ) ] , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" - aPath = dir `toAbsFp` "A.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" + aPath = dir "A.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int @@ -574,8 +580,13 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r expectNoMoreDiagnostics 0.5 where - -- similar to run except it disables kick - runTestNoKick s = runSessionWithServerInTmpDirCont True dummyPlugin def def def (mkIdeTestFs []) (const s) + runTestNoKick s = + runSessionWithTestConfig def { + testPluginDescriptor = dummyPlugin + , testDirLocation = Right (mkIdeTestFs []) + , testDisableKick = True + } $ const s + typeCheck doc = do WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ assertBool "The file should typecheck" ideResultSuccess diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 6d19891978..6c08f7ecba 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -7,20 +7,17 @@ import Control.Lens import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A +import Data.Default (Default (..)) import Data.Text as T import Development.IDE.Core.Shake (IdeState (..)) import qualified Development.IDE.LSP.Notifications as Notifications -import qualified Development.IDE.Main as IDE import Development.IDE.Plugin.HLS (toResponseError) -import Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Options import GHC.Base (coerce) import Ide.Logger (Recorder, WithPriority, cmapWithPrio) import Ide.Plugin.Error import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) -import Ide.PluginUtils (idePluginsToPluginDesc, - pluginDescToIdePlugins) +import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -31,28 +28,32 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import LogType (Log (..)) -import Test.Hls (waitForProgressDone) +import Test.Hls (TestConfig (testDisableDefaultPlugin, testPluginDescriptor), + runSessionWithTestConfig, + testCheckProject, + testConfigSession, + waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit -import TestUtils -tests :: Recorder (WithPriority Log) -> TestTree -tests recorder = do +tests :: TestTree +tests = do testGroup "Exceptions and PluginError" [ testGroup "Testing that IO Exceptions are caught in..." [ testCase "PluginHandlers" $ do let pluginId = "plugin-handler-exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do _ <- liftIO $ throwIO DivideByZero pure (InL []) ] - }] - testIde recorder (testingLite recorder plugins) $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False + } $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) case lens of Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> @@ -63,15 +64,16 @@ tests recorder = do , testCase "Commands" $ do let pluginId = "command-exception" commandId = CommandId "exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginCommands = [ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do _ <- liftIO $ throwIO DivideByZero pure (InR Null) ] - }] - testIde recorder (testingLite recorder plugins) $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) @@ -85,7 +87,8 @@ tests recorder = do , testCase "Notification Handlers" $ do let pluginId = "notification-exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> @@ -95,8 +98,8 @@ tests recorder = do [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do pure (InL []) ] - }] - testIde recorder (testingLite recorder plugins) $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -108,37 +111,18 @@ tests recorder = do _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens] , testGroup "Testing PluginError order..." - [ pluginOrderTestCase recorder "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") - , pluginOrderTestCase recorder "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") - , pluginOrderTestCase recorder "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) + [ pluginOrderTestCase "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") + , pluginOrderTestCase "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") + , pluginOrderTestCase "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) ] ] -testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> IDE.Arguments -testingLite recorder plugins = - let - arguments@IDE.Arguments{ argsIdeOptions } = - IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) plugins - hlsPlugins = pluginDescToIdePlugins $ - idePluginsToPluginDesc plugins - ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - ++ [Test.blockCommandDescriptor "block-command", Test.plugin] - ideOptions config sessionLoader = - let - defOptions = argsIdeOptions config sessionLoader - in - defOptions{ optTesting = IdeTesting True } - in - arguments - { IDE.argsHlsPlugins = hlsPlugins - , IDE.argsIdeOptions = ideOptions - } - -pluginOrderTestCase :: Recorder (WithPriority Log) -> TestName -> PluginError -> PluginError -> TestTree -pluginOrderTestCase recorder msg err1 err2 = +pluginOrderTestCase :: TestName -> PluginError -> PluginError -> TestTree +pluginOrderTestCase msg err1 err2 = testCase msg $ do let pluginId = "error-order-test" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do @@ -146,8 +130,8 @@ pluginOrderTestCase recorder msg err1 err2 = ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do throwError err2 ] - }] - testIde recorder (testingLite recorder plugins) $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) diff --git a/ghcide/test/exe/GarbageCollectionTests.hs b/ghcide/test/exe/GarbageCollectionTests.hs index 31b705c0f3..8c0c428c1a 100644 --- a/ghcide/test/exe/GarbageCollectionTests.hs +++ b/ghcide/test/exe/GarbageCollectionTests.hs @@ -1,5 +1,6 @@ module GarbageCollectionTests (tests) where +import Config (testWithDummyPluginEmpty') import Control.Monad.IO.Class (liftIO) import qualified Data.Set as Set import qualified Data.Text as T @@ -13,20 +14,19 @@ import Language.LSP.Test import System.FilePath import Test.Tasty import Test.Tasty.HUnit -import TestUtils import Text.Printf (printf) tests :: TestTree tests = testGroup "garbage collection" [ testGroup "dirty keys" - [ testSession' "are collected" $ \dir -> do + [ testWithDummyPluginEmpty' "are collected" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" doc <- generateGarbage "A" dir closeDoc doc garbage <- waitForGC liftIO $ assertBool "no garbage was found" $ not $ null garbage - , testSession' "are deleted from the state" $ \dir -> do + , testWithDummyPluginEmpty' "are deleted from the state" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir keys0 <- getStoredKeys @@ -36,7 +36,7 @@ tests = testGroup "garbage collection" keys1 <- getStoredKeys liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) - , testSession' "are not regenerated unless needed" $ \dir -> do + , testWithDummyPluginEmpty' "are not regenerated unless needed" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" docA <- generateGarbage "A" dir _docB <- generateGarbage "B" dir @@ -57,7 +57,7 @@ tests = testGroup "garbage collection" Set.intersection (Set.fromList garbage) (Set.fromList keysB) liftIO $ regeneratedKeys @?= mempty - , testSession' "regenerate successfully" $ \dir -> do + , testWithDummyPluginEmpty' "regenerate successfully" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir closeDoc docA diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs index 24d5115f3a..90d27c445b 100644 --- a/ghcide/test/exe/IfaceTests.hs +++ b/ghcide/test/exe/IfaceTests.hs @@ -35,9 +35,9 @@ tests = testGroup "Interface loading tests" -- | test that TH reevaluates across interfaces ifaceTHTest :: TestTree ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do - let aPath = dir `toAbsFp` "THA.hs" - bPath = dir `toAbsFp` "THB.hs" - cPath = dir `toAbsFp` "THC.hs" + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () _bSource <- liftIO $ readFileUtf8 bPath -- a :: () @@ -58,8 +58,8 @@ ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do ifaceErrorTest :: TestTree ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do configureCheckProject True - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int @@ -106,8 +106,8 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do ifaceErrorTest2 :: TestTree ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int @@ -140,8 +140,8 @@ ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do ifaceErrorTest3 :: TestTree ifaceErrorTest3 = testWithExtraFiles "iface-error-test-3" "recomp" $ \dir -> do - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index 16e4e4b6f4..6192a8aeed 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -87,7 +87,7 @@ tests = withResource acquire release tests where innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" acquire :: IO (TResponseMessage Method_Initialize) - acquire = runWithDummyPlugin (mkIdeTestFs []) initializeResponse + acquire = run initializeResponse release :: TResponseMessage Method_Initialize -> IO () release = mempty diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 8c6f876f39..558115fc24 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -114,5 +114,5 @@ main = do , ReferenceTests.tests , GarbageCollectionTests.tests , HieDbRetry.tests - , ExceptionTests.tests recorder + , ExceptionTests.tests ] diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index 3bafb0b20d..a1d6d8a0f7 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -26,7 +26,9 @@ import qualified Data.Aeson as A import Data.Default (def) import Data.Tuple.Extra import GHC.TypeLits (symbolVal) +import Ide.PluginUtils (toAbsolute) import Ide.Types +import System.FilePath (isAbsolute, ()) import Test.Hls (FromServerMessage' (..), SMethod (..), TCustomMessage (..), @@ -167,13 +169,14 @@ getReferences' (file, l, c) includeDeclaration = do -referenceTestSession :: String -> FilePath -> [FilePath] -> Session () -> TestTree +referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree referenceTestSession name thisDoc docs' f = do testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do + let rootDir = fs "" -- needed to build whole project indexing configureCheckProject True -- need to get the real paths through links - docs <- mapM (liftIO . canonicalizePath . toAbsFp fs) $ delete thisDoc $ nubOrd docs' + docs <- mapM (liftIO . canonicalizePath . (fs )) $ delete thisDoc $ nubOrd docs' -- Initial Index docid <- openDoc thisDoc "haskell" @@ -187,23 +190,23 @@ referenceTestSession name thisDoc docs' f = do doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) loop (delete doc docs) loop docs - f + f rootDir closeDoc docid -- | Given a location, lookup the symbol and all references to it. Make sure -- they are the ones we expect. referenceTest :: (HasCallStack) => String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ do + referenceTestSession name (fst3 loc) docs $ \rootDir -> do actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` expected + liftIO $ expectSameLocations rootDir actual expected where docs = map fst3 expected type SymbolLocation = (FilePath, UInt, UInt) -expectSameLocations :: (HasCallStack) => [Location] -> [SymbolLocation] -> Assertion -expectSameLocations actual expected = do +expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion +expectSameLocations rootDir actual expected = do let actual' = Set.map (\location -> (location ^. L.uri , location ^. L.range . L.start . L.line . Lens.to fromIntegral @@ -211,7 +214,7 @@ expectSameLocations actual expected = do $ Set.fromList actual expected' <- Set.fromList <$> (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file + fp <- canonicalizePath $ toAbsolute rootDir file return (filePathToUri fp, l, c)) actual' @?= expected' diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs index dd27a966de..61c2ef49f3 100644 --- a/ghcide/test/exe/THTests.hs +++ b/ghcide/test/exe/THTests.hs @@ -1,6 +1,7 @@ module THTests (tests) where +import Config import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Development.IDE.GHC.Util @@ -16,14 +17,13 @@ import Test.Hls (waitForAllProgressDone, waitForProgressBegin) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "TemplateHaskell" [ -- Test for https://github.com/haskell/ghcide/pull/212 - testSessionWait "load" $ do + testWithDummyPluginEmpty "load" $ do let sourceA = T.unlines [ "{-# LANGUAGE PackageImports #-}", @@ -46,7 +46,7 @@ tests = _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ] - , testSessionWait "newtype-closure" $ do + , testWithDummyPluginEmpty "newtype-closure" $ do let sourceA = T.unlines [ "{-# LANGUAGE DeriveDataTypeable #-}" @@ -70,11 +70,11 @@ tests = , thReloadingTest False , thLoadingTest , thCoreTest - , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True + , thReloadingTest True -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 , thLinkingTest False - , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True - , testSessionWait "findsTHIdentifiers" $ do + , thLinkingTest True + , testWithDummyPluginEmpty "findsTHIdentifiers" $ do let sourceA = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 0b9ce03eb2..87c129ba2f 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -195,18 +195,3 @@ copyTestDataFiles dir prefix = do withLongTimeout :: IO a -> IO a withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - withTempDir $ \dir -> do - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps dir session diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs index 4900b7cae4..1e8ac4214a 100644 --- a/ghcide/test/exe/UnitTests.hs +++ b/ghcide/test/exe/UnitTests.hs @@ -1,6 +1,7 @@ module UnitTests (tests) where +import Config (mkIdeTestFs) import Control.Concurrent import Control.Monad.IO.Class (liftIO) import Data.IORef @@ -30,7 +31,9 @@ import Network.URI import qualified Progress import System.IO.Extra hiding (withTempDir) import System.Mem (performGC) -import Test.Hls (waitForProgressDone) +import Test.Hls (IdeState, def, + runSessionWithServerInTmpDir, + waitForProgressDone) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit @@ -72,7 +75,9 @@ tests recorder = do expected `isInfixOf` shown , testCase "notification handlers run in priority order" $ do orderRef <- newIORef [] - let plugins = pluginDescToIdePlugins $ + let + plugins ::Recorder (WithPriority Ghcide.Log) -> IdePlugins IdeState + plugins recorder = pluginDescToIdePlugins $ [ (priorityPluginDescriptor i) { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> @@ -80,10 +85,10 @@ tests recorder = do ] } | i <- [1..20] - ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) + ] ++ Ghcide.descriptors recorder priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i} - testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) plugins) $ do + runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone actualOrder <- liftIO $ reverse <$> readIORef orderRef diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 92bcc694ab..8d58d70a81 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -654,6 +654,7 @@ library hls-retrie-plugin , text , transformers , unordered-containers + , filepath default-extensions: DataKinds diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs index ba303cdb99..9bd416935e 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -49,7 +49,7 @@ import Development.IDE.Graph.Classes import System.IO.Unsafe -newtype Key = UnsafeMkKey Int +newtype Key = UnsafeMkKey Int deriving (NFData) pattern Key :: () => (Typeable a, Hashable a, Show a) => a -> Key pattern Key a <- (lookupKeyValue -> KeyValue a _) diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index a5f8d7ba54..9f365eeb35 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -32,6 +32,8 @@ module Ide.PluginUtils usePropertyLsp, -- * Escape unescape, + -- * toAbsolute + toAbsolute ) where @@ -50,6 +52,7 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types import Language.LSP.Server +import System.FilePath (isAbsolute, ()) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Text.Megaparsec.Char.Lexer as P @@ -316,3 +319,10 @@ escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) inside' = concatMap f inside pure $ "\"" <> inside' <> "\"" + +-- --------------------------------------------------------------------- + +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute dir file + | isAbsolute file = file + | otherwise = dir file diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index cebf06629b..f284f8088d 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -46,6 +46,7 @@ library , ghcide == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens + , lsp , lsp-test ^>=0.17 , lsp-types ^>=2.2 , safe-exceptions diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 92bd49ac13..ad0dec8342 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -4,6 +4,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -25,19 +28,12 @@ module Test.Hls goldenWithHaskellDocFormatterInTmpDir, goldenWithCabalDocFormatter, goldenWithCabalDocFormatterInTmpDir, + goldenWithTestConfig, def, -- * Running HLS for integration tests runSessionWithServer, - runSessionWithServerAndCaps, runSessionWithServerInTmpDir, - runSessionWithServerAndCapsInTmpDir, - runSessionWithServerNoRootLock, - runSessionWithServer', - runSessionWithServerInTmpDir', - -- continuation version that take a FileSystem - runSessionWithServerInTmpDirCont, - runSessionWithServerInTmpDirCont', - runSessionWithServerAndCapsInTmpDirCont, + runSessionWithTestConfig, -- * Helpful re-exports PluginDescriptor, IdeState, @@ -63,6 +59,7 @@ module Test.Hls WithPriority(..), Recorder, Priority(..), + TestConfig(..), ) where @@ -79,7 +76,7 @@ import Data.Aeson (Result (Success), toJSON) import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) -import Data.Default (def) +import Data.Default (Default, def) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (Proxy)) @@ -87,7 +84,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState, - LoggingColumn (ThreadIdColumn)) + LoggingColumn (ThreadIdColumn), + defaultLayoutOptions, + layoutPretty, renderStrict) +import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.Main hiding (Log) import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), @@ -104,16 +104,23 @@ import Ide.Logger (Pretty (pretty), logWith, makeDefaultStderrRecorder, (<+>)) +import qualified Ide.Logger as Logger +import Ide.Plugin.Properties ((&)) +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types hiding (Null) +import qualified Language.LSP.Server as LSP import Language.LSP.Test import Prelude hiding (log) import System.Directory (canonicalizePath, createDirectoryIfMissing, getCurrentDirectory, getTemporaryDirectory, + makeAbsolute, setCurrentDirectory) import System.Environment (lookupEnv, setEnv) import System.FilePath @@ -201,7 +208,34 @@ goldenWithHaskellAndCaps -> TestTree goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) - $ runSessionWithServerAndCaps config plugin clientCaps testDataDir + $ runSessionWithTestConfig def { + testDirLocation = Left testDataDir, + testConfigCaps = clientCaps, + testLspConfig = config, + testPluginDescriptor = plugin + } + $ const +-- runSessionWithServerAndCaps config plugin clientCaps testDataDir + $ TL.encodeUtf8 . TL.fromStrict + <$> do + doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue + act doc + documentContents doc + +goldenWithTestConfig + :: Pretty b + => TestConfig b + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithTestConfig config title testDataDir path desc ext act = + goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithTestConfig config $ const $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" @@ -223,7 +257,13 @@ goldenWithHaskellAndCapsInTmpDir -> TestTree goldenWithHaskellAndCapsInTmpDir config clientCaps plugin title tree path desc ext act = goldenGitDiff title (vftOriginalRoot tree path <.> desc <.> ext) - $ runSessionWithServerAndCapsInTmpDir config plugin clientCaps tree + $ + runSessionWithTestConfig def { + testDirLocation = Right tree, + testConfigCaps = clientCaps, + testLspConfig = config, + testPluginDescriptor = plugin + } $ const $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" @@ -375,6 +415,7 @@ hlsPluginTestRecorder = initializeTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "H initializeTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a)) initializeTestRecorder envVars = do docWithPriorityRecorder <- makeDefaultStderrRecorder (Just $ ThreadIdColumn : defaultLoggingColumns) + -- lspClientLogRecorder -- There are potentially multiple environment variables that enable this logger definedEnvVars <- forM envVars (fmap (fromMaybe "0") . lookupEnv) let logStdErr = any (/= "0") definedEnvVars @@ -389,70 +430,15 @@ initializeTestRecorder envVars = do -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a -runSessionWithServerInTmpDir config plugin tree act = runSessionWithServerInTmpDirCont' config plugin tree (const act) - -runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a -runSessionWithServerAndCapsInTmpDir config plugin caps tree act = runSessionWithServerAndCapsInTmpDirCont config plugin caps tree (const act) - -runSessionWithServerInTmpDirCont' :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> (FileSystem -> Session a) -> IO a -runSessionWithServerInTmpDirCont' config plugin tree act = do - runSessionWithServerInTmpDirCont False plugin config def fullCaps tree act - -runSessionWithServerAndCapsInTmpDirCont :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> (FileSystem -> Session a) -> IO a -runSessionWithServerAndCapsInTmpDirCont config plugin caps tree act = do - runSessionWithServerInTmpDirCont False plugin config def caps tree act - -runSessionWithServerInTmpDir' :: - Pretty b => - -- | Plugins to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - VirtualFileTree -> - Session a -> IO a -runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = runSessionWithServerInTmpDirCont False plugins conf sessConf caps tree (const act) +runSessionWithServerInTmpDir config plugin tree act = + runSessionWithTestConfig def + {testLspConfig=config, testPluginDescriptor = plugin, testDirLocation=Right tree} + (const act) --- | Host a server, and run a test session on it. --- --- Creates a temporary directory, and materializes the VirtualFileTree --- in the temporary directory. --- --- To debug test cases and verify the file system is correctly set up, --- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. --- Further, we log the temporary directory location on startup. To view --- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. --- --- Example invocation to debug test cases: --- --- @ --- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test --- @ --- --- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. --- --- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. --- --- Note: cwd will be shifted into a temporary directory in @Session a@ -runSessionWithServerInTmpDirCont :: - Pretty b => - -- | whether we disable the kick action or not - Bool -> - -- | Plugins to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - VirtualFileTree -> - (FileSystem -> Session a) -> IO a -runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = withLock lockForTempDirs $ do +runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) -> IO a +runWithLockInTempDir tree act = withLock lockForTempDirs $ do testRoot <- setupTestEnvironment helperRecorder <- hlsHelperTestRecorder - -- Do not clean up the temporary directory if this variable is set to anything but '0'. -- Aids debugging. cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" @@ -468,23 +454,34 @@ runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act a <- action tempDir `finally` cleanup logWith helperRecorder Debug LogCleanup pure a - runTestInDir $ \tmpDir' -> do -- we canonicalize the path, so that we do not need to do -- cannibalization during the test when we compare two paths tmpDir <- canonicalizePath tmpDir' logWith helperRecorder Info $ LogTestDir tmpDir fs <- FS.materialiseVFT tmpDir tree - runSessionWithServer' disableKick plugins conf sessConf caps tmpDir (act fs) + act fs runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a -runSessionWithServer config plugin fp act = do - runSessionWithServer' False plugin config def fullCaps fp act - -runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a -runSessionWithServerAndCaps config plugin caps fp act = do - runSessionWithServer' False plugin config def caps fp act - +runSessionWithServer config plugin fp act = + runSessionWithTestConfig def { + testLspConfig=config + , testPluginDescriptor=plugin + , testDirLocation = Left fp + } (const act) + +instance Default (TestConfig b) where + def = TestConfig { + testDirLocation = Right $ VirtualFileTree [] "", + testShiftRoot = False, + testDisableKick = False, + testDisableDefaultPlugin = False, + testPluginDescriptor = mempty, + testLspConfig = def, + testConfigSession = def, + testConfigCaps = fullCaps, + testCheckProject = False + } -- | Setup the test environment for isolated tests. -- @@ -617,60 +614,79 @@ lock = unsafePerformIO newLock lockForTempDirs :: Lock lockForTempDirs = unsafePerformIO newLock --- | Host a server, and run a test session on it --- Note: cwd will be shifted into @root@ in @Session a@ --- notice this function should only be used in tests that --- require to be nested in the same temporary directory --- use 'runSessionWithServerInTmpDir' for other cases -runSessionWithServerNoRootLock :: - (Pretty b) => - -- | whether we disable the kick action or not - Bool -> - -- | Plugin to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - FilePath -> - Session a -> - IO a -runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = do +data TestConfig b = TestConfig + { + testDirLocation :: Either FilePath VirtualFileTree + -- ^ The file tree to use for the test, either a directory or a virtual file tree + + -- if using a virtual file tree, + -- Creates a temporary directory, and materializes the VirtualFileTree + -- in the temporary directory. + -- + -- To debug test cases and verify the file system is correctly set up, + -- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. + -- Further, we log the temporary directory location on startup. To view + -- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. + -- Example invocation to debug test cases: + -- + -- @ + -- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test + -- @ + -- + -- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. + -- + -- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. + , testShiftRoot :: Bool + -- ^ Whether to shift the current directory to the root of the project + , testDisableKick :: Bool + -- ^ Whether to disable the kick action + , testDisableDefaultPlugin :: Bool + -- ^ Whether to disable the default plugin comes with ghcide + , testCheckProject :: Bool + -- ^ Whether to disable the default plugin comes with ghcide + , testPluginDescriptor :: PluginTestDescriptor b + -- ^ Plugin to load on the server. + , testLspConfig :: Config + -- ^ lsp config for the server + , testConfigSession :: SessionConfig + -- ^ config for the test session + , testConfigCaps :: ClientCapabilities + -- ^ Client capabilities + } + + +wrapClientLogger :: Pretty a => Recorder (WithPriority a) -> + IO (Recorder (WithPriority a), LSP.LanguageContextEnv Config -> IO ()) +wrapClientLogger logger = do + (lspLogRecorder', cb1) <- Logger.withBacklog Logger.lspClientLogRecorder + let lspLogRecorder = cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions. pretty) lspLogRecorder' + return (lspLogRecorder <> logger, cb1) + +-- | Host a server, and run a test session on it. +-- For detail of the test configuration, see 'TestConfig' +runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a +runSessionWithTestConfig TestConfig{..} session = + runSessionInVFS testDirLocation $ \root -> shiftRoot root $ do (inR, inW) <- createPipe (outR, outW) <- createPipe - recorder <- hlsPluginTestRecorder - let plugins = pluginsDp recorder - recorderIde <- hlsHelperTestRecorder - - let - sconf' = sconf { lspConfig = hlsConfigToClientConfig conf } - - hlsPlugins = IdePlugins [Test.blockCommandDescriptor "block-command"] <> plugins - - arguments@Arguments{ argsIdeOptions } = - testing (cmapWithPrio LogIDEMain recorderIde) hlsPlugins - - ideOptions config ghcSession = - let defIdeOptions = argsIdeOptions config ghcSession - in defIdeOptions - { optTesting = IdeTesting True - , optCheckProject = pure False - } - + (recorder, cb1) <- wrapClientLogger =<< hlsPluginTestRecorder + (recorderIde, cb2) <- wrapClientLogger =<< hlsHelperTestRecorder + -- This plugin just installs a handler for the `initialized` notification, which then + -- picks up the LSP environment and feeds it to our recorders + let lspRecorderPlugin = pluginDescToIdePlugins [(defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin") + { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do + env <- LSP.getLspEnv + liftIO $ (cb1 <> cb2) env + }] + + let plugins = testPluginDescriptor recorder <> lspRecorderPlugin + let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig } + arguments = testingArgs root recorderIde plugins server <- async $ IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) - arguments - { argsHandleIn = pure inR - , argsHandleOut = pure outW - , argsDefaultHlsConfig = conf - , argsIdeOptions = ideOptions - , argsProjectRoot = Just root - , argsDisableKick = disableKick - } - - x <- runSessionWithHandles inW outR sconf' caps root s + arguments { argsHandleIn = pure inR , argsHandleOut = pure outW } + result <- runSessionWithHandles inW outR sconf' testConfigCaps root (session root) hClose inW timeout 3 (wait server) >>= \case Just () -> pure () @@ -678,26 +694,38 @@ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = d putStrLn "Server does not exit in 3s, canceling the async task..." (t, _) <- duration $ cancel server putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" - pure x - --- | Host a server, and run a test session on it --- Note: cwd will be shifted into @root@ in @Session a@ -runSessionWithServer' :: - (Pretty b) => - -- | whether we disable the kick action or not - Bool -> - -- | Plugin to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - FilePath -> - Session a -> - IO a -runSessionWithServer' disableKick pluginsDp conf sconf caps root s = - withLock lock $ keepCurrentDirectory $ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s + pure result + + where + shiftRoot shiftTarget f = + if testShiftRoot + then withLock lock $ keepCurrentDirectory $ setCurrentDirectory shiftTarget >> f + else f + runSessionInVFS (Left testConfigRoot) act = do + root <- makeAbsolute testConfigRoot + act root + runSessionInVFS (Right vfs) act = runWithLockInTempDir vfs $ \fs -> act (fsRoot fs) + testingArgs prjRoot recorderIde plugins = + let + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = defaultArguments (cmapWithPrio LogIDEMain recorderIde) prjRoot plugins + argsHlsPlugins' = if testDisableDefaultPlugin + then plugins + else argsHlsPlugins + hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins' + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ideOptions config sessionLoader = (argsIdeOptions config sessionLoader){ + optTesting = IdeTesting True + , optCheckProject = pure testCheckProject + } + in + arguments + { argsHlsPlugins = hlsPlugins + , argsIdeOptions = ideOptions + , argsLspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 } + , argsDefaultHlsConfig = testLspConfig + , argsProjectRoot = prjRoot + , argsDisableKick = testDisableKick + } -- | Wait for the next progress begin step waitForProgressBegin :: Session () diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 2cbc339dfa..a79fe2d722 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -116,7 +116,12 @@ suggestionsTests = contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps def hlintPlugin noLiteralCaps testDir $ do + , testCase "falls back to pre 3.8 code actions" $ + runSessionWithTestConfig def { + testConfigCaps = noLiteralCaps, + testDirLocation = Left testDir, + testPluginDescriptor = hlintPlugin, + testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "hlint" @@ -338,7 +343,14 @@ testDir :: FilePath testDir = "plugins/hls-hlint-plugin/test/testdata" runHlintSession :: FilePath -> Session a -> IO a -runHlintSession subdir = failIfSessionTimeout . runSessionWithServerAndCaps def hlintPlugin codeActionNoResolveCaps (testDir subdir) +runHlintSession subdir = failIfSessionTimeout . + runSessionWithTestConfig def + {testConfigCaps=codeActionNoResolveCaps + , testShiftRoot=True + , testDirLocation=Left (testDir subdir) + , testPluginDescriptor=hlintPlugin + } + . const noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = @@ -416,9 +428,17 @@ goldenTest testCaseName goldenFilename point hintText = void $ skipManyTill anyMessage $ getDocumentEdit document _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithHaskellAndCaps def codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithTestConfig def + {testConfigCaps=codeActionNoResolveCaps + , testShiftRoot=True + , testPluginDescriptor=hlintPlugin + , testDirLocation=Left testDir + } + testName testDir path "expected" "hs" + ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = @@ -439,4 +459,10 @@ goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path = - goldenWithHaskellAndCaps def codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithTestConfig def + {testConfigCaps=codeActionResolveCaps + , testShiftRoot=True + , testPluginDescriptor=hlintPlugin + , testDirLocation=Left testDir + } + testName testDir path "expected" "hs" diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index 1192870b00..72941c2317 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -41,8 +41,8 @@ import Development.IDE (GetParsedModule (GetParse hscEnvWithImportPaths, logWith, realSrcSpanToRange, - runAction, useWithStale, - (<+>)) + rootDir, runAction, + useWithStale, (<+>)) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.GHC.Compat (GenLocated (L), @@ -53,16 +53,17 @@ import Development.IDE.GHC.Compat (GenLocated (L), pm_parsed_source, unLoc) import Ide.Logger (Pretty (..)) import Ide.Plugin.Error +import Ide.PluginUtils (toAbsolute) import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server import Language.LSP.VFS (virtualFileText) -import System.Directory (makeAbsolute) -import System.FilePath (dropExtension, normalise, +import System.FilePath (dropExtension, + isAbsolute, normalise, pathSeparator, splitDirectories, - takeFileName) + takeFileName, ()) -- |Plugin descriptor descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -150,7 +151,7 @@ pathModuleNames recorder state normFilePath filePath let paths = map (normalise . (<> pure pathSeparator)) srcPaths logWith recorder Debug (NormalisedPaths paths) - mdlPath <- liftIO $ makeAbsolute filePath + let mdlPath = (toAbsolute $ rootDir state) filePath logWith recorder Debug (AbsoluteFilePath mdlPath) let suffixes = mapMaybe (`stripPrefix` mdlPath) paths diff --git a/plugins/hls-notes-plugin/test/NotesTest.hs b/plugins/hls-notes-plugin/test/NotesTest.hs index 61d5b79c2a..ce43a42a85 100644 --- a/plugins/hls-notes-plugin/test/NotesTest.hs +++ b/plugins/hls-notes-plugin/test/NotesTest.hs @@ -16,19 +16,20 @@ main = defaultTestRunner $ gotoNoteTests :: TestTree gotoNoteTests = testGroup "Goto Note Definition" - [ testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do + [ + testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 3 41) liftIO $ do - fp <- canonicalizePath "NoteDef.hs" + fp <- canonicalizePath $ testDataDir "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))])) , testCase "liberal_format" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 5 64) liftIO $ do - fp <- canonicalizePath "NoteDef.hs" + fp <- canonicalizePath $ testDataDir "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))])) , testCase "invalid_note" $ runSessionWithServer def plugin testDataDir $ do @@ -49,7 +50,7 @@ gotoNoteTests = testGroup "Goto Note Definition" waitForKickDone defs <- getDefinitions doc (Position 5 20) liftIO $ do - fp <- canonicalizePath "NoteDef.hs" + fp <- canonicalizePath $ testDataDir "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))])) ] diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 3670a3b398..9e2a6951fc 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3751,7 +3751,10 @@ run' :: (FilePath -> Session a) -> IO a run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a -runInDir dir act = runSessionWithServerAndCaps def refactorPlugin lspTestCaps dir act +runInDir dir act = + runSessionWithTestConfig def + {testDirLocation=Left dir, testPluginDescriptor=refactorPlugin, testConfigCaps=lspTestCaps} + $ const act lspTestCaps :: ClientCapabilities lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index dc6e99e33e..0c031be561 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -146,4 +146,8 @@ expectRenameError doc pos newName = do runRenameSession :: FilePath -> Session a -> IO a runRenameSession subdir = failIfSessionTimeout - . runSessionWithServerAndCaps def renamePlugin codeActionNoResolveCaps (testDataDir subdir) + . runSessionWithTestConfig def + {testDirLocation= Left $ testDataDir subdir, + testPluginDescriptor=renamePlugin, + testConfigCaps=codeActionNoResolveCaps} + . const diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 48d2886ff0..b88e79d2b0 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -129,7 +129,6 @@ import Retrie.SYB (everything, extQ, listify, mkQ) import Retrie.Types import Retrie.Universe (Universe) -import System.Directory (makeAbsolute) #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual @@ -762,7 +761,7 @@ reuseParsedModule state f = do getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) getCPPmodule recorder state session t = do - nt <- toNormalizedFilePath' <$> makeAbsolute t + let nt = toNormalizedFilePath' $ (toAbsolute $ rootDir state) t let getParsedModule f contents = do modSummary <- msrModSummary <$> useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 906319ed2a..31845d8bd0 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -3,7 +3,6 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Lens ((^.), (^?)) -import Control.Monad.IO.Class (liftIO) import Data.Aeson (KeyValue (..), Object) import qualified Data.Aeson.KeyMap as KV import Data.Default @@ -15,35 +14,17 @@ import Data.Text hiding (length, map, import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (Pretty) -import Development.IDE.GHC.Compat (GhcVersion (..), - ghcVersion) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) -import Development.IDE.Test (waitForBuildQueue) import Ide.Plugin.SemanticTokens import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Types import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types -import Language.LSP.Test (Session, - SessionConfig (ignoreConfigurationRequests), - openDoc, request) import qualified Language.LSP.Test as Test import Language.LSP.VFS (VirtualFile (..)) import System.FilePath -import Test.Hls (HasCallStack, - PluginTestDescriptor, - SMethod (SMethod_TextDocumentSemanticTokensFullDelta), - TestName, TestTree, - changeDoc, - defaultTestRunner, - documentContents, fullCaps, - goldenGitDiff, - mkPluginTestDescriptor, - runSessionWithServerInTmpDir, - runSessionWithServerInTmpDir', - testCase, testGroup, - waitForAction, (@?=)) +import Test.Hls import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (file, text) @@ -155,20 +136,22 @@ semanticTokensConfigTest = let funcVar = KV.fromList ["functionToken" .= var] var :: String var = "variable" - do - Test.Hls.runSessionWithServerInTmpDir' - semanticTokensPlugin - (mkSemanticConfig funcVar) - def {ignoreConfigurationRequests = False} - fullCaps - fs - $ do - -- modifySemantic funcVar - void waitForBuildQueue - doc <- openDoc "Hello.hs" "haskell" - void waitForBuildQueue - result1 <- docLspSemanticTokensString doc - liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" + Test.Hls.runSessionWithTestConfig def { + testPluginDescriptor = semanticTokensPlugin + , testConfigSession = def { + ignoreConfigurationRequests = False + } + , testConfigCaps = fullCaps + , testDirLocation = Right fs + , testLspConfig = mkSemanticConfig funcVar + } + $ const $ do + -- modifySemantic funcVar + void waitForBuildQueue + doc <- openDoc "Hello.hs" "haskell" + void waitForBuildQueue + result1 <- docLspSemanticTokensString doc + liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" ] semanticTokensFullDeltaTests :: TestTree diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 20baa2f633..42ebd8ec8c 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -87,10 +87,9 @@ goldenTestWithEdit fp expect tc line col = { _start = Position 0 0 , _end = Position (fromIntegral $ length lns + 1) 1 } - void waitForDiagnostics void waitForBuildQueue - alt <- liftIO $ T.readFile (fp <.> "error.hs") + alt <- liftIO $ T.readFile (testDataDir fp <.> "error.hs") void $ applyEdit doc $ TextEdit theRange alt changeDoc doc [TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial {_range = theRange, _rangeLength = Nothing, _text = alt} diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs index 650760c9dc..231707d142 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -75,4 +75,11 @@ stanPlugin = mkPluginTestDescriptor enabledStanDescriptor "stan" runStanSession :: FilePath -> Session a -> IO a runStanSession subdir = - failIfSessionTimeout . runSessionWithServer def stanPlugin (testDir subdir) + failIfSessionTimeout + . runSessionWithTestConfig def{ + testConfigCaps=codeActionNoResolveCaps + , testShiftRoot=True + , testPluginDescriptor=stanPlugin + , testDirLocation=Left (testDir subdir) + } + . const diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 457e0dc4ec..cbe3f33bb3 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -131,7 +131,7 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryRec log Info $ LogLspStart ghcideArgs (map pluginId $ ipMap idePlugins) let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) - (cmapWithPrio LogIDEMain recorder) idePlugins + (cmapWithPrio LogIDEMain recorder) dir idePlugins let telemetryRecorder = telemetryRecorder' & cmapWithPrio pretty diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 1dbf12c64c..a8e51531fd 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -68,7 +68,10 @@ genericConfigTests = testGroup "generic plugin config" testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin")])] runConfigSession subdir session = do - failIfSessionTimeout $ runSessionWithServer' @() False plugin def (def {ignoreConfigurationRequests=False}) fullCaps ("test/testdata" subdir) session + failIfSessionTimeout $ + runSessionWithTestConfig def + {testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True + , testPluginDescriptor=plugin, testDirLocation=Left ("test/testdata" subdir)} (const session) testPluginId = "testplugin" -- A disabled-by-default plugin that creates diagnostics