test/Test.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE DuplicateRecordFields #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE DeriveGeneric #-}
   6 {-# LANGUAGE DeriveAnyClass #-}
   7
   8 import           Test.Hspec
   9 import           Data.Aeson
  10 import           Data.Default
  11 import qualified Data.HashMap.Strict as HM
  12 import           Data.Either
  13 import           Data.Maybe
  14 import qualified Data.Text as T
  15 import           Control.Applicative.Combinators
  16 import           Control.Concurrent
  17 import           Control.Monad.IO.Class
  18 import           Control.Monad
  19 import           Control.Lens hiding (List)
  20 import           Language.Haskell.LSP.Test
  21 import           Language.Haskell.LSP.Types
  22 import           Language.Haskell.LSP.Types.Lens hiding
  23   (capabilities, message, rename, applyEdit)
  24 import qualified Language.Haskell.LSP.Types.Lens as LSP
  25 import           Language.Haskell.LSP.Types.Capabilities as LSP
  26 import           System.Directory
  27 import           System.FilePath
  28 import           System.Timeout
  29 import Data.Type.Equality
  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 SWorkspaceApplyEdit) :: 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 SWorkspaceApplyEdit)
  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 SWorkspaceApplyEdit
 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" (FromServerMess SWindowLogMessage _)) = 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 "STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True
 122               selector _ = False
 123               sesh = do
 124                 doc <- openDoc "Desktop/simple.hs" "haskell"
 125                 sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)
 126                 skipMany anyNotification
 127                 response STextDocumentRename -- the wrong type
 128             in runSession serverExe fullCaps "test/data/renamePass" sesh
 129               `shouldThrow` selector
 130
 131   describe "text document VFS" $
 132     it "sends back didChange notifications" $
 133       runSession serverExe def "test/data/refactor" $ do
 134         doc <- openDoc "Main.hs" "haskell"
 135
 136         let args = toJSON (doc ^. uri)
 137             reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
 138         request_ SWorkspaceExecuteCommand reqParams
 139
 140         editReq <- message SWorkspaceApplyEdit
 141         liftIO $ do
 142           let (Just cs) = editReq ^. params . edit . changes
 143               [(u, List es)] = HM.toList cs
 144           u `shouldBe` doc ^. uri
 145           es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"]
 146         contents <- documentContents doc
 147         liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
 148
 149   describe "getDocumentEdit" $
 150     it "automatically consumes applyedit requests" $
 151       runSession serverExe fullCaps "test/data/refactor" $ do
 152         doc <- openDoc "Main.hs" "haskell"
 153
 154         let args = toJSON (doc ^. uri)
 155             reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
 156         request_ SWorkspaceExecuteCommand reqParams
 157         contents <- getDocumentEdit doc
 158         liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
 159
 160   describe "getCodeActions" $
 161     it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
 162       doc <- openDoc "Main.hs" "haskell"
 163       waitForDiagnostics
 164       [InR action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
 165       liftIO $ action ^. title `shouldBe` "Delete this"
 166
 167   describe "getAllCodeActions" $
 168     it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
 169       doc <- openDoc "Main.hs" "haskell"
 170       _ <- waitForDiagnostics
 171       actions <- getAllCodeActions doc
 172       liftIO $ do
 173         let [InR action] = actions
 174         action ^. title `shouldBe` "Delete this"
 175         action ^. command . _Just . command  `shouldBe` "deleteThis"
 176
 177   describe "getDocumentSymbols" $
 178     it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 179       doc <- openDoc "Desktop/simple.hs" "haskell"
 180
 181       skipMany loggingNotification
 182
 183       Left (mainSymbol:_) <- getDocumentSymbols doc
 184
 185       liftIO $ do
 186         mainSymbol ^. name `shouldBe` "foo"
 187         mainSymbol ^. kind `shouldBe` SkObject
 188         mainSymbol ^. range `shouldBe` mkRange 0 0 3 6
 189
 190   describe "applyEdit" $ do
 191     it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do
 192       doc <- openDoc "Desktop/simple.hs" "haskell"
 193       VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
 194       let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
 195       VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
 196       liftIO $ newVersion `shouldBe` oldVersion + 1
 197     it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 198       doc <- openDoc "Desktop/simple.hs" "haskell"
 199       let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
 200       applyEdit doc edit
 201       contents <- documentContents doc
 202       liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
 203
 204   describe "getCompletions" $
 205     it "works" $ runSession serverExe def "test/data/renamePass" $ do
 206       doc <- openDoc "Desktop/simple.hs" "haskell"
 207
 208       comps <- getCompletions doc (Position 5 5)
 209       let item = head comps
 210       liftIO $ item ^. label `shouldBe` "foo"
 211
 212   -- describe "getReferences" $
 213   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 214   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 215   --     let pos = Position 40 3 -- interactWithUser
 216   --         uri = doc ^. LSP.uri
 217   --     refs <- getReferences doc pos True
 218   --     liftIO $ refs `shouldContain` map (Location uri) [
 219   --         mkRange 41 0 41 16
 220   --       , mkRange 75 6 75 22
 221   --       , mkRange 71 6 71 22
 222   --       ]
 223
 224   -- describe "getDefinitions" $
 225   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 226   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 227   --     let pos = Position 49 25 -- addItem
 228   --     defs <- getDefinitions doc pos
 229   --     liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
 230
 231   -- describe "getTypeDefinitions" $
 232   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 233   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 234   --     let pos = Position 20 23  -- Quit value
 235   --     defs <- getTypeDefinitions doc pos
 236   --     liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)]  -- Type definition
 237
 238   describe "waitForDiagnosticsSource" $
 239     it "works" $ runSession serverExe fullCaps "test/data" $ do
 240       openDoc "Error.hs" "haskell"
 241       [diag] <- waitForDiagnosticsSource "dummy-server"
 242       liftIO $ do
 243         diag ^. severity `shouldBe` Just DsWarning
 244         diag ^. source `shouldBe` Just "dummy-server"
 245
 246   -- describe "rename" $ do
 247   --   it "works" $ pendingWith "HaRe not in hie-bios yet"
 248   --   it "works on javascript" $
 249   --     runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
 250   --       doc <- openDoc "test.js" "javascript"
 251   --       rename doc (Position 2 11) "bar"
 252   --       documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
 253
 254   describe "getHover" $
 255     it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 256       doc <- openDoc "Desktop/simple.hs" "haskell"
 257       hover <- getHover doc (Position 45 9)
 258       liftIO $ hover `shouldSatisfy` isJust
 259
 260   -- describe "getHighlights" $
 261   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 262   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 263   --     skipManyTill loggingNotification $ count 2 noDiagnostics
 264   --     highlights <- getHighlights doc (Position 27 4) -- addItem
 265   --     liftIO $ length highlights `shouldBe` 4
 266
 267   -- describe "formatDoc" $
 268   --   it "works" $ runSession serverExe fullCaps "test/data" $ do
 269   --     doc <- openDoc "Format.hs" "haskell"
 270   --     oldContents <- documentContents doc
 271   --     formatDoc doc (FormattingOptions 4 True)
 272   --     documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 273
 274   -- describe "formatRange" $
 275   --   it "works" $ runSession serverExe fullCaps "test/data" $ do
 276   --     doc <- openDoc "Format.hs" "haskell"
 277   --     oldContents <- documentContents doc
 278   --     formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
 279   --     documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 280
 281   describe "closeDoc" $
 282     it "works" $
 283       let sesh =
 284             runSession serverExe fullCaps "test/data" $ do
 285               doc <- openDoc "Format.hs" "haskell"
 286               closeDoc doc
 287               -- need to evaluate to throw
 288               documentContents doc >>= liftIO . print
 289       in sesh `shouldThrow` anyException
 290
 291   describe "satisfy" $
 292     it "works" $ runSession serverExe fullCaps "test/data" $ do
 293       openDoc "Format.hs" "haskell"
 294       let pred (FromServerMess SWindowLogMessage _) = True
 295           pred _ = False
 296       void $ satisfy pred
 297
 298   describe "ignoreLogNotifications" $
 299     it "works" $
 300       runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe  fullCaps "test/data" $ do
 301         openDoc "Format.hs" "haskell"
 302         void publishDiagnosticsNotification
 303
 304   describe "dynamic capabilities" $ do
 305
 306     it "keeps track" $ runSession serverExe fullCaps "test/data" $ do
 307       loggingNotification -- initialized log message
 308
 309       createDoc ".register" "haskell" ""
 310       message SClientRegisterCapability
 311
 312       doc <- createDoc "Foo.watch" "haskell" ""
 313       msg <- message SWindowLogMessage
 314       liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
 315
 316       [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities
 317       liftIO $ do
 318         case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of
 319           Just HRefl ->
 320             regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List
 321                                 [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ])
 322           Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles"
 323
 324       -- now unregister it by sending a specific createDoc
 325       createDoc ".unregister" "haskell" ""
 326       message SClientUnregisterCapability
 327
 328       createDoc "Bar.watch" "haskell" ""
 329       void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
 330       count 0 $ loggingNotification
 331       void $ anyResponse
 332
 333     it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do
 334       curDir <- liftIO $ getCurrentDirectory
 335
 336       loggingNotification -- initialized log message
 337
 338       createDoc ".register.abs" "haskell" ""
 339       message SClientRegisterCapability
 340
 341       doc <- createDoc (curDir </> "Foo.watch") "haskell" ""
 342       msg <- message SWindowLogMessage
 343       liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
 344
 345       -- now unregister it by sending a specific createDoc
 346       createDoc ".unregister.abs" "haskell" ""
 347       message SClientUnregisterCapability
 348
 349       createDoc (curDir </> "Bar.watch") "haskell" ""
 350       void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
 351       count 0 $ loggingNotification
 352       void $ anyResponse
 353
 354
 355 didChangeCaps :: ClientCapabilities
 356 didChangeCaps = def { _workspace = Just workspaceCaps }
 357   where
 358     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 359     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 360
 361 docChangesCaps :: ClientCapabilities
 362 docChangesCaps = def { _workspace = Just workspaceCaps }
 363   where
 364     workspaceCaps = def { _workspaceEdit = Just editCaps }
 365     editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing
 366
 367
 368 findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)
 369 findExeRecursive exe dir = do
 370   me <- listToMaybe <$> findExecutablesInDirectories [dir] exe
 371   case me of
 372     Just e -> return (Just e)
 373     Nothing -> do
 374       subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
 375       foldM (\acc subdir -> case acc of
 376                               Just y -> pure $ Just y
 377                               Nothing -> findExeRecursive exe subdir)
 378             Nothing
 379             subdirs
 380
 381 -- | So we can find the dummy-server with cabal run
 382 -- since it doesnt put build tools on the path (only cabal test)
 383 findServer = do
 384   let serverName = "dummy-server"
 385   e <- findExecutable serverName
 386   e' <- findExeRecursive serverName "dist-newstyle"
 387   pure $ fromJust $ e <|> e'