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.Capabilities
  22 import           Language.Haskell.LSP.Types as LSP hiding (capabilities, message)
  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" "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" "test/data/renamePass" $ do
  38       rsp <- initializeResponse
  39       liftIO $ rsp ^. result `shouldNotBe` Nothing
  40
  41     it "runSessionWithConfig" $
  42       runSessionWithConfig (def { capabilities = didChangeCaps })
  43         "hie --lsp" "test/data/renamePass" $ return ()
  44
  45     describe "withTimeout" $ do
  46       it "times out" $
  47         let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
  48                     openDoc "Desktop/simple.hs" "haskell"
  49                     -- won't receive a request - will timeout
  50                     -- incoming logging requests shouldn't increase the
  51                     -- timeout
  52                     withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
  53           -- wait just a bit longer than 5 seconds so we have time
  54           -- to open the document
  55           in timeout 6000000 sesh `shouldThrow` anySessionException
  56
  57       it "doesn't time out" $
  58         let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
  59                     openDoc "Desktop/simple.hs" "haskell"
  60                     withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
  61           in void $ timeout 6000000 sesh
  62
  63       it "further timeout messages are ignored" $ runSession "hie --lsp" "test/data/renamePass" $ do
  64         doc <- openDoc "Desktop/simple.hs" "haskell"
  65         withTimeout 3 $ getDocumentSymbols doc
  66         liftIO $ threadDelay 5000000
  67         -- shouldn't throw an exception
  68         getDocumentSymbols doc
  69         return ()
  70
  71       it "overrides global message timeout" $
  72         let sesh =
  73               runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
  74                 doc <- openDoc "Desktop/simple.hs" "haskell"
  75                 -- shouldn't time out in here since we are overriding it
  76                 withTimeout 10 $ liftIO $ threadDelay 7000000
  77                 getDocumentSymbols doc
  78                 return True
  79         in sesh `shouldReturn` True
  80
  81       it "unoverrides global message timeout" $
  82         let sesh =
  83               runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
  84                 doc <- openDoc "Desktop/simple.hs" "haskell"
  85                 -- shouldn't time out in here since we are overriding it
  86                 withTimeout 10 $ liftIO $ threadDelay 7000000
  87                 getDocumentSymbols doc
  88                 -- should now timeout
  89                 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
  90         in sesh `shouldThrow` (== Timeout)
  91
  92
  93     describe "SessionException" $ do
  94       it "throw on time out" $
  95         let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do
  96                 skipMany loggingNotification
  97                 _ <- message :: Session ApplyWorkspaceEditRequest
  98                 return ()
  99         in sesh `shouldThrow` anySessionException
 100
 101       it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" "test/data/renamePass" $ do
 102         loggingNotification
 103         liftIO $ threadDelay 10
 104         _ <- openDoc "Desktop/simple.hs" "haskell"
 105         return ()
 106
 107       describe "UnexpectedMessageException" $ do
 108         it "throws when there's an unexpected message" $
 109           let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
 110               selector _ = False
 111             in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
 112         it "provides the correct types that were expected and received" $
 113           let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
 114               selector _ = False
 115               sesh = do
 116                 doc <- openDoc "Desktop/simple.hs" "haskell"
 117                 sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc)
 118                 skipMany anyNotification
 119                 message :: Session RenameResponse -- the wrong type
 120             in runSession "hie --lsp" "test/data/renamePass" sesh
 121               `shouldThrow` selector
 122
 123   describe "replaySession" $ do
 124     it "passes a test" $
 125       replaySession "hie --lsp" "test/data/renamePass"
 126     it "fails a test" $
 127       let selector (ReplayOutOfOrder _ _) = True
 128           selector _ = False
 129         in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
 130
 131   describe "manual javascript session" $
 132     it "passes a test" $
 133       runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
 134         doc <- openDoc "test.js" "javascript"
 135
 136         noDiagnostics
 137
 138         (fooSymbol:_) <- getDocumentSymbols doc
 139
 140         liftIO $ do
 141           fooSymbol ^. name `shouldBe` "foo"
 142           fooSymbol ^. kind `shouldBe` SkFunction
 143
 144   describe "text document VFS" $
 145     it "sends back didChange notifications" $
 146       runSession "hie --lsp" "test/data/refactor" $ do
 147         doc <- openDoc "Main.hs" "haskell"
 148
 149         let args = toJSON $ AOP (doc ^. uri)
 150                                 (Position 1 14)
 151                                 "Redundant bracket"
 152             reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
 153         sendRequest_ WorkspaceExecuteCommand reqParams
 154
 155         editReq <- message :: Session ApplyWorkspaceEditRequest
 156         liftIO $ do
 157           let (Just cs) = editReq ^. params . edit . changes
 158               [(u, List es)] = HM.toList cs
 159           u `shouldBe` doc ^. uri
 160           es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
 161
 162         noDiagnostics
 163
 164         contents <- documentContents doc
 165         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
 166
 167   describe "getDocumentEdit" $
 168     it "automatically consumes applyedit requests" $
 169       runSession "hie --lsp" "test/data/refactor" $ do
 170         doc <- openDoc "Main.hs" "haskell"
 171
 172         let args = toJSON $ AOP (doc ^. uri)
 173                                 (Position 1 14)
 174                                 "Redundant bracket"
 175             reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
 176         sendRequest_ WorkspaceExecuteCommand reqParams
 177         contents <- getDocumentEdit doc
 178         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
 179         noDiagnostics
 180
 181   describe "getAllCodeActions" $
 182     it "works" $ runSession "hie --lsp" "test/data/refactor" $ do
 183       doc <- openDoc "Main.hs" "haskell"
 184       _ <- waitForDiagnostics
 185       actions <- getAllCodeActions doc
 186       liftIO $ do
 187         let [CommandOrCodeActionCommand action] = actions
 188         action ^. title `shouldBe` "Apply hint:Redundant bracket"
 189         action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
 190
 191   describe "getDocumentSymbols" $
 192     it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
 193       doc <- openDoc "Desktop/simple.hs" "haskell"
 194
 195       skipMany loggingNotification
 196
 197       noDiagnostics
 198
 199       (mainSymbol:_) <- getDocumentSymbols doc
 200
 201       liftIO $ do
 202         mainSymbol ^. name `shouldBe` "main"
 203         mainSymbol ^. kind `shouldBe` SkFunction
 204         mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
 205         mainSymbol ^. containerName `shouldBe` Nothing
 206
 207   describe "applyEdit" $ do
 208     it "increments the version" $ runSessionWithConfig (def { capabilities = docChangesCaps }) "hie --lsp" "test/data/renamePass" $ do
 209       doc <- openDoc "Desktop/simple.hs" "haskell"
 210       VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
 211       let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
 212       VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
 213       liftIO $ newVersion `shouldBe` oldVersion + 1
 214     it "changes the document contents" $ runSession "hie --lsp" "test/data/renamePass" $ do
 215       doc <- openDoc "Desktop/simple.hs" "haskell"
 216       let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
 217       applyEdit doc edit
 218       contents <- documentContents doc
 219       liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
 220
 221   describe "getCompletions" $
 222     it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
 223       doc <- openDoc "Desktop/simple.hs" "haskell"
 224       [item] <- getCompletions doc (Position 5 5)
 225       liftIO $ do
 226         item ^. label `shouldBe` "interactWithUser"
 227         item ^. kind `shouldBe` Just CiFunction
 228         item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
 229
 230   describe "getReferences" $
 231     it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
 232       doc <- openDoc "Desktop/simple.hs" "haskell"
 233       let pos = Position 40 3 -- interactWithUser
 234           uri = doc ^. LSP.uri
 235       refs <- getReferences doc pos True
 236       liftIO $ refs `shouldContain` map (Location uri) [
 237           mkRange 41 0 41 16
 238         , mkRange 75 6 75 22
 239         , mkRange 71 6 71 22
 240         ]
 241
 242   describe "getDefinitions" $
 243     it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
 244       doc <- openDoc "Desktop/simple.hs" "haskell"
 245       let pos = Position 49 25 -- addItem
 246       defs <- getDefinitions doc pos
 247       liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
 248
 249   describe "waitForDiagnosticsSource" $
 250     it "works" $ runSession "hie --lsp" "test/data" $ do
 251       openDoc "Error.hs" "haskell"
 252       [diag] <- waitForDiagnosticsSource "ghcmod"
 253       liftIO $ do
 254         diag ^. severity `shouldBe` Just DsError
 255         diag ^. source `shouldBe` Just "ghcmod"
 256
 257   describe "rename" $
 258     it "works" $ runSession "hie --lsp" "test/data" $ do
 259       doc <- openDoc "Rename.hs" "haskell"
 260       rename doc (Position 1 0) "bar"
 261       documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
 262
 263   describe "getHover" $
 264     it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
 265       doc <- openDoc "Desktop/simple.hs" "haskell"
 266       -- hover returns nothing until module is loaded
 267       skipManyTill loggingNotification $ count 2 noDiagnostics
 268       hover <- getHover doc (Position 45 9) -- putStrLn
 269       liftIO $ hover `shouldSatisfy` isJust
 270
 271 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 272
 273 didChangeCaps :: ClientCapabilities
 274 didChangeCaps = def { _workspace = Just workspaceCaps }
 275   where
 276     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 277     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 278
 279 docChangesCaps :: ClientCapabilities
 280 docChangesCaps = def { _workspace = Just workspaceCaps }
 281   where
 282     workspaceCaps = def { _workspaceEdit = Just editCaps }
 283     editCaps = WorkspaceEditClientCapabilities (Just True)
 284
 285 data ApplyOneParams = AOP
 286   { file      :: Uri
 287   , start_pos :: Position
 288   , hintTitle :: String
 289   } deriving (Generic, ToJSON)