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.Maybe
  11 import qualified Data.Text as T
  12 import           Control.Applicative.Combinators
  13 import           Control.Concurrent
  14 import           Control.Monad.IO.Class
  15 import           Control.Monad
  16 import           Control.Lens hiding (List)
  17 import           GHC.Generics
  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 as LSP hiding (capabilities, message)
  22 import           System.Timeout
  23
  24 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
  25 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
  26
  27 main = hspec $ do
  28   describe "Session" $ do
  29     it "fails a test" $
  30       -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
  31       let session = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
  32                       openDoc "Desktop/simple.hs" "haskell"
  33                       skipMany loggingNotification
  34                       anyRequest
  35         in session `shouldThrow` anyException
  36     it "initializeResponse" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
  37       rsp <- initializeResponse
  38       liftIO $ rsp ^. result `shouldNotBe` Nothing
  39
  40     it "runSessionWithConfig" $
  41       runSession "hie --lsp" didChangeCaps "test/data/renamePass" $ return ()
  42
  43     describe "withTimeout" $ do
  44       it "times out" $
  45         let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
  46                     openDoc "Desktop/simple.hs" "haskell"
  47                     -- won't receive a request - will timeout
  48                     -- incoming logging requests shouldn't increase the
  49                     -- timeout
  50                     withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
  51           -- wait just a bit longer than 5 seconds so we have time
  52           -- to open the document
  53           in timeout 6000000 sesh `shouldThrow` anySessionException
  54
  55       it "doesn't time out" $
  56         let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
  57                     openDoc "Desktop/simple.hs" "haskell"
  58                     withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
  59           in void $ timeout 6000000 sesh
  60
  61       it "further timeout messages are ignored" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
  62         doc <- openDoc "Desktop/simple.hs" "haskell"
  63         withTimeout 3 $ getDocumentSymbols doc
  64         liftIO $ threadDelay 5000000
  65         -- shouldn't throw an exception
  66         getDocumentSymbols doc
  67         return ()
  68
  69       it "overrides global message timeout" $
  70         let sesh =
  71               runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do
  72                 doc <- openDoc "Desktop/simple.hs" "haskell"
  73                 -- shouldn't time out in here since we are overriding it
  74                 withTimeout 10 $ liftIO $ threadDelay 7000000
  75                 getDocumentSymbols doc
  76                 return True
  77         in sesh `shouldReturn` True
  78
  79       it "unoverrides global message timeout" $
  80         let sesh =
  81               runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do
  82                 doc <- openDoc "Desktop/simple.hs" "haskell"
  83                 -- shouldn't time out in here since we are overriding it
  84                 withTimeout 10 $ liftIO $ threadDelay 7000000
  85                 getDocumentSymbols doc
  86                 -- should now timeout
  87                 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
  88         in sesh `shouldThrow` (== Timeout)
  89
  90
  91     describe "SessionException" $ do
  92       it "throw on time out" $
  93         let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" fullCaps "test/data/renamePass" $ do
  94                 skipMany loggingNotification
  95                 _ <- message :: Session ApplyWorkspaceEditRequest
  96                 return ()
  97         in sesh `shouldThrow` anySessionException
  98
  99       it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" fullCaps "test/data/renamePass" $ do
 100         loggingNotification
 101         liftIO $ threadDelay 10
 102         _ <- openDoc "Desktop/simple.hs" "haskell"
 103         return ()
 104
 105       describe "UnexpectedMessageException" $ do
 106         it "throws when there's an unexpected message" $
 107           let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
 108               selector _ = False
 109             in runSession "hie --lsp" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
 110         it "provides the correct types that were expected and received" $
 111           let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
 112               selector _ = False
 113               sesh = do
 114                 doc <- openDoc "Desktop/simple.hs" "haskell"
 115                 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
 116                 skipMany anyNotification
 117                 message :: Session RenameResponse -- the wrong type
 118             in runSession "hie --lsp" fullCaps "test/data/renamePass" sesh
 119               `shouldThrow` selector
 120
 121   describe "replaySession" $ do
 122     it "passes a test" $
 123       replaySession "hie --lsp" "test/data/renamePass"
 124     it "fails a test" $
 125       let selector (ReplayOutOfOrder _ _) = True
 126           selector _ = False
 127         in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
 128
 129   describe "manual javascript session" $
 130     it "passes a test" $
 131       runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
 132         doc <- openDoc "test.js" "javascript"
 133
 134         noDiagnostics
 135
 136         Right (fooSymbol:_) <- getDocumentSymbols doc
 137
 138         liftIO $ do
 139           fooSymbol ^. name `shouldBe` "foo"
 140           fooSymbol ^. kind `shouldBe` SkFunction
 141
 142   describe "text document VFS" $
 143     it "sends back didChange notifications" $
 144       runSession "hie --lsp" def "test/data/refactor" $ do
 145         doc <- openDoc "Main.hs" "haskell"
 146
 147         let args = toJSON $ AOP (doc ^. uri)
 148                                 (Position 1 14)
 149                                 "Redundant bracket"
 150             reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
 151         request_ WorkspaceExecuteCommand reqParams
 152
 153         editReq <- message :: Session ApplyWorkspaceEditRequest
 154         liftIO $ do
 155           let (Just cs) = editReq ^. params . edit . changes
 156               [(u, List es)] = HM.toList cs
 157           u `shouldBe` doc ^. uri
 158           es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
 159
 160         noDiagnostics
 161
 162         contents <- documentContents doc
 163         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
 164
 165   describe "getDocumentEdit" $
 166     it "automatically consumes applyedit requests" $
 167       runSession "hie --lsp" fullCaps "test/data/refactor" $ do
 168         doc <- openDoc "Main.hs" "haskell"
 169
 170         let args = toJSON $ AOP (doc ^. uri)
 171                                 (Position 1 14)
 172                                 "Redundant bracket"
 173             reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
 174         request_ WorkspaceExecuteCommand reqParams
 175         contents <- getDocumentEdit doc
 176         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
 177         noDiagnostics
 178
 179   describe "getAllCodeActions" $
 180     it "works" $ runSession "hie --lsp" fullCaps "test/data/refactor" $ do
 181       doc <- openDoc "Main.hs" "haskell"
 182       _ <- waitForDiagnostics
 183       actions <- getAllCodeActions doc
 184       liftIO $ do
 185         let [CACodeAction action] = actions
 186         action ^. title `shouldBe` "Apply hint:Redundant bracket"
 187         action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
 188
 189   describe "getDocumentSymbols" $
 190     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 191       doc <- openDoc "Desktop/simple.hs" "haskell"
 192
 193       skipMany loggingNotification
 194
 195       noDiagnostics
 196
 197       Left (mainSymbol:_) <- getDocumentSymbols doc
 198
 199       liftIO $ do
 200         mainSymbol ^. name `shouldBe` "main"
 201         mainSymbol ^. kind `shouldBe` SkFunction
 202         mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 3 4)
 203
 204   describe "applyEdit" $ do
 205     it "increments the version" $ runSession "hie --lsp" docChangesCaps "test/data/renamePass" $ do
 206       doc <- openDoc "Desktop/simple.hs" "haskell"
 207       VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
 208       let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
 209       VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
 210       liftIO $ newVersion `shouldBe` oldVersion + 1
 211     it "changes the document contents" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 212       doc <- openDoc "Desktop/simple.hs" "haskell"
 213       let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
 214       applyEdit doc edit
 215       contents <- documentContents doc
 216       liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
 217
 218   describe "getCompletions" $
 219     it "works" $ runSession "hie --lsp" def "test/data/renamePass" $ do
 220       doc <- openDoc "Desktop/simple.hs" "haskell"
 221       item:_ <- getCompletions doc (Position 5 5)
 222       liftIO $ do
 223         item ^. label `shouldBe` "interactWithUser"
 224         item ^. kind `shouldBe` Just CiFunction
 225         item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
 226
 227   describe "getReferences" $
 228     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 229       doc <- openDoc "Desktop/simple.hs" "haskell"
 230       let pos = Position 40 3 -- interactWithUser
 231           uri = doc ^. LSP.uri
 232       refs <- getReferences doc pos True
 233       liftIO $ refs `shouldContain` map (Location uri) [
 234           mkRange 41 0 41 16
 235         , mkRange 75 6 75 22
 236         , mkRange 71 6 71 22
 237         ]
 238
 239   describe "getDefinitions" $
 240     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 241       doc <- openDoc "Desktop/simple.hs" "haskell"
 242       let pos = Position 49 25 -- addItem
 243       defs <- getDefinitions doc pos
 244       liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
 245
 246   describe "waitForDiagnosticsSource" $
 247     it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
 248       openDoc "Error.hs" "haskell"
 249       [diag] <- waitForDiagnosticsSource "ghcmod"
 250       liftIO $ do
 251         diag ^. severity `shouldBe` Just DsError
 252         diag ^. source `shouldBe` Just "ghcmod"
 253
 254   describe "rename" $
 255     it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
 256       doc <- openDoc "Rename.hs" "haskell"
 257       rename doc (Position 1 0) "bar"
 258       documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
 259
 260   describe "getHover" $
 261     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 262       doc <- openDoc "Desktop/simple.hs" "haskell"
 263       -- hover returns nothing until module is loaded
 264       skipManyTill loggingNotification $ count 2 noDiagnostics
 265       hover <- getHover doc (Position 45 9) -- putStrLn
 266       liftIO $ hover `shouldSatisfy` isJust
 267
 268   describe "getHighlights" $
 269     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 270       doc <- openDoc "Desktop/simple.hs" "haskell"
 271       skipManyTill loggingNotification $ count 2 noDiagnostics
 272       highlights <- getHighlights doc (Position 27 4) -- addItem
 273       liftIO $ length highlights `shouldBe` 4
 274
 275   describe "formatDoc" $
 276     it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
 277       doc <- openDoc "Format.hs" "haskell"
 278       oldContents <- documentContents doc
 279       formatDoc doc (FormattingOptions 4 True)
 280       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 281
 282   describe "formatRange" $
 283     it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
 284       doc <- openDoc "Format.hs" "haskell"
 285       oldContents <- documentContents doc
 286       formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
 287       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 288
 289   describe "closeDoc" $
 290     it "works" $
 291       let sesh =
 292             runSession "hie --lsp" fullCaps "test/data" $ do
 293               doc <- openDoc "Format.hs" "haskell"
 294               closeDoc doc
 295               -- need to evaluate to throw
 296               documentContents doc >>= liftIO . print
 297       in sesh `shouldThrow` anyException
 298
 299 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 300
 301 didChangeCaps :: ClientCapabilities
 302 didChangeCaps = def { _workspace = Just workspaceCaps }
 303   where
 304     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 305     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 306
 307 docChangesCaps :: ClientCapabilities
 308 docChangesCaps = def { _workspace = Just workspaceCaps }
 309   where
 310     workspaceCaps = def { _workspaceEdit = Just editCaps }
 311     editCaps = WorkspaceEditClientCapabilities (Just True)
 312
 313 data ApplyOneParams = AOP
 314   { file      :: Uri
 315   , start_pos :: Position
 316   , hintTitle :: String
 317   } deriving (Generic, ToJSON)