lsp 1.4.0.0 → 1.5.0.0

raw patch · 13 files changed

+999/−279 lines, 13 filesdep +co-log-coredep +directorydep +prettyprinterdep −hsloggerdep −rope-utf16-splaydep ~aesondep ~asyncdep ~lsp-typesPVP ok

version bump matches the API change (PVP)

Dependencies added: co-log-core, directory, prettyprinter, temporary, text-rope

Dependencies removed: hslogger, rope-utf16-splay

Dependency ranges changed: aeson, async, lsp-types, mtl, transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• example/Reactor.hs +57/−31
• example/Simple.hs +2/−2
• lsp.cabal +18/−11
• src/Language/LSP/Logging.hs +38/−0
• src/Language/LSP/Server.hs +2/−1
• src/Language/LSP/Server/Control.hs +113/−50
• src/Language/LSP/Server/Core.hs +34/−78
• src/Language/LSP/Server/Processing.hs +120/−69
• src/Language/LSP/VFS.hs +541/−0
• test/JsonSpec.hs +0/−8
• test/URIFilePathSpec.hs +1/−1
• test/VspSpec.hs +68/−28

@@ -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)

@@ -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 ->

@@ -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)               

@@ -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

@@ -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

@@ -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 

@@ -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  -- | --

@@ -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  -- --------------------------------------------------------------------- 

@@ -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  -- ----------------------------------------------------------------------

@@ -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+-- ---------------------------------------------------------------------

@@ -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

@@ -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 

@@ -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      -- ---------------------------------