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           System.Timeout
  22
  23 main = hspec $ do
  24   describe "manual session" $ do
  25     it "fails a test" $
  26       -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
  27       let session = runSession "hie --lsp" "test/data/renamePass" $ do
  28                       openDoc "Desktop/simple.hs" "haskell"
  29                       skipMany loggingNotification
  30                       anyRequest
  31         in session `shouldThrow` anyException
  32     it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do
  33       rsp <- initializeResponse
  34       liftIO $ rsp ^. result `shouldNotBe` Nothing
  35
  36     it "can register specific capabilities" $ do
  37       let caps = def { _workspace = Just workspaceCaps }
  38           workspaceCaps = def { _didChangeConfiguration = Just configCaps }
  39           configCaps = DidChangeConfigurationClientCapabilities (Just True)
  40           conf = def { capabilities = caps }
  41       runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return ()
  42
  43     describe "withTimeout" $ do
  44       it "times out" $
  45         let sesh = runSession "hie --lsp" "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" "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" "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" "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" "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` (== TimeoutException)
  89
  90
  91     describe "exceptions" $ do
  92       it "throw on time out" $
  93         let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "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" "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 (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True
 108               selector _ = False
 109             in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
 110         it "provides the correct types that were expected and received" $
 111           let selector (UnexpectedMessageException "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" "test/data/renamePass" sesh
 119               `shouldThrow` selector
 120
 121   describe "replay session" $ do
 122     it "passes a test" $
 123       replaySession "hie --lsp" "test/data/renamePass"
 124     it "fails a test" $
 125       let selector (ReplayOutOfOrderException _ _) = 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" "test/data/javascriptPass" $ do
 132         doc <- openDoc "test.js" "javascript"
 133
 134         noDiagnostics
 135
 136         (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" "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         sendRequest_ 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"
 164
 165   describe "documentEdit" $
 166     it "automatically consumes applyedit requests" $
 167       runSession "hie --lsp" "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         sendRequest_ WorkspaceExecuteCommand reqParams
 175         contents <- getDocumentEdit doc
 176         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
 177         noDiagnostics
 178
 179   describe "getAllCodeActions" $
 180     it "works" $ runSession "hie --lsp" "test/data/refactor" $ do
 181       doc <- openDoc "Main.hs" "haskell"
 182       _ <- waitForDiagnostics
 183       actions <- getAllCodeActions doc
 184       liftIO $ do
 185         let [CommandOrCodeActionCommand action] = actions
 186         action ^. title `shouldBe` "Apply hint:Redundant bracket"
 187         action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
 188
 189   describe "getDocumentSymbols" $
 190     it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
 191       doc <- openDoc "Desktop/simple.hs" "haskell"
 192
 193       skipMany loggingNotification
 194
 195       noDiagnostics
 196
 197       (mainSymbol:_) <- getDocumentSymbols doc
 198
 199       liftIO $ do
 200         mainSymbol ^. name `shouldBe` "main"
 201         mainSymbol ^. kind `shouldBe` SkFunction
 202         mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
 203         mainSymbol ^. containerName `shouldBe` Nothing
 204
 205 data ApplyOneParams = AOP
 206   { file      :: Uri
 207   , start_pos :: Position
 208   , hintTitle :: String
 209   } deriving (Generic, ToJSON)