haskell-lsp 0.22.0.0 → 0.23.0.0

raw patch · 8 files changed

+109/−40 lines, 8 filesdep ~haskell-lsp-typesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-lsp-types

API changes (from Hackage documentation)

Files

• ChangeLog.md +11/−0
• haskell-lsp.cabal +2/−2
• src/Language/Haskell/LSP/Capture.hs +39/−14
• src/Language/Haskell/LSP/Control.hs +38/−15
• src/Language/Haskell/LSP/Core.hs +8/−7
• test/InitialConfigurationSpec.hs +2/−1
• test/JsonSpec.hs +7/−0
• test/WorkspaceFoldersSpec.hs +2/−1

@@ -1,5 +1,16 @@ # Revision history for haskell-lsp +## 0.23.0.0++* Add runWith for transporots other than stdio (@paulyoung)+* Fix race condition in event captures (@bgamari)+* Tweak the sectionSeparator (@alanz)+* Add hashWithSaltInstances (@ndmitchell)+* Fix CompletionItem.tags not being optional (@bubba)+* Avoid unnecessary normalisation in Binary instance for+  NormalizedFilePath (@cocreature)+* Fix ordering of TH splices (@fendor)+ ## 0.22.0.0  * ResponseMessage results are now an Either type (@greenhat)

@@ -1,5 +1,5 @@ name:                haskell-lsp-version:             0.22.0.0+version:             0.23.0.0 synopsis:            Haskell library for the Microsoft Language Server Protocol  description:         An implementation of the types, and basic message server to@@ -46,7 +46,7 @@                      , filepath                      , hslogger                      , hashable-                     , haskell-lsp-types == 0.22.*+                     , haskell-lsp-types == 0.23.*                      , lens >= 4.15.2                      , mtl                      , network-uri

@@ -1,30 +1,55 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-module Language.Haskell.LSP.Capture where+module Language.Haskell.LSP.Capture+  ( Event(..)+  , CaptureContext+  , noCapture+  , captureToFile+  , captureFromClient+  , captureFromServer+  ) where  import Data.Aeson import Data.ByteString.Lazy.Char8 as BSL import Data.Time.Clock import GHC.Generics import Language.Haskell.LSP.Messages+import System.IO+import Language.Haskell.LSP.Utility+import Control.Concurrent+import Control.Monad+import Control.Concurrent.STM -data Event = FromClient UTCTime FromClientMessage-           | FromServer UTCTime FromServerMessage+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+data CaptureContext = NoCapture | Capture (TChan Event) -  BSL.appendFile fp $ BSL.append (encode entry) "\n"+noCapture :: CaptureContext+noCapture = NoCapture -captureFromClient :: FromClientMessage -> Maybe FilePath -> IO ()-captureFromClient _ Nothing = return ()-captureFromClient msg (Just fp) = do+captureToFile :: FilePath -> IO CaptureContext+captureToFile fname = do+    logs $ "haskell-lsp:Logging to " ++ fname+    chan <- newTChanIO+    _tid <- forkIO $ withFile fname WriteMode $ writeToHandle chan+    return $ Capture chan++captureFromServer :: FromServerMessage -> CaptureContext -> IO ()+captureFromServer _ NoCapture = return ()+captureFromServer msg (Capture chan) = do   time <- getCurrentTime-  let entry = FromClient time msg+  atomically $ writeTChan chan $ FromServer time msg -  BSL.appendFile fp $ BSL.append (encode entry) "\n"+captureFromClient :: FromClientMessage -> CaptureContext -> IO ()+captureFromClient _ NoCapture = return ()+captureFromClient msg (Capture chan) = do+  time <- getCurrentTime+  atomically $ writeTChan chan $ FromClient time msg++writeToHandle :: TChan Event -> Handle -> IO ()+writeToHandle chan hdl = forever $ do+    ev <- atomically $ readTChan chan+    BSL.hPutStrLn hdl $ encode ev

@@ -8,6 +8,7 @@ module Language.Haskell.LSP.Control   (     run+  , runWith   , runWithHandles   ) where @@ -50,8 +51,7 @@     -> IO Int run = runWithHandles stdin stdout --- | Starts listening and sending requests and responses--- at the specified handles.+-- | Convenience function for 'runWith' using the specified handles. runWithHandles :: (Show config) =>        Handle     -- ^ Handle to read client input from.@@ -63,20 +63,44 @@     -> Maybe FilePath     -> IO Int         -- exit code runWithHandles hin hout initializeCallbacks h o captureFp = do--  logm $ B.pack "\n\n\n\n\nhaskell-lsp:Starting up server ..."   hSetBuffering hin NoBuffering   hSetEncoding  hin utf8    hSetBuffering hout NoBuffering   hSetEncoding  hout utf8 +  let+    clientIn = BS.hGetSome hin defaultChunkSize++    clientOut out = do+      BSL.hPut hout out+      hFlush hout++  runWith clientIn clientOut initializeCallbacks h o captureFp++-- | Starts listening and sending requests and responses+-- using the specified I/O.+runWith :: (Show config) =>+       IO BS.ByteString+    -- ^ Client input.+    -> (BSL.ByteString -> IO ())+    -- ^ Function to provide output to.+    -> Core.InitializeCallbacks config+    -> Core.Handlers+    -> Core.Options+    -> Maybe FilePath+    -> IO Int         -- exit code+runWith clientIn clientOut initializeCallbacks h o captureFp = do++  logm $ B.pack "\n\n\n\n\nhaskell-lsp:Starting up server ..."+   timestamp <- formatTime defaultTimeLocale (iso8601DateFormat (Just "%H-%M-%S")) <$> getCurrentTime   let timestampCaptureFp = fmap (\f -> dropExtension f ++ timestamp ++ takeExtension f)                                 captureFp+  captureCtx <- maybe (return noCapture) captureToFile timestampCaptureFp    cout <- atomically newTChan :: IO (TChan FromServerMessage)-  _rhpid <- forkIO $ sendServer cout hout timestampCaptureFp+  _rhpid <- forkIO $ sendServer cout clientOut captureCtx     let sendFunc :: Core.SendFunc@@ -85,20 +109,20 @@    tvarId <- atomically $ newTVar 0   initVFS $ \vfs -> do-    tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc timestampCaptureFp vfs+    tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc captureCtx vfs -    ioLoop hin initializeCallbacks tvarDat+    ioLoop clientIn initializeCallbacks tvarDat    return 1   -- --------------------------------------------------------------------- -ioLoop :: (Show config) => Handle+ioLoop :: (Show config) => IO BS.ByteString                    -> Core.InitializeCallbacks config                    -> TVar (Core.LanguageContextData config)                    -> IO ()-ioLoop hin dispatcherProc tvarDat =+ioLoop clientIn dispatcherProc tvarDat =   go (parse parser "")   where     go :: Result BS.ByteString -> IO ()@@ -106,7 +130,7 @@       "\nhaskell-lsp: Failed to parse message header:\n" <> B.intercalate " > " (map str2lbs ctxs) <> ": " <>       str2lbs err <> "\n exiting 1 ...\n"     go (Partial c) = do-      bs <- BS.hGetSome hin defaultChunkSize+      bs <- clientIn       if BS.null bs         then logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n"         else go (c bs)@@ -123,8 +147,8 @@ -- ---------------------------------------------------------------------  -- | Simple server to make sure all output is serialised-sendServer :: TChan FromServerMessage -> Handle -> Maybe FilePath -> IO ()-sendServer msgChan clientH captureFp =+sendServer :: TChan FromServerMessage -> (BSL.ByteString -> IO ()) -> CaptureContext -> IO ()+sendServer msgChan clientOut captureCtxt =   forever $ do     msg <- atomically $ readTChan msgChan @@ -138,11 +162,10 @@                  , BSL.fromStrict _TWO_CRLF                  , str ] -    BSL.hPut clientH out-    hFlush clientH+    clientOut out     logm $ B.pack "<--2--" <> str -    captureFromServer msg captureFp+    captureFromServer msg captureCtxt  -- | --

@@ -27,6 +27,7 @@   , sendErrorLogS   , sendErrorShowS   , reverseSortEdit+  , Priority(..)   ) where  import           Control.Concurrent.Async@@ -86,7 +87,7 @@   , resConfig              :: !(Maybe config)   , resLspId               :: !(TVar Int)   , resLspFuncs            :: LspFuncs config -- NOTE: Cannot be strict, lazy initialization-  , resCaptureFile         :: !(Maybe FilePath)+  , resCaptureContext      :: !CaptureContext   , resWorkspaceFolders    :: ![J.WorkspaceFolder]   , resProgressData        :: !ProgressData   }@@ -348,7 +349,7 @@       ctx <- readTVarIO ctxVar       -- Capture exit notification       case J.fromJSON v :: J.Result J.ExitNotification of-        J.Success n -> captureFromClient (NotExit n) (resCaptureFile ctx)+        J.Success n -> captureFromClient (NotExit n) (resCaptureContext ctx)         J.Error _ -> return ()       logm $ B.pack "haskell-lsp:Got exit, exiting"       exitSuccess@@ -417,7 +418,7 @@            ctx <- readTVarIO tvarDat           let req' = wrapper req-          captureFromClient req' (resCaptureFile ctx)+          captureFromClient req' (resCaptureContext ctx)            case mh of             Just h -> h req@@ -484,7 +485,7 @@     J.Success req -> do       ctx <- readTVarIO tvarDat -      captureFromClient (notification req) (resCaptureFile ctx)+      captureFromClient (notification req) (resCaptureContext ctx)        case parseConfig req of         Left err -> do@@ -605,10 +606,10 @@ -- | -- ---defaultLanguageContextData :: Handlers -> Options -> LspFuncs config -> TVar Int -> SendFunc -> Maybe FilePath -> VFS -> LanguageContextData config-defaultLanguageContextData h o lf tv sf cf vfs =+defaultLanguageContextData :: Handlers -> Options -> LspFuncs config -> TVar Int -> SendFunc -> CaptureContext -> VFS -> LanguageContextData config+defaultLanguageContextData h o lf tv sf cc vfs =   LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf (VFSData vfs mempty) mempty-                      Nothing tv lf cf mempty defaultProgressData+                      Nothing tv lf cc mempty defaultProgressData  defaultProgressData :: ProgressData defaultProgressData = ProgressData 0 Map.empty

@@ -6,6 +6,7 @@ import           Control.Concurrent.STM import           Data.Aeson import           Data.Default+import           Language.Haskell.LSP.Capture import           Language.Haskell.LSP.Core import           Language.Haskell.LSP.Types import           Language.Haskell.LSP.VFS@@ -40,7 +41,7 @@                                                         undefined                                                         tvarLspId                                                         (const $ return ())-                                                        Nothing+                                                        noCapture                                                         vfs      let putMsg msg =

@@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+-- For the use of MarkedString+{-# OPTIONS_GHC -fno-warn-deprecations #-} -- | Test for JSON serialization module JsonSpec where @@ -44,6 +46,11 @@          (propertyJsonRoundtrip :: ResponseMessage () -> Property)     prop "ResponseMessage JSON value"          (propertyJsonRoundtrip :: ResponseMessage J.Value -> Property)+  describe "JSON decoding regressions" $+    it "CompletionItem" $+      (J.decode "{\"jsonrpc\":\"2.0\",\"result\":[{\"label\":\"raisebox\"}],\"id\":1}" :: Maybe CompletionResponse)+        `shouldNotBe` Nothing+    responseMessageSpec :: Spec responseMessageSpec = do

@@ -6,6 +6,7 @@ import Control.Concurrent.STM import Data.Aeson import Data.Default+import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types import Language.Haskell.LSP.VFS@@ -31,7 +32,7 @@                                                         undefined                                                         tvarLspId                                                         (const $ return ())-                                                        Nothing+                                                        noCapture                                                         vfs      let putMsg msg =