hie-core Logging and exceptions (#1933)

* Rename reportSeriousError to reportInternalError

* Stop using logError for logging things that are warnings to the user, not errors by us

* Rename logError

* Sort the log fields properly

* Delete tagAction from Logger

* Strip down the pure logger

* Delete unused pieces of the logger

* A quick check suggests the call stack will be useful in approximately none of the callers of logging, so just remove it

* When reporting an internal error, give as much detail as we can

* Change our logger to be based on Priority values

* HLint fixes

* Rename makeNopLogger

* In hie-core say what level of message you are setting

* Delete the unused makeOneLogger

* Make sure we can show messages floating around

* If a notification/response handler throws an exception, report it upwards

* Remove reportInternalError in favour of a general logging mechanism

* Add missing dependencies

* Just call fail for a dodgy error report

* Add a FIXME

* Make missing modules just an error

BUILD.bazel

@@ -24,6 +24,7 @@ depends = [
     "prettyprinter",
     "prettyprinter-ansi-terminal",
     "rope-utf16-splay",
+    "safe-exceptions",
     "sorted-list",
     "shake",
     "stm",

exe/Main.hs

@@ -22,6 +22,7 @@ import Development.IDE.Types.Location
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Options
 import Development.IDE.Types.Logger
+import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Language.Haskell.LSP.Messages
 import Development.IDE.LSP.LanguageServer
@@ -52,7 +53,8 @@ main = do
 
     -- lock to avoid overlapping output on stdout
     lock <- newLock
-    let logger = makeOneLogger $ withLock lock . T.putStrLn
+    let logger = Logger $ \pri msg -> withLock lock $
+            T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
 
     whenJust argsCwd setCurrentDirectory
 

hie-core.cabal

@@ -111,6 +111,7 @@ executable hie-core
         directory,
         optparse-applicative,
         hie-bios,
+        safe-exceptions,
         shake,
         data-default,
         ghc-paths,

src/Development/IDE/Core/Shake.hs

@@ -32,12 +32,12 @@ module Development.IDE.Core.Shake(
     use_, uses_,
     define, defineEarlyCutoff,
     getDiagnostics, unsafeClearDiagnostics,
-    reportSeriousError,
     IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
     garbageCollect,
     setPriority,
     sendEvent,
     ideLogger,
+    actionLogger,
     FileVersion(..)
     ) where
 
@@ -307,11 +307,6 @@ uses_ key files = do
         Nothing -> liftIO $ throwIO BadDependency
         Just v -> return v
 
-reportSeriousError :: String -> Action ()
-reportSeriousError t = do
-    ShakeExtras{logger} <- getShakeExtras
-    liftIO $ logSeriousError logger $ T.pack t
-
 
 -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
 --   which short-circuits the rest of the action
@@ -420,6 +415,11 @@ sendEvent e = do
 ideLogger :: IdeState -> Logger
 ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
 
+actionLogger :: Action Logger
+actionLogger = do
+    ShakeExtras{logger} <- getShakeExtras
+    return logger
+
 
 data GetModificationTime = GetModificationTime
     deriving (Eq, Show, Generic)

src/Development/IDE/LSP/LanguageServer.hs

@@ -17,8 +17,10 @@ import qualified Language.Haskell.LSP.Core as LSP
 import Control.Concurrent.Chan
 import Control.Concurrent.Extra
 import Control.Concurrent.Async
+import Control.Exception.Safe
 import Data.Default
 import Data.Maybe
+import qualified Data.Text as T
 import           GHC.IO.Handle                    (hDuplicate, hDuplicateTo)
 import System.IO
 import Control.Monad.Extra
@@ -27,6 +29,7 @@ import Development.IDE.LSP.Definition
 import Development.IDE.LSP.Hover
 import Development.IDE.LSP.Notifications
 import Development.IDE.Core.Service
+import Development.IDE.Types.Logger
 import Development.IDE.Core.FileStore
 import Language.Haskell.LSP.Core (LspFuncs(..))
 import Language.Haskell.LSP.Messages
@@ -89,10 +92,23 @@ runLanguageServer options userHandlers getIdeState = do
             _ <- flip forkFinally (const exitClientMsg) $ forever $ do
                 msg <- readChan clientMsgChan
                 case msg of
-                    Notification NotificationMessage{_params} act -> act ide _params
-                    Response RequestMessage{_id, _params} wrap act -> do
-                        res <- act ide _params
-                        sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
+                    Notification x@NotificationMessage{_params} act -> do
+                        catch (act ide _params) $ \(e :: SomeException) ->
+                            logError (ideLogger ide) $ T.pack $
+                                "Unexpected exception on notification, please report!\n" ++
+                                "Message: " ++ show x ++ "\n" ++
+                                "Exception: " ++ show e
+                    Response x@RequestMessage{_id, _params} wrap act ->
+                        catch (do
+                            res <- act ide _params
+                            sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
+                        ) $ \(e :: SomeException) -> do
+                            logError (ideLogger ide) $ T.pack $
+                                "Unexpected exception on request, please report!\n" ++
+                                "Message: " ++ show x ++ "\n" ++
+                                "Exception: " ++ show e
+                            sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
+                                Just $ ResponseError InternalError (T.pack $ show e) Nothing
             pure Nothing
 
 
@@ -109,8 +125,8 @@ setHandlersIgnore = PartialHandlers $ \_ x -> return x
 -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
 --   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
 data Message
-    = forall m req resp . Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (IdeState -> req -> IO resp)
-    | forall m req . Notification (NotificationMessage m req) (IdeState -> req -> IO ())
+    = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (IdeState -> req -> IO resp)
+    | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (IdeState -> req -> IO ())
 
 
 modifyOptions :: LSP.Options -> LSP.Options

src/Development/IDE/LSP/Server.hs

@@ -18,11 +18,11 @@ import Development.IDE.Core.Service
 
 
 data WithMessage = WithMessage
-    {withResponse :: forall m req resp .
+    {withResponse :: forall m req resp . (Show m, Show req) =>
         (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
         (IdeState -> req -> IO resp) -> -- actual work
         Maybe (LSP.Handler (RequestMessage m req resp))
-    ,withNotification :: forall m req .
+    ,withNotification :: forall m req . (Show m, Show req) =>
         Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
         (IdeState -> req -> IO ()) -> -- actual work
         Maybe (LSP.Handler (NotificationMessage m req))

src/Development/IDE/Types/Logger.hs

@@ -6,23 +6,45 @@
 -- concrete choice of logging framework so users can plug in whatever
 -- framework they want to.
 module Development.IDE.Types.Logger
-  ( Logger(..)
-  , makeOneLogger
-  , makeNopLogger
+  ( Priority(..)
+  , Logger(..)
+  , logError, logWarning, logInfo, logDebug
+  , noLogging
   ) where
 
 import qualified Data.Text as T
-import GHC.Stack
 
-data Logger = Logger {
-      logSeriousError :: HasCallStack => T.Text -> IO ()
-    , logInfo :: HasCallStack => T.Text -> IO ()
-    , logDebug :: HasCallStack => T.Text -> IO ()
-    , logWarning :: HasCallStack => T.Text -> IO ()
-    }
 
-makeNopLogger :: Logger
-makeNopLogger = makeOneLogger $ const $ pure ()
+data Priority
+-- Don't change the ordering of this type or you will mess up the Ord
+-- instance
+    = Debug -- ^ Verbose debug logging.
+    | Info  -- ^ Useful information in case an error has to be understood.
+    | Warning
+      -- ^ These error messages should not occur in a expected usage, and
+      -- should be investigated.
+    | Error -- ^ Such log messages must never occur in expected usage.
+    deriving (Eq, Show, Ord, Enum, Bounded)
 
-makeOneLogger :: (HasCallStack => T.Text -> IO ()) -> Logger
-makeOneLogger x = Logger x x x x
+
+-- | 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 Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}
+
+
+logError :: Logger -> T.Text -> IO ()
+logError x = logPriority x Error
+
+logWarning :: Logger -> T.Text -> IO ()
+logWarning x = logPriority x Warning
+
+logInfo :: Logger -> T.Text -> IO ()
+logInfo x = logPriority x Info
+
+logDebug :: Logger -> T.Text -> IO ()
+logDebug x = logPriority x Debug
+
+
+noLogging :: Logger
+noLogging = Logger $ \_ _ -> return ()