From d4fbbf1502cfc10f270a1c74616fbf284ee9a3e2 Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 29 Dec 2019 21:52:48 +0100 Subject: [PATCH 1/9] Improve quality and information density of error message --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 91 +++++++++++++------ .../Haskell/Ide/Engine/ModuleCache.hs | 2 +- src/Haskell/Ide/Engine/Server.hs | 7 +- 3 files changed, 71 insertions(+), 29 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index a93dcb393..da99c12ba 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -13,11 +13,11 @@ import Distribution.Helper (Package, projectPackages, pUnits, unChModuleName, Ex(..), ProjLoc(..), QueryEnv, mkQueryEnv, runQuery, Unit, unitInfo, uiComponents, - ChEntrypoint(..)) + ChEntrypoint(..), uComponentName) import Distribution.Helper.Discover (findProjects, getDefaultDistDir) import Data.Char (toLower) import Data.Function ((&)) -import Data.List (isPrefixOf, isInfixOf, sortOn, find) +import Data.List (isPrefixOf, isInfixOf, sortOn, find, intercalate) import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M @@ -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` @@ -512,7 +515,7 @@ cabalHelperCradle file = do debugm $ "Relative Module FilePath: " ++ relativeFp getComponent 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 +527,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 +541,59 @@ 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. QueryEnv pt -> [Unit pt] -> FilePath -> IO (Either String ChComponentInfo) +getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>= + \case + (tried, failed, Nothing) -> return (Left $ buildErrorMsg tried failed) + (_, _, Just comp) -> return (Right comp) + where + getComponent' :: [Unit pt] -> [Unit pt] -> [Unit pt] -> IO ([Unit pt], [Unit pt], 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:failedUnits) units + Right ui -> do + let components = M.elems (uiComponents ui) + debugm $ "Unit Info: " ++ show ui + case find (fp `partOfComponent`) components of + Nothing -> getComponent' (unit:triedUnits) failedUnits units + comp -> return (triedUnits, failedUnits, comp) + + buildErrorMsg :: [Unit pt] -> [Unit pt] -> String + buildErrorMsg triedUnits failedUnits = unlines $ + [ "Could not obtain flags for: \"" ++ fp ++ "\"."] + ++ + [ unlines + [ "The given File was not part of any component." + , "No component exposes this module, we tried the following:" + , intercalate "," (map showUnitInfo triedUnits) + , "If you dont know how to expose a module take a look at: " + , "https://www.haskell.org/cabal/users-guide/developing-packages.html" + ] + | not( null triedUnits) + ] + ++ + [ unlines + [ "We could not build all components." + , "If one of these components exposes the module, make sure these compile." + , "The following components failed to compile:" + , intercalate "," (map showUnitInfo failedUnits) + ] + | not (null failedUnits) + ] + + -- TODO: this is terrible + showUnitInfo :: Unit pt -> String + showUnitInfo unit = maybe (show unit) show (uComponentName unit) + -- | Check whether the given FilePath is part of the Component. -- A FilePath is part of the Component if and only if: diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index cb9c0b76e..3f43aab96 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -166,7 +166,7 @@ loadCradle iniDynFlags (NewCradle fp) def action = do -- just pretend the file doesn't exist. return $ IdeResultOk def BIOS.CradleFail err -> do - logm $ "GhcException on cradle initialisation: " ++ show err + logm $ "Fail on cradle initialisation: " ++ show err return $ IdeResultFail $ IdeError { ideCode = OtherError , ideMessage = Text.pack $ show err diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index b6407d5f1..89db3d07e 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 From 3b5f40833b92a9efc2ddc03d19cf09736ae96919 Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 30 Dec 2019 21:00:10 +0100 Subject: [PATCH 2/9] Implement diagnostics --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 52 +++++------ .../Haskell/Ide/Engine/ModuleCache.hs | 88 ++++++++++++------- hie-plugin-api/hie-plugin-api.cabal | 1 + src/Haskell/Ide/Engine/Scheduler.hs | 14 +-- src/Haskell/Ide/Engine/Server.hs | 41 +++++---- 5 files changed, 114 insertions(+), 82 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index da99c12ba..5b4aa2d6c 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -434,12 +434,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 @@ -531,7 +532,7 @@ cabalHelperCradle file = do $ CradleFail $ CradleError (ExitFailure 2) - [err] + err -- | Get the component the given FilePath most likely belongs to. -- Lazily ask units whether the given FilePath is part of one of their @@ -541,7 +542,7 @@ cabalHelperCradle file = do -- The given FilePath must be relative to the Root of the project -- the given units belong to. getComponent - :: forall pt. QueryEnv pt -> [Unit pt] -> FilePath -> IO (Either String ChComponentInfo) + :: forall pt. QueryEnv pt -> [Unit pt] -> FilePath -> IO (Either [String] ChComponentInfo) getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>= \case (tried, failed, Nothing) -> return (Left $ buildErrorMsg tried failed) @@ -567,33 +568,28 @@ getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>= Nothing -> getComponent' (unit:triedUnits) failedUnits units comp -> return (triedUnits, failedUnits, comp) - buildErrorMsg :: [Unit pt] -> [Unit pt] -> String - buildErrorMsg triedUnits failedUnits = unlines $ - [ "Could not obtain flags for: \"" ++ fp ++ "\"."] - ++ - [ unlines - [ "The given File was not part of any component." - , "No component exposes this module, we tried the following:" - , intercalate "," (map showUnitInfo triedUnits) - , "If you dont know how to expose a module take a look at: " - , "https://www.haskell.org/cabal/users-guide/developing-packages.html" - ] - | not( null triedUnits) + buildErrorMsg :: [Unit pt] -> [Unit pt] -> [String] + buildErrorMsg triedUnits failedUnits = + [ "Could not obtain flags for: \"" ++ fp ++ "\"." + , "" ] - ++ - [ unlines - [ "We could not build all components." - , "If one of these components exposes the module, make sure these compile." - , "The following components failed to compile:" - , intercalate "," (map showUnitInfo failedUnits) + ++ concat + [ + [ "This Module was not part of any component we are aware of." + , "" + , "If you dont know how to expose a module, take a look at: " + , "https://www.haskell.org/cabal/users-guide/developing-packages.html" + , "" + ] + | not (null triedUnits) + ] + ++ concat + [ + [ "We could not build all components." + , "If one of these components exposes this Module, make sure they compile." + ] + | not (null failedUnits) ] - | not (null failedUnits) - ] - - -- TODO: this is terrible - showUnitInfo :: Unit pt -> String - showUnitInfo unit = maybe (show unit) show (uComponentName unit) - -- | Check whether the given FilePath is part of the Component. -- A FilePath is part of the Component if and only if: diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index 3f43aab96..f060e8864 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 = Int -> 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 $ "Fail 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 maxBound 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 89db3d07e..173062885 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -197,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 @@ -358,8 +362,15 @@ publishDiagnostics :: (MonadIO m, MonadReader REnv m) => Int -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m () publishDiagnostics maxToSend uri' mv diags = do lf <- asks lspFuncs + publishDiagnostics' lf maxToSend uri' mv diags + + +publishDiagnostics' :: MonadIO m + => Core.LspFuncs c -> Int -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m () +publishDiagnostics' lf maxToSend uri' mv diags = liftIO $ Core.publishDiagnosticsFunc lf maxToSend uri' mv diags + -- --------------------------------------------------------------------- flushDiagnosticsBySource :: (MonadIO m, MonadReader REnv m) From 50c82af73e98a9c7ef5bc191b4d0009552facc17 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 1 Jan 2020 18:02:30 +0000 Subject: [PATCH 3/9] Add passPublishDiagnostics to publish diagnostics via the server It injects a message that gets processed in the right context. --- .../Haskell/Ide/Engine/ModuleCache.hs | 4 +- src/Haskell/Ide/Engine/Server.hs | 90 +++++++++++-------- test/dispatcher/Main.hs | 1 + test/plugin-dispatcher/Main.hs | 3 +- 4 files changed, 59 insertions(+), 39 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index f060e8864..5ad3054e5 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -71,7 +71,7 @@ modifyCache f = modifyModuleCache f -- --------------------------------------------------------------------- -type PublishDiagnostics = Int -> J.NormalizedUri -> J.TextDocumentVersion -> J.DiagnosticsBySource -> IO () +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. @@ -186,7 +186,7 @@ loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do source = Just "bios" diag = Diagnostic range sev Nothing source (Text.unlines msgTxt) Nothing - liftIO $ publishDiagnostics maxBound normalizedUri Nothing + liftIO $ publishDiagnostics normalizedUri Nothing (Map.singleton source (SL.singleton diag)) return $ IdeResultFail $ IdeError diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index 173062885..c75dd132d 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -198,7 +198,7 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do -- recognized properly by ghc-mod flip labelThread "scheduler" =<< forkIO - ( Scheduler.runScheduler scheduler errorHandler callbackHandler lf (publishDiagnostics' lf) mcradle + ( Scheduler.runScheduler scheduler errorHandler callbackHandler lf (passPublishDiagnostics rin) mcradle `E.catch` \(e :: E.SomeException) -> errorm $ "Scheduler thread exited unexpectedly: " ++ show e @@ -256,9 +256,13 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do -- --------------------------------------------------------------------- -type ReactorInput - = FromClientMessage - -- ^ injected into the reactor input by each of the individual callback handlers +data ReactorInput + = CM FromClientMessage + -- ^ injected into the reactor input by each of the individual + -- callback handlers + | PD J.NormalizedUri J.TextDocumentVersion DiagnosticsBySource + -- ^ injected into the reactor input by any scheduler needing to + -- publish additional diagnostics -- --------------------------------------------------------------------- @@ -359,8 +363,10 @@ 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 + clientConfig <- getClientConfig + let maxToSend = maxNumberOfProblems clientConfig lf <- asks lspFuncs publishDiagnostics' lf maxToSend uri' mv diags @@ -415,7 +421,7 @@ reactor inp diagIn = do liftIO $ U.logs $ "****** reactor: got message number:" ++ show tn case inval of - RspFromClient resp@(J.ResponseMessage _ _ _ merr) -> do + CM (RspFromClient resp@(J.ResponseMessage _ _ _ merr)) -> do liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show resp case merr of Nothing -> return () @@ -423,7 +429,7 @@ reactor inp diagIn = do -- ------------------------------- - NotInitialized _notification -> do + CM (NotInitialized _notification) -> do liftIO $ U.logm "****** reactor: processing Initialized Notification" -- Server is ready, register any specific capabilities we need @@ -477,7 +483,7 @@ reactor inp diagIn = do -- ------------------------------- - NotDidOpenTextDocument notification -> do + CM (NotDidOpenTextDocument notification) -> do liftIO $ U.logm "****** reactor: processing NotDidOpenTextDocument" let td = notification ^. J.params . J.textDocument @@ -489,17 +495,17 @@ reactor inp diagIn = do -- ------------------------------- - NotDidChangeWatchedFiles _notification -> do + CM (NotDidChangeWatchedFiles _notification) -> do liftIO $ U.logm "****** reactor: not processing NotDidChangeWatchedFiles" -- ------------------------------- - NotWillSaveTextDocument _notification -> do + CM (NotWillSaveTextDocument _notification) -> do liftIO $ U.logm "****** reactor: not processing NotWillSaveTextDocument" -- ------------------------------- - NotDidSaveTextDocument notification -> do + CM (NotDidSaveTextDocument notification) -> do -- This notification is redundant, as we get the NotDidChangeTextDocument liftIO $ U.logm "****** reactor: processing NotDidSaveTextDocument" let @@ -511,7 +517,7 @@ reactor inp diagIn = do -- ------------------------------- - NotDidChangeTextDocument notification -> do + CM (NotDidChangeTextDocument notification) -> do liftIO $ U.logm "****** reactor: processing NotDidChangeTextDocument" let params = notification ^. J.params @@ -531,7 +537,7 @@ reactor inp diagIn = do -- ------------------------------- - NotDidCloseTextDocument notification -> do + CM (NotDidCloseTextDocument notification) -> do liftIO $ U.logm "****** reactor: processing NotDidCloseTextDocument" let uri = notification ^. J.params . J.textDocument . J.uri @@ -543,7 +549,7 @@ reactor inp diagIn = do -- ------------------------------- - ReqRename req -> do + CM (ReqRename req) -> do liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req -- TODO: re-enable HaRe -- let (params, doc, pos) = reqParams req @@ -556,7 +562,7 @@ reactor inp diagIn = do -- ------------------------------- - ReqHover req -> do + CM (ReqHover req) -> do liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req let params = req ^. J.params pos = params ^. J.position @@ -586,13 +592,13 @@ reactor inp diagIn = do -- ------------------------------- - ReqCodeAction req -> do + CM (ReqCodeAction req) -> do liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req handleCodeActionReq tn req -- ------------------------------- - ReqExecuteCommand req -> do + CM (ReqExecuteCommand req) -> do liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req lf <- asks lspFuncs @@ -665,7 +671,7 @@ reactor inp diagIn = do -- ------------------------------- - ReqCompletion req -> do + CM (ReqCompletion req) -> do liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req let (_, doc, pos) = reqParams req @@ -683,7 +689,7 @@ reactor inp diagIn = do $ lift $ Completions.getCompletions doc prefix snippets makeRequest hreq - ReqCompletionItemResolve req -> do + CM (ReqCompletionItemResolve req) -> do liftIO $ U.logs $ "reactor:got CompletionItemResolveRequest:" ++ show req snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn let origCompl = req ^. J.params @@ -696,7 +702,7 @@ reactor inp diagIn = do -- ------------------------------- - ReqDocumentHighlights req -> do + CM (ReqDocumentHighlights req) -> do liftIO $ U.logs $ "reactor:got DocumentHighlightsRequest:" ++ show req let (_, doc, pos) = reqParams req callback = reactorSend . RspDocumentHighlights . Core.makeResponseMessage req . J.List @@ -706,7 +712,7 @@ reactor inp diagIn = do -- ------------------------------- - ReqDefinition req -> do + CM (ReqDefinition req) -> do liftIO $ U.logs $ "reactor:got DefinitionRequest:" ++ show req let params = req ^. J.params doc = params ^. J.textDocument . J.uri @@ -716,7 +722,7 @@ reactor inp diagIn = do $ fmap J.MultiLoc <$> Hie.findDef doc pos makeRequest hreq - ReqTypeDefinition req -> do + CM (ReqTypeDefinition req) -> do liftIO $ U.logs $ "reactor:got DefinitionTypeRequest:" ++ show req let params = req ^. J.params doc = params ^. J.textDocument . J.uri @@ -726,7 +732,7 @@ reactor inp diagIn = do $ fmap J.MultiLoc <$> Hie.findTypeDef doc pos makeRequest hreq - ReqFindReferences req -> do + CM (ReqFindReferences req) -> do liftIO $ U.logs $ "reactor:got FindReferences:" ++ show req -- TODO: implement project-wide references let (_, doc, pos) = reqParams req @@ -738,7 +744,7 @@ reactor inp diagIn = do -- ------------------------------- - ReqDocumentFormatting req -> do + CM (ReqDocumentFormatting req) -> do liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req provider <- getFormattingProvider let params = req ^. J.params @@ -750,7 +756,7 @@ reactor inp diagIn = do -- ------------------------------- - ReqDocumentRangeFormatting req -> do + CM (ReqDocumentRangeFormatting req) -> do liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req provider <- getFormattingProvider let params = req ^. J.params @@ -763,7 +769,7 @@ reactor inp diagIn = do -- ------------------------------- - ReqDocumentSymbols req -> do + CM (ReqDocumentSymbols req) -> do liftIO $ U.logs $ "reactor:got Document symbol request:" ++ show req sps <- asks symbolProviders C.ClientCapabilities _ tdc _ _ <- asksLspFuncs Core.clientCapabilities @@ -788,14 +794,14 @@ reactor inp diagIn = do -- ------------------------------- - NotCancelRequestFromClient notif -> do + CM (NotCancelRequestFromClient notif) -> do liftIO $ U.logs $ "reactor:got CancelRequest:" ++ show notif let lid = notif ^. J.params . J.id cancelRequest lid -- ------------------------------- - NotDidChangeConfiguration notif -> do + CM (NotDidChangeConfiguration notif) -> do liftIO $ U.logs $ "reactor:didChangeConfiguration notification:" ++ show notif -- if hlint has been turned off, flush the diagnostics diagsOn <- configVal hlintOn @@ -808,8 +814,15 @@ reactor inp diagIn = do else flushDiagnosticsBySource maxDiagnosticsToSend (Just "hlint") -- ------------------------------- - om -> do + + CM om -> do liftIO $ U.logs $ "reactor:got HandlerRequest:" ++ show om + + -- ------------------------------- + + PD uri version diagnostics -> do + publishDiagnostics uri version diagnostics + loop (tn + 1) -- Actually run the thing @@ -943,18 +956,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 @@ -1053,6 +1065,14 @@ hieHandlers rin passHandler :: TChan ReactorInput -> (a -> FromClientMessage) -> Core.Handler a passHandler rin c notification = do - atomically $ writeTChan rin (c notification) + atomically $ writeTChan rin (CM (c notification)) + +-- --------------------------------------------------------------------- + +-- | Generate a 'PublishDiagnostics' function that will simply insert +-- the request into the main server loop +passPublishDiagnostics :: TChan ReactorInput -> PublishDiagnostics +passPublishDiagnostics rin uri version diagnostics = do + atomically $ writeTChan rin (PD uri version diagnostics) -- --------------------------------------------------------------------- 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..b97d88260 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 @@ -65,5 +66,3 @@ newPluginSpec = do killThread pid resp1 `shouldBe` "text1" resp2 `shouldBe` "text4" - - From 1ade72c66d17663ad45c3383a3b86528711d6d99 Mon Sep 17 00:00:00 2001 From: fendor Date: Wed, 1 Jan 2020 22:03:57 +0100 Subject: [PATCH 4/9] Add more sophisticated error messages --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 48 +++++++++++++++------ 1 file changed, 36 insertions(+), 12 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 5b4aa2d6c..048d7967c 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(..), uComponentName) + ChEntrypoint(..), UnitInfo(..)) import Distribution.Helper.Discover (findProjects, getDefaultDistDir) import Data.Char (toLower) import Data.Function ((&)) -import Data.List (isPrefixOf, isInfixOf, sortOn, find, intercalate) +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(..)) @@ -146,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 @@ -548,7 +548,7 @@ getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>= (tried, failed, Nothing) -> return (Left $ buildErrorMsg tried failed) (_, _, Just comp) -> return (Right comp) where - getComponent' :: [Unit pt] -> [Unit pt] -> [Unit pt] -> IO ([Unit pt], [Unit pt], Maybe ChComponentInfo) + 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 @@ -560,15 +560,15 @@ getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>= ++ fp ++ "\" in the unit: " ++ show unit - getComponent' triedUnits (unit:failedUnits) units + getComponent' triedUnits ((unit, e):failedUnits) units Right ui -> do - let components = M.elems (uiComponents ui) + let components = Map.elems (uiComponents ui) debugm $ "Unit Info: " ++ show ui case find (fp `partOfComponent`) components of - Nothing -> getComponent' (unit:triedUnits) failedUnits units + Nothing -> getComponent' (ui:triedUnits) failedUnits units comp -> return (triedUnits, failedUnits, comp) - buildErrorMsg :: [Unit pt] -> [Unit pt] -> [String] + buildErrorMsg :: [UnitInfo] -> [(Unit pt, IOException)] -> [String] buildErrorMsg triedUnits failedUnits = [ "Could not obtain flags for: \"" ++ fp ++ "\"." , "" @@ -577,20 +577,44 @@ getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>= [ [ "This Module was not part of any component we are aware of." , "" - , "If you dont know how to expose a module, take a look at: " - , "https://www.haskell.org/cabal/users-guide/developing-packages.html" - , "" ] + ++ concatMap ppShowUnitInfo triedUnits + ++ [ "" + , "" + , "If you dont know how to expose a module, take a look at:" + , "https://www.haskell.org/cabal/users-guide/developing-packages.html" + , "" + ] | 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) ] + 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: -- From ab761e77c1dee0c228ea6b8ba9fe6dc0d20e3ad8 Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 2 Jan 2020 19:33:24 +0100 Subject: [PATCH 5/9] Make error message more legible. Co-Authored-By: Luke Lau --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 048d7967c..016a44486 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -581,7 +581,7 @@ getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>= ++ concatMap ppShowUnitInfo triedUnits ++ [ "" , "" - , "If you dont know how to expose a module, take a look at:" + , "To expose a module, refer to:" , "https://www.haskell.org/cabal/users-guide/developing-packages.html" , "" ] @@ -828,4 +828,3 @@ cradleDisplay cradle = fromString result | "multi" `isInfixOf` name = "Multi Component project" | otherwise = "project" name = map toLower $ BIOS.actionName (BIOS.cradleOptsProg cradle) - From 5e4a8c63af564d288e056012227ab3cf8cb640b4 Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 4 Jan 2020 13:57:02 +0100 Subject: [PATCH 6/9] Add build-tool agnostic error message --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 97 +++++++++++++-------- 1 file changed, 61 insertions(+), 36 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 016a44486..8aa981c18 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -238,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. @@ -476,6 +479,7 @@ cabalHelperCradle file = do CradleAction { actionName = "Cabal-Helper-" ++ actionNameSuffix , runCradle = \_ fp -> cabalHelperAction + (Ex proj) env realPackage normalisedPackageLocation @@ -497,24 +501,27 @@ 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 Right comp -> do let fs' = getFlags comp @@ -542,8 +549,8 @@ cabalHelperCradle file = do -- The given FilePath must be relative to the Root of the project -- the given units belong to. getComponent - :: forall pt. QueryEnv pt -> [Unit pt] -> FilePath -> IO (Either [String] ChComponentInfo) -getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>= + :: 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) @@ -570,33 +577,51 @@ getComponent env unitCandidates fp = getComponent' [] [] unitCandidates >>= buildErrorMsg :: [UnitInfo] -> [(Unit pt, IOException)] -> [String] buildErrorMsg triedUnits failedUnits = - [ "Could not obtain flags for: \"" ++ fp ++ "\"." + concat + [ [ "Could not obtain flags for: \"" ++ fp ++ "\"." , "" ] - ++ concat - [ - [ "This Module was not part of any component we are aware of." + , concat + [ concat + [ [ "This Module was not part of any component we are aware of." , "" ] - ++ concatMap ppShowUnitInfo triedUnits - ++ [ "" - , "" - , "To expose a module, refer to:" - , "https://www.haskell.org/cabal/users-guide/developing-packages.html" - , "" - ] - | 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 ppShowUnitInfo triedUnits + , [ "" + , "" ] - ++ concatMap (ppShowIOException . snd) failedUnits - | not (null failedUnits) + , 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 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 = From cb51e9ef830f4b34ebe6e4590db33761145c156f Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 4 Jan 2020 14:28:43 +0100 Subject: [PATCH 7/9] Revert "Add passPublishDiagnostics to publish diagnostics via the server" This reverts commit 50c82af73e98a9c7ef5bc191b4d0009552facc17. --- .../Haskell/Ide/Engine/ModuleCache.hs | 4 +- src/Haskell/Ide/Engine/Server.hs | 90 ++++++++----------- test/dispatcher/Main.hs | 1 - test/plugin-dispatcher/Main.hs | 3 +- 4 files changed, 39 insertions(+), 59 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index 5ad3054e5..f060e8864 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -71,7 +71,7 @@ modifyCache f = modifyModuleCache f -- --------------------------------------------------------------------- -type PublishDiagnostics = J.NormalizedUri -> J.TextDocumentVersion -> J.DiagnosticsBySource -> IO () +type PublishDiagnostics = Int -> 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. @@ -186,7 +186,7 @@ loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do source = Just "bios" diag = Diagnostic range sev Nothing source (Text.unlines msgTxt) Nothing - liftIO $ publishDiagnostics normalizedUri Nothing + liftIO $ publishDiagnostics maxBound normalizedUri Nothing (Map.singleton source (SL.singleton diag)) return $ IdeResultFail $ IdeError diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index c75dd132d..173062885 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -198,7 +198,7 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do -- recognized properly by ghc-mod flip labelThread "scheduler" =<< forkIO - ( Scheduler.runScheduler scheduler errorHandler callbackHandler lf (passPublishDiagnostics rin) mcradle + ( Scheduler.runScheduler scheduler errorHandler callbackHandler lf (publishDiagnostics' lf) mcradle `E.catch` \(e :: E.SomeException) -> errorm $ "Scheduler thread exited unexpectedly: " ++ show e @@ -256,13 +256,9 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do -- --------------------------------------------------------------------- -data ReactorInput - = CM FromClientMessage - -- ^ injected into the reactor input by each of the individual - -- callback handlers - | PD J.NormalizedUri J.TextDocumentVersion DiagnosticsBySource - -- ^ injected into the reactor input by any scheduler needing to - -- publish additional diagnostics +type ReactorInput + = FromClientMessage + -- ^ injected into the reactor input by each of the individual callback handlers -- --------------------------------------------------------------------- @@ -363,10 +359,8 @@ updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file -- --------------------------------------------------------------------- publishDiagnostics :: (MonadIO m, MonadReader REnv m) - => J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m () -publishDiagnostics uri' mv diags = do - clientConfig <- getClientConfig - let maxToSend = maxNumberOfProblems clientConfig + => Int -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m () +publishDiagnostics maxToSend uri' mv diags = do lf <- asks lspFuncs publishDiagnostics' lf maxToSend uri' mv diags @@ -421,7 +415,7 @@ reactor inp diagIn = do liftIO $ U.logs $ "****** reactor: got message number:" ++ show tn case inval of - CM (RspFromClient resp@(J.ResponseMessage _ _ _ merr)) -> do + RspFromClient resp@(J.ResponseMessage _ _ _ merr) -> do liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show resp case merr of Nothing -> return () @@ -429,7 +423,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (NotInitialized _notification) -> do + NotInitialized _notification -> do liftIO $ U.logm "****** reactor: processing Initialized Notification" -- Server is ready, register any specific capabilities we need @@ -483,7 +477,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (NotDidOpenTextDocument notification) -> do + NotDidOpenTextDocument notification -> do liftIO $ U.logm "****** reactor: processing NotDidOpenTextDocument" let td = notification ^. J.params . J.textDocument @@ -495,17 +489,17 @@ reactor inp diagIn = do -- ------------------------------- - CM (NotDidChangeWatchedFiles _notification) -> do + NotDidChangeWatchedFiles _notification -> do liftIO $ U.logm "****** reactor: not processing NotDidChangeWatchedFiles" -- ------------------------------- - CM (NotWillSaveTextDocument _notification) -> do + NotWillSaveTextDocument _notification -> do liftIO $ U.logm "****** reactor: not processing NotWillSaveTextDocument" -- ------------------------------- - CM (NotDidSaveTextDocument notification) -> do + NotDidSaveTextDocument notification -> do -- This notification is redundant, as we get the NotDidChangeTextDocument liftIO $ U.logm "****** reactor: processing NotDidSaveTextDocument" let @@ -517,7 +511,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (NotDidChangeTextDocument notification) -> do + NotDidChangeTextDocument notification -> do liftIO $ U.logm "****** reactor: processing NotDidChangeTextDocument" let params = notification ^. J.params @@ -537,7 +531,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (NotDidCloseTextDocument notification) -> do + NotDidCloseTextDocument notification -> do liftIO $ U.logm "****** reactor: processing NotDidCloseTextDocument" let uri = notification ^. J.params . J.textDocument . J.uri @@ -549,7 +543,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (ReqRename req) -> do + ReqRename req -> do liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req -- TODO: re-enable HaRe -- let (params, doc, pos) = reqParams req @@ -562,7 +556,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (ReqHover req) -> do + ReqHover req -> do liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req let params = req ^. J.params pos = params ^. J.position @@ -592,13 +586,13 @@ reactor inp diagIn = do -- ------------------------------- - CM (ReqCodeAction req) -> do + ReqCodeAction req -> do liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req handleCodeActionReq tn req -- ------------------------------- - CM (ReqExecuteCommand req) -> do + ReqExecuteCommand req -> do liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req lf <- asks lspFuncs @@ -671,7 +665,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (ReqCompletion req) -> do + ReqCompletion req -> do liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req let (_, doc, pos) = reqParams req @@ -689,7 +683,7 @@ reactor inp diagIn = do $ lift $ Completions.getCompletions doc prefix snippets makeRequest hreq - CM (ReqCompletionItemResolve req) -> do + ReqCompletionItemResolve req -> do liftIO $ U.logs $ "reactor:got CompletionItemResolveRequest:" ++ show req snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn let origCompl = req ^. J.params @@ -702,7 +696,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (ReqDocumentHighlights req) -> do + ReqDocumentHighlights req -> do liftIO $ U.logs $ "reactor:got DocumentHighlightsRequest:" ++ show req let (_, doc, pos) = reqParams req callback = reactorSend . RspDocumentHighlights . Core.makeResponseMessage req . J.List @@ -712,7 +706,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (ReqDefinition req) -> do + ReqDefinition req -> do liftIO $ U.logs $ "reactor:got DefinitionRequest:" ++ show req let params = req ^. J.params doc = params ^. J.textDocument . J.uri @@ -722,7 +716,7 @@ reactor inp diagIn = do $ fmap J.MultiLoc <$> Hie.findDef doc pos makeRequest hreq - CM (ReqTypeDefinition req) -> do + ReqTypeDefinition req -> do liftIO $ U.logs $ "reactor:got DefinitionTypeRequest:" ++ show req let params = req ^. J.params doc = params ^. J.textDocument . J.uri @@ -732,7 +726,7 @@ reactor inp diagIn = do $ fmap J.MultiLoc <$> Hie.findTypeDef doc pos makeRequest hreq - CM (ReqFindReferences req) -> do + ReqFindReferences req -> do liftIO $ U.logs $ "reactor:got FindReferences:" ++ show req -- TODO: implement project-wide references let (_, doc, pos) = reqParams req @@ -744,7 +738,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (ReqDocumentFormatting req) -> do + ReqDocumentFormatting req -> do liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req provider <- getFormattingProvider let params = req ^. J.params @@ -756,7 +750,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (ReqDocumentRangeFormatting req) -> do + ReqDocumentRangeFormatting req -> do liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req provider <- getFormattingProvider let params = req ^. J.params @@ -769,7 +763,7 @@ reactor inp diagIn = do -- ------------------------------- - CM (ReqDocumentSymbols req) -> do + ReqDocumentSymbols req -> do liftIO $ U.logs $ "reactor:got Document symbol request:" ++ show req sps <- asks symbolProviders C.ClientCapabilities _ tdc _ _ <- asksLspFuncs Core.clientCapabilities @@ -794,14 +788,14 @@ reactor inp diagIn = do -- ------------------------------- - CM (NotCancelRequestFromClient notif) -> do + NotCancelRequestFromClient notif -> do liftIO $ U.logs $ "reactor:got CancelRequest:" ++ show notif let lid = notif ^. J.params . J.id cancelRequest lid -- ------------------------------- - CM (NotDidChangeConfiguration notif) -> do + NotDidChangeConfiguration notif -> do liftIO $ U.logs $ "reactor:didChangeConfiguration notification:" ++ show notif -- if hlint has been turned off, flush the diagnostics diagsOn <- configVal hlintOn @@ -814,15 +808,8 @@ reactor inp diagIn = do else flushDiagnosticsBySource maxDiagnosticsToSend (Just "hlint") -- ------------------------------- - - CM om -> do + om -> do liftIO $ U.logs $ "reactor:got HandlerRequest:" ++ show om - - -- ------------------------------- - - PD uri version diagnostics -> do - publishDiagnostics uri version diagnostics - loop (tn + 1) -- Actually run the thing @@ -956,17 +943,18 @@ 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 fileUri Nothing + then publishDiagnostics maxToSend fileUri Nothing (Map.fromList [(Just "hlint",SL.toSortedList []),(Just pid,SL.toSortedList ds)]) else sendOne pid (fileUri,ds) sendOne pid (fileUri,ds) = do - publishDiagnostics fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds)]) + publishDiagnostics maxToSend 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 (J.toNormalizedUri file) Nothing (Map.fromList [(Just "bios",SL.toSortedList [])]) + sendEmpty = publishDiagnostics maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just "bios",SL.toSortedList [])]) + maxToSend = maxNumberOfProblems clientConfig let sendHlint = hlintOn clientConfig when sendHlint $ do @@ -1065,14 +1053,6 @@ hieHandlers rin passHandler :: TChan ReactorInput -> (a -> FromClientMessage) -> Core.Handler a passHandler rin c notification = do - atomically $ writeTChan rin (CM (c notification)) - --- --------------------------------------------------------------------- - --- | Generate a 'PublishDiagnostics' function that will simply insert --- the request into the main server loop -passPublishDiagnostics :: TChan ReactorInput -> PublishDiagnostics -passPublishDiagnostics rin uri version diagnostics = do - atomically $ writeTChan rin (PD uri version diagnostics) + atomically $ writeTChan rin (c notification) -- --------------------------------------------------------------------- diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index 106cce7cc..bf80d3cbb 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -81,7 +81,6 @@ 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 b97d88260..4f725f82b 100644 --- a/test/plugin-dispatcher/Main.hs +++ b/test/plugin-dispatcher/Main.hs @@ -51,7 +51,6 @@ newPluginSpec = do (\_ _ _ -> return ()) (\f x -> f x) dummyLspFuncs - (\_ _ _ -> return ()) (Just crdl) updateDocument scheduler (filePathToUri "test") 3 @@ -66,3 +65,5 @@ newPluginSpec = do killThread pid resp1 `shouldBe` "text1" resp2 `shouldBe` "text4" + + From f3cfe9d198292aa27e33ea0cdcaaa483e64b3c15 Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 4 Jan 2020 14:46:47 +0100 Subject: [PATCH 8/9] Update the diagnostic publishing function --- .../Haskell/Ide/Engine/ModuleCache.hs | 4 ++-- src/Haskell/Ide/Engine/Server.hs | 20 +++++++++---------- test/dispatcher/Main.hs | 1 + test/plugin-dispatcher/Main.hs | 1 + 4 files changed, 14 insertions(+), 12 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index f060e8864..5ad3054e5 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -71,7 +71,7 @@ modifyCache f = modifyModuleCache f -- --------------------------------------------------------------------- -type PublishDiagnostics = Int -> J.NormalizedUri -> J.TextDocumentVersion -> J.DiagnosticsBySource -> IO () +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. @@ -186,7 +186,7 @@ loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do source = Just "bios" diag = Diagnostic range sev Nothing source (Text.unlines msgTxt) Nothing - liftIO $ publishDiagnostics maxBound normalizedUri Nothing + liftIO $ publishDiagnostics normalizedUri Nothing (Map.singleton source (SL.singleton diag)) return $ IdeResultFail $ IdeError diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index 173062885..b0d7206a7 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -359,16 +359,17 @@ 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 - publishDiagnostics' lf maxToSend uri' mv diags + publishDiagnostics' lf uri' mv diags publishDiagnostics' :: MonadIO m - => Core.LspFuncs c -> Int -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m () -publishDiagnostics' lf maxToSend uri' mv diags = - liftIO $ Core.publishDiagnosticsFunc lf maxToSend uri' mv diags + => 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 -- --------------------------------------------------------------------- @@ -943,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 From 222797e5b33d0d9edb2db6e55934c01631aa612f Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 5 Jan 2020 00:09:14 +0100 Subject: [PATCH 9/9] Fix typo --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 8aa981c18..35d8b9ed6 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -583,7 +583,7 @@ getComponent proj env unitCandidates fp = getComponent' [] [] unitCandidates >>= ] , concat [ concat - [ [ "This Module was not part of any component we are aware of." + [ [ "This module was not part of any component we are aware of." , "" ] , concatMap ppShowUnitInfo triedUnits @@ -612,7 +612,7 @@ getComponent proj env unitCandidates fp = getComponent' [] [] unitCandidates >>= 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 manually expose modules." + , "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." ]