diff --git a/exe/Main.hs b/exe/Main.hs index d3f8af8d007..7100c57c71b 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -5,18 +5,21 @@ module Main(main) where import Data.Function ((&)) -import Development.IDE.Types.Logger (Priority (Debug, Info), +import Development.IDE.Types.Logger (Priority (Debug, Info, Error), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, makeDefaultStderrRecorder, - withDefaultRecorder) + withDefaultRecorder, renderStrict, layoutPretty, defaultLayoutOptions, Doc) import Ide.Arguments (Arguments (..), GhcideArguments (..), getArguments) import Ide.Main (defaultMain) import qualified Ide.Main as IdeMain import qualified Plugins -import Prettyprinter (Pretty (pretty)) +import Prettyprinter (Pretty (pretty), vcat) +import Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder) +import Data.Text (Text) +import Ide.PluginUtils (pluginDescToIdePlugins) data Log = LogIdeMain IdeMain.Log @@ -33,6 +36,7 @@ main = do -- parser to get logging arguments first or do more complicated things pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False) + (lspRecorder, lspRecorderPlugin) <- makeLspShowMessageRecorder let (minPriority, logFilePath, includeExamplePlugins) = case args of @@ -42,9 +46,23 @@ main = do _ -> (Info, Nothing, False) withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do - let recorder = - textWithPriorityRecorder - & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmapWithPrio pretty + let + recorder = cmapWithPrio pretty $ mconcat + [textWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= minPriority) + , lspRecorder + & cfilter (\WithPriority{ priority } -> priority >= Error) + & cmapWithPrio renderDoc + ] + plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins - defaultMain (cmapWithPrio LogIdeMain recorder) args (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins) + defaultMain (cmapWithPrio LogIdeMain recorder) args (pluginDescToIdePlugins [lspRecorderPlugin] <> plugins) + +renderDoc :: Doc a -> Text +renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vcat + ["Unhandled exception, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): " + ,d + ] + +issueTrackerUrl :: Doc a +issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 178052da71c..d3bfc648a58 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -23,11 +23,11 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import Development.IDE.Types.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), - Priority (Debug, Info), + Priority (Debug, Info, Error), Recorder (Recorder), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, - makeDefaultStderrRecorder) + makeDefaultStderrRecorder, layoutPretty, renderStrict, payload, defaultLayoutOptions) import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options import GHC.Stack (emptyCallStack) @@ -39,6 +39,8 @@ import System.Environment (getExecutablePath) import System.Exit (exitSuccess) import System.IO (hPutStrLn, stderr) import System.Info (compilerVersion) +import Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder) +import Control.Lens (Contravariant(contramap)) data Log = LogIDEMain IDEMain.Log @@ -86,9 +88,13 @@ main = withTelemetryLogger $ \telemetryLogger -> do docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority + (lspRecorder, lspRecorderPlugin) <- makeLspShowMessageRecorder + let docWithFilteredPriorityRecorder@Recorder{ logger_ } = - docWithPriorityRecorder - & cfilter (\WithPriority{ priority } -> priority >= minPriority) + (docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <> + (lspRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) + & cfilter (\WithPriority{ priority } -> priority >= Error) + ) -- exists so old-style logging works. intended to be phased out let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) @@ -105,6 +111,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do { IDEMain.argsProjectRoot = Just argsCwd , IDEMain.argCommand = argsCommand , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger + , IDEMain.argsHlsPlugins = pluginDescToIdePlugins [lspRecorderPlugin] <> IDEMain.argsHlsPlugins arguments , IDEMain.argsRules = do -- install the main and ghcide-plugin rules diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 1a0775714b3..9c7ed24d69e 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -202,6 +202,7 @@ library Development.IDE.Plugin.Completions.Types Development.IDE.Plugin.CodeAction Development.IDE.Plugin.CodeAction.ExactPrint + Development.IDE.Plugin.LSPWindowShowMessageRecorder Development.IDE.Plugin.HLS Development.IDE.Plugin.HLS.GhcIde Development.IDE.Plugin.Test diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 07d4595652c..f8492464aa2 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -99,6 +99,7 @@ import HieDb.Types import HieDb.Utils import System.Random (RandomGen) import qualified System.Random as Random +import Control.Monad.IO.Unlift (MonadUnliftIO) data Log = LogSettingInitialDynFlags @@ -253,7 +254,7 @@ getInitialGhcLibDirDefault recorder rootDir = do case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do - log Warning $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle + log Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle pure Nothing CradleNone -> do log Warning LogGetInitialGhcLibDirDefaultCradleNone @@ -845,7 +846,7 @@ should be filtered out, such that we dont have to re-compile everything. -- | Set the cache-directory based on the ComponentOptions and a list of -- internal packages. -- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags setCacheDirs recorder CacheDirs{..} dflags = do logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) pure $ dflags diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 29325813d51..e3aebd218d7 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -628,14 +628,14 @@ readHieFileForSrcFromDisk recorder file = do ShakeExtras{withHieDb} <- ask row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file) let hie_loc = HieDb.hieModuleHieFile row - logWith recorder Logger.Debug $ LogLoadingHieFile file + liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFile file exceptToMaybeT $ readHieFileFromDisk recorder hie_loc readHieFileFromDisk :: Recorder (WithPriority Log) -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile readHieFileFromDisk recorder hie_loc = do nc <- asks ideNc res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc - let log = logWith recorder + let log = (liftIO .) . logWith recorder case res of Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index f4c886e9b96..2ca694781d4 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -71,9 +71,6 @@ instance Pretty Log where "Cancelled request" <+> viaShow requestId LogSession log -> pretty log -issueTrackerUrl :: T.Text -issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" - -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb @@ -184,20 +181,11 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur let handleServerException (Left e) = do log Error $ LogReactorThreadException e - sendErrorMessage e exitClientMsg handleServerException (Right _) = pure () - sendErrorMessage (e :: SomeException) = do - LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtError $ T.unlines - [ "Unhandled exception, please [report](" <> issueTrackerUrl <> "): " - , T.pack(show e) - ] - exceptionInHandler e = do log Error $ LogReactorMessageActionException e - sendErrorMessage e checkCancelled _id act k = flip finally (clearReqId _id) $ diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 3152ce9ce46..43e9827c8b0 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -31,7 +31,7 @@ import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as LT import Data.Typeable (typeOf) import Development.IDE (Action, GhcVersion (..), - Priority (Debug), Rules, + Priority (Debug, Error), Rules, ghcVersion, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, @@ -336,7 +336,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re _mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions -- TODO: should probably catch/log/rethrow at top level instead - `catchAny` (\e -> log Debug (LogSetInitialDynFlagsException e) >> pure Nothing) + `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing) sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir config <- LSP.runLspT env LSP.getConfig diff --git a/ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs b/ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs new file mode 100644 index 00000000000..fb583a377a6 --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/LSPWindowShowMessageRecorder.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE GADTs #-} + +module Development.IDE.Plugin.LSPWindowShowMessageRecorder (makeLspShowMessageRecorder) where + +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Foldable (for_) +import Data.IORef +import Data.IORef.Extra (atomicModifyIORef'_) +import Data.Text (Text) +import Development.IDE.Types.Logger +import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler) +import Language.LSP.Server (LanguageContextEnv, getLspEnv) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (MessageType (..), SMethod (SInitialized, SWindowShowMessage), ShowMessageParams (..)) + +-- | Creates a recorder that logs to the LSP stream via WindowShowMessage notifications. +-- The recorder won't attempt to send messages until the LSP stream is initialized. +makeLspShowMessageRecorder :: + IO (Recorder (WithPriority Text), PluginDescriptor c) +makeLspShowMessageRecorder = do + envRef <- newIORef Nothing + -- messages logged before the LSP stream is initialized will be sent when it is + backLogRef <- newIORef [] + let recorder = Recorder $ \it -> do + mbenv <- liftIO $ readIORef envRef + case mbenv of + Nothing -> liftIO $ atomicModifyIORef'_ backLogRef (it :) + Just env -> sendMsg env it + -- the plugin captures the language context, so it can be used to send messages + plugin = + (defaultPluginDescriptor "LSPWindowShowMessageRecorder") + { pluginNotificationHandlers = mkPluginNotificationHandler SInitialized $ \_ _ _ -> do + env <- getLspEnv + liftIO $ writeIORef envRef $ Just env + -- flush the backlog + backLog <- liftIO $ atomicModifyIORef' backLogRef ([],) + for_ (reverse backLog) $ sendMsg env + } + return (recorder, plugin) + +sendMsg :: MonadUnliftIO m => LanguageContextEnv config -> WithPriority Text -> m () +sendMsg env WithPriority {..} = + LSP.runLspT env $ + LSP.sendNotification + SWindowShowMessage + ShowMessageParams + { _xtype = priorityToLsp priority, + _message = payload + } + +priorityToLsp :: Priority -> MessageType +priorityToLsp = + \case + Debug -> MtLog + Info -> MtInfo + Warning -> MtWarning + Error -> MtError diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index da0912861d0..264435b3643 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -22,6 +22,7 @@ module Development.IDE.Types.Logger , LoggingColumn(..) , cmapWithPrio , module PrettyPrinterModule + , renderStrict ) where import Control.Concurrent (myThreadId) @@ -95,10 +96,10 @@ data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallSta -- | Note that this is logging actions _of the program_, not of the user. -- You shouldn't call warning/error if the user has caused an error, only -- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). -data Recorder msg = Recorder - { logger_ :: forall m. (MonadIO m) => msg -> m () } +newtype Recorder msg = Recorder + { logger_ :: forall m. (MonadUnliftIO m) => msg -> m () } -logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () +logWith :: (HasCallStack, MonadUnliftIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg) instance Semigroup (Recorder msg) where @@ -289,7 +290,3 @@ textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = d pure (threadIdToText threadId) PriorityColumn -> pure (priorityToText priority) DataColumn -> pure payload - - - - diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index c31c3dd7555..cee9a3c7b9c 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -81,6 +81,7 @@ library , stm-containers , time , transformers + , unliftio , unordered-containers if flag(embed-files) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 0a1278f5d3f..5cb69378612 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -36,6 +36,7 @@ import qualified ListT import StmContainers.Map (Map) import qualified StmContainers.Map as SMap import System.Time.Extra (Seconds) +import UnliftIO (MonadUnliftIO) unwrapDynamic :: forall a . Typeable a => Dynamic -> a @@ -62,7 +63,7 @@ data SRules = SRules { -- ACTIONS newtype Action a = Action {fromAction :: ReaderT SAction IO a} - deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask) + deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO) data SAction = SAction { actionDatabase :: !Database,