Merge branch 'master' into github-actions
authorLuke Lau <luke_lau@icloud.com>
Fri, 18 Oct 2019 23:49:15 +0000 (00:49 +0100)
committerLuke Lau <luke_lau@icloud.com>
Fri, 18 Oct 2019 23:49:15 +0000 (00:49 +0100)
ChangeLog.md
lsp-test.cabal
src/Language/Haskell/LSP/Test.hs
src/Language/Haskell/LSP/Test/Decoding.hs
src/Language/Haskell/LSP/Test/Messages.hs
src/Language/Haskell/LSP/Test/Parsing.hs
src/Language/Haskell/LSP/Test/Session.hs
stack.yaml
stack.yaml.lock
test/Test.hs

index 8bbc01f8b7f8412b4d6659c9085295eb8b2e439b..f01ba4f1be489498bc1fa871af1f44ace48d6325 100644 (file)
@@ -1,5 +1,10 @@
 # Revision history for lsp-test
 
+## 0.8.0.0 -- 2019-10-18
+
+* Make `Session` a newtype
+* Update for haskell-lsp-0.17.0.0 (@cocreature)
+
 ## 0.7.0.0 -- 2019-09-08
 
 * Update for haskell-lsp-0.16.0.0
index 14e0046a2836a42fc46709488d08763766df5fe3..80283b75b07f32b6844fa2caa3f8445fa86ffd5f 100644 (file)
@@ -1,5 +1,5 @@
 name:                lsp-test
-version:             0.7.0.0
+version:             0.8.0.0
 synopsis:            Functional test framework for LSP servers.
 description:
   A test framework for writing tests against
@@ -36,7 +36,7 @@ library
                      , parser-combinators:Control.Applicative.Combinators
   default-language:    Haskell2010
   build-depends:       base >= 4.10 && < 5
-                     , haskell-lsp == 0.16.*
+                     , haskell-lsp == 0.17.*
                      , aeson
                      , aeson-pretty
                      , ansi-terminal
@@ -52,7 +52,7 @@ library
                      , lens
                      , mtl
                      , parser-combinators
-                     , process
+                     , process >= 1.6
                      , rope-utf16-splay
                      , text
                      , transformers
@@ -79,7 +79,7 @@ test-suite tests
   build-depends:       base >= 4.10 && < 5
                      , hspec
                      , lens
-                     , haskell-lsp == 0.16.*
+                     , haskell-lsp == 0.17.*
                      , lsp-test
                      , data-default
                      , aeson
index 1b2e7ba867a6ebc4356b008e29a7c4ce53eee962..22091c3451c16f00d6848502a60dafc0a9edd928 100644 (file)
@@ -8,7 +8,7 @@ Module      : Language.Haskell.LSP.Test
 Description : A functional testing framework for LSP servers.
 Maintainer  : luke_lau@icloud.com
 Stability   : experimental
-Portability : POSIX
+Portability : non-portable
 
 Provides the framework to start functionally testing
 <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.
@@ -163,8 +163,7 @@ runSessionWithConfig config serverExe caps rootDir session = do
         Nothing -> return ()
 
       -- Run the actual test
-      result <- session
-      return result
+      session
   where
   -- | Asks the server to shutdown and exit politely
   exitServer :: Session ()
@@ -378,7 +377,7 @@ noDiagnostics = do
 -- | Returns the symbols in a document.
 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
 getDocumentSymbols doc = do
-  ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
+  ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
   maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
   case mRes of
     Just (DSDocumentSymbols (List xs)) -> return (Left xs)
@@ -389,7 +388,7 @@ getDocumentSymbols doc = do
 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
 getCodeActions doc range = do
   ctx <- getCodeActionContext doc
-  rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
+  rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
 
   case rsp ^. result of
     Just (List xs) -> return xs
@@ -407,7 +406,7 @@ getAllCodeActions doc = do
   where
     go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
     go ctx acc diag = do
-      ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
+      ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
 
       case mErr of
         Just e -> throw (UnexpectedResponseError rspLid e)
@@ -429,7 +428,7 @@ getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^.
 executeCommand :: Command -> Session ()
 executeCommand cmd = do
   let args = decode $ encode $ fromJust $ cmd ^. arguments
-      execParams = ExecuteCommandParams (cmd ^. command) args
+      execParams = ExecuteCommandParams (cmd ^. command) args Nothing
   request_ WorkspaceExecuteCommand execParams
 
 -- | Executes a code action.
@@ -488,7 +487,7 @@ applyEdit doc edit = do
 -- | Returns the completions for the position in the document.
 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
 getCompletions doc pos = do
-  rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
+  rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
 
   case getResponseResult rsp of
     Completions (List items) -> return items
@@ -501,7 +500,7 @@ getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
               -> Session [Location] -- ^ The locations of the references.
 getReferences doc pos inclDecl =
   let ctx = ReferenceContext inclDecl
-      params = ReferenceParams doc pos ctx
+      params = ReferenceParams doc pos ctx Nothing
   in getResponseResult <$> request TextDocumentReferences params
 
 -- | Returns the definition(s) for the term at the specified position.
@@ -509,7 +508,7 @@ getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
                -> Position -- ^ The position the term is at.
                -> Session [Location] -- ^ The location(s) of the definitions
 getDefinitions doc pos = do
-  let params = TextDocumentPositionParams doc pos
+  let params = TextDocumentPositionParams doc pos Nothing
   rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
   case getResponseResult rsp of
       SingleLoc loc -> pure [loc]
@@ -520,13 +519,13 @@ getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
                -> Position -- ^ The position the term is at.
                -> Session [Location] -- ^ The location(s) of the definitions
 getTypeDefinitions doc pos =
-  let params = TextDocumentPositionParams doc pos
+  let params = TextDocumentPositionParams doc pos Nothing
   in getResponseResult <$> request TextDocumentTypeDefinition params
 
 -- | Renames the term at the specified position.
 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
 rename doc pos newName = do
-  let params = RenameParams doc pos (T.pack newName)
+  let params = RenameParams doc pos (T.pack newName) Nothing
   rsp <- request TextDocumentRename params :: Session RenameResponse
   let wEdit = getResponseResult rsp
       req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
@@ -535,13 +534,13 @@ rename doc pos newName = do
 -- | Returns the hover information at the specified position.
 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
 getHover doc pos =
-  let params = TextDocumentPositionParams doc pos
+  let params = TextDocumentPositionParams doc pos Nothing
   in getResponseResult <$> request TextDocumentHover params
 
 -- | Returns the highlighted occurences of the term at the specified position
 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
 getHighlights doc pos =
-  let params = TextDocumentPositionParams doc pos
+  let params = TextDocumentPositionParams doc pos Nothing
   in getResponseResult <$> request TextDocumentDocumentHighlight params
 
 -- | Checks the response for errors and throws an exception if needed.
@@ -554,14 +553,14 @@ getResponseResult rsp = fromMaybe exc (rsp ^. result)
 -- | Applies formatting to the specified document.
 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
 formatDoc doc opts = do
-  let params = DocumentFormattingParams doc opts
+  let params = DocumentFormattingParams doc opts Nothing
   edits <- getResponseResult <$> request TextDocumentFormatting params
   applyTextEdits doc edits
 
 -- | Applies formatting to the specified range in a document.
 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
 formatRange doc opts range = do
-  let params = DocumentRangeFormattingParams doc range opts
+  let params = DocumentRangeFormattingParams doc range opts Nothing
   edits <- getResponseResult <$> request TextDocumentRangeFormatting params
   applyTextEdits doc edits
 
@@ -574,6 +573,6 @@ applyTextEdits doc edits =
 -- | Returns the code lenses for the specified document.
 getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
 getCodeLenses tId = do
-    rsp <- request TextDocumentCodeLens (CodeLensParams tId) :: Session CodeLensResponse
+    rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
     case getResponseResult rsp of
         List res -> pure res
index af91928695d73df098cb4054abaae82632d3a845..e635267fd7f9bf6200591b4d330ca8e2c3b3df99 100644 (file)
@@ -3,6 +3,7 @@ module Language.Haskell.LSP.Test.Decoding where
 
 import           Prelude                 hiding ( id )
 import           Data.Aeson
+import           Data.Foldable
 import           Control.Exception
 import           Control.Lens
 import qualified Data.ByteString.Lazy.Char8    as B
@@ -131,9 +132,9 @@ decodeFromServerMsg reqMap bytes =
         WindowShowMessage              -> NotShowMessage $ fromJust $ decode bytes
         WindowLogMessage               -> NotLogMessage $ fromJust $ decode bytes
         CancelRequestServer            -> NotCancelRequestFromServer $ fromJust $ decode bytes
-        WindowProgressStart            -> NotProgressStart $ fromJust $ decode bytes
-        WindowProgressReport           -> NotProgressReport $ fromJust $ decode bytes
-        WindowProgressDone             -> NotProgressDone $ fromJust $ decode bytes
+        Progress                       ->
+          fromJust $ asum [NotWorkDoneProgressBegin <$> decode bytes, NotWorkDoneProgressReport <$> decode bytes, NotWorkDoneProgressEnd <$> decode bytes]
+        WindowWorkDoneProgressCreate   -> ReqWorkDoneProgressCreate $ fromJust $ decode bytes
         TelemetryEvent                 -> NotTelemetry $ fromJust $ decode bytes
         WindowShowMessageRequest       -> ReqShowMessage $ fromJust $ decode bytes
         ClientRegisterCapability       -> ReqRegisterCapability $ fromJust $ decode bytes
index f41a77b4da77466dfba087ba88dd72954b176818..f8b182233f682ad853db4ff1b38aa398e617895e 100644 (file)
@@ -60,6 +60,7 @@ handleServerMessage request response notification msg = case msg of
     (ReqShowMessage              m) -> request m
     (ReqUnregisterCapability     m) -> request m
     (ReqCustomServer             m) -> request m
+    (ReqWorkDoneProgressCreate   m) -> request m
     (RspInitialize               m) -> response m
     (RspShutdown                 m) -> response m
     (RspHover                    m) -> response m
@@ -92,9 +93,9 @@ handleServerMessage request response notification msg = case msg of
     (NotPublishDiagnostics       m) -> notification m
     (NotLogMessage               m) -> notification m
     (NotShowMessage              m) -> notification m
-    (NotProgressStart            m) -> notification m
-    (NotProgressReport           m) -> notification m
-    (NotProgressDone             m) -> notification m
+    (NotWorkDoneProgressBegin    m) -> notification m
+    (NotWorkDoneProgressReport   m) -> notification m
+    (NotWorkDoneProgressEnd      m) -> notification m
     (NotTelemetry                m) -> notification m
     (NotCancelRequestFromServer  m) -> notification m
     (NotCustomServer             m) -> notification m
@@ -148,6 +149,6 @@ handleClientMessage request response notification msg = case msg of
  (NotDidSaveTextDocument      m) -> notification m
  (NotDidChangeWatchedFiles    m) -> notification m
  (NotDidChangeWorkspaceFolders m) -> notification m
- (NotProgressCancel           m) -> notification m
+ (NotWorkDoneProgressCancel    m) -> notification m
  (ReqCustomClient             m) -> request m
  (NotCustomClient             m) -> notification m
index 52f97ae8e80a62da02e4614f5f00a5241cd5f175..70481b979a83a67434dff19f1bb304af3ee65789 100644 (file)
@@ -23,7 +23,8 @@ import Control.Monad.IO.Class
 import Control.Monad
 import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as B
-import Data.Conduit.Parser
+import Data.Conduit.Parser hiding (named)
+import qualified Data.Conduit.Parser (named)
 import qualified Data.Text as T
 import Data.Typeable
 import Language.Haskell.LSP.Messages
@@ -81,7 +82,7 @@ satisfyMaybe pred = do
       threadDelay (timeout * 1000000)
       writeChan chan (TimeoutMessage timeoutId)
 
-  x <- await
+  x <- Session await
 
   unless skipTimeout $
     modify $ \s -> s { curTimeoutId = timeoutId + 1 }
@@ -94,6 +95,9 @@ satisfyMaybe pred = do
       return a
     Nothing -> empty
 
+named :: T.Text -> Session a -> Session a
+named s (Session x) = Session (Data.Conduit.Parser.named s x)
+
 -- | Matches a message of type @a@.
 message :: forall a. (Typeable a, FromJSON a) => Session a
 message =
index b8286a208c8f5e5369171b87ad62802d899b485d..b8dbe2ac04797c21ddf2d6b7a4beba3036d67c86 100644 (file)
@@ -1,12 +1,13 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
 
 module Language.Haskell.LSP.Test.Session
-  ( Session
+  ( Session(..)
   , SessionConfig(..)
   , defaultConfig
   , SessionMessage(..)
@@ -28,6 +29,7 @@ module Language.Haskell.LSP.Test.Session
 
 where
 
+import Control.Applicative
 import Control.Concurrent hiding (yield)
 import Control.Exception
 import Control.Lens hiding (List)
@@ -40,7 +42,7 @@ import Control.Monad.Fail
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import qualified Control.Monad.Trans.Reader as Reader (ask)
 import Control.Monad.Trans.State (StateT, runStateT)
-import qualified Control.Monad.Trans.State as State (get, put)
+import qualified Control.Monad.Trans.State as State
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Aeson
 import Data.Aeson.Encode.Pretty
@@ -76,7 +78,8 @@ import System.Timeout
 -- 'Language.Haskell.LSP.Test.sendRequest' and
 -- 'Language.Haskell.LSP.Test.sendNotification'.
 
-type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
+newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
+  deriving (Functor, Applicative, Monad, MonadIO, Alternative)
 
 #if __GLASGOW_HASKELL__ >= 806
 instance MonadFail Session where
@@ -121,10 +124,10 @@ class Monad m => HasReader r m where
   asks :: (r -> b) -> m b
   asks f = f <$> ask
 
-instance Monad m => HasReader r (ParserStateReader a s r m) where
-  ask = lift $ lift Reader.ask
+instance HasReader SessionContext Session where
+  ask  = Session (lift $ lift Reader.ask)
 
-instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
+instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
   ask = lift $ lift Reader.ask
 
 data SessionState = SessionState
@@ -150,19 +153,22 @@ class Monad m => HasState s m where
   modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
   modifyM f = get >>= f >>= put
 
-instance Monad m => HasState s (ParserStateReader a s r m) where
+instance HasState SessionState Session where
+  get = Session (lift State.get)
+  put = Session . lift . State.put
+
+instance Monad m => HasState s (ConduitM a b (StateT s m))
+ where
   get = lift State.get
   put = lift . State.put
 
-instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
+instance Monad m => HasState s (ConduitParser a (StateT s m))
  where
   get = lift State.get
   put = lift . State.put
 
-type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
-
 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
-runSession context state session = runReaderT (runStateT conduit state) context
+runSession context state (Session session) = runReaderT (runStateT conduit state) context
   where
     conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
 
@@ -235,7 +241,8 @@ updateStateC = awaitForever $ \msg -> do
   updateState msg
   yield msg
 
-updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
+updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
+            => FromServerMessage -> m ()
 updateState (NotPublishDiagnostics n) = do
   let List diags = n ^. params . diagnostics
       doc = n ^. params . uri
index 07b7ffcc8cb097c7d6e0b2d970d3f9bf2731ac4d..1e8b3c24f725ba629b30abe796b15332ba195715 100644 (file)
@@ -4,5 +4,8 @@ packages:
 
 extra-deps:
   - rope-utf16-splay-0.3.1.0
-  - haskell-lsp-0.16.0.0
-  - haskell-lsp-types-0.16.0.0
+  - github: alanz/haskell-lsp
+    commit: 2aacc5ca706bcce111e976a1af4a95a376137c5e
+    subdirs:
+      - .
+      - haskell-lsp-types
index e894dd7fd61bf716bf7a4c32fe4b88b110221d2f..d72396d09d1929aa58407806cce02e03cea32925 100644 (file)
@@ -12,19 +12,37 @@ packages:
   original:
     hackage: rope-utf16-splay-0.3.1.0
 - completed:
-    hackage: haskell-lsp-0.16.0.0@sha256:6ac4b58e6caef43546a3c115f1aaaae0e23d30f0e37b8c4e94525468e9982d09,5264
+    size: 86224
+    subdir: .
+    url: https://github.com/alanz/haskell-lsp/archive/2aacc5ca706bcce111e976a1af4a95a376137c5e.tar.gz
+    cabal-file:
+      size: 5264
+      sha256: ddfcc2798f04bcb1ec20fafc02c03faa197322192578e879cef5852aba43ebcb
+    name: haskell-lsp
+    version: 0.17.0.0
+    sha256: fbbc3ebdbb2c0f6eacdb9f3c8a3550e71617aff9df279da175c8b99c422ddeb9
     pantry-tree:
-      size: 1725
-      sha256: 31b245f4da5b5b844be9802bb2bfd397c90c0a50b063e5bae26648c6220aaf7f
+      size: 5675
+      sha256: 80539460483f0459786fce73d842b203eef003fd1c657281daec8aea2957db3f
   original:
-    hackage: haskell-lsp-0.16.0.0
+    subdir: .
+    url: https://github.com/alanz/haskell-lsp/archive/2aacc5ca706bcce111e976a1af4a95a376137c5e.tar.gz
 - completed:
-    hackage: haskell-lsp-types-0.16.0.0@sha256:57729b32b1ca65d4869e1e518fa4df749d4488ec5f11e23b50c2b89417f5f211,2882
+    size: 86224
+    subdir: haskell-lsp-types
+    url: https://github.com/alanz/haskell-lsp/archive/2aacc5ca706bcce111e976a1af4a95a376137c5e.tar.gz
+    cabal-file:
+      size: 2941
+      sha256: 9078237412d0596a7d09d432389c8fa21d6f3e21ed2ed761b3093a21607d6c28
+    name: haskell-lsp-types
+    version: 0.17.0.0
+    sha256: fbbc3ebdbb2c0f6eacdb9f3c8a3550e71617aff9df279da175c8b99c422ddeb9
     pantry-tree:
-      size: 2369
-      sha256: cc24c23f741e777b9c01ccd700af034e2258e560f5fdb271d08befd4b03196b7
+      size: 2501
+      sha256: a575ce26976bd31d34a9db27e20e8e34d9b50b8d2e34a2e3772b3236b8cf778c
   original:
-    hackage: haskell-lsp-types-0.16.0.0
+    subdir: haskell-lsp-types
+    url: https://github.com/alanz/haskell-lsp/archive/2aacc5ca706bcce111e976a1af4a95a376137c5e.tar.gz
 snapshots:
 - completed:
     size: 499889
index 75e16283b49895b6dae4eee1737c7dc92a5acf50..d689bff411e53a6603c9812f46ba62825ebe87c6 100644 (file)
@@ -118,7 +118,7 @@ main = hspec $ do
               selector _ = False
               sesh = do
                 doc <- openDoc "Desktop/simple.hs" "haskell"
-                sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
+                sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
                 skipMany anyNotification
                 message :: Session RenameResponse -- the wrong type
             in runSession "hie" fullCaps "test/data/renamePass" sesh
@@ -154,7 +154,7 @@ main = hspec $ do
         let args = toJSON $ AOP (doc ^. uri)
                                 (Position 1 14)
                                 "Redundant bracket"
-            reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
+            reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
         request_ WorkspaceExecuteCommand reqParams
 
         editReq <- message :: Session ApplyWorkspaceEditRequest
@@ -177,7 +177,7 @@ main = hspec $ do
         let args = toJSON $ AOP (doc ^. uri)
                                 (Position 1 14)
                                 "Redundant bracket"
-            reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
+            reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
         request_ WorkspaceExecuteCommand reqParams
         contents <- getDocumentEdit doc
         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"