diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for lsp +## 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 * Fix extraneous `asdf` in `withProgress` output (#372) (@heitor-lassarote) diff --git a/example/Reactor.hs b/example/Reactor.hs --- a/example/Reactor.hs +++ b/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 @@ 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 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 @@ 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 @@ -- | 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 @@ 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 @@ 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 @@ 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 @@ , 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 @@ . 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 @@ 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 @@ 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,12 +277,12 @@ 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 -- makeCommand only generates commands for diagnostics whose source is us - makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams] + makeCommand (J.Diagnostic (J.Range s _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams] where title = "Apply LSP hello command:" <> head (T.lines _m) -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above @@ -264,7 +290,7 @@ -- need 'file' and 'start_pos' args = J.List [ J.object [("file", J.object [("textDocument",J.toJSON doc)])] - , J.object [("start_pos",J.object [("position", J.toJSON start)])] + , J.object [("start_pos",J.object [("position", J.toJSON s)])] ] cmdparams = Just args makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] @@ -272,11 +298,11 @@ 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/example/Simple.hs b/example/Simple.hs --- a/example/Simple.hs +++ b/example/Simple.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} import Language.LSP.Server import Language.LSP.Types @@ -10,8 +11,7 @@ [ notificationHandler SInitialized $ \_not -> do let params = ShowMessageRequestParams MtInfo "Turn on code lenses?" (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) - _ <- sendRequest SWindowShowMessageRequest params $ \res -> - case res of + _ <- sendRequest SWindowShowMessageRequest params $ \case Right (Just (MessageActionItem "Turn on")) -> do let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False) diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp -version: 1.4.0.0 +version: 1.5.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -24,32 +24,38 @@ reexported-modules: Language.LSP.Types , Language.LSP.Types.Capabilities , Language.LSP.Types.Lens - , Language.LSP.VFS exposed-modules: Language.LSP.Server , Language.LSP.Diagnostics + , Language.LSP.Logging + , Language.LSP.VFS other-modules: Language.LSP.Server.Core , Language.LSP.Server.Control , Language.LSP.Server.Processing ghc-options: -Wall build-depends: base >= 4.11 && < 5 - , async + , async >= 2.0 , aeson >=1.0.0.0 , attoparsec , bytestring , containers + , co-log-core >= 0.3.1.0 , data-default + , directory , exceptions - , hslogger + , filepath , hashable - , lsp-types == 1.4.* + , lsp-types == 1.5.* , lens >= 4.15.2 - , mtl + , mtl < 2.4 , network-uri + , prettyprinter , sorted-list == 0.2.1.* , stm == 2.5.* , scientific + , temporary , text - , transformers >= 0.5.6 && < 0.6 + , text-rope + , transformers >= 0.5.6 && < 0.7 , time , unordered-containers , unliftio-core >= 0.2.0.0 @@ -68,9 +74,10 @@ 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 @@ -112,7 +119,8 @@ WorkspaceEditSpec build-depends: base , QuickCheck - , aeson + -- for instance Arbitrary Value + , aeson >= 2.0.3.0 , containers , filepath , lsp @@ -121,14 +129,13 @@ , lens >= 4.15.2 , network-uri , quickcheck-instances - , rope-utf16-splay >= 0.2 , sorted-list == 0.2.1.* , text + , text-rope , unordered-containers -- For GHCI tests -- , async -- , haskell-lsp-types - -- , hslogger -- , temporary -- , time -- , unordered-containers diff --git a/src/Language/LSP/Logging.hs b/src/Language/LSP/Logging.hs new file mode 100644 --- /dev/null +++ b/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/src/Language/LSP/Server.hs b/src/Language/LSP/Server.hs --- a/src/Language/LSP/Server.hs +++ b/src/Language/LSP/Server.hs @@ -26,6 +26,7 @@ , getClientCapabilities , getConfig + , setConfig , getRootPath , getWorkspaceFolders @@ -38,6 +39,7 @@ , persistVirtualFile , getVersionedTextDoc , reverseFileMap + , snapshotVirtualFiles -- * Diagnostics , publishDiagnostics @@ -55,7 +57,6 @@ , unregisterCapability , RegistrationToken - , setupLogger , reverseSortEdit ) where diff --git a/src/Language/LSP/Server/Control.hs b/src/Language/LSP/Server/Control.hs --- a/src/Language/LSP/Server/Control.hs +++ b/src/Language/LSP/Server/Control.hs @@ -1,20 +1,28 @@ {-# 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 ( -- * Running 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.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 +-- | 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. +-- | 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 @@ 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 @@ _ <- 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 @@ , str ] clientOut out - debugM "lsp.sendServer" $ "<--2--" <> TL.unpack (TL.decodeUtf8 str) + logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug -- | -- diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs --- a/src/Language/LSP/Server/Core.hs +++ b/src/Language/LSP/Server/Core.hs @@ -1,26 +1,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE DerivingVia #-} {-# 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 +20,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 +30,7 @@ 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 @@ -48,6 +41,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Monoid (Ap(..)) import Data.Ord (Down (Down)) import qualified Data.Text as T import Data.Text ( Text ) @@ -59,12 +53,6 @@ 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) @@ -77,6 +65,7 @@ newtype LspT config m a = LspT { unLspT :: ReaderT (LanguageContextEnv config) m a } deriving (Functor, Applicative, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow, MonadTrans, MonadUnliftIO, MonadFix) + deriving (Semigroup, Monoid) via (Ap (LspT config m) a) -- for deriving the instance of MonadUnliftIO type role LspT representational representational nominal @@ -107,7 +96,7 @@ 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) @@ -232,7 +221,7 @@ -- | The characters that trigger completion automatically. , completionTriggerCharacters :: Maybe [Char] -- | The list of all possible characters that commit a completion. This field can be used - -- if clients don't support individual commmit characters per completion item. See + -- if clients don't support individual commit characters per completion item. See -- `_commitCharactersSupport`. , completionAllCommitCharacters :: Maybe [Char] -- | The characters that trigger signature help automatically. @@ -263,7 +252,7 @@ defaultOptions :: Options defaultOptions = def --- | A package indicating the perecentage of progress complete and a +-- | A package indicating the percentage of progress complete and a -- an optional message to go with it during a 'withProgress' -- -- @since 0.10.0.0 @@ -300,12 +289,12 @@ -- ^ Called *after* receiving the @initialize@ request and *before* -- returning the response. This callback will be invoked to offer the -- language server implementation the chance to create any processes or - -- start new threads that may be necesary for the server lifecycle. It can + -- start new threads that may be necessary for the server lifecycle. It can -- also return an error in the initialization if necessary. , staticHandlers :: Handlers m -- ^ Handlers for any methods you want to statically support. -- The handlers here cannot be unregistered during the server's lifetime - -- and will be regsitered statically in the initialize request. + -- and will be registered statically in the initialize request. , interpretHandler :: a -> (m <~> IO) -- ^ How to run the handlers in your own monad of choice, @m@. -- It is passed the result of 'doInitialize', so typically you will want @@ -330,7 +319,7 @@ newtype ServerResponseCallback (m :: Method FromServer Request) = ServerResponseCallback (Either ResponseError (ResponseResult m) -> IO ()) --- | Return value signals if response handler was inserted succesfully +-- | Return value signals if response handler was inserted successfully -- Might fail if the id was already in the map addResponseHandler :: MonadLsp config f => LspId m -> (Product SMethod ServerResponseCallback) m -> f Bool addResponseHandler lid h = do @@ -359,7 +348,7 @@ 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 +360,9 @@ -- | 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 #-} @@ -380,12 +371,19 @@ {-# INLINE getVirtualFiles #-} +-- | Take an atomic snapshot of the current state of the virtual file system. +snapshotVirtualFiles :: LanguageContextEnv c -> STM VFS +snapshotVirtualFiles env = vfsData <$> readTVar (resVFS $ resState env) + +{-# INLINE snapshotVirtualFiles #-} + + -- | 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 @@ -395,7 +393,7 @@ Nothing -> reverseMap vfs !vfs' = vfs {reverseMap = revMap} act = do - liftIO write + write pure (Just fn) in (act, vfs') @@ -433,15 +431,6 @@ -- --------------------------------------------------------------------- -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 -> @@ -452,12 +441,18 @@ -- --------------------------------------------------------------------- -- | The current configuration from the client as set via the @initialize@ and --- @workspace/didChangeConfiguration@ requests. +-- @workspace/didChangeConfiguration@ requests, as well as by calls to +-- 'setConfig'. getConfig :: MonadLsp config m => m config getConfig = getsState resConfig {-# INLINE getConfig #-} +setConfig :: MonadLsp config m => config -> m () +setConfig config = stateState resConfig (const ((), config)) + +{-# INLINE setConfig #-} + getClientCapabilities :: MonadLsp config m => m J.ClientCapabilities getClientCapabilities = resClientCapabilities <$> getLspEnv @@ -621,7 +616,7 @@ _ <- sendRequest SWindowWorkDoneProgressCreate (WorkDoneProgressCreateParams progId) $ \res -> do case res of - -- An error ocurred when the client was setting it up + -- An error occurred when the client was setting it up -- No need to do anything then, as per the spec Left _err -> pure () Right Empty -> pure () @@ -717,45 +712,6 @@ Just params -> do 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 -- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Server/Processing.hs b/src/Language/LSP/Server/Processing.hs --- a/src/Language/LSP/Server/Processing.hs +++ b/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,24 +33,58 @@ import Language.LSP.Types.SMethodMap (SMethodMap) import qualified Language.LSP.Types.SMethodMap as SMethodMap import Language.LSP.Server.Core -import Language.LSP.VFS -import Data.Functor.Product +import Language.LSP.VFS as VFS +import qualified Data.Functor.Product as P import qualified Control.Exception as E -import Data.Monoid hiding (Product) +import Data.Monoid +import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Except +import Control.Monad.Except () 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) +import Control.Monad.State +import Control.Monad.Writer.Strict +import Data.Foldable (traverse_) -processMessage :: BSL.ByteString -> LspM config () -processMessage jsonStr = do +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,23 +92,17 @@ msg <- except $ parseEither (parser pending) val lift $ case msg of FromClientMess m mess -> - pure $ handle m mess - FromClientRsp (Pair (ServerResponseCallback f) (Const !newMap)) res -> do + pure $ handle logger m mess + FromClientRsp (P.Pair (ServerResponseCallback f) (Const !newMap)) res -> do writeTVar pendingResponsesVar newMap pure $ liftIO $ f (res ^. LSP.result) where - parser :: ResponseMap -> Value -> Parser (FromClientMessage' (Product ServerResponseCallback (Const ResponseMap))) + parser :: ResponseMap -> Value -> Parser (FromClientMessage' (P.Product ServerResponseCallback (Const ResponseMap))) parser rm = parseClientMessage $ \i -> let (mhandler, newMap) = pickFromIxMap i rm - in (\(Pair m handler) -> (m,Pair handler (Const newMap))) <$> mhandler - - handleErrors = either (sendErrorLog . errMsg) id + in (\(P.Pair m handler) -> (m,P.Pair handler (Const newMap))) <$> mhandler - 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 @@ -165,7 +201,7 @@ , _selectionRangeProvider = supportedBool STextDocumentSelectionRange , _callHierarchyProvider = supportedBool STextDocumentPrepareCallHierarchy , _semanticTokensProvider = semanticTokensProvider - , _workspaceSymbolProvider = supported SWorkspaceSymbol + , _workspaceSymbolProvider = supportedBool SWorkspaceSymbol , _workspace = Just workspace -- TODO: Add something for experimental , _experimental = Nothing :: Maybe Value @@ -253,7 +289,7 @@ 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 @@ -- | 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 + 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 t (m :: Method FromClient t) config. - Maybe (ClientMessage m -> LspM config ()) +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 @@ 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,60 +373,74 @@ 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 + (Just (P.Pair _ (ClientMessageHandler h)), _) -> Just h (Nothing, Just (ClientMessageHandler h)) -> Just h (Nothing, Nothing) -> Nothing -- '$/' 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 @@ modifyState resWorkspaceFolders newWfs -- --------------------------------------------------------------------- - diff --git a/src/Language/LSP/VFS.hs b/src/Language/LSP/VFS.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/VFS.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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" \/ +"Language.LSP.Types.TextDocumentDidOpen" \/ +"Language.LSP.Types.TextDocumentDidClose" messages to keep an in-memory +`filesystem` of the current client workspace. The server can access and edit +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 + , changeFromClientVFS + , changeFromServerVFS + , persistFileVFS + , closeVFS + + -- * Positions and transformations + , CodePointPosition (..) + , line + , character + , codePointPositionToPosition + , positionToCodePointPosition + , CodePointRange (..) + , start + , end + , codePointRangeToRange + , rangeToCodePointRange + + -- * manipulating the file contents + , rangeLinesFromVfs + , PosPrefixInfo(..) + , getCompletionPrefix + + -- * for tests + , applyChanges + , applyChange + , changeChars + ) where + +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 +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text.Rope as URope +import Data.Text.Utf16.Rope ( Rope ) +import qualified Data.Text.Utf16.Rope as Rope +import Data.Text.Prettyprint.Doc hiding (line) +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.Temp +import Data.Foldable (traverse_) + +-- --------------------------------------------------------------------- +{-# ANN module ("hlint: ignore Eta reduce" :: String) #-} +{-# ANN module ("hlint: ignore Redundant do" :: String) #-} +-- --------------------------------------------------------------------- + +data VirtualFile = + 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. + , _file_text :: !Rope -- ^ The full contents of the document + } deriving (Show) + +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 (_file_text vf) + +virtualFileVersion :: VirtualFile -> Int32 +virtualFileVersion vf = _lsp_version vf + +--- + +initVFS :: (VFS -> IO r) -> IO r +initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty temp_dir) + +-- --------------------------------------------------------------------- + +-- | Applies the changes from a 'J.DidOpenTextDocument' to the '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 :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidChange -> m () +changeFromClientVFS logger msg = do + let + 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 :: (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) + uri + (VirtualFile 0 0 mempty) + 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 (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 + Just (J.CreateFileOptions (Just False) Nothing ) -> False -- `overwrite` is False + Just (J.CreateFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False + Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` + +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 (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 + Just (J.RenameFileOptions (Just False) Nothing ) -> False -- `overwrite` is False + Just (J.RenameFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False + Just (J.RenameFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` + +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 + changeFromClientVFS logger notif + + where + editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range + editRange (J.InR e) = e ^. J.range + editRange (J.InL e) = e ^. J.range + + editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent + 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 :: (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 :: 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 -> pure () + + where + changeToTextDocumentEdit acc uri edits = + acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) (fmap J.InL edits)] + + 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 + project _ = Nothing + +-- --------------------------------------------------------------------- +virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath +virtualFileName prefix uri (VirtualFile _ file_ver _) = + let uri_raw = J.fromNormalizedUri uri + basename = maybe "" takeFileName (J.uriToFilePath uri_raw) + -- Given a length and a version number, pad the version number to + -- the given n. Does nothing if the version number string is longer + -- than the given length. + padLeft :: Int -> Int -> String + padLeft n num = + let numString = show num + in replicate (n - length numString) '0' ++ numString + 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 :: (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 (vfs ^. vfsTempDir) uri vf + action = do + exists <- liftIO $ doesFileExist tfn + unless exists $ do + let contents = Rope.toText (_file_text vf) + writeRaw h = do + -- We honour original file line endings + hSetNewlineMode h noNewlineTranslation + hSetEncoding h utf8 + T.hPutStr h contents + logger <& PersistingFile uri tfn `WithSeverity` Debug + liftIO $ withFile tfn WriteMode writeRaw + in Just (tfn, action) + +-- --------------------------------------------------------------------- + +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 :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> [J.TextDocumentContentChangeEvent] -> m Rope +applyChanges logger = foldM (applyChange logger) + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +-- | 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] + +-- --------------------------------------------------------------------- + +-- | A position, like a 'J.Position', but where the offsets in the line are measured in +-- Unicode code points instead of UTF-16 code units. +data CodePointPosition = + CodePointPosition + { -- | Line position in a document (zero-based). + _line :: J.UInt + -- | Character offset on a line in a document in *code points* (zero-based). + , _character :: J.UInt + } deriving (Show, Read, Eq, Ord) + +-- | A range, like a 'J.Range', but where the offsets in the line are measured in +-- Unicode code points instead of UTF-16 code units. +data CodePointRange = + CodePointRange + { _start :: CodePointPosition -- ^ The range's start position. + , _end :: CodePointPosition -- ^ The range's end position. + } deriving (Show, Read, Eq, Ord) + +makeFieldsNoPrefix ''CodePointPosition +makeFieldsNoPrefix ''CodePointRange + +{- Note [Converting between code points and code units] +This is inherently a somewhat expensive operation, but we take some care to minimize the cost. +In particular, we use the good asymptotics of 'Rope' to our advantage: +- We extract the single line that we are interested in in time logarithmic in the number of lines. +- We then split the line at the given position, and check how long the prefix is, which takes +linear time in the length of the (single) line. + +We also may need to convert the line back and forth between ropes with different indexing. Again +this is linear time in the length of the line. + +So the overall process is logarithmic in the number of lines, and linear in the length of the specific +line. Which is okay-ish, so long as we don't have very long lines. +-} + +-- | Extracts a specific line from a 'Rope.Rope'. +-- Logarithmic in the number of lines. +extractLine :: Rope.Rope -> Word -> Maybe Rope.Rope +extractLine rope l = do + -- Check for the line being out of bounds + let lastLine = Rope.posLine $ Rope.lengthAsPosition rope + guard $ l <= lastLine + + let (_, suffix) = Rope.splitAtLine l rope + (prefix, _) = Rope.splitAtLine 1 suffix + pure prefix + +-- | Translate a code-point offset into a code-unit offset. +-- Linear in the length of the rope. +codePointOffsetToCodeUnitOffset :: URope.Rope -> Word -> Maybe Word +codePointOffsetToCodeUnitOffset rope offset = do + -- Check for the position being out of bounds + guard $ offset <= URope.length rope + -- Split at the given position in *code points* + let (prefix, _) = URope.splitAt offset rope + -- Convert the prefix to a rope using *code units* + utf16Prefix = Rope.fromText $ URope.toText prefix + -- Get the length of the prefix in *code units* + pure $ Rope.length utf16Prefix + +-- | Translate a UTF-16 code-unit offset into a code-point offset. +-- Linear in the length of the rope. +codeUnitOffsetToCodePointOffset :: Rope.Rope -> Word -> Maybe Word +codeUnitOffsetToCodePointOffset rope offset = do + -- Check for the position being out of bounds + guard $ offset <= Rope.length rope + -- Split at the given position in *code units* + (prefix, _) <- Rope.splitAt offset rope + -- Convert the prefix to a rope using *code points* + let utfPrefix = URope.fromText $ Rope.toText prefix + -- Get the length of the prefix in *code points* + pure $ URope.length utfPrefix + +-- | Given a virtual file, translate a 'CodePointPosition' in that file into a 'J.Position' in that file. +-- +-- Will return 'Nothing' if the requested position is out of bounds of the document. +-- +-- Logarithmic in the number of lines in the document, and linear in the length of the line containing +-- the position. +codePointPositionToPosition :: VirtualFile -> CodePointPosition -> Maybe J.Position +codePointPositionToPosition vFile (CodePointPosition l cpc) = do + -- See Note [Converting between code points and code units] + let text = _file_text vFile + utf16Line <- extractLine text (fromIntegral l) + -- Convert the line a rope using *code points* + let utfLine = URope.fromText $ Rope.toText utf16Line + + cuc <- codePointOffsetToCodeUnitOffset utfLine (fromIntegral cpc) + pure $ J.Position l (fromIntegral cuc) + +-- | Given a virtual file, translate a 'CodePointRange' in that file into a 'J.Range' in that file. +-- +-- Will return 'Nothing' if any of the positions are out of bounds of the document. +-- +-- Logarithmic in the number of lines in the document, and linear in the length of the lines containing +-- the positions. +codePointRangeToRange :: VirtualFile -> CodePointRange -> Maybe J.Range +codePointRangeToRange vFile (CodePointRange b e) = + J.Range <$> codePointPositionToPosition vFile b <*> codePointPositionToPosition vFile e + +-- | Given a virtual file, translate a 'J.Position' in that file into a 'CodePointPosition' in that file. +-- +-- Will return 'Nothing' if the requested position lies inside a code point, or if it is out of bounds of the document. +-- +-- Logarithmic in the number of lines in the document, and linear in the length of the line containing +-- the position. +positionToCodePointPosition :: VirtualFile -> J.Position -> Maybe CodePointPosition +positionToCodePointPosition vFile (J.Position l cuc) = do + -- See Note [Converting between code points and code units] + let text = _file_text vFile + utf16Line <- extractLine text (fromIntegral l) + + cpc <- codeUnitOffsetToCodePointOffset utf16Line (fromIntegral cuc) + pure $ CodePointPosition l (fromIntegral cpc) + +-- | Given a virtual file, translate a 'J.Range' in that file into a 'CodePointRange' in that file. +-- +-- Will return 'Nothing' if any of the positions are out of bounds of the document. +-- +-- Logarithmic in the number of lines in the document, and linear in the length of the lines containing +-- the positions. +rangeToCodePointRange :: VirtualFile -> J.Range -> Maybe CodePointRange +rangeToCodePointRange vFile (J.Range b e) = + CodePointRange <$> positionToCodePointPosition vFile b <*> positionToCodePointPosition vFile e + +-- --------------------------------------------------------------------- + +-- TODO:AZ:move this to somewhere sane +-- | Describes the line at the current cursor position +data PosPrefixInfo = PosPrefixInfo + { fullLine :: !T.Text + -- ^ The full contents of the line the cursor is at + + , prefixModule :: !T.Text + -- ^ If any, the module name that was typed right before the cursor position. + -- For example, if the user has typed "Data.Maybe.from", then this property + -- will be "Data.Maybe" + + , prefixText :: !T.Text + -- ^ The word right before the cursor position, after removing the module part. + -- For example if the user has typed "Data.Maybe.from", + -- then this property will be "from" + , cursorPos :: !J.Position + -- ^ The cursor position + } deriving (Show,Eq) + +getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo) +getCompletionPrefix pos@(J.Position l c) (VirtualFile _ _ ropetext) = + return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad + let lastMaybe [] = Nothing + lastMaybe xs = Just $ last xs + + let curRope = fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext + beforePos <- Rope.toText . fst <$> Rope.splitAt (fromIntegral c) curRope + curWord <- + if | T.null beforePos -> Just "" + | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc ' + | otherwise -> lastMaybe (T.words beforePos) + + let parts = T.split (=='.') + $ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord + case reverse parts of + [] -> Nothing + (x:xs) -> do + let modParts = dropWhile (not . isUpper . T.head) + $ reverse $ filter (not .T.null) xs + modName = T.intercalate "." modParts + -- curRope is already a single line, but it may include an enclosing '\n' + let curLine = T.dropWhileEnd (== '\n') $ Rope.toText curRope + return $ PosPrefixInfo curLine modName x pos + +-- --------------------------------------------------------------------- + +rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text +rangeLinesFromVfs (VirtualFile _ _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r + where + (_ ,s1) = Rope.splitAtLine (fromIntegral lf) ropetext + (s2, _) = Rope.splitAtLine (fromIntegral (lt - lf)) s1 + r = Rope.toText s2 +-- --------------------------------------------------------------------- diff --git a/test/JsonSpec.hs b/test/JsonSpec.hs --- a/test/JsonSpec.hs +++ b/test/JsonSpec.hs @@ -159,14 +159,6 @@ instance (Arbitrary a) => Arbitrary (List a) where arbitrary = List <$> arbitrary -instance Arbitrary J.Value where - arbitrary = oneof - [ J.String <$> arbitrary - , J.Number <$> arbitrary - , J.Bool <$> arbitrary - , pure J.Null - ] - -- --------------------------------------------------------------------- instance Arbitrary DidChangeWatchedFilesRegistrationOptions where diff --git a/test/URIFilePathSpec.hs b/test/URIFilePathSpec.hs --- a/test/URIFilePathSpec.hs +++ b/test/URIFilePathSpec.hs @@ -164,7 +164,7 @@ let theUri = filePathToUri testFilePath theUri `shouldBe` testUri - it "removes unnecesary current directory paths" $ do + it "removes unnecessary current directory paths" $ do let theUri = filePathToUri withCurrentDirFilePath theUri `shouldBe` testUri diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module VspSpec where - import Data.String -import qualified Data.Rope.UTF16 as Rope +import qualified Data.Text.Utf16.Rope as Rope import Language.LSP.VFS import qualified Language.LSP.Types as J import qualified Data.Text as T import Test.Hspec +import Data.Functor.Identity -- --------------------------------------------------------------------- @@ -41,7 +41,7 @@ , 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 = @@ -49,7 +49,7 @@ , 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" -- --------------------------------- @@ -63,9 +63,9 @@ , "-- fooo" , "foo :: Int" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 1 2 5) (Just 4) "" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "-oo" @@ -80,9 +80,9 @@ , "-- fooo" , "foo :: Int" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 1 2 5) Nothing "" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "-oo" @@ -100,9 +100,9 @@ , "-- fooo" , "foo :: Int" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 0 3 0) (Just 8) "" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "foo :: Int" @@ -117,9 +117,9 @@ , "-- fooo" , "foo :: Int" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 0 3 0) Nothing "" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "foo :: Int" @@ -135,9 +135,9 @@ , "foo :: Int" , "foo = bb" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 3 0) (Just 19) "" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "foo = bb" ] @@ -151,9 +151,9 @@ , "foo :: Int" , "foo = bb" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 3 0) Nothing "" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "foo = bb" ] @@ -168,9 +168,9 @@ , "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" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "-- fooo" @@ -186,9 +186,9 @@ [ "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" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "foo = bb" , "-- fooo" @@ -213,9 +213,9 @@ , " 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 =" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "-- fooo" , "foo :: Int" @@ -241,9 +241,9 @@ , " 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 =" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "-- fooo" , "foo :: Int" @@ -260,9 +260,9 @@ [ "a𐐀b" , "a𐐀b" ] - new = applyChange (fromString orig) + new = applyChange mempty (fromString orig) $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 1 3) (Just 3) "𐐀𐐀" - lines (Rope.toString new) `shouldBe` + Rope.lines <$> new `shouldBe` Identity [ "a𐐀b" , "𐐀𐐀b" ] @@ -285,19 +285,59 @@ ] (left,right) = Rope.splitAtLine 4 (fromString orig) - lines (Rope.toString left) `shouldBe` + Rope.lines left `shouldBe` [ "module Foo where" , "-- fooo" , "foo :: Int" , "foo = bb" ] - lines (Rope.toString right) `shouldBe` + Rope.lines right `shouldBe` [ "" , "bb = 5" , "" , "baz = do" , " putStrLn \"hello world\"" ] + + it "converts code units to code points" $ do + let + orig = unlines + [ "a𐐀b" + , "a𐐀b" + ] + vfile = VirtualFile 0 0 (fromString orig) + + positionToCodePointPosition vfile (J.Position 1 0) `shouldBe` Just (CodePointPosition 1 0) + positionToCodePointPosition vfile (J.Position 1 1) `shouldBe` Just (CodePointPosition 1 1) + -- Split inside code point + positionToCodePointPosition vfile (J.Position 1 2) `shouldBe` Nothing + positionToCodePointPosition vfile (J.Position 1 3) `shouldBe` Just (CodePointPosition 1 2) + positionToCodePointPosition vfile (J.Position 1 4) `shouldBe` Just (CodePointPosition 1 3) + positionToCodePointPosition vfile (J.Position 1 5) `shouldBe` Just (CodePointPosition 1 4) + -- Greater column than max column + positionToCodePointPosition vfile (J.Position 1 6) `shouldBe` Nothing + positionToCodePointPosition vfile (J.Position 2 1) `shouldBe` Nothing + -- Greater line than max line + positionToCodePointPosition vfile (J.Position 3 0) `shouldBe` Nothing + + it "converts code points to code units" $ do + let + orig = unlines + [ "a𐐀b" + , "a𐐀b" + ] + vfile = VirtualFile 0 0 (fromString orig) + + codePointPositionToPosition vfile (CodePointPosition 1 0) `shouldBe` Just (J.Position 1 0) + codePointPositionToPosition vfile (CodePointPosition 1 1) `shouldBe` Just (J.Position 1 1) + codePointPositionToPosition vfile (CodePointPosition 1 2) `shouldBe` Just (J.Position 1 3) + codePointPositionToPosition vfile (CodePointPosition 1 3) `shouldBe` Just (J.Position 1 4) + codePointPositionToPosition vfile (CodePointPosition 1 4) `shouldBe` Just (J.Position 1 5) + -- Greater column than max column + codePointPositionToPosition vfile (CodePointPosition 1 5) `shouldBe` Nothing + codePointPositionToPosition vfile (CodePointPosition 2 1) `shouldBe` Nothing + -- Greater line than max line + codePointPositionToPosition vfile (CodePointPosition 3 0) `shouldBe` Nothing -- ---------------------------------