+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
import Control.Monad.IO.Class
import Control.Monad
import Control.Lens hiding (List)
-import GHC.Generics
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Test
-import Language.Haskell.LSP.Test.Replay
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens as LSP hiding
+import Language.LSP.Test
+import Language.LSP.Types
+import Language.LSP.Types.Lens hiding
(capabilities, message, rename, applyEdit)
-import Language.Haskell.LSP.Types.Capabilities as LSP
+import qualified Language.LSP.Types.Lens as LSP
+import Language.LSP.Types.Capabilities as LSP
import System.Directory
import System.FilePath
import System.Timeout
+import Data.Type.Equality
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
{-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
-- won't receive a request - will timeout
-- incoming logging requests shouldn't increase the
-- timeout
- withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
+ withTimeout 5 $ skipManyTill anyMessage (message SWorkspaceApplyEdit)
-- wait just a bit longer than 5 seconds so we have time
-- to open the document
in timeout 6000000 sesh `shouldThrow` anySessionException
withTimeout 10 $ liftIO $ threadDelay 7000000
getDocumentSymbols doc
-- should now timeout
- skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
+ skipManyTill anyMessage (message SWorkspaceApplyEdit)
isTimeout (Timeout _) = True
isTimeout _ = False
in sesh `shouldThrow` isTimeout
it "throw on time out" $
let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do
skipMany loggingNotification
- _ <- message :: Session ApplyWorkspaceEditRequest
+ _ <- message SWorkspaceApplyEdit
return ()
in sesh `shouldThrow` anySessionException
describe "UnexpectedMessageException" $ do
it "throws when there's an unexpected message" $
- let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
+ let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SWindowLogMessage _)) = True
selector _ = False
in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
it "provides the correct types that were expected and received" $
- let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
+ let selector (UnexpectedMessage "Response for: STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True
selector _ = False
sesh = do
doc <- openDoc "Desktop/simple.hs" "haskell"
- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
+ sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)
skipMany anyNotification
- message :: Session RenameResponse -- the wrong type
+ response STextDocumentRename -- the wrong type
in runSession serverExe fullCaps "test/data/renamePass" sesh
`shouldThrow` selector
- describe "replaySession" $
- -- This is too fickle at the moment
- -- it "passes a test" $
- -- replaySession serverExe "test/data/renamePass"
- it "fails a test" $
- let selector (ReplayOutOfOrder _ _) = True
- selector _ = False
- in replaySession serverExe "test/data/renameFail" `shouldThrow` selector
-
- -- describe "manual javascript session" $
- -- it "passes a test" $
- -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
- -- doc <- openDoc "test.js" "javascript"
-
- -- noDiagnostics
-
- -- Right (fooSymbol:_) <- getDocumentSymbols doc
-
- -- liftIO $ do
- -- fooSymbol ^. name `shouldBe` "foo"
- -- fooSymbol ^. kind `shouldBe` SkFunction
-
describe "text document VFS" $
it "sends back didChange notifications" $
runSession serverExe def "test/data/refactor" $ do
doc <- openDoc "Main.hs" "haskell"
let args = toJSON (doc ^. uri)
- reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
- request_ WorkspaceExecuteCommand reqParams
+ reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
+ request_ SWorkspaceExecuteCommand reqParams
- editReq <- message :: Session ApplyWorkspaceEditRequest
+ editReq <- message SWorkspaceApplyEdit
liftIO $ do
let (Just cs) = editReq ^. params . edit . changes
[(u, List es)] = HM.toList cs
doc <- openDoc "Main.hs" "haskell"
let args = toJSON (doc ^. uri)
- reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
- request_ WorkspaceExecuteCommand reqParams
+ reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
+ request_ SWorkspaceExecuteCommand reqParams
contents <- getDocumentEdit doc
liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
- -- describe "getCodeActions" $
- -- it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
- -- doc <- openDoc "Main.hs" "haskell"
- -- waitForDiagnostics
- -- [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
- -- liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
+ describe "getCodeActions" $
+ it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
+ doc <- openDoc "Main.hs" "haskell"
+ waitForDiagnostics
+ [InR action] <- getCodeActions doc (Range (Position 0 0) (Position 0 2))
+ actions <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
+ liftIO $ action ^. title `shouldBe` "Delete this"
+ liftIO $ actions `shouldSatisfy` null
describe "getAllCodeActions" $
it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
_ <- waitForDiagnostics
actions <- getAllCodeActions doc
liftIO $ do
- let [CACodeAction action] = actions
+ let [InR action] = actions
action ^. title `shouldBe` "Delete this"
action ^. command . _Just . command `shouldBe` "deleteThis"
- -- describe "getDocumentSymbols" $
- -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
- -- doc <- openDoc "Desktop/simple.hs" "haskell"
-
- -- skipMany loggingNotification
+ describe "getDocumentSymbols" $
+ it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
+ doc <- openDoc "Desktop/simple.hs" "haskell"
- -- noDiagnostics
+ skipMany loggingNotification
- -- Left (mainSymbol:_) <- getDocumentSymbols doc
+ Left (mainSymbol:_) <- getDocumentSymbols doc
- -- liftIO $ do
- -- mainSymbol ^. name `shouldBe` "main"
- -- mainSymbol ^. kind `shouldBe` SkFunction
- -- mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
+ liftIO $ do
+ mainSymbol ^. name `shouldBe` "foo"
+ mainSymbol ^. kind `shouldBe` SkObject
+ mainSymbol ^. range `shouldBe` mkRange 0 0 3 6
describe "applyEdit" $ do
it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do
contents <- documentContents doc
liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
- -- describe "getCompletions" $
- -- it "works" $ runSession serverExe def "test/data/renamePass" $ do
- -- doc <- openDoc "Desktop/simple.hs" "haskell"
-
- -- -- wait for module to be loaded
- -- skipMany loggingNotification
- -- noDiagnostics
- -- noDiagnostics
+ describe "getCompletions" $
+ it "works" $ runSession serverExe def "test/data/renamePass" $ do
+ doc <- openDoc "Desktop/simple.hs" "haskell"
- -- comps <- getCompletions doc (Position 5 5)
- -- let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
- -- liftIO $ do
- -- item ^. label `shouldBe` "interactWithUser"
- -- item ^. kind `shouldBe` Just CiFunction
- -- item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
+ comps <- getCompletions doc (Position 5 5)
+ let item = head comps
+ liftIO $ item ^. label `shouldBe` "foo"
-- describe "getReferences" $
-- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
-- defs <- getTypeDefinitions doc pos
-- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
- -- describe "waitForDiagnosticsSource" $
- -- it "works" $ runSession serverExe fullCaps "test/data" $ do
- -- openDoc "Error.hs" "haskell"
- -- [diag] <- waitForDiagnosticsSource "bios"
- -- liftIO $ do
- -- diag ^. severity `shouldBe` Just DsError
- -- diag ^. source `shouldBe` Just "bios"
+ describe "waitForDiagnosticsSource" $
+ it "works" $ runSession serverExe fullCaps "test/data" $ do
+ openDoc "Error.hs" "haskell"
+ [diag] <- waitForDiagnosticsSource "dummy-server"
+ liftIO $ do
+ diag ^. severity `shouldBe` Just DsWarning
+ diag ^. source `shouldBe` Just "dummy-server"
-- describe "rename" $ do
-- it "works" $ pendingWith "HaRe not in hie-bios yet"
-- rename doc (Position 2 11) "bar"
-- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
- -- describe "getHover" $
- -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
- -- doc <- openDoc "Desktop/simple.hs" "haskell"
- -- hover <- getHover doc (Position 45 9)
- -- liftIO $ hover `shouldSatisfy` isJust
+ describe "getHover" $
+ it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
+ doc <- openDoc "Desktop/simple.hs" "haskell"
+ hover <- getHover doc (Position 45 9)
+ liftIO $ hover `shouldSatisfy` isJust
-- describe "getHighlights" $
-- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
describe "satisfy" $
it "works" $ runSession serverExe fullCaps "test/data" $ do
openDoc "Format.hs" "haskell"
- let pred (NotLogMessage _) = True
+ let pred (FromServerMess SWindowLogMessage _) = True
pred _ = False
void $ satisfy pred
openDoc "Format.hs" "haskell"
void publishDiagnosticsNotification
-mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
+ describe "dynamic capabilities" $ do
+
+ it "keeps track" $ runSession serverExe fullCaps "test/data" $ do
+ loggingNotification -- initialized log message
+
+ createDoc ".register" "haskell" ""
+ message SClientRegisterCapability
+
+ doc <- createDoc "Foo.watch" "haskell" ""
+ msg <- message SWindowLogMessage
+ liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
+
+ [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities
+ liftIO $ do
+ case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of
+ Just HRefl ->
+ regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List
+ [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ])
+ Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles"
+
+ -- now unregister it by sending a specific createDoc
+ createDoc ".unregister" "haskell" ""
+ message SClientUnregisterCapability
+
+ createDoc "Bar.watch" "haskell" ""
+ void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
+ count 0 $ loggingNotification
+ void $ anyResponse
+
+ it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do
+ curDir <- liftIO $ getCurrentDirectory
+
+ loggingNotification -- initialized log message
+
+ createDoc ".register.abs" "haskell" ""
+ message SClientRegisterCapability
+
+ doc <- createDoc (curDir </> "Foo.watch") "haskell" ""
+ msg <- message SWindowLogMessage
+ liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
+
+ -- now unregister it by sending a specific createDoc
+ createDoc ".unregister.abs" "haskell" ""
+ message SClientUnregisterCapability
+
+ createDoc (curDir </> "Bar.watch") "haskell" ""
+ void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
+ count 0 $ loggingNotification
+ void $ anyResponse
+
didChangeCaps :: ClientCapabilities
didChangeCaps = def { _workspace = Just workspaceCaps }
docChangesCaps = def { _workspace = Just workspaceCaps }
where
workspaceCaps = def { _workspaceEdit = Just editCaps }
- editCaps = WorkspaceEditClientCapabilities (Just True)
+ editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing
findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)