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.Test.Replay
  21 import           Language.Haskell.LSP.Types
  22 import           Language.Haskell.LSP.Types.Lens as LSP hiding
  23   (capabilities, message, rename, applyEdit)
  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   describe "replaySession" $
 130     -- This is too fickle at the moment
 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   --     -- wait for module to be loaded
 229   --     skipMany loggingNotification
 230   --     noDiagnostics
 231   --     noDiagnostics
 232
 233   --     comps <- getCompletions doc (Position 5 5)
 234   --     let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
 235   --     liftIO $ do
 236   --       item ^. label `shouldBe` "interactWithUser"
 237   --       item ^. kind `shouldBe` Just CiFunction
 238   --       item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
 239
 240   -- describe "getReferences" $
 241   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 242   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 243   --     let pos = Position 40 3 -- interactWithUser
 244   --         uri = doc ^. LSP.uri
 245   --     refs <- getReferences doc pos True
 246   --     liftIO $ refs `shouldContain` map (Location uri) [
 247   --         mkRange 41 0 41 16
 248   --       , mkRange 75 6 75 22
 249   --       , mkRange 71 6 71 22
 250   --       ]
 251
 252   -- describe "getDefinitions" $
 253   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 254   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 255   --     let pos = Position 49 25 -- addItem
 256   --     defs <- getDefinitions doc pos
 257   --     liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
 258
 259   -- describe "getTypeDefinitions" $
 260   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 261   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 262   --     let pos = Position 20 23  -- Quit value
 263   --     defs <- getTypeDefinitions doc pos
 264   --     liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)]  -- Type definition
 265
 266   describe "waitForDiagnosticsSource" $
 267     it "works" $ runSession serverExe fullCaps "test/data" $ do
 268       openDoc "Error.hs" "haskell"
 269       [diag] <- waitForDiagnosticsSource "dummy-server"
 270       liftIO $ do
 271         diag ^. severity `shouldBe` Just DsWarning
 272         diag ^. source `shouldBe` Just "dummy-server"
 273
 274   -- describe "rename" $ do
 275   --   it "works" $ pendingWith "HaRe not in hie-bios yet"
 276   --   it "works on javascript" $
 277   --     runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
 278   --       doc <- openDoc "test.js" "javascript"
 279   --       rename doc (Position 2 11) "bar"
 280   --       documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
 281
 282   describe "getHover" $
 283     it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 284       doc <- openDoc "Desktop/simple.hs" "haskell"
 285       hover <- getHover doc (Position 45 9)
 286       liftIO $ hover `shouldSatisfy` isJust
 287
 288   -- describe "getHighlights" $
 289   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 290   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 291   --     skipManyTill loggingNotification $ count 2 noDiagnostics
 292   --     highlights <- getHighlights doc (Position 27 4) -- addItem
 293   --     liftIO $ length highlights `shouldBe` 4
 294
 295   -- describe "formatDoc" $
 296   --   it "works" $ runSession serverExe fullCaps "test/data" $ do
 297   --     doc <- openDoc "Format.hs" "haskell"
 298   --     oldContents <- documentContents doc
 299   --     formatDoc doc (FormattingOptions 4 True)
 300   --     documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 301
 302   -- describe "formatRange" $
 303   --   it "works" $ runSession serverExe fullCaps "test/data" $ do
 304   --     doc <- openDoc "Format.hs" "haskell"
 305   --     oldContents <- documentContents doc
 306   --     formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
 307   --     documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 308
 309   describe "closeDoc" $
 310     it "works" $
 311       let sesh =
 312             runSession serverExe fullCaps "test/data" $ do
 313               doc <- openDoc "Format.hs" "haskell"
 314               closeDoc doc
 315               -- need to evaluate to throw
 316               documentContents doc >>= liftIO . print
 317       in sesh `shouldThrow` anyException
 318
 319   describe "satisfy" $
 320     it "works" $ runSession serverExe fullCaps "test/data" $ do
 321       openDoc "Format.hs" "haskell"
 322       let pred (NotLogMessage _) = True
 323           pred _ = False
 324       void $ satisfy pred
 325
 326   describe "ignoreLogNotifications" $
 327     it "works" $
 328       runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe  fullCaps "test/data" $ do
 329         openDoc "Format.hs" "haskell"
 330         void publishDiagnosticsNotification
 331
 332 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 333
 334 didChangeCaps :: ClientCapabilities
 335 didChangeCaps = def { _workspace = Just workspaceCaps }
 336   where
 337     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 338     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 339
 340 docChangesCaps :: ClientCapabilities
 341 docChangesCaps = def { _workspace = Just workspaceCaps }
 342   where
 343     workspaceCaps = def { _workspaceEdit = Just editCaps }
 344     editCaps = WorkspaceEditClientCapabilities (Just True)
 345
 346
 347 findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)
 348 findExeRecursive exe dir = do
 349   me <- listToMaybe <$> findExecutablesInDirectories [dir] exe
 350   case me of
 351     Just e -> return (Just e)
 352     Nothing -> do
 353       subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
 354       foldM (\acc subdir -> case acc of
 355                               Just y -> pure $ Just y
 356                               Nothing -> findExeRecursive exe subdir)
 357             Nothing
 358             subdirs
 359
 360 -- | So we can find the dummy-server with cabal run
 361 -- since it doesnt put build tools on the path (only cabal test)
 362 findServer = do
 363   let serverName = "dummy-server"
 364   e <- findExecutable serverName
 365   e' <- findExeRecursive serverName "dist-newstyle"
 366   pure $ fromJust $ e <|> e'