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 "getCodeActions" $
 180     it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
 181       doc <- openDoc "Main.hs" "haskell"
 182       waitForDiagnostics
 183       [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
 184       liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
 185
 186   describe "getAllCodeActions" $
 187     it "works" $ runSession "hie --lsp" fullCaps "test/data/refactor" $ do
 188       doc <- openDoc "Main.hs" "haskell"
 189       _ <- waitForDiagnostics
 190       actions <- getAllCodeActions doc
 191       liftIO $ do
 192         let [CACodeAction action] = actions
 193         action ^. title `shouldBe` "Apply hint:Redundant bracket"
 194         action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
 195
 196   describe "getDocumentSymbols" $
 197     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 198       doc <- openDoc "Desktop/simple.hs" "haskell"
 199
 200       skipMany loggingNotification
 201
 202       noDiagnostics
 203
 204       Left (mainSymbol:_) <- getDocumentSymbols doc
 205
 206       liftIO $ do
 207         mainSymbol ^. name `shouldBe` "main"
 208         mainSymbol ^. kind `shouldBe` SkFunction
 209         mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 3 4)
 210
 211   describe "applyEdit" $ do
 212     it "increments the version" $ runSession "hie --lsp" docChangesCaps "test/data/renamePass" $ do
 213       doc <- openDoc "Desktop/simple.hs" "haskell"
 214       VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
 215       let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
 216       VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
 217       liftIO $ newVersion `shouldBe` oldVersion + 1
 218     it "changes the document contents" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 219       doc <- openDoc "Desktop/simple.hs" "haskell"
 220       let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
 221       applyEdit doc edit
 222       contents <- documentContents doc
 223       liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
 224
 225   describe "getCompletions" $
 226     it "works" $ runSession "hie --lsp" def "test/data/renamePass" $ do
 227       doc <- openDoc "Desktop/simple.hs" "haskell"
 228       item:_ <- getCompletions doc (Position 5 5)
 229       liftIO $ do
 230         item ^. label `shouldBe` "interactWithUser"
 231         item ^. kind `shouldBe` Just CiFunction
 232         item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
 233
 234   describe "getReferences" $
 235     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 236       doc <- openDoc "Desktop/simple.hs" "haskell"
 237       let pos = Position 40 3 -- interactWithUser
 238           uri = doc ^. LSP.uri
 239       refs <- getReferences doc pos True
 240       liftIO $ refs `shouldContain` map (Location uri) [
 241           mkRange 41 0 41 16
 242         , mkRange 75 6 75 22
 243         , mkRange 71 6 71 22
 244         ]
 245
 246   describe "getDefinitions" $
 247     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 248       doc <- openDoc "Desktop/simple.hs" "haskell"
 249       let pos = Position 49 25 -- addItem
 250       defs <- getDefinitions doc pos
 251       liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
 252
 253   describe "waitForDiagnosticsSource" $
 254     it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
 255       openDoc "Error.hs" "haskell"
 256       [diag] <- waitForDiagnosticsSource "ghcmod"
 257       liftIO $ do
 258         diag ^. severity `shouldBe` Just DsError
 259         diag ^. source `shouldBe` Just "ghcmod"
 260
 261   describe "rename" $
 262     it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
 263       doc <- openDoc "Rename.hs" "haskell"
 264       rename doc (Position 1 0) "bar"
 265       documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
 266
 267   describe "getHover" $
 268     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 269       doc <- openDoc "Desktop/simple.hs" "haskell"
 270       -- hover returns nothing until module is loaded
 271       skipManyTill loggingNotification $ count 2 noDiagnostics
 272       hover <- getHover doc (Position 45 9) -- putStrLn
 273       liftIO $ hover `shouldSatisfy` isJust
 274
 275   describe "getHighlights" $
 276     it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
 277       doc <- openDoc "Desktop/simple.hs" "haskell"
 278       skipManyTill loggingNotification $ count 2 noDiagnostics
 279       highlights <- getHighlights doc (Position 27 4) -- addItem
 280       liftIO $ length highlights `shouldBe` 4
 281
 282   describe "formatDoc" $
 283     it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
 284       doc <- openDoc "Format.hs" "haskell"
 285       oldContents <- documentContents doc
 286       formatDoc doc (FormattingOptions 4 True)
 287       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 288
 289   describe "formatRange" $
 290     it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
 291       doc <- openDoc "Format.hs" "haskell"
 292       oldContents <- documentContents doc
 293       formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
 294       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 295
 296   describe "closeDoc" $
 297     it "works" $
 298       let sesh =
 299             runSession "hie --lsp" fullCaps "test/data" $ do
 300               doc <- openDoc "Format.hs" "haskell"
 301               closeDoc doc
 302               -- need to evaluate to throw
 303               documentContents doc >>= liftIO . print
 304       in sesh `shouldThrow` anyException
 305
 306 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 307
 308 didChangeCaps :: ClientCapabilities
 309 didChangeCaps = def { _workspace = Just workspaceCaps }
 310   where
 311     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 312     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 313
 314 docChangesCaps :: ClientCapabilities
 315 docChangesCaps = def { _workspace = Just workspaceCaps }
 316   where
 317     workspaceCaps = def { _workspaceEdit = Just editCaps }
 318     editCaps = WorkspaceEditClientCapabilities (Just True)
 319
 320 data ApplyOneParams = AOP
 321   { file      :: Uri
 322   , start_pos :: Position
 323   , hintTitle :: String
 324   } deriving (Generic, ToJSON)