test/Test.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE DeriveAnyClass #-}
   5
   6 import           Test.Hspec
   7 import           Data.Aeson
   8 import           Data.Default
   9 import qualified Data.HashMap.Strict as HM
  10 import           Data.Either
  11 import           Data.List (sortOn)
  12 import           Data.Maybe
  13 import qualified Data.Text as T
  14 import           Control.Applicative.Combinators
  15 import           Control.Concurrent
  16 import           Control.Exception (finally)
  17 import           Control.Monad.IO.Class
  18 import           Control.Monad
  19 import           Control.Lens hiding (List)
  20 import           Language.Haskell.LSP.Messages
  21 import           Language.Haskell.LSP.Test
  22 import           Language.Haskell.LSP.Types
  23 import           Language.Haskell.LSP.Types.Lens hiding
  24   (capabilities, message, rename, applyEdit)
  25 import qualified Language.Haskell.LSP.Types.Lens as LSP
  26 import           Language.Haskell.LSP.Types.Capabilities as LSP
  27 import           System.Directory
  28 import           System.FilePath
  29 import           System.Timeout
  30
  31 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
  32 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
  33
  34
  35 main = findServer >>= \serverExe -> hspec $ do
  36   describe "Session" $ do
  37     it "fails a test" $ do
  38       let session = runSession serverExe fullCaps "test/data/renamePass" $ do
  39                       openDoc "Desktop/simple.hs" "haskell"
  40                       anyRequest
  41         in session `shouldThrow` anySessionException
  42     it "initializeResponse" $ runSession serverExe fullCaps "test/data/renamePass" $ do
  43       rsp <- initializeResponse
  44       liftIO $ rsp ^. result `shouldSatisfy` isRight
  45
  46     it "runSessionWithConfig" $
  47       runSession serverExe didChangeCaps "test/data/renamePass" $ return ()
  48
  49     describe "withTimeout" $ do
  50       it "times out" $
  51         let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
  52                     openDoc "Desktop/simple.hs" "haskell"
  53                     -- won't receive a request - will timeout
  54                     -- incoming logging requests shouldn't increase the
  55                     -- timeout
  56                     withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
  57           -- wait just a bit longer than 5 seconds so we have time
  58           -- to open the document
  59           in timeout 6000000 sesh `shouldThrow` anySessionException
  60
  61       it "doesn't time out" $
  62         let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
  63                     openDoc "Desktop/simple.hs" "haskell"
  64                     withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
  65           in void $ timeout 6000000 sesh
  66
  67       it "further timeout messages are ignored" $ runSession serverExe fullCaps "test/data/renamePass" $ do
  68         doc <- openDoc "Desktop/simple.hs" "haskell"
  69         -- shouldn't timeout
  70         withTimeout 3 $ getDocumentSymbols doc
  71         -- longer than the original timeout
  72         liftIO $ threadDelay (5 * 10^6)
  73         -- shouldn't throw an exception
  74         getDocumentSymbols doc
  75         return ()
  76
  77       it "overrides global message timeout" $
  78         let sesh =
  79               runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do
  80                 doc <- openDoc "Desktop/simple.hs" "haskell"
  81                 -- shouldn't time out in here since we are overriding it
  82                 withTimeout 10 $ liftIO $ threadDelay 7000000
  83                 getDocumentSymbols doc
  84                 return True
  85         in sesh `shouldReturn` True
  86
  87       it "unoverrides global message timeout" $
  88         let sesh =
  89               runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do
  90                 doc <- openDoc "Desktop/simple.hs" "haskell"
  91                 -- shouldn't time out in here since we are overriding it
  92                 withTimeout 10 $ liftIO $ threadDelay 7000000
  93                 getDocumentSymbols doc
  94                 -- should now timeout
  95                 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
  96             isTimeout (Timeout _) = True
  97             isTimeout _ = False
  98         in sesh `shouldThrow` isTimeout
  99
 100
 101     describe "SessionException" $ do
 102       it "throw on time out" $
 103         let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do
 104                 skipMany loggingNotification
 105                 _ <- message :: Session ApplyWorkspaceEditRequest
 106                 return ()
 107         in sesh `shouldThrow` anySessionException
 108
 109       it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) serverExe fullCaps "test/data/renamePass" $ do
 110         loggingNotification
 111         liftIO $ threadDelay $ 6 * 1000000
 112         _ <- openDoc "Desktop/simple.hs" "haskell"
 113         return ()
 114
 115       describe "UnexpectedMessageException" $ do
 116         it "throws when there's an unexpected message" $
 117           let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
 118               selector _ = False
 119             in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
 120         it "provides the correct types that were expected and received" $
 121           let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
 122               selector _ = False
 123               sesh = do
 124                 doc <- openDoc "Desktop/simple.hs" "haskell"
 125                 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
 126                 skipMany anyNotification
 127                 message :: Session RenameResponse -- the wrong type
 128             in runSession serverExe fullCaps "test/data/renamePass" sesh
 129               `shouldThrow` selector
 130
 131   -- This is too fickle at the moment
 132   -- describe "replaySession" $
 133   --   it "passes a test" $
 134   --     replaySession serverExe "test/data/renamePass"
 135   --   it "fails a test" $
 136   --     let selector (ReplayOutOfOrder _ _) = True
 137   --         selector _ = False
 138   --       in replaySession serverExe "test/data/renameFail" `shouldThrow` selector
 139
 140   -- describe "manual javascript session" $
 141   --   it "passes a test" $
 142   --     runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
 143   --       doc <- openDoc "test.js" "javascript"
 144
 145   --       noDiagnostics
 146
 147   --       Right (fooSymbol:_) <- getDocumentSymbols doc
 148
 149   --       liftIO $ do
 150   --         fooSymbol ^. name `shouldBe` "foo"
 151   --         fooSymbol ^. kind `shouldBe` SkFunction
 152
 153   describe "text document VFS" $
 154     it "sends back didChange notifications" $
 155       runSession serverExe def "test/data/refactor" $ do
 156         doc <- openDoc "Main.hs" "haskell"
 157
 158         let args = toJSON (doc ^. uri)
 159             reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
 160         request_ WorkspaceExecuteCommand reqParams
 161
 162         editReq <- message :: Session ApplyWorkspaceEditRequest
 163         liftIO $ do
 164           let (Just cs) = editReq ^. params . edit . changes
 165               [(u, List es)] = HM.toList cs
 166           u `shouldBe` doc ^. uri
 167           es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"]
 168         contents <- documentContents doc
 169         liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
 170
 171   describe "getDocumentEdit" $
 172     it "automatically consumes applyedit requests" $
 173       runSession serverExe fullCaps "test/data/refactor" $ do
 174         doc <- openDoc "Main.hs" "haskell"
 175
 176         let args = toJSON (doc ^. uri)
 177             reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
 178         request_ WorkspaceExecuteCommand reqParams
 179         contents <- getDocumentEdit doc
 180         liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
 181
 182   describe "getCodeActions" $
 183     it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
 184       doc <- openDoc "Main.hs" "haskell"
 185       waitForDiagnostics
 186       [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
 187       liftIO $ action ^. title `shouldBe` "Delete this"
 188
 189   describe "getAllCodeActions" $
 190     it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
 191       doc <- openDoc "Main.hs" "haskell"
 192       _ <- waitForDiagnostics
 193       actions <- getAllCodeActions doc
 194       liftIO $ do
 195         let [CACodeAction action] = actions
 196         action ^. title `shouldBe` "Delete this"
 197         action ^. command . _Just . command `shouldBe` "deleteThis"
 198
 199   describe "getDocumentSymbols" $
 200     it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 201       doc <- openDoc "Desktop/simple.hs" "haskell"
 202
 203       skipMany loggingNotification
 204
 205       Left (mainSymbol:_) <- getDocumentSymbols doc
 206
 207       liftIO $ do
 208         mainSymbol ^. name `shouldBe` "foo"
 209         mainSymbol ^. kind `shouldBe` SkObject
 210         mainSymbol ^. range `shouldBe` mkRange 0 0 3 6
 211
 212   describe "applyEdit" $ do
 213     it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do
 214       doc <- openDoc "Desktop/simple.hs" "haskell"
 215       VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
 216       let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
 217       VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
 218       liftIO $ newVersion `shouldBe` oldVersion + 1
 219     it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 220       doc <- openDoc "Desktop/simple.hs" "haskell"
 221       let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
 222       applyEdit doc edit
 223       contents <- documentContents doc
 224       liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
 225
 226   -- describe "getCompletions" $
 227   --   it "works" $ runSession serverExe def "test/data/renamePass" $ do
 228   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 229
 230   --     -- wait for module to be loaded
 231   --     skipMany loggingNotification
 232   --     noDiagnostics
 233   --     noDiagnostics
 234
 235   --     comps <- getCompletions doc (Position 5 5)
 236   --     let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
 237   --     liftIO $ do
 238   --       item ^. label `shouldBe` "interactWithUser"
 239   --       item ^. kind `shouldBe` Just CiFunction
 240   --       item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
 241
 242   -- describe "getReferences" $
 243   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 244   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 245   --     let pos = Position 40 3 -- interactWithUser
 246   --         uri = doc ^. LSP.uri
 247   --     refs <- getReferences doc pos True
 248   --     liftIO $ refs `shouldContain` map (Location uri) [
 249   --         mkRange 41 0 41 16
 250   --       , mkRange 75 6 75 22
 251   --       , mkRange 71 6 71 22
 252   --       ]
 253
 254   -- describe "getDefinitions" $
 255   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 256   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 257   --     let pos = Position 49 25 -- addItem
 258   --     defs <- getDefinitions doc pos
 259   --     liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
 260
 261   -- describe "getTypeDefinitions" $
 262   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 263   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 264   --     let pos = Position 20 23  -- Quit value
 265   --     defs <- getTypeDefinitions doc pos
 266   --     liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)]  -- Type definition
 267
 268   describe "waitForDiagnosticsSource" $
 269     it "works" $ runSession serverExe fullCaps "test/data" $ do
 270       openDoc "Error.hs" "haskell"
 271       [diag] <- waitForDiagnosticsSource "dummy-server"
 272       liftIO $ do
 273         diag ^. severity `shouldBe` Just DsWarning
 274         diag ^. source `shouldBe` Just "dummy-server"
 275
 276   -- describe "rename" $ do
 277   --   it "works" $ pendingWith "HaRe not in hie-bios yet"
 278   --   it "works on javascript" $
 279   --     runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
 280   --       doc <- openDoc "test.js" "javascript"
 281   --       rename doc (Position 2 11) "bar"
 282   --       documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
 283
 284   describe "getHover" $
 285     it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 286       doc <- openDoc "Desktop/simple.hs" "haskell"
 287       hover <- getHover doc (Position 45 9)
 288       liftIO $ hover `shouldSatisfy` isJust
 289
 290   -- describe "getHighlights" $
 291   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 292   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 293   --     skipManyTill loggingNotification $ count 2 noDiagnostics
 294   --     highlights <- getHighlights doc (Position 27 4) -- addItem
 295   --     liftIO $ length highlights `shouldBe` 4
 296
 297   -- describe "formatDoc" $
 298   --   it "works" $ runSession serverExe fullCaps "test/data" $ do
 299   --     doc <- openDoc "Format.hs" "haskell"
 300   --     oldContents <- documentContents doc
 301   --     formatDoc doc (FormattingOptions 4 True)
 302   --     documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 303
 304   -- describe "formatRange" $
 305   --   it "works" $ runSession serverExe fullCaps "test/data" $ do
 306   --     doc <- openDoc "Format.hs" "haskell"
 307   --     oldContents <- documentContents doc
 308   --     formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
 309   --     documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 310
 311   describe "closeDoc" $
 312     it "works" $
 313       let sesh =
 314             runSession serverExe fullCaps "test/data" $ do
 315               doc <- openDoc "Format.hs" "haskell"
 316               closeDoc doc
 317               -- need to evaluate to throw
 318               documentContents doc >>= liftIO . print
 319       in sesh `shouldThrow` anyException
 320
 321   describe "satisfy" $
 322     it "works" $ runSession serverExe fullCaps "test/data" $ do
 323       openDoc "Format.hs" "haskell"
 324       let pred (NotLogMessage _) = True
 325           pred _ = False
 326       void $ satisfy pred
 327
 328   describe "ignoreLogNotifications" $
 329     it "works" $
 330       runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe  fullCaps "test/data" $ do
 331         openDoc "Format.hs" "haskell"
 332         void publishDiagnosticsNotification
 333
 334   describe "dynamic capabilities" $ do
 335     it "keeps track" $ runSession serverExe fullCaps "test/data" $ do
 336       loggingNotification -- initialized log message
 337
 338       createDoc ".register" "haskell" ""
 339       message :: Session RegisterCapabilityRequest
 340
 341       doc <- createDoc "Foo.watch" "haskell" ""
 342       NotLogMessage msg <- loggingNotification
 343       liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
 344
 345       caps <- getRegisteredCapabilities
 346       liftIO $ caps `shouldBe`
 347         [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
 348           DidChangeWatchedFilesRegistrationOptions $ List
 349           [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]
 350         ]
 351
 352       -- now unregister it by sending a specific createDoc
 353       createDoc ".unregister" "haskell" ""
 354       message :: Session UnregisterCapabilityRequest
 355
 356       createDoc "Bar.watch" "haskell" ""
 357       void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing
 358       count 0 $ loggingNotification
 359       void $ anyResponse
 360
 361     it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do
 362       curDir <- liftIO $ getCurrentDirectory
 363
 364       loggingNotification -- initialized log message
 365
 366       createDoc ".register.abs" "haskell" ""
 367       message :: Session RegisterCapabilityRequest
 368
 369       doc <- createDoc (curDir </> "Foo.watch") "haskell" ""
 370       NotLogMessage msg <- loggingNotification
 371       liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
 372
 373       -- now unregister it by sending a specific createDoc
 374       createDoc ".unregister.abs" "haskell" ""
 375       message :: Session UnregisterCapabilityRequest
 376
 377       createDoc (curDir </> "Bar.watch") "haskell" ""
 378       void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing
 379       count 0 $ loggingNotification
 380       void $ anyResponse
 381
 382   describe "file watching" $
 383     it "works" $ do
 384       tmp <- liftIO getTemporaryDirectory
 385       let testFile = tmp </> "lsp-test.watch"
 386           testFile' = tmp </> "lsp-test.nowatch"
 387       finally (runSession serverExe fullCaps "" $ do
 388         loggingNotification -- initialized log message
 389
 390         createDoc ".register.tmp" "haskell" ""
 391         message :: Session RegisterCapabilityRequest
 392
 393         liftIO $ writeFile testFile "Hello" -- >> hFlush h
 394         NotLogMessage msg <- loggingNotification
 395         liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
 396
 397         -- this shouldn't trigger a watch files thingy
 398         liftIO $ writeFile testFile' "Hello"
 399         doc <- createDoc "blah" "haskell" ""
 400
 401         let testNoLog = do
 402               void $ sendRequest TextDocumentHover $
 403                 TextDocumentPositionParams doc (Position 0 0) Nothing
 404               count 0 $ loggingNotification
 405               void $ anyResponse
 406         testNoLog
 407
 408         -- unwatch .watch in tmp
 409         createDoc ".unregister.tmp" "haskell" ""
 410         message :: Session UnregisterCapabilityRequest
 411
 412         -- modifying shouldn't return anything
 413         liftIO $ writeFile testFile "Hello"
 414         testNoLog) (mapM_ removeFile [testFile, testFile'])
 415
 416
 417 mkRange :: Int -> Int -> Int -> Int -> Range
 418 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 419
 420 didChangeCaps :: ClientCapabilities
 421 didChangeCaps = def { _workspace = Just workspaceCaps }
 422   where
 423     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 424     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 425
 426 docChangesCaps :: ClientCapabilities
 427 docChangesCaps = def { _workspace = Just workspaceCaps }
 428   where
 429     workspaceCaps = def { _workspaceEdit = Just editCaps }
 430     editCaps = WorkspaceEditClientCapabilities (Just True)
 431
 432
 433 findExeRecursive :: FilePath -> FilePath -> IO [FilePath]
 434 findExeRecursive exe dir = do
 435   exes <- findExecutablesInDirectories [dir] exe
 436   subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
 437   exes' <- concat <$> mapM (findExeRecursive exe) subdirs
 438   return $ exes ++ exes'
 439
 440 newestExe :: [FilePath] -> IO (Maybe FilePath)
 441 newestExe exes = do
 442   pairs <- zip exes <$> mapM getModificationTime exes
 443   case sortOn snd pairs of
 444     (e,_):_ -> return $ Just e
 445     _ -> return Nothing
 446
 447 -- | So we can find the dummy-server with cabal run
 448 -- since it doesnt put build tools on the path (only cabal test)
 449 findServer = do
 450   let serverName = "dummy-server"
 451   e <- findExecutable serverName
 452   e' <- findExeRecursive serverName "dist-newstyle" >>= newestExe
 453   pure $ fromJust $ e <|> e'