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.Concurrent
  12 import           Control.Monad.IO.Class
  13 import           Control.Monad
  14 import           Control.Lens hiding (List)
  15 import           GHC.Generics
  16 import           Language.Haskell.LSP.Messages
  17 import           Language.Haskell.LSP.Test
  18 import           Language.Haskell.LSP.Test.Replay
  19 import           Language.Haskell.LSP.TH.ClientCapabilities
  20 import           Language.Haskell.LSP.Types hiding (message, capabilities)
  21 import           ParsingTests
  22 import           System.Timeout
  23
  24 main = hspec $ do
  25   describe "manual session" $ do
  26     it "fails a test" $
  27       -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
  28       let session = runSession "hie --lsp" "test/data/renamePass" $ do
  29                       openDoc "Desktop/simple.hs" "haskell"
  30                       skipMany loggingNotification
  31                       anyRequest
  32         in session `shouldThrow` anyException
  33     it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do
  34       rsp <- initializeResponse
  35       liftIO $ rsp ^. result `shouldNotBe` Nothing
  36
  37     it "can register specific capabilities" $ do
  38       let caps = def { _workspace = Just workspaceCaps }
  39           workspaceCaps = def { _didChangeConfiguration = Just configCaps }
  40           configCaps = DidChangeConfigurationClientCapabilities (Just True)
  41           conf = def { capabilities = caps }
  42       runSessionWithConfig conf "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` (== TimeoutException)
  90
  91
  92     describe "exceptions" $ 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 (UnexpectedMessageException "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 (UnexpectedMessageException "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 "replay session" $ do
 123     it "passes a test" $
 124       replaySession "hie --lsp" "test/data/renamePass"
 125     it "fails a test" $
 126       let selector (ReplayOutOfOrderException _ _) = 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"
 165
 166   describe "documentEdit" $
 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"
 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   parsingSpec
 207
 208 data ApplyOneParams = AOP
 209   { file      :: Uri
 210   , start_pos :: Position
 211   , hintTitle :: String
 212   } deriving (Generic, ToJSON)