haskell-lsp 0.13.0.0 → 0.14.0.0

raw patch · 8 files changed

+109/−65 lines, 8 filesdep +attoparsecdep −parsecdep ~aesondep ~haskell-lsp-typesPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec

Dependencies removed: parsec

Dependency ranges changed: aeson, haskell-lsp-types

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• README.md +1/−1
• haskell-lsp.cabal +10/−4
• src/Language/Haskell/LSP/Control.hs +26/−36
• src/Language/Haskell/LSP/Core.hs +16/−16
• src/Language/Haskell/LSP/Messages.hs +13/−2
• test/URIFilePathSpec.hs +35/−3
• test/WorkspaceFoldersSpec.hs +1/−3

@@ -1,5 +1,12 @@ # Revision history for haskell-lsp +## 0.14.0.0 -- 2019-06-13++* Add support for custom request and notification methods+  (@cocreature)+* Use attoparsec to parse message headers incrementally (@cocreature)+* Only build lsp-hello when -fdemo flag is set (@bubba)+ ## 0.13.0.0 -- 2019-05-18  * Fix relative posix URIs (@DavidM-D)

@@ -36,7 +36,7 @@  ## Using the example server -    stack install+    stack install :lsp-hello --flag haskell-lsp:demo  will generate a `lsp-hello` executable. 

@@ -1,5 +1,5 @@ name:                haskell-lsp-version:             0.13.0.0+version:             0.14.0.0 synopsis:            Haskell library for the Microsoft Language Server Protocol  description:         An implementation of the types, and basic message server to@@ -38,6 +38,7 @@   build-depends:       base >=4.9 && <4.13                      , async                      , aeson >=1.0.0.0+                     , attoparsec                      , bytestring                      , containers                      , directory@@ -45,11 +46,10 @@                      , filepath                      , hslogger                      , hashable-                     , haskell-lsp-types == 0.13.*+                     , haskell-lsp-types == 0.14.*                      , lens >= 4.15.2                      , mtl                      , network-uri-                     , parsec                      , rope-utf16-splay >= 0.3.1.0                      , sorted-list == 0.2.1.*                      , stm@@ -78,7 +78,6 @@                      , lens >= 4.15.2                      , mtl                      , network-uri-                     , parsec                      , rope-utf16-splay >= 0.2                      , stm                      , text@@ -88,6 +87,13 @@                      , vector                      -- the package library. Comment this out if you want repl changes to propagate                      , haskell-lsp+  if !flag(demo)+    buildable:         False++flag demo {+  description: Build the lsp-hello demo executable+  default:     False+}  test-suite haskell-lsp-test   type:                exitcode-stdio-1.0

@@ -17,6 +17,10 @@ import           Control.Monad import           Control.Monad.STM import qualified Data.Aeson as J+import qualified Data.Attoparsec.ByteString as Attoparsec+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString as BS+import Data.ByteString.Builder.Extra (defaultChunkSize) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B import           Data.Time.Clock@@ -30,7 +34,6 @@ import           Language.Haskell.LSP.Utility import           System.IO import           System.FilePath-import           Text.Parsec  -- --------------------------------------------------------------------- @@ -94,40 +97,27 @@                    -> Core.InitializeCallback c                    -> TVar (Core.LanguageContextData c)                    -> IO ()-ioLoop hin dispatcherProc tvarDat = go BSL.empty+ioLoop hin dispatcherProc tvarDat = do+  go (parse parser "")   where-    go :: BSL.ByteString -> IO ()-    go buf = do-      c <- BSL.hGet hin 1--      if c == BSL.empty-        then do-          logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n"-          return ()-        else do-          -- logs $ "ioLoop: got" ++ show c-          let newBuf = BSL.append buf c-          case readContentLength (lbs2str newBuf) of-            Left _ -> go newBuf-            Right len -> do-              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.handleMessage dispatcherProc tvarDat newBuf cnt-                  ioLoop hin dispatcherProc tvarDat-      where-        readContentLength :: String -> Either ParseError Int-        readContentLength = parse parser "readContentLength"--        parser = do-          _ <- string "Content-Length: "-          len <- manyTill digit (string _TWO_CRLF)-          return . read $ len+    go :: Result BS.ByteString -> IO ()+    go (Fail _ ctxs err) = logm $ B.pack+      "\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+      if BS.null bs+        then logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n"+        else go (c bs)+    go (Done remainder msg) = do+      logm $ B.pack "---> " <> BSL.fromStrict msg+      Core.handleMessage dispatcherProc tvarDat (BSL.fromStrict msg)+      go (parse parser remainder)+    parser = do+      _ <- string "Content-Length: "+      len <- decimal+      _ <- string _TWO_CRLF+      Attoparsec.take len  -- --------------------------------------------------------------------- @@ -144,7 +134,7 @@      let out = BSL.concat                  [ str2lbs $ "Content-Length: " ++ show (BSL.length str)-                 , str2lbs _TWO_CRLF+                 , BSL.fromStrict _TWO_CRLF                  , str ]      BSL.hPut clientH out@@ -156,7 +146,7 @@ -- | -- ---_TWO_CRLF :: String+_TWO_CRLF :: BS.ByteString _TWO_CRLF = "\r\n\r\n"  

@@ -254,6 +254,10 @@     , initializeRequestHandler                 :: !(Maybe (Handler J.InitializeRequest))     -- Will default to terminating `exitMessage` if Nothing     , exitNotificationHandler                  :: !(Maybe (Handler J.ExitNotification))++    , customRequestHandler                     :: !(Maybe (Handler J.CustomClientRequest))+    , customNotificationHandler                :: !(Maybe (Handler J.CustomClientNotification))+     }  instance Default Handlers where@@ -261,7 +265,7 @@                  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@@ -337,17 +341,13 @@ handlerMap _ h J.TextDocumentRename              = hh nop ReqRename $ renameHandler h handlerMap _ h J.TextDocumentFoldingRange        = hh nop ReqFoldingRange $ foldingRangeHandler h handlerMap _ _ J.WindowProgressCancel            = helper progressCancelHandler-handlerMap _ _ (J.Misc x)   = helper f-  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)+handlerMap _ h (J.CustomClientMethod _)          = \ctxData val ->+    case val of+        J.Object o | "id" `HM.member` o ->+            -- Custom request+            hh nop ReqCustomClient (customRequestHandler h) ctxData val+        _ -> -- Custom notification+            hh nop NotCustomClient (customNotificationHandler h) ctxData val  -- --------------------------------------------------------------------- @@ -497,8 +497,8 @@ -- ---------------------------------------------------------------------  handleMessage :: (Show c) => InitializeCallback c-              -> TVar (LanguageContextData c) -> BSL.ByteString -> BSL.ByteString -> IO ()-handleMessage dispatcherProc tvarDat contLenStr jsonStr = do+              -> TVar (LanguageContextData c) -> BSL.ByteString -> IO ()+handleMessage dispatcherProc tvarDat jsonStr = do   {-   Message Types we must handle are the following @@ -510,7 +510,7 @@    case J.eitherDecode jsonStr :: Either String J.Object of     Left  err -> do-      let msg =  T.pack $ unwords [ "haskell-lsp:incoming message parse error.", lbs2str contLenStr, lbs2str jsonStr, show err]+      let msg =  T.pack $ unwords [ "haskell-lsp:incoming message parse error.", lbs2str jsonStr, show err]               ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL)               ++ "\n"       sendErrorLog tvarDat msg@@ -522,7 +522,7 @@                                    J.Success m -> handle (J.Object o) m                                    J.Error _ -> do                                      let msg = T.pack $ unwords ["haskell-lsp:unknown message received:method='"-                                                                 ++ T.unpack s ++ "',", lbs2str contLenStr, lbs2str jsonStr]+                                                                 ++ T.unpack s ++ "',", lbs2str jsonStr]                                      sendErrorLog tvarDat msg         Just oops -> logs $ "haskell-lsp:got strange method param, ignoring:" ++ show oops         Nothing -> do

@@ -61,8 +61,12 @@                        | NotDidChangeWatchedFiles        DidChangeWatchedFilesNotification                        | NotDidChangeWorkspaceFolders    DidChangeWorkspaceFoldersNotification                        | NotProgressCancel               ProgressCancelNotification-                       -- Unknown (The client sends something we don't understand)-                       | UnknownFromClientMessage        Value++                       -- It is common for language servers to add custom message types so these+                       -- three constructors can be used to handle custom request, response or notification+                       -- types.+                       | ReqCustomClient                 CustomClientRequest+                       | NotCustomClient                 CustomClientNotification   deriving (Eq,Read,Show,Generic,ToJSON,FromJSON)  -- | A wrapper around a message that originates from the server@@ -110,4 +114,11 @@                        | NotTelemetry                TelemetryNotification                        -- A cancel request notification is duplex!                        | NotCancelRequestFromServer  CancelNotificationServer++                       -- It is common for language servers to add custom message types so these+                       -- three constructors can be used to handle custom request, response or notification+                       -- types.+                       | ReqCustomServer             CustomServerRequest+                       | RspCustomServer             CustomResponse+                       | NotCustomServer             CustomServerNotification   deriving (Eq,Read,Show,Generic,ToJSON,FromJSON)

@@ -1,12 +1,18 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module URIFilePathSpec where +import Data.List+import Data.Monoid ((<>)) import Data.Text                              (pack) import Language.Haskell.LSP.Types  import           Network.URI+import qualified System.FilePath.Windows as FPW import Test.Hspec+import Test.QuickCheck + -- ---------------------------------------------------------------------  main :: IO ()@@ -27,7 +33,7 @@ relativePosixFilePath = "myself/example.hs"  testWindowsUri :: Uri-testWindowsUri = Uri $ pack "file:///c%3A/Users/myself/example.hs"+testWindowsUri = Uri $ pack "file:///c:/Users/myself/example.hs"  testWindowsFilePath :: FilePath testWindowsFilePath = "c:\\Users\\myself\\example.hs"@@ -61,8 +67,8 @@     theFilePath `shouldBe` (Uri "file:///./Functional.hs")    it "converts a Windows file path to a URI" $ do-    let theFilePath = platformAwareFilePathToUri windowsOS "c:./Functional.hs"-    theFilePath `shouldBe` (Uri "file:///c%3A/./Functional.hs")+    let theFilePath = platformAwareFilePathToUri windowsOS "c:/Functional.hs"+    theFilePath `shouldBe` (Uri "file:///c:/Functional.hs")    it "converts a POSIX file path to a URI and back" $ do     let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs"@@ -76,9 +82,35 @@       ,"")     Just "./Functional.hs" `shouldBe` platformAwareUriToFilePath "posix" theFilePath +  it "converts a Posix file path to a URI and back" $ property $ forAll genPosixFilePath $ \fp -> do+      let uri = platformAwareFilePathToUri "posix" fp+      platformAwareUriToFilePath "posix" uri `shouldBe` Just fp +  it "converts a Windows file path to a URI and back" $ property $ forAll genWindowsFilePath $ \fp -> do+      let uri = platformAwareFilePathToUri windowsOS fp+      -- We normalise to account for changes in the path separator.+      platformAwareUriToFilePath windowsOS uri `shouldBe` Just (FPW.normalise fp)+   it "converts a relative POSIX file path to a URI and back" $ do     let uri = platformAwareFilePathToUri "posix" relativePosixFilePath     uri `shouldBe` Uri "file://myself/example.hs"     let back = platformAwareUriToFilePath "posix" uri     back `shouldBe` Just relativePosixFilePath++genWindowsFilePath :: Gen FilePath+genWindowsFilePath = do+    segments <- listOf pathSegment+    pathSep <- elements ['/', '\\']+    pure ("C:" <> [pathSep] <> intercalate [pathSep] segments)+  where pathSegment = listOf1 (arbitraryASCIIChar `suchThat` (`notElem` ['/', '\\', '.', ':']))++genPosixFilePath :: Gen FilePath+genPosixFilePath = do+    segments <- listOf pathSegment+    pure ("/" <> intercalate "/" segments)+  where pathSegment = listOf1 (arbitraryASCIIChar `suchThat` (`notElem` ['/', '.']))++#if !MIN_VERSION_QuickCheck(2,10,0)+arbitraryASCIIChar :: Gen Char+arbitraryASCIIChar = arbitrary+#endif

@@ -5,7 +5,6 @@ import Control.Concurrent.MVar import Control.Concurrent.STM import Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Default import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types@@ -28,8 +27,7 @@      let putMsg msg =           let jsonStr = encode msg-              clStr = BSL.pack $ "Content-Length: " ++ show (BSL.length jsonStr)-            in handleMessage initCb tvarCtx clStr jsonStr+            in handleMessage initCb tvarCtx jsonStr      let starterWorkspaces = List [wf0]         initParams = InitializeParams