haskell-lsp 0.2.2.0 → 0.4.0.0

raw patch · 11 files changed

+459/−258 lines, 11 filesdep ~aesondep ~haskell-lsp-typesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, haskell-lsp-types

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−0
• example/Main.hs +46/−45
• haskell-lsp.cabal +6/−4
• src/Language/Haskell/LSP/Capture.hs +30/−0
• src/Language/Haskell/LSP/Control.hs +67/−27
• src/Language/Haskell/LSP/Core.hs +123/−143
• src/Language/Haskell/LSP/Diagnostics.hs +2/−2
• src/Language/Haskell/LSP/Messages.hs +96/−4
• src/Language/Haskell/LSP/Types/Capabilities.hs +6/−0
• src/Language/Haskell/LSP/VFS.hs +48/−22
• test/VspSpec.hs +17/−11

@@ -1,5 +1,23 @@ # Revision history for haskell-lsp +## 0.4.0.0  -- 2018-07-10++* CodeAction support as per v3.8 of the specification, by @Bubba+* Update VersionedTextDocumentIdentifier to match specification, by @Bubba++## 0.3.0.0++* Handle TextDocumentSync fallbacks with new TDS type.++## 0.2.3.0  -- 2018-99-99++* GHC 8.4.3 support+* Apply changes to the VFS in the order received in a message.+  This fixes vscode undo behaviour. By @Bubba+* Introduce additional error codes as per the LSP spec. By @Bubba+* Add preliminary support for recording LSP traffic for later playback+  in test scenarios. By @Bubba+ ## 0.2.2.0  -- 2018-05-04  * Make Diagnostic relatedInformation optional, as per the LSP Spec. By @Bubba.

@@ -57,16 +57,16 @@    let     dp lf = do-      liftIO $ U.logs $ "main.run:dp entered"+      liftIO $ U.logs "main.run:dp entered"       _rpid  <- forkIO $ reactor lf rin-      liftIO $ U.logs $ "main.run:dp tchan"+      liftIO $ U.logs "main.run:dp tchan"       dispatcherProc-      liftIO $ U.logs $ "main.run:dp after dispatcherProc"+      liftIO $ U.logs "main.run:dp after dispatcherProc"       return Nothing    flip E.finally finalProc $ do     Core.setupLogger (Just "/tmp/lsp-hello.log") [] L.DEBUG-    CTRL.run (return (Right ()), dp) (lspHandlers rin) lspOptions+    CTRL.run (return (Right ()), dp) (lspHandlers rin) lspOptions (Just "/tmp/lsp-hello-session.log")    where     handlers = [ E.Handler ioExcept@@ -83,7 +83,7 @@ -- reply sent.  data ReactorInput-  = HandlerRequest Core.OutMessage+  = HandlerRequest FromClientMessage       -- ^ injected into the reactor input by each of the individual callback handlers  -- ---------------------------------------------------------------------@@ -97,24 +97,24 @@  -- --------------------------------------------------------------------- -reactorSend :: (J.ToJSON a) => a -> R () ()+reactorSend :: FromServerMessage -> R () () reactorSend msg = do   lf <- ask   liftIO $ Core.sendFunc lf msg  -- --------------------------------------------------------------------- -publishDiagnostics :: Int -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> R () ()-publishDiagnostics maxToPublish uri mv diags = do+publishDiagnostics :: Int -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> R () ()+publishDiagnostics maxToPublish uri v diags = do   lf <- ask-  liftIO $ (Core.publishDiagnosticsFunc lf) maxToPublish uri mv diags+  liftIO $ (Core.publishDiagnosticsFunc lf) maxToPublish uri v diags  -- ---------------------------------------------------------------------  nextLspReqId :: R () J.LspId nextLspReqId = do   f <- asks Core.getNextReqId-  liftIO $ f+  liftIO f  -- --------------------------------------------------------------------- @@ -123,20 +123,20 @@ -- server and backend compiler reactor :: Core.LspFuncs () -> TChan ReactorInput -> IO () reactor lf inp = do-  liftIO $ U.logs $ "reactor:entered"+  liftIO $ U.logs "reactor:entered"   flip runReaderT lf $ forever $ do     inval <- liftIO $ atomically $ readTChan inp     case inval of        -- Handle any response from a message originating at the server, such as       -- "workspace/applyEdit"-      HandlerRequest (Core.RspFromClient rm) -> do+      HandlerRequest (RspFromClient rm) -> do         liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show rm        -- ------------------------------- -      HandlerRequest (Core.NotInitialized _notification) -> do-        liftIO $ U.logm $ "****** reactor: processing Initialized Notification"+      HandlerRequest (NotInitialized _notification) -> do+        liftIO $ U.logm "****** reactor: processing Initialized Notification"         -- Server is ready, register any specific capabilities we need           {-@@ -163,7 +163,7 @@         let registrations = J.RegistrationParams (J.List [registration])         rid <- nextLspReqId -        reactorSend $ fmServerRegisterCapabilityRequest rid registrations+        reactorSend $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest rid registrations          -- example of showMessageRequest         let@@ -171,12 +171,12 @@                            (Just [J.MessageActionItem "option a", J.MessageActionItem "option b"])         rid1 <- nextLspReqId -        reactorSend $ fmServerShowMessageRequest rid1 params+        reactorSend $ ReqShowMessage $ fmServerShowMessageRequest rid1 params        -- ------------------------------- -      HandlerRequest (Core.NotDidOpenTextDocument notification) -> do-        liftIO $ U.logm $ "****** reactor: processing NotDidOpenTextDocument"+      HandlerRequest (NotDidOpenTextDocument notification) -> do+        liftIO $ U.logm "****** reactor: processing NotDidOpenTextDocument"         let             doc  = notification ^. J.params                                  . J.textDocument@@ -187,7 +187,7 @@        -- ------------------------------- -      HandlerRequest (Core.NotDidChangeTextDocument notification) -> do+      HandlerRequest (NotDidChangeTextDocument notification) -> do         let doc :: J.Uri             doc  = notification ^. J.params                                  . J.textDocument@@ -197,13 +197,13 @@           Just (VirtualFile _version str) -> do             liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf got:" ++ (show $ Yi.toString str)           Nothing -> do-            liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf returned Nothing"+            liftIO $ U.logs "reactor:processing NotDidChangeTextDocument: vf returned Nothing"          liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: uri=" ++ (show doc)        -- ------------------------------- -      HandlerRequest (Core.NotDidSaveTextDocument notification) -> do+      HandlerRequest (NotDidSaveTextDocument notification) -> do         liftIO $ U.logm "****** reactor: processing NotDidSaveTextDocument"         let             doc  = notification ^. J.params@@ -215,7 +215,7 @@        -- ------------------------------- -      HandlerRequest (Core.ReqRename req) -> do+      HandlerRequest (ReqRename req) -> do         liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req         let             _params = req ^. J.params@@ -227,11 +227,11 @@                     Nothing -- "changes" field is deprecated                     (Just (J.List [])) -- populate with actual changes from the rename         let rspMsg = Core.makeResponseMessage req we-        reactorSend rspMsg+        reactorSend $ RspRename rspMsg        -- ------------------------------- -      HandlerRequest (Core.ReqHover req) -> do+      HandlerRequest (ReqHover req) -> do         liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req         let J.TextDocumentPositionParams _doc pos = req ^. J.params             J.Position _l _c' = pos@@ -240,11 +240,11 @@           ht = J.Hover ms (Just range)           ms = J.List [J.CodeString $ J.LanguageString "lsp-hello" "TYPE INFO" ]           range = J.Range pos pos-        reactorSend $ Core.makeResponseMessage req ht+        reactorSend $ RspHover $ Core.makeResponseMessage req ht        -- ------------------------------- -      HandlerRequest (Core.ReqCodeAction req) -> do+      HandlerRequest (ReqCodeAction req) -> do         liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req         let params = req ^. J.params             doc = params ^. J.textDocument@@ -266,20 +266,21 @@                       ]               cmdparams = Just args           makeCommand (J.Diagnostic _r _s _c _source _m _l) = []-        let body = J.List $ concatMap makeCommand diags-        reactorSend $ Core.makeResponseMessage req body+        let body = J.List $ map J.CommandOrCodeActionCommand $ concatMap makeCommand diags+            rsp = Core.makeResponseMessage req body+        reactorSend $ RspCodeAction rsp        -- ------------------------------- -      HandlerRequest (Core.ReqExecuteCommand req) -> do-        liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" -- ++ show req+      HandlerRequest (ReqExecuteCommand req) -> do+        liftIO $ U.logs "reactor:got ExecuteCommandRequest:" -- ++ show req         let params = req ^. J.params             margs = params ^. J.arguments          liftIO $ U.logs $ "reactor:ExecuteCommandRequest:margs=" ++ show margs          let-          reply v = reactorSend $ Core.makeResponseMessage req v+          reply v = reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req v         -- When we get a RefactorResult or HieDiff, we need to send a         -- separate WorkspaceEdit Notification           r = J.List [] :: J.List Int@@ -289,7 +290,7 @@             reply (J.Object mempty)             lid <- nextLspReqId             -- reactorSend $ J.RequestMessage "2.0" lid "workspace/applyEdit" (Just we)-            reactorSend $ fmServerApplyWorkspaceEditRequest lid we+            reactorSend $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest lid we           Nothing ->             reply (J.Object mempty) @@ -308,7 +309,7 @@ -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification sendDiagnostics :: J.Uri -> Maybe Int -> R () ()-sendDiagnostics fileUri mversion = do+sendDiagnostics fileUri version = do   let     diags = [J.Diagnostic               (J.Range (J.Position 0 1) (J.Position 0 5))@@ -319,7 +320,7 @@               (Just (J.List []))             ]   -- reactorSend $ J.NotificationMessage "2.0" "textDocument/publishDiagnostics" (Just r)-  publishDiagnostics 100 fileUri mversion (partitionBySource diags)+  publishDiagnostics 100 fileUri version (partitionBySource diags)  -- --------------------------------------------------------------------- @@ -339,22 +340,22 @@  lspHandlers :: TChan ReactorInput -> Core.Handlers lspHandlers rin-  = def { Core.initializedHandler                       = Just $ passHandler rin Core.NotInitialized-        , Core.renameHandler                            = Just $ passHandler rin Core.ReqRename-        , Core.hoverHandler                             = Just $ passHandler rin Core.ReqHover-        , Core.didOpenTextDocumentNotificationHandler   = Just $ passHandler rin Core.NotDidOpenTextDocument-        , Core.didSaveTextDocumentNotificationHandler   = Just $ passHandler rin Core.NotDidSaveTextDocument-        , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidChangeTextDocument-        , Core.didCloseTextDocumentNotificationHandler  = Just $ passHandler rin Core.NotDidCloseTextDocument-        , Core.cancelNotificationHandler                = Just $ passHandler rin Core.NotCancelRequest+  = def { Core.initializedHandler                       = Just $ passHandler rin NotInitialized+        , Core.renameHandler                            = Just $ passHandler rin ReqRename+        , Core.hoverHandler                             = Just $ passHandler rin ReqHover+        , Core.didOpenTextDocumentNotificationHandler   = Just $ passHandler rin NotDidOpenTextDocument+        , Core.didSaveTextDocumentNotificationHandler   = Just $ passHandler rin NotDidSaveTextDocument+        , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument+        , Core.didCloseTextDocumentNotificationHandler  = Just $ passHandler rin NotDidCloseTextDocument+        , Core.cancelNotificationHandler                = Just $ passHandler rin NotCancelRequestFromClient         , Core.responseHandler                          = Just $ responseHandlerCb rin-        , Core.codeActionHandler                        = Just $ passHandler rin Core.ReqCodeAction-        , Core.executeCommandHandler                    = Just $ passHandler rin Core.ReqExecuteCommand+        , Core.codeActionHandler                        = Just $ passHandler rin ReqCodeAction+        , Core.executeCommandHandler                    = Just $ passHandler rin ReqExecuteCommand         }  -- --------------------------------------------------------------------- -passHandler :: TChan ReactorInput -> (a -> Core.OutMessage) -> Core.Handler a+passHandler :: TChan ReactorInput -> (a -> FromClientMessage) -> Core.Handler a passHandler rin c notification = do   atomically $ writeTChan rin (HandlerRequest (c notification)) 

@@ -1,5 +1,5 @@ name:                haskell-lsp-version:             0.2.2.0+version:             0.4.0.0 synopsis:            Haskell library for the Microsoft Language Server Protocol  description:         An implementation of the types, and basic message server to@@ -14,19 +14,21 @@ license-file:        LICENSE author:              Alan Zimmerman maintainer:          alan.zimm@gmail.com-copyright:           Alan Zimmerman, 2016-2017+copyright:           Alan Zimmerman, 2016-2018 category:            Development build-type:          Simple extra-source-files:  ChangeLog.md, README.md cabal-version:       >=1.10  library-  exposed-modules:     Language.Haskell.LSP.Constant+  exposed-modules:     Language.Haskell.LSP.Capture+                     , Language.Haskell.LSP.Constant                      , Language.Haskell.LSP.Core                      , Language.Haskell.LSP.Control                      , Language.Haskell.LSP.Diagnostics                      , Language.Haskell.LSP.Messages                      , Language.Haskell.LSP.Types+                     , Language.Haskell.LSP.Types.Capabilities                      , Language.Haskell.LSP.Utility                      , Language.Haskell.LSP.VFS   -- other-modules:@@ -42,7 +44,7 @@                      , filepath                      , hslogger                      , hashable-                     , haskell-lsp-types+                     , haskell-lsp-types >= 0.4                      , lens >= 4.15.2                      , mtl                      , network-uri

@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Language.Haskell.LSP.Capture where++import Data.Aeson+import Data.ByteString.Lazy.Char8 as BSL+import Data.Time.Clock+import GHC.Generics+import Language.Haskell.LSP.Messages++data Event = FromClient UTCTime FromClientMessage+           | FromServer UTCTime FromServerMessage+  deriving (Show, Eq, Generic, ToJSON, FromJSON)++captureFromServer :: FromServerMessage -> Maybe FilePath -> IO ()+captureFromServer _ Nothing = return ()+captureFromServer msg (Just fp) = do+  time <- getCurrentTime+  let entry = FromServer time msg+  +  BSL.appendFile fp $ BSL.append (encode entry) "\n"++captureFromClient :: FromClientMessage -> Maybe FilePath -> IO ()+captureFromClient _ Nothing = return ()+captureFromClient msg (Just fp) = do+  time <- getCurrentTime+  let entry = FromClient time msg+  +  BSL.appendFile fp $ BSL.append (encode entry) "\n"

@@ -1,6 +1,5 @@ {-# LANGUAGE CPP                 #-} {-# LANGUAGE GADTs               #-}-{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE BinaryLiterals      #-} {-# LANGUAGE OverloadedStrings   #-}@@ -9,6 +8,7 @@ module Language.Haskell.LSP.Control   (     run+  , runWithHandles   ) where  import           Control.Concurrent@@ -19,56 +19,87 @@ import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B+import           Data.Time.Clock+import           Data.Time.Format #if __GLASGOW_HASKELL__ < 804 import           Data.Monoid #endif+import           Language.Haskell.LSP.Capture import qualified Language.Haskell.LSP.Core as Core+import           Language.Haskell.LSP.Messages import           Language.Haskell.LSP.Utility import           System.IO+import           System.FilePath import           Text.Parsec  -- --------------------------------------------------------------------- +-- | Convenience function for 'runWithHandles stdin stdout'. run :: (Show c) => Core.InitializeCallback c-                                 -- ^ function to be called once initialize has-                                 -- been received from the client. Further message-                                 -- processing will start only after this returns.+                -- ^ function to be called once initialize has+                -- been received from the client. Further message+                -- processing will start only after this returns.     -> Core.Handlers     -> Core.Options+    -> Maybe FilePath+    -- ^ File to capture the session to.+    -> IO Int+run = runWithHandles stdin stdout++-- | Starts listening and sending requests and responses+-- at the specified handles.+runWithHandles :: (Show c) =>+       Handle+    -- ^ Handle to read client input from.+    -> Handle+    -- ^ Handle to write output to.+    -> Core.InitializeCallback c+    -> Core.Handlers+    -> Core.Options+    -> Maybe FilePath     -> IO Int         -- exit code-run dp h o = do+runWithHandles hin hout dp h o captureFp = do    logm $ B.pack "\n\n\n\n\nhaskell-lsp:Starting up server ..."-  hSetBuffering stdin NoBuffering-  hSetEncoding  stdin utf8+  hSetBuffering hin NoBuffering+  hSetEncoding  hin utf8 -  hSetBuffering stdout NoBuffering-  hSetEncoding  stdout utf8+  hSetBuffering hout NoBuffering+  hSetEncoding  hout utf8 -  cout <- atomically newTChan :: IO (TChan BSL.ByteString)-  _rhpid <- forkIO $ sendServer cout+  timestamp <- formatTime defaultTimeLocale (iso8601DateFormat (Just "%H-%M-%S")) <$> getCurrentTime+  let timestampCaptureFp = fmap (\f -> dropExtension f ++ timestamp ++ takeExtension f)+                                captureFp +  cout <- atomically newTChan :: IO (TChan FromServerMessage)+  _rhpid <- forkIO $ sendServer cout hout timestampCaptureFp +   let sendFunc :: Core.SendFunc-      sendFunc str = atomically $ writeTChan cout (J.encode str)+      sendFunc msg = atomically $ writeTChan cout msg   let lf = error "LifeCycle error, ClientCapabilities not set yet via initialize maessage"    tvarId <- atomically $ newTVar 0 -  tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc+  tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc timestampCaptureFp -  ioLoop dp tvarDat+  ioLoop hin dp tvarDat    return 1 + -- --------------------------------------------------------------------- -ioLoop :: (Show c) => Core.InitializeCallback c -> TVar (Core.LanguageContextData c) -> IO ()-ioLoop dispatcherProc tvarDat = go BSL.empty+ioLoop :: (Show c) => Handle+                   -> Core.InitializeCallback c+                   -> TVar (Core.LanguageContextData c)+                   -> IO ()+ioLoop hin dispatcherProc tvarDat = go BSL.empty   where     go :: BSL.ByteString -> IO ()     go buf = do-      c <- BSL.hGet stdin 1+      c <- BSL.hGet hin 1+       if c == BSL.empty         then do           logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n"@@ -79,15 +110,16 @@           case readContentLength (lbs2str newBuf) of             Left _ -> go newBuf             Right len -> do-              cnt <- BSL.hGet stdin len+              cnt <- BSL.hGet hin len+               if cnt == BSL.empty                 then do                   logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n"                   return ()                 else do-                  logm $ (B.pack "---> ") <> cnt-                  Core.handleRequest dispatcherProc tvarDat newBuf cnt-                  ioLoop dispatcherProc tvarDat+                  logm $ B.pack "---> " <> cnt+                  Core.handleMessage dispatcherProc tvarDat newBuf cnt+                  ioLoop hin dispatcherProc tvarDat       where         readContentLength :: String -> Either ParseError Int         readContentLength = parse parser "readContentLength"@@ -99,19 +131,27 @@  -- --------------------------------------------------------------------- --- | Simple server to make sure all stdout is serialised-sendServer :: TChan BSL.ByteString -> IO ()-sendServer cstdout = do+-- | Simple server to make sure all output is serialised+sendServer :: TChan FromServerMessage -> Handle -> Maybe FilePath -> IO ()+sendServer msgChan clientH captureFp =   forever $ do-    str <- atomically $ readTChan cstdout+    msg <- atomically $ readTChan msgChan++    -- We need to make sure we only send over the content of the message,+    -- and no other tags/wrapper stuff+    let str = J.encode $+                J.genericToJSON (J.defaultOptions { J.sumEncoding = J.UntaggedValue }) msg+     let out = BSL.concat                  [ str2lbs $ "Content-Length: " ++ show (BSL.length str)                  , str2lbs _TWO_CRLF                  , str ] -    BSL.hPut stdout out-    hFlush stdout+    BSL.hPut clientH out+    hFlush clientH     logm $ B.pack "<--2--" <> str++    captureFromServer msg captureFp  -- | --

@@ -1,5 +1,4 @@ {-# LANGUAGE GADTs               #-}-{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE BinaryLiterals      #-} {-# LANGUAGE OverloadedStrings   #-}@@ -7,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-}  module Language.Haskell.LSP.Core (-    handleRequest+    handleMessage   , LanguageContextData(..)   , Handler   , InitializeCallback@@ -15,9 +14,7 @@   , SendFunc   , Handlers(..)   , Options(..)-  , OutMessage(..)   , defaultLanguageContextData-  , initializeRequestHandler   , makeResponseMessage   , makeResponseError   , setupLogger@@ -41,6 +38,7 @@ import           Data.Monoid import qualified Data.Text as T import           Data.Text ( Text )+import           Language.Haskell.LSP.Capture import           Language.Haskell.LSP.Constant import           Language.Haskell.LSP.Messages import qualified Language.Haskell.LSP.TH.ClientCapabilities as C@@ -64,13 +62,12 @@ -- ---------------------------------------------------------------------  -- | A function to send a message to the client-type SendFunc = forall a. (J.ToJSON a => a -> IO ())+type SendFunc = FromServerMessage -> IO ()  -- | state used by the LSP dispatcher to manage the message loop data LanguageContextData a =   LanguageContextData {     resSeqDebugContextData :: !Int-  , resRootPath            :: !(Maybe FilePath)   , resHandlers            :: !Handlers   , resOptions             :: !Options   , resSendResponse        :: !SendFunc@@ -79,6 +76,7 @@   , resConfig              :: !(Maybe a)   , resLspId               :: !(TVar Int)   , resLspFuncs            :: LspFuncs a -- NOTE: Cannot be strict, lazy initialization+  , resCaptureFile         :: !(Maybe FilePath)   }  -- ---------------------------------------------------------------------@@ -105,7 +103,7 @@ -- 'textDocument/publishDiagnostics' notification with the total (limited by the -- first parameter) whenever it is updated. type PublishDiagnosticsFunc = Int -- Max number of diagnostics to send-                            -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> IO ()+                            -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> IO ()  -- | A function to remove all diagnostics from a particular source, and send the updates to the client. type FlushDiagnosticsBySourceFunc = Int -- Max number of diagnostics to send@@ -123,6 +121,7 @@     , publishDiagnosticsFunc       :: !PublishDiagnosticsFunc     , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc     , getNextReqId                 :: !(IO J.LspId)+    , rootPath                     :: !(Maybe FilePath)     }  -- | The function in the LSP process that is called once the 'initialize'@@ -164,7 +163,7 @@     -- Next 2 go from server -> client     -- , registerCapabilityHandler      :: !(Maybe (Handler J.RegisterCapabilityRequest))     -- , unregisterCapabilityHandler    :: !(Maybe (Handler J.UnregisterCapabilityRequest))-    , willSaveWaitUntilTextDocHandler:: !(Maybe (Handler J.WillSaveWaitUntilTextDocumentResponse))+    , willSaveWaitUntilTextDocHandler:: !(Maybe (Handler J.WillSaveWaitUntilTextDocumentRequest))      -- Notifications from the client     , didChangeConfigurationParamsHandler      :: !(Maybe (Handler J.DidChangeConfigurationNotification))@@ -179,22 +178,30 @@     , cancelNotificationHandler                :: !(Maybe (Handler J.CancelNotification))      -- Responses to Request messages originated from the server-    , responseHandler                          :: !(Maybe (Handler J.BareResponseMessage))+    -- TODO: Properly decode response types and replace them with actual handlers+    , responseHandler                    :: !(Maybe (Handler J.BareResponseMessage))+    -- , registerCapabilityHandler                :: !(Maybe (Handler J.RegisterCapabilityResponse))+    -- , unregisterCapabilityHandler              :: !(Maybe (Handler J.RegisterCapabilityResponse))+    -- , showMessageHandler                       :: !(Maybe (Handler J.ShowMessageResponse))++    -- Initialization request on startup+    , initializeRequestHandler                 :: !(Maybe (Handler J.InitializeRequest))+    -- Will default to terminating `exitMessage` if Nothing+    , exitNotificationHandler                  :: !(Maybe (Handler J.ExitNotification))     }  instance Default Handlers where   def = Handlers Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing                  Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing                  Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing-                 Nothing Nothing Nothing+                 Nothing Nothing Nothing Nothing Nothing  -- --------------------------------------------------------------------- nop :: a -> b -> IO a nop = const . return -helper :: J.FromJSON a-       => (TVar (LanguageContextData c) -> a       -> IO ())-       -> (TVar (LanguageContextData c) -> J.Value -> IO ())++helper :: J.FromJSON a => (TVar (LanguageContextData c) -> a -> IO ()) -> (TVar (LanguageContextData c) -> J.Value -> IO ()) helper requestHandler tvarDat json =   case J.fromJSON json of     J.Success req -> requestHandler tvarDat req@@ -212,47 +219,60 @@ handlerMap :: (Show c) => InitializeCallback c            -> Handlers -> J.ClientMethod -> (TVar (LanguageContextData c) -> J.Value -> IO ()) -- General-handlerMap i _ J.Initialize                      = helper (initializeRequestHandler i)-handlerMap _ h J.Initialized                     = hh nop $ initializedHandler h+handlerMap i h J.Initialize                      = helper (initializeRequestHandler' i (initializeRequestHandler h))+handlerMap _ h J.Initialized                     = hh nop NotInitialized $ initializedHandler h handlerMap _ _ J.Shutdown                        = helper shutdownRequestHandler-handlerMap _ _ J.Exit                            = \_ _ -> do-  logm $ B.pack "haskell-lsp:Got exit, exiting"-  exitSuccess-handlerMap _ h J.CancelRequest                   = hh nop $ cancelNotificationHandler h+handlerMap _ h J.Exit                            =+  case exitNotificationHandler h of+    Just _ -> hh nop NotExit $ exitNotificationHandler h+    Nothing -> \ctxVar v -> do+      ctx <- readTVarIO ctxVar+      -- Capture exit notification+      case J.fromJSON v :: J.Result J.ExitNotification of+        J.Success n -> captureFromClient (NotExit n) (resCaptureFile ctx)+        J.Error _ -> return ()+      logm $ B.pack "haskell-lsp:Got exit, exiting"+      exitSuccess+handlerMap _ h J.CancelRequest                   = hh nop NotCancelRequestFromClient $ cancelNotificationHandler h -- Workspace-handlerMap i h J.WorkspaceDidChangeConfiguration = hc i   $ didChangeConfigurationParamsHandler h-handlerMap _ h J.WorkspaceDidChangeWatchedFiles  = hh nop $ didChangeWatchedFilesNotificationHandler h-handlerMap _ h J.WorkspaceSymbol                 = hh nop $ workspaceSymbolHandler h-handlerMap _ h J.WorkspaceExecuteCommand         = hh nop $ executeCommandHandler h+handlerMap i h J.WorkspaceDidChangeConfiguration = hc i $ didChangeConfigurationParamsHandler h+handlerMap _ h J.WorkspaceDidChangeWatchedFiles  = hh nop NotDidChangeWatchedFiles $ didChangeWatchedFilesNotificationHandler h+handlerMap _ h J.WorkspaceSymbol                 = hh nop ReqWorkspaceSymbols $ workspaceSymbolHandler h+handlerMap _ h J.WorkspaceExecuteCommand         = hh nop ReqExecuteCommand $ executeCommandHandler h -- Document-handlerMap _ h J.TextDocumentDidOpen             = hh openVFS $ didOpenTextDocumentNotificationHandler h-handlerMap _ h J.TextDocumentDidChange           = hh changeVFS $ didChangeTextDocumentNotificationHandler h-handlerMap _ h J.TextDocumentWillSave            = hh nop $ willSaveTextDocumentNotificationHandler h-handlerMap _ h J.TextDocumentWillSaveWaitUntil   = hh nop $ willSaveWaitUntilTextDocHandler h-handlerMap _ h J.TextDocumentDidSave             = hh nop $ didSaveTextDocumentNotificationHandler h-handlerMap _ h J.TextDocumentDidClose            = hh closeVFS $ didCloseTextDocumentNotificationHandler h-handlerMap _ h J.TextDocumentCompletion          = hh nop $ completionHandler h-handlerMap _ h J.CompletionItemResolve           = hh nop $ completionResolveHandler h-handlerMap _ h J.TextDocumentHover               = hh nop $ hoverHandler h-handlerMap _ h J.TextDocumentSignatureHelp       = hh nop $ signatureHelpHandler h-handlerMap _ h J.TextDocumentReferences          = hh nop $ referencesHandler h-handlerMap _ h J.TextDocumentDocumentHighlight   = hh nop $ documentHighlightHandler h-handlerMap _ h J.TextDocumentDocumentSymbol      = hh nop $ documentSymbolHandler h-handlerMap _ h J.TextDocumentFormatting          = hh nop $ documentFormattingHandler h-handlerMap _ h J.TextDocumentRangeFormatting     = hh nop $ documentRangeFormattingHandler h-handlerMap _ h J.TextDocumentOnTypeFormatting    = hh nop $ documentTypeFormattingHandler h-handlerMap _ h J.TextDocumentDefinition          = hh nop $ definitionHandler h-handlerMap _ h J.TextDocumentCodeAction          = hh nop $ codeActionHandler h-handlerMap _ h J.TextDocumentCodeLens            = hh nop $ codeLensHandler h-handlerMap _ h J.CodeLensResolve                 = hh nop $ codeLensResolveHandler h-handlerMap _ h J.TextDocumentDocumentLink        = hh nop $ documentLinkHandler h-handlerMap _ h J.DocumentLinkResolve             = hh nop $ documentLinkResolveHandler h-handlerMap _ h J.TextDocumentRename              = hh nop $ renameHandler h+handlerMap _ h J.TextDocumentDidOpen             = hh openVFS NotDidOpenTextDocument $ didOpenTextDocumentNotificationHandler h+handlerMap _ h J.TextDocumentDidChange           = hh changeFromClientVFS NotDidChangeTextDocument $ didChangeTextDocumentNotificationHandler h+handlerMap _ h J.TextDocumentWillSave            = hh nop NotWillSaveTextDocument $ willSaveTextDocumentNotificationHandler h+handlerMap _ h J.TextDocumentWillSaveWaitUntil   = hh nop ReqWillSaveWaitUntil $ willSaveWaitUntilTextDocHandler h+handlerMap _ h J.TextDocumentDidSave             = hh nop NotDidSaveTextDocument $ didSaveTextDocumentNotificationHandler h+handlerMap _ h J.TextDocumentDidClose            = hh closeVFS NotDidCloseTextDocument $ didCloseTextDocumentNotificationHandler h+handlerMap _ h J.TextDocumentCompletion          = hh nop ReqCompletion $ completionHandler h+handlerMap _ h J.CompletionItemResolve           = hh nop ReqCompletionItemResolve $ completionResolveHandler h+handlerMap _ h J.TextDocumentHover               = hh nop ReqHover $ hoverHandler h+handlerMap _ h J.TextDocumentSignatureHelp       = hh nop ReqSignatureHelp $ signatureHelpHandler h+handlerMap _ h J.TextDocumentReferences          = hh nop ReqFindReferences $ referencesHandler h+handlerMap _ h J.TextDocumentDocumentHighlight   = hh nop ReqDocumentHighlights $ documentHighlightHandler h+handlerMap _ h J.TextDocumentDocumentSymbol      = hh nop ReqDocumentSymbols $ documentSymbolHandler h+handlerMap _ h J.TextDocumentFormatting          = hh nop ReqDocumentFormatting $ documentFormattingHandler h+handlerMap _ h J.TextDocumentRangeFormatting     = hh nop ReqDocumentRangeFormatting $ documentRangeFormattingHandler h+handlerMap _ h J.TextDocumentOnTypeFormatting    = hh nop ReqDocumentOnTypeFormatting $ documentTypeFormattingHandler h+handlerMap _ h J.TextDocumentDefinition          = hh nop ReqDefinition $ definitionHandler h+handlerMap _ h J.TextDocumentCodeAction          = hh nop ReqCodeAction $ codeActionHandler h+handlerMap _ h J.TextDocumentCodeLens            = hh nop ReqCodeLens $ codeLensHandler h+handlerMap _ h J.CodeLensResolve                 = hh nop ReqCodeLensResolve $ codeLensResolveHandler h+handlerMap _ h J.TextDocumentDocumentLink        = hh nop ReqDocumentLink $ documentLinkHandler h+handlerMap _ h J.DocumentLinkResolve             = hh nop ReqDocumentLinkResolve $ documentLinkResolveHandler h+handlerMap _ h J.TextDocumentRename              = hh nop ReqRename $ renameHandler h handlerMap _ _ (J.Misc x)   = helper f-  where f ::  TVar (LanguageContextData c) -> J.TraceNotification -> IO ()-        f tvarDat _ = do+  where f ::  TVar (LanguageContextData c) -> J.Value -> IO ()+        f tvarDat n = do           let msg = "haskell-lsp:Got " ++ T.unpack x ++ " ignoring"           logm (B.pack msg)++          ctx <- readTVarIO tvarDat++          captureFromClient (UnknownFromClientMessage n) (resCaptureFile ctx)+           sendErrorLog tvarDat (T.pack msg)  -- ---------------------------------------------------------------------@@ -260,13 +280,16 @@ -- | Adapter from the normal handlers exposed to the library users and the -- internal message loop hh :: forall b c. (J.FromJSON b)-   => (VFS -> b -> IO VFS) -> Maybe (Handler b) -> TVar (LanguageContextData c) -> J.Value -> IO ()-hh getVfs mh tvarDat json = do+   => (VFS -> b -> IO VFS) -> (b -> FromClientMessage) -> Maybe (Handler b) -> TVar (LanguageContextData c) -> J.Value -> IO ()+hh getVfs wrapper mh tvarDat json = do       case J.fromJSON json of         J.Success req -> do           ctx <- readTVarIO tvarDat           vfs' <- getVfs (resVFS ctx) req           atomically $ modifyTVar' tvarDat (\c -> c {resVFS = vfs'})++          captureFromClient (wrapper req) (resCaptureFile ctx)+           case mh of             Just h -> h req             Nothing -> do@@ -283,14 +306,17 @@       case J.fromJSON json of         J.Success req -> do           ctx <- readTVarIO tvarDat++          captureFromClient (NotDidChangeConfiguration req) (resCaptureFile ctx)+           case c req of             Left err -> do-              let msg = T.pack $ unwords $ ["haskell-lsp:didChangeConfiguration error.", show req, show err]+              let msg = T.pack $ unwords ["haskell-lsp:didChangeConfiguration error.", show req, show err]               sendErrorLog tvarDat msg             Right newConfig -> do               -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification got newConfig:" ++ show newConfig               let ctx' = ctx { resConfig = Just newConfig }-              atomically $ modifyTVar' tvarDat (\_ -> ctx')+              atomically $ modifyTVar' tvarDat (const ctx')           case mh of             Just h -> h req             Nothing -> return ()@@ -302,72 +328,12 @@ -- ---------------------------------------------------------------------  getVirtualFile :: TVar (LanguageContextData c) -> J.Uri -> IO (Maybe VirtualFile)-getVirtualFile tvarDat uri = do-  ctx <- readTVarIO tvarDat-  return $ Map.lookup uri (resVFS ctx)+getVirtualFile tvarDat uri = Map.lookup uri . resVFS <$> readTVarIO tvarDat  -- ---------------------------------------------------------------------  getConfig :: TVar (LanguageContextData c) -> IO (Maybe c)-getConfig tvar = do-  ctx <- readTVarIO tvar-  return (resConfig ctx)----- ------------------------------------------------------------------------- | Wrap all the protocol messages into a single type, for use in the language--- handler in storing the original message-data OutMessage = ReqHover                    J.HoverRequest-                | ReqCompletion               J.CompletionRequest-                | ReqCompletionItemResolve    J.CompletionItemResolveRequest-                | ReqSignatureHelp            J.SignatureHelpRequest-                | ReqDefinition               J.DefinitionRequest-                | ReqFindReferences           J.ReferencesRequest-                | ReqDocumentHighlights       J.DocumentHighlightRequest-                | ReqDocumentSymbols          J.DocumentSymbolRequest-                | ReqWorkspaceSymbols         J.WorkspaceSymbolRequest-                | ReqCodeAction               J.CodeActionRequest-                | ReqCodeLens                 J.CodeLensRequest-                | ReqCodeLensResolve          J.CodeLensResolveRequest-                | ReqDocumentFormatting       J.DocumentFormattingRequest-                | ReqDocumentRangeFormatting  J.DocumentRangeFormattingRequest-                | ReqDocumentOnTypeFormatting J.DocumentOnTypeFormattingRequest-                | ReqRename                   J.RenameRequest-                | ReqExecuteCommand           J.ExecuteCommandRequest-                -- responses-                | RspHover                    J.HoverResponse-                | RspCompletion               J.CompletionResponse-                | RspCompletionItemResolve    J.CompletionItemResolveResponse-                | RspSignatureHelp            J.SignatureHelpResponse-                | RspDefinition               J.DefinitionResponse-                | RspFindReferences           J.ReferencesResponse-                | RspDocumentHighlights       J.DocumentHighlightsResponse-                | RspDocumentSymbols          J.DocumentSymbolsResponse-                | RspWorkspaceSymbols         J.WorkspaceSymbolsResponse-                | RspCodeAction               J.CodeActionResponse-                | RspCodeLens                 J.CodeLensResponse-                | RspCodeLensResolve          J.CodeLensResolveResponse-                | RspDocumentFormatting       J.DocumentFormattingResponse-                | RspDocumentRangeFormatting  J.DocumentRangeFormattingResponse-                | RspDocumentOnTypeFormatting J.DocumentOnTypeFormattingResponse-                | RspRename                   J.RenameResponse-                | RspExecuteCommand           J.ExecuteCommandResponse--                -- notifications-                | NotInitialized                  J.InitializedNotification-                | NotDidChangeConfigurationParams J.DidChangeConfigurationNotification-                | NotDidOpenTextDocument          J.DidOpenTextDocumentNotification-                | NotDidChangeTextDocument        J.DidChangeTextDocumentNotification-                | NotDidCloseTextDocument         J.DidCloseTextDocumentNotification-                | NotWillSaveTextDocument         J.WillSaveTextDocumentNotification-                | NotDidSaveTextDocument          J.DidSaveTextDocumentNotification-                | NotDidChangeWatchedFiles        J.DidChangeWatchedFilesNotification--                | NotCancelRequest                J.CancelNotification--                | RspFromClient                   J.BareResponseMessage-                deriving (Eq,Read,Show)+getConfig tvar = resConfig <$> readTVarIO tvar  -- --------------------------------------------------------------------- -- |@@ -401,15 +367,15 @@ -- | -- ---defaultLanguageContextData :: Handlers -> Options -> LspFuncs c -> TVar Int -> SendFunc -> LanguageContextData c-defaultLanguageContextData h o lf tv sf =-  LanguageContextData _INITIAL_RESPONSE_SEQUENCE Nothing h o sf mempty mempty Nothing tv lf+defaultLanguageContextData :: Handlers -> Options -> LspFuncs c -> TVar Int -> SendFunc -> Maybe FilePath -> LanguageContextData c+defaultLanguageContextData h o lf tv sf cf =+  LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf mempty mempty Nothing tv lf cf  -- --------------------------------------------------------------------- -handleRequest :: (Show c) => InitializeCallback c+handleMessage :: (Show c) => InitializeCallback c               -> TVar (LanguageContextData c) -> BSL.ByteString -> BSL.ByteString -> IO ()-handleRequest dispatcherProc tvarDat contLenStr jsonStr = do+handleMessage dispatcherProc tvarDat contLenStr jsonStr = do   {-   Message Types we must handle are the following @@ -427,6 +393,7 @@       sendErrorLog tvarDat msg      Right o -> do+       case HM.lookup "method" o of         Just cmd@(J.String s) -> case J.fromJSON cmd of                                    J.Success m -> handle (J.Object o) m@@ -465,15 +432,15 @@ -- --------------------------------------------------------------------- -- | ---sendEvent :: J.ToJSON a => TVar (LanguageContextData c) -> a -> IO ()-sendEvent tvarCtx str = sendResponse tvarCtx str+sendEvent :: TVar (LanguageContextData c) -> FromServerMessage -> IO ()+sendEvent tvarCtx msg = sendResponse tvarCtx msg  -- | ---sendResponse :: J.ToJSON a => TVar (LanguageContextData c) -> a -> IO ()-sendResponse tvarCtx str = do+sendResponse :: TVar (LanguageContextData c) -> FromServerMessage -> IO ()+sendResponse tvarCtx msg = do   ctx <- readTVarIO tvarCtx-  resSendResponse ctx str+  resSendResponse ctx msg   -- ---------------------------------------------------------------------@@ -485,22 +452,22 @@  sendErrorResponseS ::  SendFunc -> J.LspIdRsp -> J.ErrorCode -> Text -> IO () sendErrorResponseS sf origId err msg = do-  sf $ (J.ResponseMessage "2.0" origId Nothing-                (Just $ J.ResponseError err msg Nothing) :: J.ErrorResponse)+  sf $ RspError (J.ResponseMessage "2.0" origId Nothing+                  (Just $ J.ResponseError err msg Nothing) :: J.ErrorResponse)  sendErrorLog :: TVar (LanguageContextData c) -> Text -> IO () sendErrorLog tv msg = sendErrorLogS (sendEvent tv) msg  sendErrorLogS :: SendFunc -> Text -> IO () sendErrorLogS sf msg =-  sf $ fmServerLogMessageNotification J.MtError msg+  sf $ NotLogMessage $ fmServerLogMessageNotification J.MtError msg  -- sendErrorShow :: String -> IO () -- sendErrorShow msg = sendErrorShowS sendEvent msg  sendErrorShowS :: SendFunc -> Text -> IO () sendErrorShowS sf msg =-  sf $ fmServerShowMessageNotification J.MtError msg+  sf $ NotShowMessage $ fmServerShowMessageNotification J.MtError msg  -- --------------------------------------------------------------------- @@ -519,18 +486,26 @@  -- | ---initializeRequestHandler :: (Show c) => InitializeCallback c+initializeRequestHandler' :: (Show c) => InitializeCallback c+                         -> Maybe (Handler J.InitializeRequest)                          -> TVar (LanguageContextData c)-                         -> J.InitializeRequest -> IO ()-initializeRequestHandler (_configHandler,dispatcherProc) tvarCtx req@(J.RequestMessage _ origId _ params) =+                         -> J.InitializeRequest+                         -> IO ()+initializeRequestHandler' (_configHandler,dispatcherProc) mHandler tvarCtx req@(J.RequestMessage _ origId _ params) =   flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do +    case mHandler of+      Just handler -> handler req+      Nothing -> return ()+     ctx0 <- readTVarIO tvarCtx +    -- capture initialize request+    captureFromClient (ReqInitialize req) (resCaptureFile ctx0)+     let rootDir = getFirst $ foldMap First [ params ^. J.rootUri  >>= J.uriToFilePath                                            , params ^. J.rootPath <&> T.unpack ] -    atomically $ modifyTVar' tvarCtx (\c -> c { resRootPath = rootDir })     case rootDir of       Nothing -> return ()       Just dir -> do@@ -553,6 +528,7 @@                             (publishDiagnostics tvarCtx)                             (flushDiagnosticsBySource tvarCtx)                             (getLspId $ resLspId ctx0)+                            rootDir     let ctx = ctx0 { resLspFuncs = lspFuncs }     atomically $ writeTVar tvarCtx ctx @@ -560,7 +536,7 @@      case initializationResult of       Just errResp -> do-        sendResponse tvarCtx $ makeResponseError (J.responseId origId) errResp+        sendResponse tvarCtx $ RspError $ makeResponseError (J.responseId origId) errResp        Nothing -> do @@ -571,9 +547,13 @@           supported (Just _) = Just True           supported Nothing   = Nothing +          sync = case textDocumentSync o of+                  Just x -> Just (J.TDSOptions x)+                  Nothing -> Nothing+           capa =             J.InitializeResponseCapabilitiesInner-              { J._textDocumentSync                 = textDocumentSync o+              { J._textDocumentSync                 = sync               , J._hoverProvider                    = supported (hoverHandler h)               , J._completionProvider               = completionProvider o               , J._signatureHelpProvider            = signatureHelpProvider o@@ -592,13 +572,13 @@               , J._documentLinkProvider             = documentLinkProvider o               , J._executeCommandProvider           = executeCommandProvider o               -- TODO: Add something for experimental-              , J._experimental                     = (Nothing :: Maybe J.Value)+              , J._experimental                     = Nothing :: Maybe J.Value               }            -- TODO: wrap this up into a fn to create a response message           res  = J.ResponseMessage "2.0" (J.responseId origId) (Just $ J.InitializeResponseCapabilities capa) Nothing -        sendResponse tvarCtx res+        sendResponse tvarCtx $ RspInitialize res  -- | --@@ -607,23 +587,23 @@   flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do   let res  = makeResponseMessage req "ok" -  sendResponse tvarCtx res+  sendResponse tvarCtx $ RspShutdown res  -- ---------------------------------------------------------------------  -- | Take the new diagnostics, update the stored diagnostics for the given file -- and version, and publish the total to the client. publishDiagnostics :: TVar (LanguageContextData c) -> PublishDiagnosticsFunc-publishDiagnostics tvarDat maxDiagnosticCount uri mversion diags = do+publishDiagnostics tvarDat maxDiagnosticCount uri version diags = do   ctx <- readTVarIO tvarDat-  let ds = updateDiagnostics (resDiagnostics ctx) uri mversion diags+  let ds = updateDiagnostics (resDiagnostics ctx) uri version diags   atomically $ writeTVar tvarDat $ ctx{resDiagnostics = ds}   let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri   case mdp of     Nothing -> return ()     Just params -> do-      resSendResponse ctx-        $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics (Just params)+      resSendResponse ctx $ NotPublishDiagnostics+        $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params  -- --------------------------------------------------------------------- @@ -642,8 +622,8 @@     case mdp of       Nothing -> return ()       Just params -> do-        resSendResponse ctx-          $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics (Just params)+        resSendResponse ctx $ NotPublishDiagnostics+          $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params  -- |===================================================================== --

@@ -42,7 +42,7 @@ type DiagnosticStore = Map.Map J.Uri StoreItem  data StoreItem-  = StoreItem (Maybe J.TextDocumentVersion) DiagnosticsBySource+  = StoreItem J.TextDocumentVersion DiagnosticsBySource   deriving (Show,Eq)  type DiagnosticsBySource = Map.Map (Maybe J.DiagnosticSource) (SL.SortedList J.Diagnostic)@@ -63,7 +63,7 @@ -- ---------------------------------------------------------------------  updateDiagnostics :: DiagnosticStore-                  -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource+                  -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource                   -> DiagnosticStore updateDiagnostics store uri mv newDiagsBySource = r   where

@@ -1,6 +1,98 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+ module Language.Haskell.LSP.Messages-  (-    module Language.Haskell.LSP.TH.Messages-  ) where+  ( module Language.Haskell.LSP.TH.MessageFuncs+  , FromClientMessage(..)+  , FromServerMessage(..)+  )+where -import Language.Haskell.LSP.TH.Messages+import           Language.Haskell.LSP.TH.MessageFuncs+import           Language.Haskell.LSP.TH.DataTypesJSON+import           GHC.Generics+import           Data.Aeson++-- | A wrapper around a message that originates from the client+-- and is sent to the server.+data FromClientMessage = ReqInitialize               InitializeRequest+                       | ReqShutdown                 ShutdownRequest+                       | ReqHover                    HoverRequest+                       | ReqCompletion               CompletionRequest+                       | ReqCompletionItemResolve    CompletionItemResolveRequest+                       | ReqSignatureHelp            SignatureHelpRequest+                       | ReqDefinition               DefinitionRequest+                       | ReqFindReferences           ReferencesRequest+                       | ReqDocumentHighlights       DocumentHighlightRequest+                       | ReqDocumentSymbols          DocumentSymbolRequest+                       | ReqWorkspaceSymbols         WorkspaceSymbolRequest+                       | ReqCodeAction               CodeActionRequest+                       | ReqCodeLens                 CodeLensRequest+                       | ReqCodeLensResolve          CodeLensResolveRequest+                       | ReqDocumentFormatting       DocumentFormattingRequest+                       | ReqDocumentRangeFormatting  DocumentRangeFormattingRequest+                       | ReqDocumentOnTypeFormatting DocumentOnTypeFormattingRequest+                       | ReqRename                   RenameRequest+                       | ReqExecuteCommand           ExecuteCommandRequest+                       | ReqDocumentLink             DocumentLinkRequest+                       | ReqDocumentLinkResolve      DocumentLinkResolveRequest+                       | ReqWillSaveWaitUntil        WillSaveWaitUntilTextDocumentRequest+                       -- Responses+                       | RspApplyWorkspaceEdit       ApplyWorkspaceEditResponse+                       -- TODO: Remove this and properly decode the type of responses+                       -- based on the id+                       | RspFromClient               BareResponseMessage+                       -- Notifications+                       | NotInitialized                  InitializedNotification+                       | NotExit                         ExitNotification+                       -- A cancel request notification is duplex!+                       | NotCancelRequestFromClient      CancelNotification+                       | NotDidChangeConfiguration       DidChangeConfigurationNotification+                       | NotDidOpenTextDocument          DidOpenTextDocumentNotification+                       | NotDidChangeTextDocument        DidChangeTextDocumentNotification+                       | NotDidCloseTextDocument         DidCloseTextDocumentNotification+                       | NotWillSaveTextDocument         WillSaveTextDocumentNotification+                       | NotDidSaveTextDocument          DidSaveTextDocumentNotification+                       | NotDidChangeWatchedFiles        DidChangeWatchedFilesNotification+                       -- Unknown (The client sends something we don't understand)+                       | UnknownFromClientMessage        Value+  deriving (Eq,Read,Show,Generic,ToJSON,FromJSON)++-- | A wrapper around a message that originates from the server+-- and is sent to the client.+data FromServerMessage = ReqRegisterCapability       RegisterCapabilityRequest+                       | ReqUnregisterCapability     UnregisterCapabilityRequest+                       | ReqApplyWorkspaceEdit       ApplyWorkspaceEditRequest+                       | ReqShowMessage              ShowMessageRequest+                       -- Responses+                       | RspInitialize               InitializeResponse+                       | RspShutdown                 ShutdownResponse+                       | RspHover                    HoverResponse+                       | RspCompletion               CompletionResponse+                       | RspCompletionItemResolve    CompletionItemResolveResponse+                       | RspSignatureHelp            SignatureHelpResponse+                       | RspDefinition               DefinitionResponse+                       | RspFindReferences           ReferencesResponse+                       | RspDocumentHighlights       DocumentHighlightsResponse+                       | RspDocumentSymbols          DocumentSymbolsResponse+                       | RspWorkspaceSymbols         WorkspaceSymbolsResponse+                       | RspCodeAction               CodeActionResponse+                       | RspCodeLens                 CodeLensResponse+                       | RspCodeLensResolve          CodeLensResolveResponse+                       | RspDocumentFormatting       DocumentFormattingResponse+                       | RspDocumentRangeFormatting  DocumentRangeFormattingResponse+                       | RspDocumentOnTypeFormatting DocumentOnTypeFormattingResponse+                       | RspRename                   RenameResponse+                       | RspExecuteCommand           ExecuteCommandResponse+                       | RspError                    ErrorResponse+                       | RspDocumentLink             DocumentLinkResponse+                       | RspDocumentLinkResolve      DocumentLinkResolveResponse+                       | RspWillSaveWaitUntil        WillSaveWaitUntilTextDocumentResponse+                       -- Notifications+                       | NotPublishDiagnostics       PublishDiagnosticsNotification+                       | NotLogMessage               LogMessageNotification+                       | NotShowMessage              ShowMessageNotification+                       | NotTelemetry                TelemetryNotification+                       -- A cancel request notification is duplex!+                       | NotCancelRequestFromServer  CancelNotificationServer+  deriving (Eq,Read,Show,Generic,ToJSON,FromJSON)

@@ -0,0 +1,6 @@+module Language.Haskell.LSP.Types.Capabilities+  (+    module Language.Haskell.LSP.TH.ClientCapabilities+  ) where++import Language.Haskell.LSP.TH.ClientCapabilities

@@ -14,23 +14,29 @@     VFS   , VirtualFile(..)   , openVFS-  , changeVFS+  , changeFromClientVFS+  , changeFromServerVFS   , closeVFS    -- * for tests+  , applyChanges   , applyChange-  , sortChanges   , deleteChars , addChars   , changeChars   , yiSplitAt   ) where +import           Control.Lens+import           Control.Monad import           Data.Text ( Text ) import           Data.List+import           Data.Ord #if __GLASGOW_HASKELL__ < 804 import           Data.Monoid #endif+import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map+import           Data.Maybe import qualified Language.Haskell.LSP.TH.DataTypesJSON      as J import           Language.Haskell.LSP.Utility import qualified Yi.Rope as Yi@@ -58,21 +64,54 @@  -- --------------------------------------------------------------------- -changeVFS :: VFS -> J.DidChangeTextDocumentNotification -> IO VFS-changeVFS vfs (J.NotificationMessage _ _ params) = do+changeFromClientVFS :: VFS -> J.DidChangeTextDocumentNotification -> IO VFS+changeFromClientVFS vfs (J.NotificationMessage _ _ params) = do   let     J.DidChangeTextDocumentParams vid (J.List changes) = params     J.VersionedTextDocumentIdentifier uri version = vid   case Map.lookup uri vfs of     Just (VirtualFile _ str) -> do       let str' = applyChanges str changes-      return $ Map.insert uri (VirtualFile version str') vfs+      -- the client shouldn't be sending over a null version, only the server.+      return $ Map.insert uri (VirtualFile (fromMaybe 0 version) str') vfs     Nothing -> do       logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri       return vfs  -- --------------------------------------------------------------------- +changeFromServerVFS :: VFS -> J.ApplyWorkspaceEditRequest -> IO VFS+changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do+  let J.ApplyWorkspaceEditParams edit = params+      J.WorkspaceEdit mChanges mDocChanges = edit+  case mDocChanges of+    Just (J.List textDocEdits) -> applyEdits textDocEdits+    Nothing -> case mChanges of+      Just cs -> applyEdits $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs+      Nothing -> do+        logs "haskell-lsp:changeVfs:no changes"+        return initVfs++  where++    changeToTextDocumentEdit acc uri edits =+      acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) edits]++    applyEdits = foldM f initVfs . sortOn (^. J.textDocument . J.version)++    f vfs (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 . (^. J.range)) edits+          changeEvents = map editToChangeEvent sortedEdits+          ps = J.DidChangeTextDocumentParams vid (J.List changeEvents)+          notif = J.NotificationMessage "" J.TextDocumentDidChange ps+      changeFromClientVFS vfs notif+  +    editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text++-- ---------------------------------------------------------------------+ closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> IO VFS closeVFS vfs (J.NotificationMessage _ _ params) = do   let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params@@ -89,12 +128,11 @@     } deriving (Read,Show,Eq) -} --- | Apply the list of changes, in descending order of range. Assuming no overlaps.+-- | Apply the list of changes.+-- Changes should be applied in the order that they are+-- received from the client. applyChanges :: Yi.YiString -> [J.TextDocumentContentChangeEvent] -> Yi.YiString-applyChanges str changes' = r-  where-    changes = sortChanges changes'-    r = foldl' applyChange str changes+applyChanges = foldl' applyChange  -- --------------------------------------------------------------------- @@ -175,17 +213,5 @@     (b,a) = Yi.splitAtLine l str     before = Yi.concat [b,Yi.take c a]     after = Yi.drop c a----- -----------------------------------------------------------------------sortChanges :: [J.TextDocumentContentChangeEvent] -> [J.TextDocumentContentChangeEvent]-sortChanges changes = changes'-  where-    myComp (J.TextDocumentContentChangeEvent (Just r1) _ _)-           (J.TextDocumentContentChangeEvent (Just r2) _ _)-      = compare r2 r1 -- want descending order-    myComp _ _ = EQ-    changes' = sortBy myComp changes  -- ---------------------------------------------------------------------

@@ -32,17 +32,23 @@  vspSpec :: Spec vspSpec = do-  describe "sorts changes" $ do-    it "sorts changes that all have ranges" $ do-      let-        unsorted =-          [ (J.TextDocumentContentChangeEvent (mkRange 1 0 2 0) Nothing "")-          , (J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) Nothing "")-          ]-      (sortChanges unsorted) `shouldBe`-          [ (J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) Nothing "")-          , (J.TextDocumentContentChangeEvent (mkRange 1 0 2 0) Nothing "")-          ]+  describe "applys changes in order" $ do+    it "handles vscode style undos" $ do+      let orig = "abc"+          changes =+            [ J.TextDocumentContentChangeEvent (mkRange 0 2 0 3) Nothing ""+            , J.TextDocumentContentChangeEvent (mkRange 0 1 0 2) Nothing ""+            , J.TextDocumentContentChangeEvent (mkRange 0 0 0 1) Nothing ""+            ]+      applyChanges orig changes `shouldBe` ""+    it "handles vscode style redos" $ do+      let orig = ""+          changes =+            [ J.TextDocumentContentChangeEvent (mkRange 0 1 0 1) Nothing "a"+            , J.TextDocumentContentChangeEvent (mkRange 0 2 0 2) Nothing "b"+            , J.TextDocumentContentChangeEvent (mkRange 0 3 0 3) Nothing "c"+            ]+      applyChanges orig changes `shouldBe` "abc"      -- ---------------------------------