test/Test.hs

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