LSP window message log recorder (#2750)

* failing to set the unsafe dynflags is an error

* makeLspRecorder

* include link to the issue tracker

* avoid double popup

* catch another ghc lib dir error

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"

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

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

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

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

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) $

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

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

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
-
-
-
-

hls-graph/hls-graph.cabal

@@ -81,6 +81,7 @@ library
     , stm-containers
     , time
     , transformers
+    , unliftio
     , unordered-containers
 
   if flag(embed-files)

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,