diff --git a/lsp-test/bench/SimpleBench.hs b/lsp-test/bench/SimpleBench.hs index 051118e3e..72d868e2e 100644 --- a/lsp-test/bench/SimpleBench.hs +++ b/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 diff --git a/lsp-test/func-test/FuncTest.hs b/lsp-test/func-test/FuncTest.hs index f4fc4fd6c..46016423a 100644 --- a/lsp-test/func-test/FuncTest.hs +++ b/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] diff --git a/lsp-test/lsp-test.cabal b/lsp-test/lsp-test.cabal index cddfd8f09..4d0fab719 100644 --- a/lsp-test/lsp-test.cabal +++ b/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 diff --git a/lsp-test/src/Language/LSP/Test.hs b/lsp-test/src/Language/LSP/Test.hs index 079928662..423512ba7 100644 --- a/lsp-test/src/Language/LSP/Test.hs +++ b/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,7 +348,7 @@ 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 @@ -356,16 +356,16 @@ sendNotification STextDocumentDidOpen params = do 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. diff --git a/lsp-test/src/Language/LSP/Test/Session.hs b/lsp-test/src/Language/LSP/Test/Session.hs index 81c828ef8..1d945dcda 100644 --- a/lsp-test/src/Language/LSP/Test/Session.hs +++ b/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,14 +384,16 @@ 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 @@ -399,7 +401,7 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do 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 diff --git a/lsp-test/test/DummyServer.hs b/lsp-test/test/DummyServer.hs index 0085d0832..237dddcec 100644 --- a/lsp-test/test/DummyServer.hs +++ b/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)) diff --git a/lsp-types/src/Language/LSP/Types/Message.hs b/lsp-types/src/Language/LSP/Types/Message.hs index 6460907a6..156414cd0 100644 --- a/lsp-types/src/Language/LSP/Types/Message.hs +++ b/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 diff --git a/lsp-types/src/Language/LSP/Types/Method.hs b/lsp-types/src/Language/LSP/Types/Method.hs index 5b83ad887..3a0de33e4 100644 --- a/lsp-types/src/Language/LSP/Types/Method.hs +++ b/lsp-types/src/Language/LSP/Types/Method.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} diff --git a/lsp/ChangeLog.md b/lsp/ChangeLog.md index 0de3ef201..b71ca2a7d 100644 --- a/lsp/ChangeLog.md +++ b/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 diff --git a/lsp/example/Reactor.hs b/lsp/example/Reactor.hs index 20724d87e..f079b816c 100644 --- a/lsp/example/Reactor.hs +++ b/lsp/example/Reactor.hs @@ -8,6 +8,10 @@ {-# LANGUAGE TypeInType #-} {-# LANGUAGE DuplicateRecordFields #-} +-- So we can keep using the old prettyprinter modules (which have a better +-- compatibility range) for now. +{-# OPTIONS_GHC -Wno-deprecations #-} + {- | This is an example language server built with haskell-lsp using a 'Reactor' design. With a 'Reactor' all requests are handled on a /single thread/. @@ -23,6 +27,9 @@ To try out this server, install it with and plug it into your client of choice. -} module Main (main) where + +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) +import qualified Colog.Core as L import Control.Concurrent.STM.TChan import qualified Control.Exception as E import Control.Lens hiding (Iso) @@ -32,14 +39,16 @@ import Control.Monad.STM import qualified Data.Aeson as J import Data.Int (Int32) import qualified Data.Text as T +import Data.Text.Prettyprint.Doc import GHC.Generics (Generic) import Language.LSP.Server +import System.IO import Language.LSP.Diagnostics +import Language.LSP.Logging (defaultClientLogger) import qualified Language.LSP.Types as J import qualified Language.LSP.Types.Lens as J import Language.LSP.VFS import System.Exit -import System.Log.Logger import Control.Concurrent @@ -67,27 +76,44 @@ run = flip E.catches handlers $ do rin <- atomically newTChan :: IO (TChan ReactorInput) let + -- Three loggers: + -- 1. To stderr + -- 2. To the client (filtered by severity) + -- 3. To both + stderrLogger :: LogAction IO (WithSeverity T.Text) + stderrLogger = L.cmap show L.logStringStderr + clientLogger :: LogAction (LspM Config) (WithSeverity T.Text) + clientLogger = defaultClientLogger + dualLogger :: LogAction (LspM Config) (WithSeverity T.Text) + dualLogger = clientLogger <> L.hoistLogAction liftIO stderrLogger + serverDefinition = ServerDefinition { defaultConfig = Config {fooTheBar = False, wibbleFactor = 0 } , onConfigurationChange = \_old v -> do case J.fromJSON v of J.Error e -> Left (T.pack e) J.Success cfg -> Right cfg - , doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env) - , staticHandlers = lspHandlers rin + , doInitialize = \env _ -> forkIO (reactor stderrLogger rin) >> pure (Right env) + -- Handlers log to both the client and stderr + , staticHandlers = lspHandlers dualLogger rin , interpretHandler = \env -> Iso (runLspT env) liftIO , options = lspOptions } - flip E.finally finalProc $ do - setupLogger Nothing ["reactor"] DEBUG - runServer serverDefinition + let + logToText = T.pack . show . pretty + runServerWithHandles + -- Log to both the client and stderr when we can, stderr beforehand + (L.cmap (fmap logToText) stderrLogger) + (L.cmap (fmap logToText) dualLogger) + stdin + stdout + serverDefinition where handlers = [ E.Handler ioExcept , E.Handler someExcept ] - finalProc = removeAllHandlers ioExcept (e :: E.IOException) = print e >> return 1 someExcept (e :: E.SomeException) = print e >> return 1 @@ -138,17 +164,17 @@ sendDiagnostics fileUri version = do -- | The single point that all events flow through, allowing management of state -- to stitch replies and requests together from the two asynchronous sides: lsp -- server and backend compiler -reactor :: TChan ReactorInput -> IO () -reactor inp = do - debugM "reactor" "Started the reactor" +reactor :: L.LogAction IO (WithSeverity T.Text) -> TChan ReactorInput -> IO () +reactor logger inp = do + logger <& "Started the reactor" `WithSeverity` Info forever $ do ReactorAction act <- atomically $ readTChan inp act -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as -- input into the reactor -lspHandlers :: TChan ReactorInput -> Handlers (LspM Config) -lspHandlers rin = mapHandlers goReq goNot handle +lspHandlers :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> TChan ReactorInput -> Handlers m +lspHandlers logger rin = mapHandlers goReq goNot (handle logger) where goReq :: forall (a :: J.Method J.FromClient J.Request). Handler (LspM Config) a -> Handler (LspM Config) a goReq f = \msg k -> do @@ -161,10 +187,10 @@ lspHandlers rin = mapHandlers goReq goNot handle liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg) -- | Where the actual logic resides for handling requests and notifications. -handle :: Handlers (LspM Config) -handle = mconcat +handle :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> Handlers m +handle logger = mconcat [ notificationHandler J.SInitialized $ \_msg -> do - liftIO $ debugM "reactor.handle" "Processing the Initialized notification" + logger <& "Processing the Initialized notification" `WithSeverity` Info -- We're initialized! Lets send a showMessageRequest now let params = J.ShowMessageRequestParams @@ -174,7 +200,7 @@ handle = mconcat void $ sendRequest J.SWindowShowMessageRequest params $ \res -> case res of - Left e -> liftIO $ errorM "reactor.handle" $ "Got an error: " ++ show e + Left e -> logger <& ("Got an error: " <> T.pack (show e)) `WithSeverity` Error Right _ -> do sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") @@ -184,7 +210,7 @@ handle = mconcat let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) void $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do - liftIO $ debugM "reactor.handle" "Processing a textDocument/codeLens request" + logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info let cmd = J.Command "Say hello" "lsp-hello-command" Nothing rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] responder (Right rsp) @@ -192,12 +218,12 @@ handle = mconcat , notificationHandler J.STextDocumentDidOpen $ \msg -> do let doc = msg ^. J.params . J.textDocument . J.uri fileName = J.uriToFilePath doc - liftIO $ debugM "reactor.handle" $ "Processing DidOpenTextDocument for: " ++ show fileName + logger <& ("Processing DidOpenTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info sendDiagnostics (J.toNormalizedUri doc) (Just 0) , notificationHandler J.SWorkspaceDidChangeConfiguration $ \msg -> do cfg <- getConfig - liftIO $ debugM "configuration changed: " (show (msg,cfg)) + logger L.<& ("Configuration changed: " <> T.pack (show (msg,cfg))) `WithSeverity` Info sendNotification J.SWindowShowMessage $ J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) @@ -206,22 +232,22 @@ handle = mconcat . J.textDocument . J.uri . to J.toNormalizedUri - liftIO $ debugM "reactor.handle" $ "Processing DidChangeTextDocument for: " ++ show doc + logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info mdoc <- getVirtualFile doc case mdoc of Just (VirtualFile _version str _) -> do - liftIO $ debugM "reactor.handle" $ "Found the virtual file: " ++ show str + logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info Nothing -> do - liftIO $ debugM "reactor.handle" $ "Didn't find anything in the VFS for: " ++ show doc + logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info , notificationHandler J.STextDocumentDidSave $ \msg -> do let doc = msg ^. J.params . J.textDocument . J.uri fileName = J.uriToFilePath doc - liftIO $ debugM "reactor.handle" $ "Processing DidSaveTextDocument for: " ++ show fileName + logger <& ("Processing DidSaveTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info sendDiagnostics (J.toNormalizedUri doc) Nothing , requestHandler J.STextDocumentRename $ \req responder -> do - liftIO $ debugM "reactor.handle" "Processing a textDocument/rename request" + logger <& "Processing a textDocument/rename request" `WithSeverity` Info let params = req ^. J.params J.Position l c = params ^. J.position newName = params ^. J.newName @@ -234,7 +260,7 @@ handle = mconcat responder (Right rsp) , requestHandler J.STextDocumentHover $ \req responder -> do - liftIO $ debugM "reactor.handle" "Processing a textDocument/hover request" + logger <& "Processing a textDocument/hover request" `WithSeverity` Info let J.HoverParams _doc pos _workDone = req ^. J.params J.Position _l _c' = pos rsp = J.Hover ms (Just range) @@ -243,7 +269,7 @@ handle = mconcat responder (Right $ Just rsp) , requestHandler J.STextDocumentDocumentSymbol $ \req responder -> do - liftIO $ debugM "reactor.handle" "Processing a textDocument/documentSymbol request" + logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info let J.DocumentSymbolParams _ _ doc = req ^. J.params loc = J.Location (doc ^. J.uri) (J.Range (J.Position 0 0) (J.Position 0 0)) sym = J.SymbolInformation "lsp-hello" J.SkFunction Nothing Nothing loc Nothing @@ -251,7 +277,7 @@ handle = mconcat responder (Right rsp) , requestHandler J.STextDocumentCodeAction $ \req responder -> do - liftIO $ debugM "reactor.handle" $ "Processing a textDocument/codeAction request" + logger <& "Processing a textDocument/codeAction request" `WithSeverity` Info let params = req ^. J.params doc = params ^. J.textDocument (J.List diags) = params ^. J.context . J.diagnostics @@ -272,11 +298,11 @@ handle = mconcat responder (Right rsp) , requestHandler J.SWorkspaceExecuteCommand $ \req responder -> do - liftIO $ debugM "reactor.handle" "Processing a workspace/executeCommand request" + logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info let params = req ^. J.params margs = params ^. J.arguments - liftIO $ debugM "reactor.handle" $ "The arguments are: " ++ show margs + logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug responder (Right (J.Object mempty)) -- respond to the request void $ withProgress "Executing some long running command" Cancellable $ \update -> diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal index 3ed943f15..c80172d5d 100644 --- a/lsp/lsp.cabal +++ b/lsp/lsp.cabal @@ -26,6 +26,7 @@ library , Language.LSP.Types.Lens exposed-modules: Language.LSP.Server , Language.LSP.Diagnostics + , Language.LSP.Logging , Language.LSP.VFS other-modules: Language.LSP.Server.Core , Language.LSP.Server.Control @@ -37,16 +38,17 @@ library , attoparsec , bytestring , containers + , co-log-core >= 0.3.1.0 , data-default , directory , exceptions , filepath - , hslogger , hashable , lsp-types == 1.5.* , lens >= 4.15.2 , mtl , network-uri + , prettyprinter , sorted-list == 0.2.1.* , stm == 2.5.* , scientific @@ -72,9 +74,10 @@ executable lsp-demo-reactor-server build-depends: base , aeson - , hslogger + , co-log-core , lens >= 4.15.2 , stm + , prettyprinter , text -- the package library. Comment this out if you want repl changes to propagate , lsp @@ -133,7 +136,6 @@ test-suite unit-test -- For GHCI tests -- , async -- , haskell-lsp-types - -- , hslogger -- , temporary -- , time -- , unordered-containers diff --git a/lsp/src/Language/LSP/Logging.hs b/lsp/src/Language/LSP/Logging.hs new file mode 100644 index 000000000..2fb2d3dae --- /dev/null +++ b/lsp/src/Language/LSP/Logging.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.LSP.Logging (logToShowMessage, logToLogMessage, defaultClientLogger) where + +import Colog.Core +import Language.LSP.Server.Core +import Language.LSP.Types +import Data.Text (Text) + +logSeverityToMessageType :: Severity -> MessageType +logSeverityToMessageType sev = case sev of + Error -> MtError + Warning -> MtWarning + Info -> MtInfo + Debug -> MtLog + +-- | Logs messages to the client via @window/logMessage@. +logToLogMessage :: (MonadLsp c m) => LogAction m (WithSeverity Text) +logToLogMessage = LogAction $ \(WithSeverity msg sev) -> do + sendToClient $ fromServerNot $ + NotificationMessage "2.0" SWindowLogMessage (LogMessageParams (logSeverityToMessageType sev) msg) + +-- | Logs messages to the client via @window/showMessage@. +logToShowMessage :: (MonadLsp c m) => LogAction m (WithSeverity Text) +logToShowMessage = LogAction $ \(WithSeverity msg sev) -> do + sendToClient $ fromServerNot $ + NotificationMessage "2.0" SWindowShowMessage (ShowMessageParams (logSeverityToMessageType sev) msg) + +-- | A 'sensible' log action for logging messages to the client: +-- +-- * Shows 'Error' logs to the user via @window/showMessage@ +-- * Logs 'Info' and above logs in the client via @window/logMessage@ +-- +-- If you want finer control (e.g. the ability to log 'Debug' logs based on a flag, or similar), +-- then do not use this and write your own based on 'logToShowMessage' and 'logToLogMessage'. +defaultClientLogger :: (MonadLsp c m) => LogAction m (WithSeverity Text) +defaultClientLogger = + filterBySeverity Error getSeverity logToShowMessage + <> filterBySeverity Info getSeverity logToLogMessage diff --git a/lsp/src/Language/LSP/Server.hs b/lsp/src/Language/LSP/Server.hs index 794148b56..58973b430 100644 --- a/lsp/src/Language/LSP/Server.hs +++ b/lsp/src/Language/LSP/Server.hs @@ -56,7 +56,6 @@ module Language.LSP.Server , unregisterCapability , RegistrationToken - , setupLogger , reverseSortEdit ) where diff --git a/lsp/src/Language/LSP/Server/Control.hs b/lsp/src/Language/LSP/Server/Control.hs index 6c9e67dee..1314567b6 100644 --- a/lsp/src/Language/LSP/Server/Control.hs +++ b/lsp/src/Language/LSP/Server/Control.hs @@ -1,7 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE LambdaCase #-} + +-- So we can keep using the old prettyprinter modules (which have a better +-- compatibility range) for now. +{-# OPTIONS_GHC -Wno-deprecations #-} module Language.LSP.Server.Control ( @@ -9,12 +13,16 @@ module Language.LSP.Server.Control runServer , runServerWith , runServerWithHandles + , LspServerLog (..) ) where +import qualified Colog.Core as L +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) import Control.Concurrent import Control.Concurrent.STM.TChan import Control.Monad import Control.Monad.STM +import Control.Monad.IO.Class import qualified Data.Aeson as J import qualified Data.Attoparsec.ByteString as Attoparsec import Data.Attoparsec.ByteString.Char8 @@ -25,35 +33,78 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Text.Prettyprint.Doc import Data.List import Language.LSP.Server.Core -import Language.LSP.Server.Processing +import qualified Language.LSP.Server.Processing as Processing import Language.LSP.Types import Language.LSP.VFS +import Language.LSP.Logging (defaultClientLogger) import System.IO -import System.Log.Logger +data LspServerLog = + LspProcessingLog Processing.LspProcessingLog + | DecodeInitializeError String + | HeaderParseFail [String] String + | EOF + | Starting + | ParsedMsg T.Text + | SendMsg TL.Text + deriving (Show) + +instance Pretty LspServerLog where + pretty (LspProcessingLog l) = pretty l + pretty (DecodeInitializeError err) = + vsep [ + "Got error while decoding initialize:" + , pretty err + ] + pretty (HeaderParseFail ctxs err) = + vsep [ + "Failed to parse message header:" + , pretty (intercalate " > " ctxs) <> ": " <+> pretty err + ] + pretty EOF = "Got EOF" + pretty Starting = "Starting server" + pretty (ParsedMsg msg) = "---> " <> pretty msg + pretty (SendMsg msg) = "<--2-- " <> pretty msg -- --------------------------------------------------------------------- --- | Convenience function for 'runServerWithHandles stdin stdout'. -runServer :: ServerDefinition config - -- ^ function to be called once initialize has - -- been received from the client. Further message - -- processing will start only after this returns. - -> IO Int -runServer = runServerWithHandles stdin stdout - --- | Starts a language server over the specified handles. +-- | Convenience function for 'runServerWithHandles' which: +-- (1) reads from stdin; +-- (2) writes to stdout; and +-- (3) logs to stderr and to the client, with some basic filtering. +runServer :: forall config . ServerDefinition config -> IO Int +runServer = + runServerWithHandles + ioLogger + lspLogger + stdin + stdout + where + prettyMsg l = "[" <> viaShow (L.getSeverity l) <> "] " <> pretty (L.getMsg l) + ioLogger :: LogAction IO (WithSeverity LspServerLog) + ioLogger = L.cmap (show . prettyMsg) L.logStringStderr + lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog) + lspLogger = + let clientLogger = L.cmap (fmap (T.pack . show . pretty)) defaultClientLogger + in clientLogger <> L.hoistLogAction liftIO ioLogger + +-- | Starts a language server over the specified handles. -- This function will return once the @exit@ notification is received. runServerWithHandles :: - Handle + LogAction IO (WithSeverity LspServerLog) + -- ^ The logger to use outside the main body of the server where we can't assume the ability to send messages. + -> LogAction (LspM config) (WithSeverity LspServerLog) + -- ^ The logger to use once the server has started and can successfully send messages. + -> Handle -- ^ Handle to read client input from. -> Handle -- ^ Handle to write output to. -> ServerDefinition config -> IO Int -- exit code -runServerWithHandles hin hout serverDefinition = do +runServerWithHandles ioLogger logger hin hout serverDefinition = do hSetBuffering hin NoBuffering hSetEncoding hin utf8 @@ -68,80 +119,70 @@ runServerWithHandles hin hout serverDefinition = do BSL.hPut hout out hFlush hout - runServerWith clientIn clientOut serverDefinition + runServerWith ioLogger logger clientIn clientOut serverDefinition -- | Starts listening and sending requests and responses -- using the specified I/O. runServerWith :: - IO BS.ByteString + LogAction IO (WithSeverity LspServerLog) + -- ^ The logger to use outside the main body of the server where we can't assume the ability to send messages. + -> LogAction (LspM config) (WithSeverity LspServerLog) + -- ^ The logger to use once the server has started and can successfully send messages. + -> IO BS.ByteString -- ^ Client input. -> (BSL.ByteString -> IO ()) -- ^ Function to provide output to. -> ServerDefinition config -> IO Int -- exit code -runServerWith clientIn clientOut serverDefinition = do +runServerWith ioLogger logger clientIn clientOut serverDefinition = do - infoM "lsp.runWith" "\n\n\n\n\nlsp:Starting up server ..." + ioLogger <& Starting `WithSeverity` Info cout <- atomically newTChan :: IO (TChan J.Value) - _rhpid <- forkIO $ sendServer cout clientOut + _rhpid <- forkIO $ sendServer ioLogger cout clientOut let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg initVFS $ \vfs -> do - ioLoop clientIn serverDefinition vfs sendMsg + ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg return 1 -- --------------------------------------------------------------------- ioLoop :: - IO BS.ByteString + forall config + . LogAction IO (WithSeverity LspServerLog) + -> LogAction (LspM config) (WithSeverity LspServerLog) + -> IO BS.ByteString -> ServerDefinition config -> VFS -> (FromServerMessage -> IO ()) -> IO () -ioLoop clientIn serverDefinition vfs sendMsg = do - minitialize <- parseOne (parse parser "") +ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg = do + minitialize <- parseOne ioLogger clientIn (parse parser "") case minitialize of Nothing -> pure () Just (msg,remainder) -> do case J.eitherDecode $ BSL.fromStrict msg of - Left err -> - errorM "lsp.ioLoop" $ - "Got error while decoding initialize:\n" <> err <> "\n exiting 1 ...\n" + Left err -> ioLogger <& DecodeInitializeError err `WithSeverity` Error Right initialize -> do - mInitResp <- initializeRequestHandler serverDefinition vfs sendMsg initialize + mInitResp <- Processing.initializeRequestHandler serverDefinition vfs sendMsg initialize case mInitResp of Nothing -> pure () - Just env -> loop env (parse parser remainder) + Just env -> runLspT env $ loop (parse parser remainder) where - parseOne :: Result BS.ByteString -> IO (Maybe (BS.ByteString,BS.ByteString)) - parseOne (Fail _ ctxs err) = do - errorM "lsp.parseOne" $ - "Failed to parse message header:\n" <> intercalate " > " ctxs <> ": " <> - err <> "\n exiting 1 ...\n" - pure Nothing - parseOne (Partial c) = do - bs <- clientIn - if BS.null bs - then do - errorM "lsp.parseON" "lsp:Got EOF, exiting 1 ...\n" - pure Nothing - else parseOne (c bs) - parseOne (Done remainder msg) = do - debugM "lsp.parseOne" $ "---> " <> T.unpack (T.decodeUtf8 msg) - pure $ Just (msg,remainder) - - loop env = go + loop :: Result BS.ByteString -> LspM config () + loop = go where + pLogger = L.cmap (fmap LspProcessingLog) logger go r = do - res <- parseOne r + res <- parseOne logger clientIn r case res of Nothing -> pure () Just (msg,remainder) -> do - runLspT env $ processMessage $ BSL.fromStrict msg + Processing.processMessage pLogger $ BSL.fromStrict msg go (parse parser remainder) parser = do @@ -150,11 +191,33 @@ ioLoop clientIn serverDefinition vfs sendMsg = do _ <- string _TWO_CRLF Attoparsec.take len +parseOne :: + MonadIO m + => LogAction m (WithSeverity LspServerLog) + -> IO BS.ByteString + -> Result BS.ByteString + -> m (Maybe (BS.ByteString,BS.ByteString)) +parseOne logger clientIn = go + where + go (Fail _ ctxs err) = do + logger <& HeaderParseFail ctxs err `WithSeverity` Error + pure Nothing + go (Partial c) = do + bs <- liftIO clientIn + if BS.null bs + then do + logger <& EOF `WithSeverity` Error + pure Nothing + else go (c bs) + go (Done remainder msg) = do + logger <& ParsedMsg (T.decodeUtf8 msg) `WithSeverity` Debug + pure $ Just (msg,remainder) + -- --------------------------------------------------------------------- -- | Simple server to make sure all output is serialised -sendServer :: TChan J.Value -> (BSL.ByteString -> IO ()) -> IO () -sendServer msgChan clientOut = do +sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan J.Value -> (BSL.ByteString -> IO ()) -> IO () +sendServer logger msgChan clientOut = do forever $ do msg <- atomically $ readTChan msgChan @@ -168,7 +231,7 @@ sendServer msgChan clientOut = do , str ] clientOut out - debugM "lsp.sendServer" $ "<--2--" <> TL.unpack (TL.decodeUtf8 str) + logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug -- | -- diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index c5ba3177c..131b60655 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -2,25 +2,16 @@ {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE RoleAnnotations #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} @@ -28,6 +19,7 @@ module Language.LSP.Server.Core where +import Colog.Core (LogAction (..), WithSeverity (..)) import Control.Concurrent.Async import Control.Concurrent.STM import qualified Control.Exception as E @@ -37,7 +29,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader import Control.Monad.Trans.Class import Control.Monad.IO.Unlift -import Control.Lens ( (^.), (^?), _Just ) +import Control.Lens ( (^.), (^?), _Just, at) import qualified Data.Aeson as J import Data.Default import Data.Functor.Product @@ -59,12 +51,6 @@ import qualified Language.LSP.Types.SMethodMap as SMethodMap import qualified Language.LSP.Types.Lens as J import Language.LSP.VFS import Language.LSP.Diagnostics -import System.IO -import qualified System.Log.Formatter as L -import qualified System.Log.Handler as LH -import qualified System.Log.Handler.Simple as LHS -import System.Log.Logger -import qualified System.Log.Logger as L import System.Random hiding (next) import Control.Monad.Trans.Identity import Control.Monad.Catch (MonadMask, MonadCatch, MonadThrow) @@ -107,7 +93,7 @@ instance MonadLsp c m => MonadLsp c (IdentityT m) where data LanguageContextEnv config = LanguageContextEnv { resHandlers :: !(Handlers IO) - , resParseConfig :: !(config -> J.Value -> (Either T.Text config)) + , resParseConfig :: !(config -> J.Value -> Either T.Text config) , resSendMessage :: !(FromServerMessage -> IO ()) -- We keep the state in a TVar to be thread safe , resState :: !(LanguageContextState config) @@ -359,7 +345,7 @@ sendRequest m params resHandler = do reqId <- IdInt <$> freshLspId rio <- askRunInIO success <- addResponseHandler reqId (Pair m (ServerResponseCallback (rio . resHandler))) - unless success $ error "haskell-lsp: could not send FromServer request as id is reused" + unless success $ error "LSP: could not send FromServer request as id is reused" let msg = RequestMessage "2.0" reqId m params ~() <- case splitServerMethod m of @@ -371,7 +357,9 @@ sendRequest m params resHandler = do -- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile) -getVirtualFile uri = Map.lookup uri . vfsMap . vfsData <$> getsState resVFS +getVirtualFile uri = do + dat <- vfsData <$> getsState resVFS + pure $ dat ^. vfsMap . at uri {-# INLINE getVirtualFile #-} @@ -389,10 +377,10 @@ snapshotVirtualFiles env = vfsData <$> readTVar (resVFS $ resState env) -- | Dump the current text for a given VFS file to a temporary file, -- and return the path to the file. -persistVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe FilePath) -persistVirtualFile uri = do +persistVirtualFile :: MonadLsp config m => LogAction m (WithSeverity VfsLog) -> NormalizedUri -> m (Maybe FilePath) +persistVirtualFile logger uri = do join $ stateState resVFS $ \vfs -> - case persistFileVFS (vfsData vfs) uri of + case persistFileVFS logger (vfsData vfs) uri of Nothing -> (return Nothing, vfs) Just (fn, write) -> let !revMap = case uriToFilePath (fromNormalizedUri uri) of @@ -402,7 +390,7 @@ persistVirtualFile uri = do Nothing -> reverseMap vfs !vfs' = vfs {reverseMap = revMap} act = do - liftIO write + write pure (Just fn) in (act, vfs') @@ -440,15 +428,6 @@ sendToClient msg = do -- --------------------------------------------------------------------- -sendErrorLog :: MonadLsp config m => Text -> m () -sendErrorLog msg = - sendToClient $ fromServerNot $ - NotificationMessage "2.0" SWindowLogMessage (LogMessageParams MtError msg) - -{-# INLINE sendErrorLog #-} - --- --------------------------------------------------------------------- - freshLspId :: MonadLsp config m => m Int32 freshLspId = do stateState resLspId $ \cur -> @@ -725,45 +704,6 @@ flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState resDiagn sendToClient $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params in (act,newDiags) --- ===================================================================== --- --- utility - - --- --- Logger --- -setupLogger :: Maybe FilePath -> [String] -> Priority -> IO () -setupLogger mLogFile extraLogNames level = do - - logStream <- case mLogFile of - Just logFile -> openFile logFile AppendMode `E.catch` handleIOException logFile - Nothing -> return stderr - hSetEncoding logStream utf8 - - logH <- LHS.streamHandler logStream level - - let logHandle = logH {LHS.closeFunc = hClose} - logFormatter = L.tfLogFormatter logDateFormat logFormat - logHandler = LH.setFormatter logHandle logFormatter - - L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle]) - L.updateGlobalLogger "haskell-lsp" $ L.setHandlers [logHandler] - L.updateGlobalLogger "haskell-lsp" $ L.setLevel level - - -- Also route the additional log names to the same log - forM_ extraLogNames $ \logName -> do - L.updateGlobalLogger logName $ L.setHandlers [logHandler] - L.updateGlobalLogger logName $ L.setLevel level - where - logFormat = "$time [$tid] $prio $loggername:\t$msg" - logDateFormat = "%Y-%m-%d %H:%M:%S%Q" - -handleIOException :: FilePath -> E.IOException -> IO Handle -handleIOException logFile _ = do - hPutStr stderr $ "Couldn't open log file " ++ logFile ++ "; falling back to stderr logging" - return stderr - -- --------------------------------------------------------------------- -- | The changes in a workspace edit should be applied from the end of the file diff --git a/lsp/src/Language/LSP/Server/Processing.hs b/lsp/src/Language/LSP/Server/Processing.hs index aff536ad3..18a1ac9fa 100644 --- a/lsp/src/Language/LSP/Server/Processing.hs +++ b/lsp/src/Language/LSP/Server/Processing.hs @@ -7,17 +7,25 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} + {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +-- So we can keep using the old prettyprinter modules (which have a better +-- compatibility range) for now. +{-# OPTIONS_GHC -Wno-deprecations #-} + module Language.LSP.Server.Processing where +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) + import Control.Lens hiding (List, Empty) -import Data.Aeson hiding (Options) -import Data.Aeson.Types hiding (Options) +import Data.Aeson hiding (Options, Error) +import Data.Aeson.Types hiding (Options, Error) import qualified Data.ByteString.Lazy as BSL import Data.List import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Text as T -import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Language.LSP.Types import Language.LSP.Types.Capabilities @@ -25,7 +33,8 @@ import qualified Language.LSP.Types.Lens as LSP import Language.LSP.Types.SMethodMap (SMethodMap) import qualified Language.LSP.Types.SMethodMap as SMethodMap import Language.LSP.Server.Core -import Language.LSP.VFS + +import Language.LSP.VFS as VFS import Data.Functor.Product import qualified Control.Exception as E import Data.Monoid hiding (Product) @@ -35,14 +44,47 @@ import Control.Concurrent.STM import Control.Monad.Trans.Except import Control.Monad.Reader import Data.IxMap -import System.Log.Logger import Data.Maybe import qualified Data.Map.Strict as Map +import Data.Text.Prettyprint.Doc import System.Exit import Data.Default (def) - -processMessage :: BSL.ByteString -> LspM config () -processMessage jsonStr = do +import Control.Monad.State +import Control.Monad.Writer.Strict hiding (Product) +import Data.Foldable (traverse_) + +data LspProcessingLog = + VfsLog VfsLog + | MessageProcessingError BSL.ByteString String + | forall m . MissingHandler Bool (SClientMethod m) + | ConfigurationParseError Value T.Text + | ProgressCancel ProgressToken + | Exiting + +deriving instance Show LspProcessingLog + +instance Pretty LspProcessingLog where + pretty (VfsLog l) = pretty l + pretty (MessageProcessingError bs err) = + vsep [ + "LSP: incoming message parse error:" + , pretty err + , "when processing" + , pretty (TL.decodeUtf8 bs) + ] + pretty (MissingHandler _ m) = "LSP: no handler for:" <+> viaShow m + pretty (ConfigurationParseError settings err) = + vsep [ + "LSP: configuration parse error:" + , pretty err + , "when parsing" + , viaShow settings + ] + pretty (ProgressCancel tid) = "LSP: cancelling action for token:" <+> viaShow tid + pretty Exiting = "LSP: Got exit, exiting" + +processMessage :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> BSL.ByteString -> m () +processMessage logger jsonStr = do pendingResponsesVar <- LspT $ asks $ resPendingResponses . resState join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do val <- except $ eitherDecode jsonStr @@ -50,7 +92,7 @@ processMessage jsonStr = do msg <- except $ parseEither (parser pending) val lift $ case msg of FromClientMess m mess -> - pure $ handle m mess + pure $ handle logger m mess FromClientRsp (Pair (ServerResponseCallback f) (Const !newMap)) res -> do writeTVar pendingResponsesVar newMap pure $ liftIO $ f (res ^. LSP.result) @@ -60,13 +102,7 @@ processMessage jsonStr = do let (mhandler, newMap) = pickFromIxMap i rm in (\(Pair m handler) -> (m,Pair handler (Const newMap))) <$> mhandler - handleErrors = either (sendErrorLog . errMsg) id - - errMsg err = TL.toStrict $ TL.unwords - [ "lsp:incoming message parse error." - , TL.decodeUtf8 jsonStr - , TL.pack err - ] <> "\n" + handleErrors = either (\e -> logger <& MessageProcessingError jsonStr e `WithSeverity` Error) id -- | Call this to initialize the session initializeRequestHandler @@ -253,7 +289,7 @@ inferServerCapabilities clientCaps o h = semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing def semanticTokenRangeProvider semanticTokenFullProvider semanticTokenRangeProvider | supported_b STextDocumentSemanticTokensRange = Just $ SemanticTokensRangeBool True - | otherwise = Nothing + | otherwise = Nothing semanticTokenFullProvider | supported_b STextDocumentSemanticTokensFull = Just $ SemanticTokensFullDelta $ SemanticTokensDeltaClientCapabilities $ supported STextDocumentSemanticTokensFullDelta | otherwise = Nothing @@ -269,26 +305,28 @@ inferServerCapabilities clientCaps o h = -- | Invokes the registered dynamic or static handlers for the given message and -- method, as well as doing some bookkeeping. -handle :: SClientMethod m -> ClientMessage m -> LspM config () -handle m msg = +handle :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> ClientMessage meth -> m () +handle logger m msg = case m of - SWorkspaceDidChangeWorkspaceFolders -> handle' (Just updateWorkspaceFolders) m msg - SWorkspaceDidChangeConfiguration -> handle' (Just handleConfigChange) m msg - STextDocumentDidOpen -> handle' (Just $ vfsFunc openVFS) m msg - STextDocumentDidChange -> handle' (Just $ vfsFunc changeFromClientVFS) m msg - STextDocumentDidClose -> handle' (Just $ vfsFunc closeVFS) m msg - SWindowWorkDoneProgressCancel -> handle' (Just progressCancelHandler) m msg - _ -> handle' Nothing m msg - - -handle' :: forall t (m :: Method FromClient t) config. - Maybe (ClientMessage m -> LspM config ()) + SWorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg + SWorkspaceDidChangeConfiguration -> handle' logger (Just $ handleConfigChange logger) m msg + STextDocumentDidOpen -> handle' logger (Just $ vfsFunc logger openVFS) m msg + STextDocumentDidChange -> handle' logger (Just $ vfsFunc logger changeFromClientVFS) m msg + STextDocumentDidClose -> handle' logger (Just $ vfsFunc logger closeVFS) m msg + SWindowWorkDoneProgressCancel -> handle' logger (Just $ progressCancelHandler logger) m msg + _ -> handle' logger Nothing m msg + + +handle' :: forall m t (meth :: Method FromClient t) config + . (m ~ LspM config) + => LogAction m (WithSeverity LspProcessingLog) + -> Maybe (ClientMessage meth -> m ()) -- ^ An action to be run before invoking the handler, used for -- bookkeeping stuff like the vfs etc. - -> SClientMethod m - -> ClientMessage m - -> LspM config () -handle' mAction m msg = do + -> SClientMethod meth + -> ClientMessage meth + -> m () +handle' logger mAction m msg = do maybe (return ()) (\f -> f msg) mAction dynReqHandlers <- getsState resRegistrationsReq @@ -307,7 +345,7 @@ handle' mAction m msg = do IsClientNot -> case pickHandler dynNotHandlers notHandlers of Just h -> liftIO $ h msg Nothing - | SExit <- m -> liftIO $ exitNotificationHandler msg + | SExit <- m -> exitNotificationHandler logger msg | otherwise -> do reportMissingHandler @@ -335,7 +373,7 @@ handle' mAction m msg = do where -- | Checks to see if there's a dynamic handler, and uses it in favour of the -- static handler, if it exists. - pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO m) + pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO meth) pickHandler dynHandlerMap staticHandler = case (SMethodMap.lookup m dynHandlerMap, SMethodMap.lookup m staticHandler) of (Just (Pair _ (ClientMessageHandler h)), _) -> Just h (Nothing, Just (ClientMessageHandler h)) -> Just h @@ -344,51 +382,65 @@ handle' mAction m msg = do -- '$/' notifications should/could be ignored by server. -- Don't log errors in that case. -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. - reportMissingHandler :: LspM config () - reportMissingHandler - | isOptionalNotification m = return () - | otherwise = do - let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] - sendErrorLog errorMsg + reportMissingHandler :: m () + reportMissingHandler = + let optional = isOptionalNotification m + in logger <& MissingHandler optional m `WithSeverity` if optional then Warning else Error isOptionalNotification (SCustomMethod method) | "$/" `T.isPrefixOf` method = True isOptionalNotification _ = False -progressCancelHandler :: Message WindowWorkDoneProgressCancel -> LspM config () -progressCancelHandler (NotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do - mact <- Map.lookup tid <$> getsState (progressCancel . resProgressData) - case mact of +progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Message WindowWorkDoneProgressCancel -> m () +progressCancelHandler logger (NotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do + pdata <- getsState (progressCancel . resProgressData) + case Map.lookup tid pdata of Nothing -> return () - Just cancelAction -> liftIO $ cancelAction + Just cancelAction -> do + logger <& ProgressCancel tid `WithSeverity` Debug + liftIO cancelAction -exitNotificationHandler :: Handler IO Exit -exitNotificationHandler = \_ -> do - noticeM "lsp.exitNotificationHandler" "Got exit, exiting" - exitSuccess +exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Exit +exitNotificationHandler logger _ = do + logger <& Exiting `WithSeverity` Info + liftIO exitSuccess -- | Default Shutdown handler shutdownRequestHandler :: Handler IO Shutdown -shutdownRequestHandler = \_req k -> do +shutdownRequestHandler _req k = do k $ Right Empty -handleConfigChange :: Message WorkspaceDidChangeConfiguration -> LspM config () -handleConfigChange req = do +handleConfigChange :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Message WorkspaceDidChangeConfiguration -> m () +handleConfigChange logger req = do parseConfig <- LspT $ asks resParseConfig - res <- stateState resConfig $ \oldConfig -> case parseConfig oldConfig (req ^. LSP.params . LSP.settings) of + let settings = req ^. LSP.params . LSP.settings + res <- stateState resConfig $ \oldConfig -> case parseConfig oldConfig settings of Left err -> (Left err, oldConfig) Right !newConfig -> (Right (), newConfig) case res of Left err -> do - let msg = T.pack $ unwords - ["lsp:configuration parse error.", show req, show err] - sendErrorLog msg + logger <& ConfigurationParseError settings err `WithSeverity` Error Right () -> pure () -vfsFunc :: (VFS -> b -> (VFS, [String])) -> b -> LspM config () -vfsFunc modifyVfs req = do - join $ stateState resVFS $ \(VFSData vfs rm) -> - let (!vfs', ls) = modifyVfs vfs req - in (liftIO $ mapM_ (debugM "lsp.vfsFunc") ls,VFSData vfs' rm) +vfsFunc :: forall m n a config + . (m ~ LspM config, n ~ WriterT [WithSeverity VfsLog] (State VFS)) + => LogAction m (WithSeverity LspProcessingLog) + -> (LogAction n (WithSeverity VfsLog) -> a -> n ()) + -> a + -> m () +vfsFunc logger modifyVfs req = do + -- This is an intricate dance. We want to run the VFS functions essentially in STM, that's + -- what 'stateState' does. But we also want them to log. We accomplish this by exfiltrating + -- the logs through the return value of 'stateState' and then re-logging them. + -- We therefore have to use the stupid approach of accumulating the logs in Writer inside + -- the VFS functions. They don't log much so for now we just use [Log], but we could use + -- DList here if we're worried about performance. + logs <- stateState resVFS $ \(VFSData vfs rm) -> + let (ls, vfs') = flip runState vfs $ execWriterT $ modifyVfs innerLogger req + in (ls, VFSData vfs' rm) + traverse_ (\l -> logger <& fmap VfsLog l) logs + where + innerLogger :: LogAction n (WithSeverity VfsLog) + innerLogger = LogAction $ \m -> tell [m] -- | Updates the list of workspace folders updateWorkspaceFolders :: Message WorkspaceDidChangeWorkspaceFolders -> LspM config () @@ -399,4 +451,3 @@ updateWorkspaceFolders (NotificationMessage _ _ params) = do modifyState resWorkspaceFolders newWfs -- --------------------------------------------------------------------- - diff --git a/lsp/src/Language/LSP/VFS.hs b/lsp/src/Language/LSP/VFS.hs index 19c1819bd..522e34e61 100644 --- a/lsp/src/Language/LSP/VFS.hs +++ b/lsp/src/Language/LSP/VFS.hs @@ -6,7 +6,16 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeInType #-} + {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} + +-- So we can keep using the old prettyprinter modules (which have a better +-- compatibility range) for now. +{-# OPTIONS_GHC -Wno-deprecations #-} {-| Handles the "Language.LSP.Types.TextDocumentDidChange" \/ @@ -18,9 +27,15 @@ files in the client workspace by operating on the "VFS" in "LspFuncs". module Language.LSP.VFS ( VFS(..) + , vfsMap + , vfsTempDir , VirtualFile(..) + , lsp_version + , file_version + , file_text , virtualFileText , virtualFileVersion + , VfsLog (..) -- * Managing the VFS , initVFS , openVFS @@ -28,7 +43,6 @@ module Language.LSP.VFS , changeFromServerVFS , persistFileVFS , closeVFS - , updateVFS -- * manipulating the file contents , rangeLinesFromVfs @@ -43,9 +57,12 @@ module Language.LSP.VFS import Control.Lens hiding ( (<.>), parts ) import Control.Monad +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) +import Control.Monad.State import Data.Char (isUpper, isAlphaNum) import Data.Text ( Text ) import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Int (Int32) import Data.List import Data.Ord @@ -54,14 +71,15 @@ import qualified Data.Map.Strict as Map import Data.Maybe import Data.Text.Utf16.Rope ( Rope ) import qualified Data.Text.Utf16.Rope as Rope +import Data.Text.Prettyprint.Doc import qualified Language.LSP.Types as J import qualified Language.LSP.Types.Lens as J import System.FilePath import Data.Hashable import System.Directory -import System.IO +import System.IO import System.IO.Temp -import System.Log.Logger +import Data.Foldable (traverse_) -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} @@ -73,20 +91,41 @@ data VirtualFile = _lsp_version :: !Int32 -- ^ The LSP version of the document , _file_version :: !Int -- ^ This number is only incremented whilst the file -- remains in the map. - , _text :: !Rope -- ^ The full contents of the document + , _file_text :: !Rope -- ^ The full contents of the document } deriving (Show) - -type VFSMap = Map.Map J.NormalizedUri VirtualFile - -data VFS = VFS { vfsMap :: !(Map.Map J.NormalizedUri VirtualFile) - , vfsTempDir :: !FilePath -- ^ This is where all the temporary files will be written to +data VFS = VFS { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFile) + , _vfsTempDir :: !FilePath -- ^ This is where all the temporary files will be written to } deriving Show +data VfsLog = + SplitInsideCodePoint Rope.Position Rope + | URINotFound J.NormalizedUri + | Opening J.NormalizedUri + | Closing J.NormalizedUri + | PersistingFile J.NormalizedUri FilePath + | CantRecursiveDelete J.NormalizedUri + | DeleteNonExistent J.NormalizedUri + deriving (Show) + +instance Pretty VfsLog where + pretty (SplitInsideCodePoint pos r) = + "VFS: asked to make change inside code point. Position" <+> viaShow pos <+> "in" <+> viaShow r + pretty (URINotFound uri) = "VFS: don't know about URI" <+> viaShow uri + pretty (Opening uri) = "VFS: opening" <+> viaShow uri + pretty (Closing uri) = "VFS: closing" <+> viaShow uri + pretty (PersistingFile uri fp) = "VFS: Writing virtual file for" <+> viaShow uri <+> "to" <+> viaShow fp + pretty (CantRecursiveDelete uri) = + "VFS: can't recursively delete" <+> viaShow uri <+> "because we don't track directory status" + pretty (DeleteNonExistent uri) = "VFS: asked to delete non-existent file" <+> viaShow uri + +makeFieldsNoPrefix ''VirtualFile +makeFieldsNoPrefix ''VFS + --- virtualFileText :: VirtualFile -> Text -virtualFileText vf = Rope.toText (_text vf) +virtualFileText vf = Rope.toText (_file_text vf) virtualFileVersion :: VirtualFile -> Int32 virtualFileVersion vf = _lsp_version vf @@ -99,51 +138,44 @@ initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty t -- --------------------------------------------------------------------- -- | Applies the changes from a 'J.DidOpenTextDocument' to the 'VFS' -openVFS :: VFS -> J.Message 'J.TextDocumentDidOpen -> (VFS, [String]) -openVFS vfs (J.NotificationMessage _ _ params) = - let J.DidOpenTextDocumentParams - (J.TextDocumentItem uri _ version text) = params - in (updateVFS (Map.insert (J.toNormalizedUri uri) (VirtualFile version 0 (Rope.fromText text))) vfs - , []) - +openVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidOpen -> m () +openVFS logger msg = do + let J.TextDocumentItem (J.toNormalizedUri -> uri) _ version text = msg ^. J.params . J.textDocument + vfile = VirtualFile version 0 (Rope.fromText text) + logger <& Opening uri `WithSeverity` Debug + vfsMap . at uri .= Just vfile -- --------------------------------------------------------------------- --- ^ Applies a 'DidChangeTextDocumentNotification' to the 'VFS' -changeFromClientVFS :: VFS -> J.Message 'J.TextDocumentDidChange -> (VFS,[String]) -changeFromClientVFS vfs (J.NotificationMessage _ _ params) = +-- | Applies a 'DidChangeTextDocumentNotification' to the 'VFS' +changeFromClientVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidChange -> m () +changeFromClientVFS logger msg = do let - J.DidChangeTextDocumentParams vid (J.List changes) = params - J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid - in - case Map.lookup uri (vfsMap vfs) of - Just (VirtualFile _ file_ver str) -> - let str' = applyChanges str changes - -- the client shouldn't be sending over a null version, only the server. - in (updateVFS (Map.insert uri (VirtualFile (fromMaybe 0 version) (file_ver + 1) str')) vfs, []) - Nothing -> - -- logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri - -- return vfs - (vfs, ["haskell-lsp:changeVfs:can't find uri:" ++ show uri]) - -updateVFS :: (VFSMap -> VFSMap) -> VFS -> VFS -updateVFS f vfs@VFS{vfsMap} = vfs { vfsMap = f vfsMap } + J.DidChangeTextDocumentParams vid (J.List changes) = msg ^. J.params + -- the client shouldn't be sending over a null version, only the server, but we just use 0 if that happens + J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) (fromMaybe 0 -> version) = vid + vfs <- get + case vfs ^. vfsMap . at uri of + Just (VirtualFile _ file_ver contents) -> do + contents' <- applyChanges logger contents changes + vfsMap . at uri .= Just (VirtualFile version (file_ver + 1) contents') + Nothing -> logger <& URINotFound uri `WithSeverity` Warning -- --------------------------------------------------------------------- -applyCreateFile :: J.CreateFile -> VFS -> VFS -applyCreateFile (J.CreateFile uri options _ann) = - updateVFS $ Map.insertWith +applyCreateFile :: (MonadState VFS m) => J.CreateFile -> m () +applyCreateFile (J.CreateFile (J.toNormalizedUri -> uri) options _ann) = + vfsMap %= Map.insertWith (\ new old -> if shouldOverwrite then new else old) - (J.toNormalizedUri uri) + uri (VirtualFile 0 0 mempty) - where - shouldOverwrite :: Bool - shouldOverwrite = case options of + where + shouldOverwrite :: Bool + shouldOverwrite = case options of Nothing -> False -- default Just (J.CreateFileOptions Nothing Nothing ) -> False -- default - Just (J.CreateFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True - Just (J.CreateFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False + Just (J.CreateFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True + Just (J.CreateFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False Just (J.CreateFileOptions (Just True) Nothing ) -> True -- `overwrite` is True Just (J.CreateFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists` Just (J.CreateFileOptions (Just True) (Just False)) -> True -- `overwrite` is True @@ -151,26 +183,27 @@ applyCreateFile (J.CreateFile uri options _ann) = Just (J.CreateFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` -applyRenameFile :: J.RenameFile -> VFS -> VFS -applyRenameFile (J.RenameFile oldUri' newUri' options _ann) vfs = - let oldUri = J.toNormalizedUri oldUri' - newUri = J.toNormalizedUri newUri' - in case Map.lookup oldUri (vfsMap vfs) of - -- nothing to rename - Nothing -> vfs - Just file -> case Map.lookup newUri (vfsMap vfs) of - -- the target does not exist, just move over - Nothing -> updateVFS (Map.insert newUri file . Map.delete oldUri) vfs - Just _ -> if shouldOverwrite - then updateVFS (Map.insert newUri file . Map.delete oldUri) vfs - else vfs - where - shouldOverwrite :: Bool - shouldOverwrite = case options of +applyRenameFile :: (MonadState VFS m) => J.RenameFile -> m () +applyRenameFile (J.RenameFile (J.toNormalizedUri -> oldUri) (J.toNormalizedUri -> newUri) options _ann) = do + vfs <- get + case vfs ^. vfsMap . at oldUri of + -- nothing to rename + Nothing -> pure () + Just file -> case vfs ^. vfsMap . at newUri of + -- the target does not exist, just move over + Nothing -> do + vfsMap . at oldUri .= Nothing + vfsMap . at newUri .= Just file + Just _ -> when shouldOverwrite $ do + vfsMap . at oldUri .= Nothing + vfsMap . at newUri .= Just file + where + shouldOverwrite :: Bool + shouldOverwrite = case options of Nothing -> False -- default Just (J.RenameFileOptions Nothing Nothing ) -> False -- default - Just (J.RenameFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True - Just (J.RenameFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False + Just (J.RenameFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True + Just (J.RenameFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False Just (J.RenameFileOptions (Just True) Nothing ) -> True -- `overwrite` is True Just (J.RenameFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists` Just (J.RenameFileOptions (Just True) (Just False)) -> True -- `overwrite` is True @@ -178,23 +211,29 @@ applyRenameFile (J.RenameFile oldUri' newUri' options _ann) vfs = Just (J.RenameFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False Just (J.RenameFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` --- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory -applyDeleteFile :: J.DeleteFile -> VFS -> VFS -applyDeleteFile (J.DeleteFile uri _options _ann) = - updateVFS $ Map.delete (J.toNormalizedUri uri) - - -applyTextDocumentEdit :: J.TextDocumentEdit -> VFS -> IO VFS -applyTextDocumentEdit (J.TextDocumentEdit vid (J.List edits)) vfs = do +applyDeleteFile :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.DeleteFile -> m () +applyDeleteFile logger (J.DeleteFile (J.toNormalizedUri -> uri) options _ann) = do + -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory + when (options ^? _Just . J.recursive . _Just == Just True) $ + logger <& CantRecursiveDelete uri `WithSeverity` Warning + -- Remove and get the old value so we can check if it was missing + old <- vfsMap . at uri <.= Nothing + case old of + -- It's not entirely clear what the semantics of 'ignoreIfNotExists' are, but if it + -- doesn't exist and we're not ignoring it, let's at least log it. + Nothing | options ^? _Just . J.ignoreIfNotExists . _Just /= Just True -> + logger <& CantRecursiveDelete uri `WithSeverity` Warning + _ -> pure () + +applyTextDocumentEdit :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TextDocumentEdit -> m () +applyTextDocumentEdit logger (J.TextDocumentEdit vid (J.List edits)) = do -- all edits are supposed to be applied at once -- so apply from bottom up so they don't affect others let sortedEdits = sortOn (Down . editRange) edits changeEvents = map editToChangeEvent sortedEdits ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) notif = J.NotificationMessage "" J.STextDocumentDidChange ps - let (vfs',ls) = changeFromClientVFS vfs notif - mapM_ (debugM "haskell-lsp.applyTextDocumentEdit") ls - return vfs' + changeFromClientVFS logger notif where editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range @@ -205,32 +244,30 @@ applyTextDocumentEdit (J.TextDocumentEdit vid (J.List edits)) vfs = do editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText) editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText) -applyDocumentChange :: J.DocumentChange -> VFS -> IO VFS -applyDocumentChange (J.InL change) = applyTextDocumentEdit change -applyDocumentChange (J.InR (J.InL change)) = return . applyCreateFile change -applyDocumentChange (J.InR (J.InR (J.InL change))) = return . applyRenameFile change -applyDocumentChange (J.InR (J.InR (J.InR change))) = return . applyDeleteFile change +applyDocumentChange :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.DocumentChange -> m () +applyDocumentChange logger (J.InL change) = applyTextDocumentEdit logger change +applyDocumentChange _ (J.InR (J.InL change)) = applyCreateFile change +applyDocumentChange _ (J.InR (J.InR (J.InL change))) = applyRenameFile change +applyDocumentChange logger (J.InR (J.InR (J.InR change))) = applyDeleteFile logger change --- ^ Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' -changeFromServerVFS :: VFS -> J.Message 'J.WorkspaceApplyEdit -> IO VFS -changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do - let J.ApplyWorkspaceEditParams _label edit = params +-- | Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' +changeFromServerVFS :: forall m . MonadState VFS m => LogAction m (WithSeverity VfsLog) -> J.Message 'J.WorkspaceApplyEdit -> m () +changeFromServerVFS logger msg = do + let J.ApplyWorkspaceEditParams _label edit = msg ^. J.params J.WorkspaceEdit mChanges mDocChanges _anns = edit case mDocChanges of Just (J.List docChanges) -> applyDocumentChanges docChanges Nothing -> case mChanges of Just cs -> applyDocumentChanges $ map J.InL $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs - Nothing -> do - debugM "haskell-lsp.changeVfs" "No changes" - return initVfs + Nothing -> pure () where changeToTextDocumentEdit acc uri edits = acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) (fmap J.InL edits)] - applyDocumentChanges :: [J.DocumentChange] -> IO VFS - applyDocumentChanges = foldM (flip applyDocumentChange) initVfs . sortOn project - + applyDocumentChanges :: [J.DocumentChange] -> m () + applyDocumentChanges = traverse_ (applyDocumentChange logger) . sortOn project + -- for sorting [DocumentChange] project :: J.DocumentChange -> J.TextDocumentVersion -- type TextDocumentVersion = Maybe Int project (J.InL textDocumentEdit) = textDocumentEdit ^. J.textDocument . J.version @@ -251,58 +288,61 @@ virtualFileName prefix uri (VirtualFile _ file_ver _) = in prefix basename ++ "-" ++ padLeft 5 file_ver ++ "-" ++ show (hash uri_raw) <.> takeExtensions basename -- | Write a virtual file to a temporary file if it exists in the VFS. -persistFileVFS :: VFS -> J.NormalizedUri -> Maybe (FilePath, IO ()) -persistFileVFS vfs uri = - case Map.lookup uri (vfsMap vfs) of +persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> VFS -> J.NormalizedUri -> Maybe (FilePath, m ()) +persistFileVFS logger vfs uri = + case vfs ^. vfsMap . at uri of Nothing -> Nothing Just vf -> - let tfn = virtualFileName (vfsTempDir vfs) uri vf + let tfn = virtualFileName (vfs ^. vfsTempDir) uri vf action = do - exists <- doesFileExist tfn + exists <- liftIO $ doesFileExist tfn unless exists $ do - let contents = T.unpack (Rope.toText (_text vf)) + let contents = Rope.toText (_file_text vf) writeRaw h = do -- We honour original file line endings hSetNewlineMode h noNewlineTranslation hSetEncoding h utf8 - hPutStr h contents - debugM "haskell-lsp.persistFileVFS" $ "Writing virtual file: " - ++ "uri = " ++ show uri ++ ", virtual file = " ++ show tfn - withFile tfn WriteMode writeRaw + T.hPutStr h contents + logger <& PersistingFile uri tfn `WithSeverity` Debug + liftIO $ withFile tfn WriteMode writeRaw in Just (tfn, action) -- --------------------------------------------------------------------- -closeVFS :: VFS -> J.Message 'J.TextDocumentDidClose -> (VFS, [String]) -closeVFS vfs (J.NotificationMessage _ _ params) = - let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params - in (updateVFS (Map.delete (J.toNormalizedUri uri)) vfs,["Closed: " ++ show uri]) +closeVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidClose -> m () +closeVFS logger msg = do + let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier (J.toNormalizedUri -> uri)) = msg ^. J.params + logger <& Closing uri `WithSeverity` Debug + vfsMap . at uri .= Nothing -- --------------------------------------------------------------------- -- | Apply the list of changes. -- Changes should be applied in the order that they are -- received from the client. -applyChanges :: Rope -> [J.TextDocumentContentChangeEvent] -> Rope -applyChanges = foldl' applyChange +applyChanges :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> [J.TextDocumentContentChangeEvent] -> m Rope +applyChanges logger = foldM (applyChange logger) -- --------------------------------------------------------------------- -applyChange :: Rope -> J.TextDocumentContentChangeEvent -> Rope -applyChange _ (J.TextDocumentContentChangeEvent Nothing Nothing str) - = Rope.fromText str -applyChange str (J.TextDocumentContentChangeEvent (Just (J.Range (J.Position sl sc) (J.Position fl fc))) _ txt) - = changeChars str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt -applyChange str (J.TextDocumentContentChangeEvent Nothing (Just _) _txt) - = str +applyChange :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> J.TextDocumentContentChangeEvent -> m Rope +applyChange _ _ (J.TextDocumentContentChangeEvent Nothing _ str) + = pure $ Rope.fromText str +applyChange logger str (J.TextDocumentContentChangeEvent (Just (J.Range (J.Position sl sc) (J.Position fl fc))) _ txt) + = changeChars logger str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt -- --------------------------------------------------------------------- -changeChars :: Rope -> Rope.Position -> Rope.Position -> Text -> Rope -changeChars str start finish new = mconcat [before', Rope.fromText new, after] - where - (before, after) = fromJust $ Rope.splitAtPosition finish str - (before', _) = fromJust $ Rope.splitAtPosition start before +-- | Given a 'Rope', start and end positions, and some new text, replace +-- the given range with the new text. If the given positions lie within +-- a code point then this does nothing (returns the original 'Rope') and logs. +changeChars :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> Rope.Position -> Rope.Position -> Text -> m Rope +changeChars logger str start finish new = do + case Rope.splitAtPosition finish str of + Nothing -> logger <& SplitInsideCodePoint finish str `WithSeverity` Warning >> pure str + Just (before, after) -> case Rope.splitAtPosition start before of + Nothing -> logger <& SplitInsideCodePoint start before `WithSeverity` Warning >> pure str + Just (before', _) -> pure $ mconcat [before', Rope.fromText new, after] -- --------------------------------------------------------------------- diff --git a/lsp/test/VspSpec.hs b/lsp/test/VspSpec.hs index e4d691062..14b1649f9 100644 --- a/lsp/test/VspSpec.hs +++ b/lsp/test/VspSpec.hs @@ -8,6 +8,7 @@ import qualified Language.LSP.Types as J import qualified Data.Text as T import Test.Hspec +import Data.Functor.Identity -- --------------------------------------------------------------------- @@ -40,7 +41,7 @@ vspSpec = do , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 1 0 2) Nothing "" , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 0 0 1) Nothing "" ] - applyChanges orig changes `shouldBe` "" + applyChanges mempty orig changes `shouldBe` Identity "" it "handles vscode style redos" $ do let orig = "" changes = @@ -48,7 +49,7 @@ vspSpec = do , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 2 0 2) Nothing "b" , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 3 0 3) Nothing "c" ] - applyChanges orig changes `shouldBe` "abc" + applyChanges mempty orig changes `shouldBe` Identity "abc" -- --------------------------------- @@ -62,9 +63,9 @@ vspSpec = do , "-- fooo" , "foo :: Int" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 1 2 5) (Just 4) "" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "-oo" @@ -79,9 +80,9 @@ vspSpec = do , "-- fooo" , "foo :: Int" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 1 2 5) Nothing "" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "-oo" @@ -99,9 +100,9 @@ vspSpec = do , "-- fooo" , "foo :: Int" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 0 3 0) (Just 8) "" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "foo :: Int" @@ -116,9 +117,9 @@ vspSpec = do , "-- fooo" , "foo :: Int" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 0 3 0) Nothing "" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "foo :: Int" @@ -134,9 +135,9 @@ vspSpec = do , "foo :: Int" , "foo = bb" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 3 0) (Just 19) "" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "foo = bb" ] @@ -150,9 +151,9 @@ vspSpec = do , "foo :: Int" , "foo = bb" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 3 0) Nothing "" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "foo = bb" ] @@ -167,9 +168,9 @@ vspSpec = do , "module Foo where" , "foo :: Int" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 16 1 16) (Just 0) "\n-- fooo" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "-- fooo" @@ -185,9 +186,9 @@ vspSpec = do [ "module Foo where" , "foo = bb" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 8 1 8) Nothing "\n-- fooo\nfoo :: Int" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "foo = bb" , "-- fooo" @@ -212,9 +213,9 @@ vspSpec = do , " putStrLn \"hello world\"" ] -- new = changeChars (fromString orig) (J.Position 7 0) (J.Position 7 8) "baz =" - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 7 0 7 8) (Just 8) "baz =" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "-- fooo" , "foo :: Int" @@ -240,9 +241,9 @@ vspSpec = do , " putStrLn \"hello world\"" ] -- new = changeChars (fromString orig) (J.Position 7 0) (J.Position 7 8) "baz =" - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 7 0 7 8) Nothing "baz =" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "-- fooo" , "foo :: Int" @@ -259,9 +260,9 @@ vspSpec = do [ "a𐐀b" , "a𐐀b" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 1 3) (Just 3) "𐐀𐐀" - Rope.lines new `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "a𐐀b" , "𐐀𐐀b" ] diff --git a/stack.yaml b/stack.yaml index 6b641d23f..2ca1055ee 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,3 +11,4 @@ nix: packages: [icu] extra-deps: - text-rope-0.1 +- co-log-core-0.3.1.0