From ddc2cdb9d0563dcf30102c8ef41dc6932717a872 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 6 May 2020 15:41:28 +0100 Subject: [PATCH] Use a dummy server for testing Not tied to HIE anymore --- .github/workflows/haskell.yml | 46 +---- .gitignore | 1 + cabal.project | 3 + lsp-test.cabal | 22 +++ test/Test.hs | 335 +++++++++++++++++----------------- test/dummy-server/Main.hs | 78 ++++++++ 6 files changed, 278 insertions(+), 207 deletions(-) create mode 100644 cabal.project create mode 100644 test/dummy-server/Main.hs diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 77048ed..10e82d8 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -6,17 +6,14 @@ jobs: runs-on: ${{ matrix.os }} - env: - hieref: d9d21fb0675280e20e837dbeb5715dab65e9c6be - strategy: fail-fast: false matrix: - ghc: ['8.8.3', '8.6.5', '8.4.4'] + ghc: ['8.10.1', '8.8.3', '8.6.5', '8.4.4'] os: [ubuntu-latest, macOS-latest, windows-latest] - exclude: - - os: macOS-latest - ghc: '8.4.4' # fails due to ghc panic + # exclude: + # - os: macOS-latest + # ghc: '8.4.4' # fails due to ghc panic steps: - uses: actions/checkout@v1 @@ -26,46 +23,15 @@ jobs: cabal-version: '3.0' - run: cabal update - - name: Clone HIE - uses: actions/checkout@v1 - with: - repository: haskell/haskell-ide-engine - submodules: recursive - ref: ${{ env.hieref }} - path: haskell-ide-engine - - name: Cache Cabal uses: actions/cache@v1.1.0 with: path: ~/.cabal - key: ${{ runner.OS }}-${{ matrix.ghc }}-cabal-${{ env.hieref }} + key: ${{ runner.OS }}-${{ matrix.ghc }}-cabal restore-keys: | ${{ runner.OS }}-${{ matrix.ghc }}-cabal - - name: Cache Hoogle - uses: actions/cache@v1.1.0 - with: - path: ~/.hoogle - key: ${{ runner.OS }}-${{ matrix.ghc }}-hoogle-${{ env.hieref }} - - - name: Build HIE - run: | - pushd ../haskell-ide-engine - cabal install hie - cabal install hoogle - popd - - name: Generate hoogle database - run: | - if [ -d $HOME/.hoogle ]; then - echo "hoogle database already built" - exit 0 - fi - hoogle generate - - name: Install JS Language Server - run: npm install javascript-typescript-langserver - name: Build run: cabal build - name: Test - run: | - export PATH=$PATH:$(npm bin) - cabal test + run: cabal test diff --git a/.gitignore b/.gitignore index 223787e..2e1608d 100644 --- a/.gitignore +++ b/.gitignore @@ -19,3 +19,4 @@ example/.ghc.environment.* # downloaded by .download-hie.sh on travis hie +.hie \ No newline at end of file diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..9b493ab --- /dev/null +++ b/cabal.project @@ -0,0 +1,3 @@ +packages: . +flags: DummyServer +test-show-details: direct \ No newline at end of file diff --git a/lsp-test.cabal b/lsp-test.cabal index c6d543c..17f78b0 100644 --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -26,6 +26,11 @@ source-repository head type: git location: https://github.com/bubba/lsp-test/ +Flag DummyServer + Description: Build the dummy server executable used in testing + Default: False + Manual: True + library hs-source-dirs: src exposed-modules: Language.Haskell.LSP.Test @@ -69,6 +74,20 @@ library Language.Haskell.LSP.Test.Session ghc-options: -W +executable dummy-server + main-is: Main.hs + hs-source-dirs: test/dummy-server + ghc-options: -W + build-depends: base >= 4.10 && < 5 + , haskell-lsp + , data-default + , aeson + , unordered-containers + default-language: Haskell2010 + scope: private + if !flag(DummyServer) + buildable: False + test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs @@ -83,4 +102,7 @@ test-suite tests , aeson , unordered-containers , text + , directory + , filepath default-language: Haskell2010 + build-tool-depends: lsp-test:dummy-server diff --git a/test/Test.hs b/test/Test.hs index e38af42..4cffda3 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -23,29 +23,31 @@ import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens as LSP hiding (capabilities, message, rename, applyEdit) import Language.Haskell.LSP.Types.Capabilities as LSP +import System.Directory +import System.FilePath import System.Timeout {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} -main = hspec $ do + +main = findServer >>= \serverExe -> hspec $ do describe "Session" $ do - it "fails a test" $ - let session = runSession "hie" fullCaps "test/data/renamePass" $ do + it "fails a test" $ do + let session = runSession serverExe fullCaps "test/data/renamePass" $ do openDoc "Desktop/simple.hs" "haskell" - skipMany loggingNotification anyRequest in session `shouldThrow` anySessionException - it "initializeResponse" $ runSession "hie" fullCaps "test/data/renamePass" $ do + it "initializeResponse" $ runSession serverExe fullCaps "test/data/renamePass" $ do rsp <- initializeResponse - liftIO $ rsp ^. result `shouldSatisfy` isLeft + liftIO $ rsp ^. result `shouldSatisfy` isRight it "runSessionWithConfig" $ - runSession "hie" didChangeCaps "test/data/renamePass" $ return () + runSession serverExe didChangeCaps "test/data/renamePass" $ return () describe "withTimeout" $ do it "times out" $ - let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do + let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do openDoc "Desktop/simple.hs" "haskell" -- won't receive a request - will timeout -- incoming logging requests shouldn't increase the @@ -56,15 +58,13 @@ main = hspec $ do in timeout 6000000 sesh `shouldThrow` anySessionException it "doesn't time out" $ - let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do + let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do openDoc "Desktop/simple.hs" "haskell" withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification in void $ timeout 6000000 sesh - it "further timeout messages are ignored" $ runSession "hie" fullCaps "test/data/renamePass" $ do + it "further timeout messages are ignored" $ runSession serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" - -- warm up the cache - getDocumentSymbols doc -- shouldn't timeout withTimeout 3 $ getDocumentSymbols doc -- longer than the original timeout @@ -75,7 +75,7 @@ main = hspec $ do it "overrides global message timeout" $ let sesh = - runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do + runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000 @@ -85,7 +85,7 @@ main = hspec $ do it "unoverrides global message timeout" $ let sesh = - runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do + runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000 @@ -99,15 +99,15 @@ main = hspec $ do describe "SessionException" $ do it "throw on time out" $ - let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie" fullCaps "test/data/renamePass" $ do + let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do skipMany loggingNotification _ <- message :: Session ApplyWorkspaceEditRequest return () in sesh `shouldThrow` anySessionException - it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do + it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) serverExe fullCaps "test/data/renamePass" $ do loggingNotification - liftIO $ threadDelay $ 10 * 1000000 + liftIO $ threadDelay $ 6 * 1000000 _ <- openDoc "Desktop/simple.hs" "haskell" return () @@ -115,7 +115,7 @@ main = hspec $ do it "throws when there's an unexpected message" $ let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True selector _ = False - in runSession "hie" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector + 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 selector _ = False @@ -124,40 +124,38 @@ main = hspec $ do sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) skipMany anyNotification message :: Session RenameResponse -- the wrong type - in runSession "hie" fullCaps "test/data/renamePass" sesh + in runSession serverExe fullCaps "test/data/renamePass" sesh `shouldThrow` selector describe "replaySession" $ -- This is too fickle at the moment -- it "passes a test" $ - -- replaySession "hie" "test/data/renamePass" + -- replaySession serverExe "test/data/renamePass" it "fails a test" $ let selector (ReplayOutOfOrder _ _) = True selector _ = False - in replaySession "hie" "test/data/renameFail" `shouldThrow` selector + 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" + -- describe "manual javascript session" $ + -- it "passes a test" $ + -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do + -- doc <- openDoc "test.js" "javascript" - noDiagnostics + -- noDiagnostics - Right (fooSymbol:_) <- getDocumentSymbols doc + -- Right (fooSymbol:_) <- getDocumentSymbols doc - liftIO $ do - fooSymbol ^. name `shouldBe` "foo" - fooSymbol ^. kind `shouldBe` SkFunction + -- liftIO $ do + -- fooSymbol ^. name `shouldBe` "foo" + -- fooSymbol ^. kind `shouldBe` SkFunction describe "text document VFS" $ it "sends back didChange notifications" $ - runSession "hie" def "test/data/refactor" $ do + runSession serverExe def "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" - let args = toJSON $ AOP (doc ^. uri) - (Position 1 14) - "Redundant bracket" - reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing + let args = toJSON (doc ^. uri) + reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing request_ WorkspaceExecuteCommand reqParams editReq <- message :: Session ApplyWorkspaceEditRequest @@ -165,169 +163,156 @@ main = hspec $ do let (Just cs) = editReq ^. params . edit . changes [(u, List es)] = HM.toList cs u `shouldBe` doc ^. uri - es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"] - - noDiagnostics - + es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"] contents <- documentContents doc - liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n" + liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" describe "getDocumentEdit" $ it "automatically consumes applyedit requests" $ - runSession "hie" fullCaps "test/data/refactor" $ do + runSession serverExe fullCaps "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" - let args = toJSON $ AOP (doc ^. uri) - (Position 1 14) - "Redundant bracket" - reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing + let args = toJSON (doc ^. uri) + reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing request_ WorkspaceExecuteCommand reqParams contents <- getDocumentEdit doc - liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n" - noDiagnostics + liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" - describe "getCodeActions" $ - it "works" $ runSession "hie" 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 + -- [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) + -- liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket" describe "getAllCodeActions" $ - it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do + it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" _ <- waitForDiagnostics actions <- getAllCodeActions doc liftIO $ do let [CACodeAction action] = actions - action ^. title `shouldBe` "Apply hint:Redundant bracket" - action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne" + action ^. title `shouldBe` "Delete this" + action ^. command . _Just . command `shouldBe` "deleteThis" - describe "getDocumentSymbols" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" + -- describe "getDocumentSymbols" $ + -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" - skipMany loggingNotification + -- skipMany loggingNotification - noDiagnostics + -- noDiagnostics - 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` "main" + -- mainSymbol ^. kind `shouldBe` SkFunction + -- mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30) describe "applyEdit" $ do - it "increments the version" $ runSession "hie" docChangesCaps "test/data/renamePass" $ do + it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo" VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit liftIO $ newVersion `shouldBe` oldVersion + 1 - it "changes the document contents" $ runSession "hie" fullCaps "test/data/renamePass" $ do + it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo" applyEdit doc edit contents <- documentContents doc liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule" - describe "getCompletions" $ - it "works" $ runSession "hie" def "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - - -- wait for module to be loaded - skipMany loggingNotification - noDiagnostics - noDiagnostics - - 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" - - describe "getReferences" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - let pos = Position 40 3 -- interactWithUser - uri = doc ^. LSP.uri - refs <- getReferences doc pos True - liftIO $ refs `shouldContain` map (Location uri) [ - mkRange 41 0 41 16 - , mkRange 75 6 75 22 - , mkRange 71 6 71 22 - ] - - describe "getDefinitions" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - let pos = Position 49 25 -- addItem - defs <- getDefinitions doc pos - liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)] - - describe "getTypeDefinitions" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - let pos = Position 20 23 -- Quit value - defs <- getTypeDefinitions doc pos - liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition - - describe "waitForDiagnosticsSource" $ - it "works" $ runSession "hie" fullCaps "test/data" $ do - openDoc "Error.hs" "haskell" - [diag] <- waitForDiagnosticsSource "bios" - liftIO $ do - diag ^. severity `shouldBe` Just DsError - diag ^. source `shouldBe` Just "bios" - - describe "rename" $ do - it "works" $ pendingWith "HaRe not in hie-bios yet" - it "works on javascript" $ - runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do - doc <- openDoc "test.js" "javascript" - rename doc (Position 2 11) "bar" - documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack - - -- runSession "hie" fullCaps "test/data" $ do - -- doc <- openDoc "Rename.hs" "haskell" - -- rename doc (Position 1 0) "bar" - -- documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n" - - describe "getHover" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - -- hover returns nothing until module is loaded - skipManyTill loggingNotification $ count 2 noDiagnostics - hover <- getHover doc (Position 45 9) -- putStrLn - liftIO $ hover `shouldSatisfy` isJust - - describe "getHighlights" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - skipManyTill loggingNotification $ count 2 noDiagnostics - highlights <- getHighlights doc (Position 27 4) -- addItem - liftIO $ length highlights `shouldBe` 4 - - describe "formatDoc" $ - it "works" $ runSession "hie" fullCaps "test/data" $ do - doc <- openDoc "Format.hs" "haskell" - oldContents <- documentContents doc - formatDoc doc (FormattingOptions 4 True) - documentContents doc >>= liftIO . (`shouldNotBe` oldContents) - - describe "formatRange" $ - it "works" $ runSession "hie" fullCaps "test/data" $ do - doc <- openDoc "Format.hs" "haskell" - oldContents <- documentContents doc - formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10)) - documentContents doc >>= liftIO . (`shouldNotBe` oldContents) + -- 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 + + -- 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" + + -- describe "getReferences" $ + -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- let pos = Position 40 3 -- interactWithUser + -- uri = doc ^. LSP.uri + -- refs <- getReferences doc pos True + -- liftIO $ refs `shouldContain` map (Location uri) [ + -- mkRange 41 0 41 16 + -- , mkRange 75 6 75 22 + -- , mkRange 71 6 71 22 + -- ] + + -- describe "getDefinitions" $ + -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- let pos = Position 49 25 -- addItem + -- defs <- getDefinitions doc pos + -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)] + + -- describe "getTypeDefinitions" $ + -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- let pos = Position 20 23 -- Quit value + -- 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 "rename" $ do + -- it "works" $ pendingWith "HaRe not in hie-bios yet" + -- it "works on javascript" $ + -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do + -- doc <- openDoc "test.js" "javascript" + -- 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 "getHighlights" $ + -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- skipManyTill loggingNotification $ count 2 noDiagnostics + -- highlights <- getHighlights doc (Position 27 4) -- addItem + -- liftIO $ length highlights `shouldBe` 4 + + -- describe "formatDoc" $ + -- it "works" $ runSession serverExe fullCaps "test/data" $ do + -- doc <- openDoc "Format.hs" "haskell" + -- oldContents <- documentContents doc + -- formatDoc doc (FormattingOptions 4 True) + -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents) + + -- describe "formatRange" $ + -- it "works" $ runSession serverExe fullCaps "test/data" $ do + -- doc <- openDoc "Format.hs" "haskell" + -- oldContents <- documentContents doc + -- formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10)) + -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents) describe "closeDoc" $ it "works" $ let sesh = - runSession "hie" fullCaps "test/data" $ do + runSession serverExe fullCaps "test/data" $ do doc <- openDoc "Format.hs" "haskell" closeDoc doc -- need to evaluate to throw @@ -335,7 +320,7 @@ main = hspec $ do in sesh `shouldThrow` anyException describe "satisfy" $ - it "works" $ runSession "hie" fullCaps "test/data" $ do + it "works" $ runSession serverExe fullCaps "test/data" $ do openDoc "Format.hs" "haskell" let pred (NotLogMessage _) = True pred _ = False @@ -343,7 +328,7 @@ main = hspec $ do describe "ignoreLogNotifications" $ it "works" $ - runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) "hie" fullCaps "test/data" $ do + runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do openDoc "Format.hs" "haskell" void publishDiagnosticsNotification @@ -361,8 +346,24 @@ docChangesCaps = def { _workspace = Just workspaceCaps } workspaceCaps = def { _workspaceEdit = Just editCaps } editCaps = WorkspaceEditClientCapabilities (Just True) -data ApplyOneParams = AOP - { file :: Uri - , start_pos :: Position - , hintTitle :: String - } deriving (Generic, ToJSON) + +findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath) +findExeRecursive exe dir = do + me <- listToMaybe <$> findExecutablesInDirectories [dir] exe + case me of + Just e -> return (Just e) + Nothing -> do + subdirs <- (fmap (dir )) <$> listDirectory dir >>= filterM doesDirectoryExist + foldM (\acc subdir -> case acc of + Just y -> pure $ Just y + Nothing -> findExeRecursive exe subdir) + Nothing + subdirs + +-- | So we can find the dummy-server with cabal run +-- since it doesnt put build tools on the path (only cabal test) +findServer = do + let serverName = "dummy-server" + e <- findExecutable serverName + e' <- findExeRecursive serverName "dist-newstyle" + pure $ fromJust $ e <|> e' \ No newline at end of file diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs new file mode 100644 index 0000000..f67b043 --- /dev/null +++ b/test/dummy-server/Main.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Aeson +import Data.Default +import qualified Data.HashMap.Strict as HM +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Control +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Control.Concurrent +import Control.Monad + +main = do + lfvar <- newEmptyMVar + let initCbs = InitializeCallbacks + { onInitialConfiguration = const $ Right () + , onConfigurationChange = const $ Right () + , onStartup = \lf -> do + putMVar lfvar lf + + return Nothing + } + options = def + { executeCommandCommands = Just ["doAnEdit"] + } + run initCbs (handlers lfvar) options Nothing + +handlers :: MVar (LspFuncs ()) -> Handlers +handlers lfvar = def + { initializedHandler = pure $ \_ -> send $ NotLogMessage $ fmServerLogMessageNotification MtLog "initialized" + , hoverHandler = pure $ \req -> send $ + RspHover $ makeResponseMessage req (Just (Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing)) + , documentSymbolHandler = pure $ \req -> send $ + RspDocumentSymbols $ makeResponseMessage req $ DSDocumentSymbols $ + List [ DocumentSymbol "foo" + Nothing + SkObject + Nothing + (Range (Position 0 0) (Position 0 1)) + (Range (Position 0 0) (Position 0 1)) + Nothing + ] + , didOpenTextDocumentNotificationHandler = pure $ \noti -> + void $ forkIO $ do + threadDelay (2 * 10^6) + let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti + TextDocumentItem uri _ _ _ = doc + diag = Diagnostic (Range (Position 0 0) (Position 0 1)) + (Just DsWarning) + (Just (NumberValue 42)) + (Just "dummy-server") + "Here's a warning" + Nothing + Nothing + send $ NotPublishDiagnostics $ + fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag] + , executeCommandHandler = pure $ \req -> do + send $ RspExecuteCommand $ makeResponseMessage req Null + reqId <- readMVar lfvar >>= getNextReqId + let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req + Success docUri = fromJSON val + edit = List [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"] + send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $ + ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit)) + Nothing + , codeActionHandler = pure $ \req -> do + let RequestMessage _ _ _ params = req + CodeActionParams _ _ cactx _ = params + CodeActionContext diags _ = cactx + caresults = fmap diag2caresult diags + diag2caresult d = CACodeAction $ + CodeAction "Delete this" + Nothing + (Just (List [d])) + Nothing + (Just (Command "" "deleteThis" Nothing)) + send $ RspCodeAction $ makeResponseMessage req caresults + } + where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg -- 2.30.2