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 qualified Data.Text as T
  11 import           Control.Applicative.Combinators
  12 import           Control.Concurrent
  13 import           Control.Monad.IO.Class
  14 import           Control.Monad
  15 import           Control.Lens hiding (List)
  16 import           GHC.Generics
  17 import           Language.Haskell.LSP.Messages
  18 import           Language.Haskell.LSP.Test
  19 import           Language.Haskell.LSP.Test.Replay
  20 import           Language.Haskell.LSP.Types.Capabilities
  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" "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" "test/data/renamePass" $ do
  37       rsp <- initializeResponse
  38       liftIO $ rsp ^. result `shouldNotBe` Nothing
  39
  40     it "runSessionWithConfig" $
  41       runSessionWithConfig (def { capabilities = didChangeCaps })
  42         "hie --lsp" "test/data/renamePass" $ return ()
  43
  44     describe "withTimeout" $ do
  45       it "times out" $
  46         let sesh = runSession "hie --lsp" "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" "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" "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" "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" "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" "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" "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" "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" "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" "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" "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" "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" "test/data/refactor" $ do
 182       doc <- openDoc "Main.hs" "haskell"
 183       _ <- waitForDiagnostics
 184       actions <- getAllCodeActions doc
 185       liftIO $ do
 186         let [CommandOrCodeActionCommand action] = actions
 187         action ^. title `shouldBe` "Apply hint:Redundant bracket"
 188         action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
 189
 190   describe "getDocumentSymbols" $
 191     it "works" $ runSession "hie --lsp" "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" $ runSessionWithConfig (def { capabilities = docChangesCaps }) "hie --lsp" "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" "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" "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" "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" "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" "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" "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 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 263
 264 didChangeCaps :: ClientCapabilities
 265 didChangeCaps = def { _workspace = Just workspaceCaps }
 266   where
 267     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 268     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 269
 270 docChangesCaps :: ClientCapabilities
 271 docChangesCaps = def { _workspace = Just workspaceCaps }
 272   where
 273     workspaceCaps = def { _workspaceEdit = Just editCaps }
 274     editCaps = WorkspaceEditClientCapabilities (Just True)
 275
 276 data ApplyOneParams = AOP
 277   { file      :: Uri
 278   , start_pos :: Position
 279   , hintTitle :: String
 280   } deriving (Generic, ToJSON)