Change logging to use co-log-core instead of hslogger

This started as an attempt to bubble up errors from the VFS as actual
errors and return them to the user via the LSP response. However, in
fact VFS operations occur in response to notifications, which don't have
responses.

So all we can do is log the error and drop the change, which is okay.
However, that made me look at how the logging works. At the moment we
use `hslogger`, which is fine, but isn't so great when it's plugging
into part of a larger system. For example, we might want to have a
global log handler that sends error-level logs to the client as
messages, or uses the `logMessage` method of the LSP spec. But there's no
way to intercept the messages sent by the VFS currently.

So I switched over to using `co-log-core`, which is also the direction
that [HLS is going](haskell/haskell-language-server#2558).

`co-log-core` is also a lightweight dependency.
It's suboptimal for `lsp-types` to depend on a logging library, however, but that
should be fixed when we do haskell#394.

Author: michaelpj

cabal.project

@@ -10,3 +10,11 @@ tests: True
 benchmarks: True
 test-show-details: direct
 haddock-quickjump: True
+
+-- For 9.2 support. Fixed, just needs a Hackage release
+allow-newer: co-log-core:base
+
+source-repository-package
+  type: git
+  location: https://github.com/co-log/co-log-core
+  tag: 77a01a4344b7a048e41b3da9371f41f948053891

lsp-test/bench/SimpleBench.hs

@@ -44,7 +44,7 @@ main = do
 
   n <- read . head <$> getArgs
 
-  forkIO $ void $ runServerWithHandles hinRead houtWrite server
+  forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite server
   liftIO $ putStrLn $ "Starting " <> show n <> " rounds"
 
   i <- newIORef 0

lsp-test/func-test/FuncTest.hs

@@ -18,9 +18,11 @@ import UnliftIO
 import UnliftIO.Concurrent
 import Control.Exception
 import System.Exit
+import qualified Colog.Core as L
 
 main :: IO ()
 main = hspec $ do
+  let logger = L.cmap show L.logStringStderr
   describe "progress reporting" $
     it "sends end notification if thread is killed" $ do
       (hinRead, hinWrite) <- createPipe
@@ -48,7 +50,7 @@ main = hspec $ do
                 takeMVar killVar
                 killThread tid
 
-      forkIO $ void $ runServerWithHandles hinRead houtWrite definition
+      forkIO $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition
 
       Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do
         -- First make sure that we get a $/progress begin notification
@@ -107,8 +109,7 @@ main = hspec $ do
                   _ -> error "Shouldn't be here"
             ]
 
-      
-      server <- async $ void $ runServerWithHandles hinRead houtWrite definition
+      server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition
 
       let config = Test.defaultConfig
             { Test.initialWorkspaceFolders = Just [wf0]

lsp-test/lsp-test.cabal

@@ -44,6 +44,7 @@ library
                      , ansi-terminal
                      , async
                      , bytestring
+                     , co-log-core
                      , conduit
                      , conduit-parse == 0.2.*
                      , containers >= 0.5.9
@@ -104,6 +105,7 @@ test-suite func-test
                      , lsp-test
                      , lsp
                      , process
+                     , co-log-core
                      , lens
                      , unliftio
                      , hspec

lsp-test/src/Language/LSP/Test.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeInType #-}
@@ -119,7 +118,7 @@ import Data.List
 import Data.Maybe
 import Language.LSP.Types
 import Language.LSP.Types.Lens hiding
-  (id, capabilities, message, executeCommand, applyEdit, rename)
+  (id, capabilities, message, executeCommand, applyEdit, rename, to)
 import qualified Language.LSP.Types.Lens as LSP
 import qualified Language.LSP.Types.Capabilities as C
 import Language.LSP.VFS
@@ -135,6 +134,7 @@ import System.Directory
 import System.FilePath
 import System.Process (ProcessHandle)
 import qualified System.FilePath.Glob as Glob
+import Control.Monad.State (execState)
 
 -- | Starts a new session.
 --
@@ -280,7 +280,7 @@ envOverrideConfig cfg = do
 documentContents :: TextDocumentIdentifier -> Session T.Text
 documentContents doc = do
   vfs <- vfs <$> get
-  let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
+  let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. uri))
   return (virtualFileText file)
 
 -- | Parses an ApplyEditRequest, checks that it is for the passed document
@@ -348,24 +348,24 @@ sendNotification :: SClientMethod (m :: Method FromClient Notification) -- ^ The
 sendNotification STextDocumentDidOpen params = do
   let n = NotificationMessage "2.0" STextDocumentDidOpen params
   oldVFS <- vfs <$> get
-  let (newVFS,_) = openVFS oldVFS n
+  let newVFS = flip execState oldVFS $ openVFS mempty n
   modify (\s -> s { vfs = newVFS })
   sendMessage n
 
 -- Close a virtual file if we send a close text document notification
 sendNotification STextDocumentDidClose params = do
   let n = NotificationMessage "2.0" STextDocumentDidClose params
   oldVFS <- vfs <$> get
-  let (newVFS,_) = closeVFS oldVFS n
+  let newVFS = flip execState oldVFS $ closeVFS mempty n
   modify (\s -> s { vfs = newVFS })
   sendMessage n
 
 sendNotification STextDocumentDidChange params = do
-    let n = NotificationMessage "2.0" STextDocumentDidChange params
-    oldVFS <- vfs <$> get
-    let (newVFS,_) = changeFromClientVFS oldVFS n
-    modify (\s -> s { vfs = newVFS })
-    sendMessage n
+  let n = NotificationMessage "2.0" STextDocumentDidChange params
+  oldVFS <- vfs <$> get
+  let newVFS = flip execState oldVFS $ changeFromClientVFS mempty n
+  modify (\s -> s { vfs = newVFS })
+  sendMessage n
 
 sendNotification method params =
   case splitClientMethod method of
@@ -594,11 +594,8 @@ executeCodeAction action = do
 -- | Adds the current version to the document, as tracked by the session.
 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
 getVersionedDoc (TextDocumentIdentifier uri) = do
-  fs <- vfsMap . vfs <$> get
-  let ver =
-        case fs Map.!? toNormalizedUri uri of
-          Just vf -> Just (virtualFileVersion vf)
-          _ -> Nothing
+  vfs <- vfs <$> get
+  let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion
   return (VersionedTextDocumentIdentifier uri ver)
 
 -- | Applys an edit to the document and returns the updated document version.

lsp-test/src/Language/LSP/Test/Session.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP               #-}
-{-# LANGUAGE BangPatterns      #-}
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -48,10 +47,10 @@ import Control.Monad.Fail
 #endif
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import qualified Control.Monad.Trans.Reader as Reader (ask)
-import Control.Monad.Trans.State (StateT, runStateT)
+import Control.Monad.Trans.State (StateT, runStateT, execState)
 import qualified Control.Monad.Trans.State as State
 import qualified Data.ByteString.Lazy.Char8 as B
-import Data.Aeson
+import Data.Aeson hiding (Error)
 import Data.Aeson.Encode.Pretty
 import Data.Conduit as Conduit
 import Data.Conduit.Parser as Parser
@@ -80,8 +79,9 @@ import System.Process (ProcessHandle())
 #ifndef mingw32_HOST_OS
 import System.Process (waitForProcess)
 #endif
-import System.Timeout
+import System.Timeout ( timeout )
 import Data.IORef
+import Colog.Core (LogAction (..), WithSeverity (..), Severity (..))
 
 -- | A session representing one instance of launching and connecting to a server.
 --
@@ -367,7 +367,7 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
         error "WorkspaceEdit contains neither documentChanges nor changes!"
 
   modifyM $ \s -> do
-    newVFS <- liftIO $ changeFromServerVFS (vfs s) r
+    let newVFS = flip execState (vfs s) $ changeFromServerVFS logger r
     return $ s { vfs = newVFS }
 
   let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams
@@ -384,22 +384,24 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
     modify $ \s ->
       let oldVFS = vfs s
           update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver +1) t
-          newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS
+          newVFS = oldVFS & vfsMap . ix (toNormalizedUri uri) %~ update
       in s { vfs = newVFS }
 
-  where checkIfNeedsOpened uri = do
+  where
+        logger = LogAction $ \(WithSeverity msg sev) -> case sev of { Error -> error $ show msg; _ -> pure () }
+        checkIfNeedsOpened uri = do
           oldVFS <- vfs <$> get
 
           -- if its not open, open it
-          unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do
+          unless (has (vfsMap . ix (toNormalizedUri uri)) oldVFS) $ do
             let fp = fromJust $ uriToFilePath uri
             contents <- liftIO $ T.readFile fp
             let item = TextDocumentItem (filePathToUri fp) "" 0 contents
                 msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item)
             sendMessage msg
 
             modifyM $ \s -> do
-              let (newVFS,_) = openVFS (vfs s) msg
+              let newVFS = flip execState (vfs s) $ openVFS logger msg
               return $ s { vfs = newVFS }
 
         getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams
@@ -420,9 +422,8 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
         -- For a uri returns an infinite list of versions [n,n+1,n+2,...]
         -- where n is the current version
         textDocumentVersions uri = do
-          m <- vfsMap . vfs <$> get
-          let curVer = fromMaybe 0 $
-                _lsp_version <$> m Map.!? (toNormalizedUri uri)
+          vfs <- vfs <$> get
+          let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version
           pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..]
 
         textDocumentEdits uri edits = do

lsp-test/test/DummyServer.hs

@@ -35,7 +35,7 @@ withDummyServer f = do
         }
 
   bracket
-    (forkIO $ void $ runServerWithHandles hinRead houtWrite definition)
+    (forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite definition)
     killThread
     (const $ f (hinWrite, houtRead))
 

lsp-types/src/Language/LSP/Types/Message.hs

@@ -372,7 +372,7 @@ deriving instance Read (ResponseResult m) => Read (ResponseMessage m)
 deriving instance Show (ResponseResult m) => Show (ResponseMessage m)
 
 instance (ToJSON (ResponseResult m)) => ToJSON (ResponseMessage m) where
-  toJSON (ResponseMessage { _jsonrpc = jsonrpc, _id = lspid, _result = result })
+  toJSON ResponseMessage { _jsonrpc = jsonrpc, _id = lspid, _result = result }
     = object
       [ "jsonrpc" .= jsonrpc
       , "id" .= lspid
@@ -389,11 +389,11 @@ instance FromJSON (ResponseResult a) => FromJSON (ResponseMessage a) where
     _result  <- o .:! "result"
     _error   <- o .:? "error"
     result   <- case (_error, _result) of
-      ((Just err), Nothing   ) -> pure $ Left err
-      (Nothing   , (Just res)) -> pure $ Right res
-      ((Just _err), (Just _res)) -> fail $ "both error and result cannot be present: " ++ show o
+      (Just err, Nothing) -> pure $ Left err
+      (Nothing, Just res) -> pure $ Right res
+      (Just _err, Just _res) -> fail $ "both error and result cannot be present: " ++ show o
       (Nothing, Nothing) -> fail "both error and result cannot be Nothing"
-    return $ ResponseMessage _jsonrpc _id $ result
+    return $ ResponseMessage _jsonrpc _id result
 
 -- ---------------------------------------------------------------------
 -- Helper Type Families

lsp-types/src/Language/LSP/Types/Method.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE MagicHash                  #-}
 {-# LANGUAGE TypeFamilies               #-}