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" $
  37       runSessionWithConfig (def { capabilities = didChangeCaps })
  38         "hie --lsp" "test/data/renamePass" $ return ()
  39
  40     describe "withTimeout" $ do
  41       it "times out" $
  42         let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
  43                     openDoc "Desktop/simple.hs" "haskell"
  44                     -- won't receive a request - will timeout
  45                     -- incoming logging requests shouldn't increase the
  46                     -- timeout
  47                     withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
  48           -- wait just a bit longer than 5 seconds so we have time
  49           -- to open the document
  50           in timeout 6000000 sesh `shouldThrow` anySessionException
  51
  52       it "doesn't time out" $
  53         let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
  54                     openDoc "Desktop/simple.hs" "haskell"
  55                     withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
  56           in void $ timeout 6000000 sesh
  57
  58       it "further timeout messages are ignored" $ runSession "hie --lsp" "test/data/renamePass" $ do
  59         doc <- openDoc "Desktop/simple.hs" "haskell"
  60         withTimeout 3 $ getDocumentSymbols doc
  61         liftIO $ threadDelay 5000000
  62         -- shouldn't throw an exception
  63         getDocumentSymbols doc
  64         return ()
  65
  66       it "overrides global message timeout" $
  67         let sesh =
  68               runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
  69                 doc <- openDoc "Desktop/simple.hs" "haskell"
  70                 -- shouldn't time out in here since we are overriding it
  71                 withTimeout 10 $ liftIO $ threadDelay 7000000
  72                 getDocumentSymbols doc
  73                 return True
  74         in sesh `shouldReturn` True
  75
  76       it "unoverrides global message timeout" $
  77         let sesh =
  78               runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
  79                 doc <- openDoc "Desktop/simple.hs" "haskell"
  80                 -- shouldn't time out in here since we are overriding it
  81                 withTimeout 10 $ liftIO $ threadDelay 7000000
  82                 getDocumentSymbols doc
  83                 -- should now timeout
  84                 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
  85         in sesh `shouldThrow` (== TimeoutException)
  86
  87
  88     describe "exceptions" $ do
  89       it "throw on time out" $
  90         let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do
  91                 skipMany loggingNotification
  92                 _ <- message :: Session ApplyWorkspaceEditRequest
  93                 return ()
  94         in sesh `shouldThrow` anySessionException
  95
  96       it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" "test/data/renamePass" $ do
  97         loggingNotification
  98         liftIO $ threadDelay 10
  99         _ <- openDoc "Desktop/simple.hs" "haskell"
 100         return ()
 101
 102       describe "UnexpectedMessageException" $ do
 103         it "throws when there's an unexpected message" $
 104           let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True
 105               selector _ = False
 106             in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
 107         it "provides the correct types that were expected and received" $
 108           let selector (UnexpectedMessageException "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
 109               selector _ = False
 110               sesh = do
 111                 doc <- openDoc "Desktop/simple.hs" "haskell"
 112                 sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc)
 113                 skipMany anyNotification
 114                 message :: Session RenameResponse -- the wrong type
 115             in runSession "hie --lsp" "test/data/renamePass" sesh
 116               `shouldThrow` selector
 117
 118   describe "replay session" $ do
 119     it "passes a test" $
 120       replaySession "hie --lsp" "test/data/renamePass"
 121     it "fails a test" $
 122       let selector (ReplayOutOfOrderException _ _) = True
 123           selector _ = False
 124         in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
 125
 126   describe "manual javascript session" $
 127     it "passes a test" $
 128       runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
 129         doc <- openDoc "test.js" "javascript"
 130
 131         noDiagnostics
 132
 133         (fooSymbol:_) <- getDocumentSymbols doc
 134
 135         liftIO $ do
 136           fooSymbol ^. name `shouldBe` "foo"
 137           fooSymbol ^. kind `shouldBe` SkFunction
 138
 139   describe "text document VFS" $
 140     it "sends back didChange notifications" $
 141       runSession "hie --lsp" "test/data/refactor" $ do
 142         doc <- openDoc "Main.hs" "haskell"
 143
 144         let args = toJSON $ AOP (doc ^. uri)
 145                                 (Position 1 14)
 146                                 "Redundant bracket"
 147             reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
 148         sendRequest_ WorkspaceExecuteCommand reqParams
 149
 150         editReq <- message :: Session ApplyWorkspaceEditRequest
 151         liftIO $ do
 152           let (Just cs) = editReq ^. params . edit . changes
 153               [(u, List es)] = HM.toList cs
 154           u `shouldBe` doc ^. uri
 155           es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
 156
 157         noDiagnostics
 158
 159         contents <- documentContents doc
 160         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
 161
 162   describe "documentEdit" $
 163     it "automatically consumes applyedit requests" $
 164       runSession "hie --lsp" "test/data/refactor" $ do
 165         doc <- openDoc "Main.hs" "haskell"
 166
 167         let args = toJSON $ AOP (doc ^. uri)
 168                                 (Position 1 14)
 169                                 "Redundant bracket"
 170             reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
 171         sendRequest_ WorkspaceExecuteCommand reqParams
 172         contents <- getDocumentEdit doc
 173         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
 174         noDiagnostics
 175
 176   describe "getAllCodeActions" $
 177     it "works" $ runSession "hie --lsp" "test/data/refactor" $ do
 178       doc <- openDoc "Main.hs" "haskell"
 179       _ <- waitForDiagnostics
 180       actions <- getAllCodeActions doc
 181       liftIO $ do
 182         let [CommandOrCodeActionCommand action] = actions
 183         action ^. title `shouldBe` "Apply hint:Redundant bracket"
 184         action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
 185
 186   describe "getDocumentSymbols" $
 187     it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
 188       doc <- openDoc "Desktop/simple.hs" "haskell"
 189
 190       skipMany loggingNotification
 191
 192       noDiagnostics
 193
 194       (mainSymbol:_) <- getDocumentSymbols doc
 195
 196       liftIO $ do
 197         mainSymbol ^. name `shouldBe` "main"
 198         mainSymbol ^. kind `shouldBe` SkFunction
 199         mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
 200         mainSymbol ^. containerName `shouldBe` Nothing
 201
 202   describe "applyEdit" $ do
 203     it "increments the version" $ runSessionWithConfig (def { capabilities = docChangesCaps }) "hie --lsp" "test/data/renamePass" $ do
 204       doc <- openDoc "Desktop/simple.hs" "haskell"
 205       VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
 206       let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
 207       VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit edit doc
 208       liftIO $ newVersion `shouldBe` oldVersion + 1
 209     it "changes the document contents" $ runSession "hie --lsp" "test/data/renamePass" $ do
 210       doc <- openDoc "Desktop/simple.hs" "haskell"
 211       let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
 212       applyEdit edit doc
 213       contents <- documentContents doc
 214       liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
 215
 216
 217 didChangeCaps :: ClientCapabilities
 218 didChangeCaps = def { _workspace = Just workspaceCaps }
 219   where
 220     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 221     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 222
 223 docChangesCaps :: ClientCapabilities
 224 docChangesCaps = def { _workspace = Just workspaceCaps }
 225   where
 226     workspaceCaps = def { _workspaceEdit = Just editCaps }
 227     editCaps = WorkspaceEditClientCapabilities (Just True)
 228
 229 data ApplyOneParams = AOP
 230   { file      :: Uri
 231   , start_pos :: Position
 232   , hintTitle :: String
 233   } deriving (Generic, ToJSON)