Merge pull request #401 from michaelpj/mpj/propagate-utf16-err

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

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

lsp/ChangeLog.md

@@ -3,6 +3,7 @@
 ## 1.5.0.0
 
 * VFS module moved to `lsp` from `lsp-types`.
+* Logging reworked to use `co-log-core` instead of `hslogger`.
 
 ## 1.4.0.0