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