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