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