diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index a93dcb393..35d8b9ed6 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -13,14 +13,14 @@ import Distribution.Helper (Package, projectPackages, pUnits, unChModuleName, Ex(..), ProjLoc(..), QueryEnv, mkQueryEnv, runQuery, Unit, unitInfo, uiComponents, - ChEntrypoint(..)) + ChEntrypoint(..), UnitInfo(..)) import Distribution.Helper.Discover (findProjects, getDefaultDistDir) import Data.Char (toLower) import Data.Function ((&)) import Data.List (isPrefixOf, isInfixOf, sortOn, find) import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) -import qualified Data.Map as M +import qualified Data.Map as Map import Data.Maybe (listToMaybe, mapMaybe, isJust) import Data.Ord (Down(..)) import Data.String (IsString(..)) @@ -45,10 +45,13 @@ import System.Process (readCreateProcessWithExitCode, shell) findLocalCradle :: FilePath -> IO Cradle findLocalCradle fp = do cradleConf <- BIOS.findCradle fp - case cradleConf of - Just yaml -> BIOS.loadCradle yaml + crdl <- case cradleConf of + Just yaml -> do + debugm $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\"" + BIOS.loadCradle yaml Nothing -> cabalHelperCradle fp - + logm $ "Module \"" ++ fp ++ "\" is loaded by Cradle: " ++ show crdl + return crdl -- | Check if the given cradle is a stack cradle. -- This might be used to determine the GHC version to use on the project. -- If it is a stack-cradle, we have to use `stack path --compiler-exe` @@ -143,7 +146,7 @@ getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath) getProjectGhcLibDir crdl = execProjectGhc crdl ["--print-libdir"] >>= \case Nothing -> do - logm "Could not obtain the libdir." + errorm "Could not obtain the libdir." return Nothing mlibdir -> return mlibdir @@ -235,17 +238,20 @@ findCabalHelperEntryPoint fp = do supported (Ex ProjLocV1Dir {}) _ cabalInstalled = cabalInstalled supported (Ex ProjLocV1CabalFile {}) _ cabalInstalled = cabalInstalled - isStackProject (Ex ProjLocStackYaml {}) = True - isStackProject _ = False +isStackProject :: Ex ProjLoc -> Bool +isStackProject (Ex ProjLocStackYaml {}) = True +isStackProject _ = False - isCabalV2FileProject (Ex ProjLocV2File {}) = True - isCabalV2FileProject _ = False +isCabalV2FileProject :: Ex ProjLoc -> Bool +isCabalV2FileProject (Ex ProjLocV2File {}) = True +isCabalV2FileProject _ = False - isCabalProject (Ex ProjLocV1CabalFile {}) = True - isCabalProject (Ex ProjLocV1Dir {}) = True - isCabalProject (Ex ProjLocV2File {}) = True - isCabalProject (Ex ProjLocV2Dir {}) = True - isCabalProject _ = False +isCabalProject :: Ex ProjLoc -> Bool +isCabalProject (Ex ProjLocV1CabalFile {}) = True +isCabalProject (Ex ProjLocV1Dir {}) = True +isCabalProject (Ex ProjLocV2File {}) = True +isCabalProject (Ex ProjLocV2Dir {}) = True +isCabalProject _ = False {- | Given a FilePath, find the cradle the FilePath belongs to. @@ -431,12 +437,13 @@ cabalHelperCradle file = do } } Just (Ex proj) -> do + logm $ "Cabal-Helper decided to use: " ++ show proj -- Find the root of the project based on project type. let root = projectRootDir proj -- Create a suffix for the cradle name. -- Purpose is mainly for easier debugging. let actionNameSuffix = projectSuffix proj - logm $ "Cabal-Helper dirs: " ++ show [root, file] + debugm $ "Cabal-Helper dirs: " ++ show [root, file] let dist_dir = getDefaultDistDir proj env <- mkQueryEnv proj dist_dir packages <- runQuery projectPackages env @@ -472,6 +479,7 @@ cabalHelperCradle file = do CradleAction { actionName = "Cabal-Helper-" ++ actionNameSuffix , runCradle = \_ fp -> cabalHelperAction + (Ex proj) env realPackage normalisedPackageLocation @@ -493,26 +501,29 @@ cabalHelperCradle file = do else arg else arg - -- | cradle Action to query for the ComponentOptions that are needed + -- | Cradle Action to query for the ComponentOptions that are needed -- to load the given FilePath. -- This Function is not supposed to throw any exceptions and use -- 'CradleLoadResult' to indicate errors. - cabalHelperAction :: QueryEnv v -- ^ Query Env created by 'mkQueryEnv' + cabalHelperAction :: Ex ProjLoc -- ^ Project location, can be used + -- to present error build-tool + -- agnostic error messages. + -> QueryEnv v -- ^ Query Env created by 'mkQueryEnv' -- with the appropriate 'distdir' -> Package v -- ^ Package this cradle is part for. -> FilePath -- ^ Root directory of the cradle -- this action belongs to. -> FilePath -- ^ FilePath to load, expected to be an absolute path. -> IO (CradleLoadResult ComponentOptions) - cabalHelperAction env package root fp = do + cabalHelperAction proj env package root fp = do -- Get all unit infos the given FilePath may belong to let units = pUnits package -- make the FilePath to load relative to the root of the cradle. let relativeFp = makeRelative root fp debugm $ "Relative Module FilePath: " ++ relativeFp - getComponent env (toList units) relativeFp + getComponent proj env (toList units) relativeFp >>= \case - Just comp -> do + Right comp -> do let fs' = getFlags comp let fs = map (fixImportDirs root) fs' let targets = getTargets comp relativeFp @@ -524,11 +535,11 @@ cabalHelperCradle file = do ComponentOptions { componentOptions = ghcOptions , componentDependencies = [] } - Nothing -> return + Left err -> return $ CradleFail $ CradleError (ExitFailure 2) - ["Could not obtain flags for " ++ fp] + err -- | Get the component the given FilePath most likely belongs to. -- Lazily ask units whether the given FilePath is part of one of their @@ -538,25 +549,96 @@ cabalHelperCradle file = do -- The given FilePath must be relative to the Root of the project -- the given units belong to. getComponent - :: QueryEnv pt -> [Unit pt] -> FilePath -> IO (Maybe ChComponentInfo) -getComponent _env [] _fp = return Nothing -getComponent env (unit : units) fp = - try (runQuery (unitInfo unit) env) >>= \case - Left (e :: IOException) -> do - warningm $ "Catching and swallowing an IOException: " ++ show e - warningm - $ "The Exception was thrown in the context of finding" - ++ " a component for \"" - ++ fp - ++ "\" in the unit: " - ++ show unit - getComponent env units fp - Right ui -> do - let components = M.elems (uiComponents ui) - debugm $ "Unit Info: " ++ show ui - case find (fp `partOfComponent`) components of - Nothing -> getComponent env units fp - comp -> return comp + :: forall pt. Ex ProjLoc -> QueryEnv pt -> [Unit pt] -> FilePath -> IO (Either [String] ChComponentInfo) +getComponent proj env unitCandidates fp = getComponent' [] [] unitCandidates >>= + \case + (tried, failed, Nothing) -> return (Left $ buildErrorMsg tried failed) + (_, _, Just comp) -> return (Right comp) + where + getComponent' :: [UnitInfo] -> [(Unit pt, IOException)] -> [Unit pt] -> IO ([UnitInfo], [(Unit pt, IOException)], Maybe ChComponentInfo) + getComponent' triedUnits failedUnits [] = return (triedUnits, failedUnits, Nothing) + getComponent' triedUnits failedUnits (unit : units) = + try (runQuery (unitInfo unit) env) >>= \case + Left (e :: IOException) -> do + warningm $ "Catching and swallowing an IOException: " ++ show e + warningm + $ "The Exception was thrown in the context of finding" + ++ " a component for \"" + ++ fp + ++ "\" in the unit: " + ++ show unit + getComponent' triedUnits ((unit, e):failedUnits) units + Right ui -> do + let components = Map.elems (uiComponents ui) + debugm $ "Unit Info: " ++ show ui + case find (fp `partOfComponent`) components of + Nothing -> getComponent' (ui:triedUnits) failedUnits units + comp -> return (triedUnits, failedUnits, comp) + + buildErrorMsg :: [UnitInfo] -> [(Unit pt, IOException)] -> [String] + buildErrorMsg triedUnits failedUnits = + concat + [ [ "Could not obtain flags for: \"" ++ fp ++ "\"." + , "" + ] + , concat + [ concat + [ [ "This module was not part of any component we are aware of." + , "" + ] + , concatMap ppShowUnitInfo triedUnits + , [ "" + , "" + ] + , if isStackProject proj + then stackSpecificInstructions + else cabalSpecificInstructions + ] + | not (null triedUnits) + ] + , concat + [ + [ "We could not build all components." + , "If one of these components exposes this Module, make sure they compile." + , "You can try to invoke the commands yourself." + , "The following commands failed:" + ] + ++ concatMap (ppShowIOException . snd) failedUnits + | not (null failedUnits) + ] + ] + + stackSpecificInstructions :: [String] + stackSpecificInstructions = + [ "To expose a module, refer to:" + , "https://docs.haskellstack.org/en/stable/GUIDE/" + , "If you are using `package.yaml` then you don't have to manually expose modules." + , "Maybe you didn't set the source directories for your project correctly." + ] + + cabalSpecificInstructions :: [String] + cabalSpecificInstructions = + [ "To expose a module, refer to:" + , "https://www.haskell.org/cabal/users-guide/developing-packages.html" + , "" + ] + + ppShowUnitInfo :: UnitInfo -> [String] + ppShowUnitInfo u = + u + & uiComponents + & Map.toList + & map + (\(name, info) -> + "Component: " ++ show name ++ " with source directory: " ++ show (ciSourceDirs info) + ) + + + ppShowIOException :: IOException -> [String] + ppShowIOException e = + [ "" + , show e + ] -- | Check whether the given FilePath is part of the Component. -- A FilePath is part of the Component if and only if: @@ -771,4 +853,3 @@ cradleDisplay cradle = fromString result | "multi" `isInfixOf` name = "Multi Component project" | otherwise = "project" name = map toLower $ BIOS.actionName (BIOS.cradleOptsProg cradle) - diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index cb9c0b76e..5ad3054e5 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -4,7 +4,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} @@ -24,6 +23,7 @@ module Haskell.Ide.Engine.ModuleCache , cacheInfoNoClear , runActionWithContext , ModuleCache(..) + , PublishDiagnostics ) where @@ -32,26 +32,28 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Free +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as B import Data.Dynamic (toDyn, fromDynamic, Dynamic) import Data.Generics (Proxy(..), TypeRep, typeRep, typeOf) import qualified Data.Map as Map import Data.Maybe +import qualified Data.SortedList as SL +import qualified Data.Trie.Convenience as T +import qualified Data.Trie as T +import qualified Data.Text as Text import Data.Typeable (Typeable) +import qualified Data.Yaml as Yaml import System.Directory import qualified GHC import qualified HscMain as GHC +import qualified HIE.Bios as Bios +import qualified HIE.Bios.Ghc.Api as Bios -import qualified Data.Aeson as Aeson -import qualified Data.Trie.Convenience as T -import qualified Data.Trie as T -import qualified Data.Text as Text -import qualified Data.Yaml as Yaml -import qualified HIE.Bios as BIOS -import qualified HIE.Bios.Ghc.Api as BIOS -import qualified Data.ByteString.Char8 as B - +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Diagnostics as J import Haskell.Ide.Engine.ArtifactMap import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay) import Haskell.Ide.Engine.TypeMap @@ -68,6 +70,9 @@ modifyCache :: (HasGhcModuleCache m) => (GhcModuleCache -> GhcModuleCache) -> m modifyCache f = modifyModuleCache f -- --------------------------------------------------------------------- + +type PublishDiagnostics = J.NormalizedUri -> J.TextDocumentVersion -> J.DiagnosticsBySource -> IO () + -- | Run the given action in context and initialise a session with hie-bios. -- If a context is given, the context is used to initialise a session for GHC. -- The project "hie-bios" is used to find a Cradle and setup a GHC session @@ -88,22 +93,23 @@ modifyCache f = modifyModuleCache f -- though we know nothing about the file. -- 2. Return the default value for the specific action. runActionWithContext :: (MonadIde m, GHC.GhcMonad m, HasGhcModuleCache m, MonadBaseControl IO m) - => GHC.DynFlags + => PublishDiagnostics + -> GHC.DynFlags -> Maybe FilePath -- ^ Context for the Action -> a -- ^ Default value for none cradle -> m a -- ^ Action to execute -> m (IdeResult a) -- ^ Result of the action or error in -- the context initialisation. -runActionWithContext _df Nothing _def action = +runActionWithContext _pub _df Nothing _def action = -- Cradle with no additional flags -- dir <- liftIO $ getCurrentDirectory --This causes problems when loading a later package which sets the --packageDb - -- loadCradle df (BIOS.defaultCradle dir) + -- loadCradle df (Bios.defaultCradle dir) fmap IdeResultOk action -runActionWithContext df (Just uri) def action = do +runActionWithContext publishDiagnostics df (Just uri) def action = do mcradle <- getCradle uri - loadCradle df mcradle def action + loadCradle publishDiagnostics df mcradle def action -- --------------------------------------------------------------------- @@ -114,17 +120,18 @@ runActionWithContext df (Just uri) def action = do -- to set up the Session, including downloading all dependencies of a Cradle. loadCradle :: forall a m . (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m , MonadBaseControl IO m) - => GHC.DynFlags + => PublishDiagnostics + -> GHC.DynFlags -> LookupCradleResult -> a -> m a -> m (IdeResult a) -loadCradle _ ReuseCradle _def action = do +loadCradle _ _ ReuseCradle _def action = do -- Since we expect this message to show up often, only show in debug mode debugm "Reusing cradle" IdeResultOk <$> action -loadCradle _iniDynFlags (LoadCradle (CachedCradle crd env)) _def action = do +loadCradle _ _iniDynFlags (LoadCradle (CachedCradle crd env)) _def action = do -- Reloading a cradle happens on component switch logm $ "Switch to cradle: " ++ show crd -- Cache the existing cradle @@ -133,7 +140,7 @@ loadCradle _iniDynFlags (LoadCradle (CachedCradle crd env)) _def action = do setCurrentCradle crd IdeResultOk <$> action -loadCradle iniDynFlags (NewCradle fp) def action = do +loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do -- If this message shows up a lot in the logs, it is an indicator for a bug logm $ "New cradle: " ++ fp -- Cache the existing cradle @@ -156,34 +163,49 @@ loadCradle iniDynFlags (NewCradle fp) def action = do where -- | Initialise the given cradle. This might fail and return an error via `IdeResultFail`. -- Reports its progress to the client. - initialiseCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m, MonadBaseControl IO m) - => BIOS.Cradle -> (Progress -> IO ()) -> m (IdeResult a) + initialiseCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m) + => Bios.Cradle -> (Progress -> IO ()) -> m (IdeResult a) initialiseCradle cradle f = do - res <- BIOS.initializeFlagsWithCradleWithMessage (Just (toMessager f)) fp cradle + res <- Bios.initializeFlagsWithCradleWithMessage (Just (toMessager f)) fp cradle case res of - BIOS.CradleNone -> + Bios.CradleNone -> -- Note: The action is not run if we are in the none cradle, we -- just pretend the file doesn't exist. return $ IdeResultOk def - BIOS.CradleFail err -> do - logm $ "GhcException on cradle initialisation: " ++ show err + Bios.CradleFail (Bios.CradleError code msg) -> do + warningm $ "Fail on cradle initialisation: (" ++ show code ++ ")" ++ show msg + + -- Send a detailed diagnostic to the user. + + let normalizedUri = J.toNormalizedUri (filePathToUri fp) + sev = Just DsError + range = Range (Position 0 0) (Position 1 0) + msgTxt = + [ "Fail on initialisation for \"" <> Text.pack fp <> "\"." + ] <> map Text.pack msg + source = Just "bios" + diag = Diagnostic range sev Nothing source (Text.unlines msgTxt) Nothing + + liftIO $ publishDiagnostics normalizedUri Nothing + (Map.singleton source (SL.singleton diag)) + return $ IdeResultFail $ IdeError { ideCode = OtherError - , ideMessage = Text.pack $ show err + , ideMessage = Text.unwords (take 2 msgTxt) , ideInfo = Aeson.Null } - BIOS.CradleSuccess init_session -> do + Bios.CradleSuccess init_session -> do -- Note that init_session contains a Hook to 'f'. -- So, it can still provide Progress Reports. -- Therefore, invocation of 'init_session' must happen -- while 'f' is still valid. liftIO (GHC.newHscEnv iniDynFlags) >>= GHC.setSession - liftIO $ setCurrentDirectory (BIOS.cradleRootDir cradle) + liftIO $ setCurrentDirectory (Bios.cradleRootDir cradle) let onGhcError = return . Left let onSourceError srcErr = do logm $ "Source error on cradle initialisation: " ++ show srcErr - return $ Right BIOS.Failed + return $ Right Bios.Failed -- We continue setting the cradle in case the file has source errors -- cause they will be reported to user by diagnostics init_res <- gcatches @@ -202,12 +224,12 @@ loadCradle iniDynFlags (NewCradle fp) def action = do -- it on a save whilst there are errors. Subsequent loads won't -- be that slow, even though the cradle isn't cached because the -- `.hi` files will be saved. - Right BIOS.Succeeded -> do + Right Bios.Succeeded -> do setCurrentCradle cradle logm "Cradle set succesfully" IdeResultOk <$> action - Right BIOS.Failed -> do + Right Bios.Failed -> do setCurrentCradle cradle logm "Cradle did not load succesfully" IdeResultOk <$> action @@ -217,7 +239,7 @@ loadCradle iniDynFlags (NewCradle fp) def action = do -- that belong to this cradle. -- If the cradle does not load any module, it is responsible for an empty -- list of Modules. -setCurrentCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => BIOS.Cradle -> m () +setCurrentCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => Bios.Cradle -> m () setCurrentCradle cradle = do mg <- GHC.getModuleGraph let ps = mapMaybe (GHC.ml_hs_file . GHC.ms_location) (mgModSummaries mg) @@ -230,7 +252,7 @@ setCurrentCradle cradle = do -- for. -- Via 'lookupCradle' it can be checked if a given FilePath is managed by -- a any Cradle that has already been loaded. -cacheCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => ([FilePath], BIOS.Cradle) -> m () +cacheCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => ([FilePath], Bios.Cradle) -> m () cacheCradle (ds, c) = do env <- GHC.getSession let cc = CachedCradle c env diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index 32f2a2d42..aa2888a1f 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -57,6 +57,7 @@ library , monad-control , mtl , process + , sorted-list , stm , syb , text diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index 392d852aa..211a064dc 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -145,11 +145,12 @@ runScheduler -- ^ A handler to run the requests' callback in your monad of choosing. -> Core.LspFuncs Config -- ^ The LspFuncs provided by haskell-lsp. + -> PublishDiagnostics -> Maybe Bios.Cradle -- ^ Context in which the ghc thread is executed. -- Neccessary to obtain the libdir, for example. -> IO () -runScheduler Scheduler {..} errorHandler callbackHandler lf mcradle = do +runScheduler Scheduler {..} errorHandler callbackHandler lf pubDiags mcradle = do let dEnv = DispatcherEnv { cancelReqsTVar = requestsToCancel , wipReqsTVar = requestsInProgress @@ -168,7 +169,7 @@ runScheduler Scheduler {..} errorHandler callbackHandler lf mcradle = do Just crdl -> Bios.getProjectGhcLibDir crdl let runGhcDisp = runIdeGhcM mlibdir plugins lf stateVar $ - ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut + ghcDispatcher dEnv errorHandler pubDiags callbackHandler ghcChanOut runIdeDisp = runIdeM plugins lf stateVar $ ideDispatcher dEnv errorHandler callbackHandler ideChanOut @@ -322,10 +323,11 @@ ghcDispatcher :: forall void m . DispatcherEnv -> ErrorHandler + -> PublishDiagnostics -> CallbackHandler m -> Channel.OutChan (GhcRequest m) -> IdeGhcM void -ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler callbackHandler pin +ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler publishDiagnostics callbackHandler pin = do iniDynFlags <- getSessionDynFlags forever $ do @@ -339,13 +341,13 @@ ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler callbackHandler runner :: a -> IdeGhcM a -> IdeGhcM (IdeResult a) runner a act = case context of - Nothing -> runActionWithContext iniDynFlags Nothing a act + Nothing -> runActionWithContext publishDiagnostics iniDynFlags Nothing a act Just uri -> case uriToFilePath uri of - Just fp -> runActionWithContext iniDynFlags (Just fp) a act + Just fp -> runActionWithContext publishDiagnostics iniDynFlags (Just fp) a act Nothing -> do debugm "ghcDispatcher:Got malformed uri, running action with default context" - runActionWithContext iniDynFlags Nothing a act + runActionWithContext publishDiagnostics iniDynFlags Nothing a act let runWithCallback = do diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index b6407d5f1..b0d7206a7 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -182,7 +182,12 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do Left (e :: Yaml.ParseException) -> do logm $ "Failed to parse `hie.yaml`: " ++ show e - sf $ NotShowMessage $ fmServerShowMessageNotification J.MtError ("Couldn't parse hie.yaml: \n" <> T.pack (show e)) + sf $ NotShowMessage + $ fmServerShowMessageNotification + J.MtError + ( "Couldn't parse hie.yaml: \n" + <> T.pack (Yaml.prettyPrintParseException e) + ) let mcradle = case cradleRes of Left _ -> Nothing @@ -192,23 +197,27 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do -- We launch the dispatcher after that so that the default cradle is -- recognized properly by ghc-mod flip labelThread "scheduler" =<< - (forkIO ( - Scheduler.runScheduler scheduler errorHandler callbackHandler lf mcradle - `E.catch` \(e :: E.SomeException) -> - (errorm $ "Scheduler thread exited unexpectedly: " ++ show e) - )) + forkIO + ( Scheduler.runScheduler scheduler errorHandler callbackHandler lf (publishDiagnostics' lf) mcradle + `E.catch` + \(e :: E.SomeException) -> + errorm $ "Scheduler thread exited unexpectedly: " ++ show e + ) flip labelThread "reactor" =<< - (forkIO ( - reactorFunc - `E.catch` \(e :: E.SomeException) -> - (errorm $ "Reactor thread exited unexpectedly: " ++ show e) - )) + forkIO + ( reactorFunc + `E.catch` + \(e :: E.SomeException) -> + errorm $ "Reactor thread exited unexpectedly: " ++ show e + ) + flip labelThread "diagnostics" =<< - (forkIO ( - diagnosticsQueue tr - `E.catch` \(e :: E.SomeException) -> - (errorm $ "Diagnostic thread exited unexpectedly: " ++ show e) - )) + forkIO + ( diagnosticsQueue tr + `E.catch` + \(e :: E.SomeException) -> + errorm $ "Diagnostic thread exited unexpectedly: " ++ show e + ) return Nothing @@ -350,10 +359,18 @@ updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file -- --------------------------------------------------------------------- publishDiagnostics :: (MonadIO m, MonadReader REnv m) - => Int -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m () -publishDiagnostics maxToSend uri' mv diags = do + => J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m () +publishDiagnostics uri' mv diags = do lf <- asks lspFuncs - liftIO $ Core.publishDiagnosticsFunc lf maxToSend uri' mv diags + publishDiagnostics' lf uri' mv diags + + +publishDiagnostics' :: MonadIO m + => Core.LspFuncs Config -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m () +publishDiagnostics' lf uri' mv diags = do + config <- liftIO $ fromMaybe Data.Default.def <$> Core.config lf + liftIO $ Core.publishDiagnosticsFunc lf (maxNumberOfProblems config) uri' mv diags + -- --------------------------------------------------------------------- @@ -927,18 +944,17 @@ requestDiagnosticsNormal tn file mVer = do sendOneGhc :: J.DiagnosticSource -> (J.NormalizedUri, [Diagnostic]) -> R () sendOneGhc pid (fileUri,ds) = do if any (hasSeverity J.DsError) ds - then publishDiagnostics maxToSend fileUri Nothing + then publishDiagnostics fileUri Nothing (Map.fromList [(Just "hlint",SL.toSortedList []),(Just pid,SL.toSortedList ds)]) else sendOne pid (fileUri,ds) sendOne pid (fileUri,ds) = do - publishDiagnostics maxToSend fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds)]) + publishDiagnostics fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds)]) hasSeverity :: J.DiagnosticSeverity -> J.Diagnostic -> Bool hasSeverity sev (J.Diagnostic _ (Just s) _ _ _ _) = s == sev hasSeverity _ _ = False - sendEmpty = publishDiagnostics maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just "bios",SL.toSortedList [])]) - maxToSend = maxNumberOfProblems clientConfig + sendEmpty = publishDiagnostics (J.toNormalizedUri file) Nothing (Map.fromList [(Just "bios",SL.toSortedList [])]) let sendHlint = hlintOn clientConfig when sendHlint $ do diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index bf80d3cbb..106cce7cc 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -81,6 +81,7 @@ startServer = do (\lid errCode e -> logToChan logChan ("received an error", Left (lid, errCode, e))) (\g x -> g x) dummyLspFuncs + (\_ _ _ -> return ()) (Just crdl) return (scheduler, logChan, dispatcher) diff --git a/test/plugin-dispatcher/Main.hs b/test/plugin-dispatcher/Main.hs index 4f725f82b..db356c5cc 100644 --- a/test/plugin-dispatcher/Main.hs +++ b/test/plugin-dispatcher/Main.hs @@ -51,6 +51,7 @@ newPluginSpec = do (\_ _ _ -> return ()) (\f x -> f x) dummyLspFuncs + (\_ _ _ -> return ()) (Just crdl) updateDocument scheduler (filePathToUri "test") 3