test/Test.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE DeriveAnyClass #-}
   5 import           Test.Hspec
   6 import           Data.Aeson
   7 import           Data.Default
   8 import qualified Data.HashMap.Strict as HM
   9 import           Data.Maybe
  10 import           Control.Concurrent
  11 import           Control.Monad.IO.Class
  12 import           Control.Lens hiding (List)
  13 import           GHC.Generics
  14 import           Language.Haskell.LSP.Test
  15 import           Language.Haskell.LSP.Test.Replay
  16 import           Language.Haskell.LSP.TH.ClientCapabilities
  17 import           Language.Haskell.LSP.Types hiding (capabilities)
  18 import           ParsingTests
  19
  20 main = hspec $ do
  21   describe "manual session" $ do
  22     it "passes a test" $
  23       runSession "hie --lsp" "test/data/renamePass" $ do
  24         doc <- openDoc "Desktop/simple.hs" "haskell"
  25
  26         skipMany loggingNotification
  27
  28         checkNoDiagnostics
  29
  30         rspSymbols <- documentSymbols doc
  31
  32         liftIO $ do
  33           let (List symbols) = fromJust (rspSymbols ^. result)
  34               mainSymbol = head symbols
  35           mainSymbol ^. name `shouldBe` "main"
  36           mainSymbol ^. kind `shouldBe` SkFunction
  37           mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
  38           mainSymbol ^. containerName `shouldBe` Nothing
  39
  40     it "fails a test" $
  41       -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
  42       let session = runSession "hie --lsp" "test/data/renamePass" $ do
  43                       openDoc "Desktop/simple.hs" "haskell"
  44                       skipMany loggingNotification
  45                       anyRequest
  46         in session `shouldThrow` anyException
  47     it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do
  48       rsp <- getInitializeResponse
  49       liftIO $ rsp ^. result `shouldNotBe` Nothing
  50
  51     it "can register specific capabilities" $ do
  52       let caps = def { _workspace = Just workspaceCaps }
  53           workspaceCaps = def { _didChangeConfiguration = Just configCaps }
  54           configCaps = DidChangeConfigurationClientCapabilities (Just True)
  55           conf = def { capabilities = caps }
  56       runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return ()
  57
  58     it "times out" $
  59       let sesh = runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do
  60               skipMany loggingNotification
  61               _ <- request :: Session ApplyWorkspaceEditRequest
  62               return ()
  63       in sesh `shouldThrow` anySessionException
  64
  65     it "doesn't time out" $ runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do
  66       loggingNotification
  67       liftIO $ threadDelay 5
  68
  69
  70   describe "replay session" $ do
  71     it "passes a test" $
  72       replaySession "hie --lsp" "test/data/renamePass" `shouldReturn` True
  73     it "fails a test" $
  74       replaySession "hie --lsp" "test/data/renameFail" `shouldReturn` False
  75
  76   describe "manual javascript session" $
  77     it "passes a test" $
  78       runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
  79         doc <- openDoc "test.js" "javascript"
  80
  81         checkNoDiagnostics
  82
  83         rspSymbols <- documentSymbols doc
  84
  85         let (List symbols) = fromJust (rspSymbols ^. result)
  86             fooSymbol = head symbols
  87         liftIO $ do
  88           fooSymbol ^. name `shouldBe` "foo"
  89           fooSymbol ^. kind `shouldBe` SkFunction
  90
  91   describe "text document state" $
  92     it "sends back didChange notifications" $
  93       runSession "hie --lsp" "test/data/refactor" $ do
  94         doc <- openDoc "Main.hs" "haskell"
  95
  96         let args = toJSON $ AOP (doc ^. uri)
  97                                 (Position 1 14)
  98                                 "Redundant bracket"
  99             reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
 100         sendRequest WorkspaceExecuteCommand reqParams
 101         skipMany anyNotification
 102         _ <- response :: Session ExecuteCommandResponse
 103
 104         editReq <- request :: Session ApplyWorkspaceEditRequest
 105         liftIO $ do
 106           let (Just cs) = editReq ^. params . edit . changes
 107               [(u, List es)] = HM.toList cs
 108           u `shouldBe` doc ^. uri
 109           es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
 110
 111         checkNoDiagnostics
 112
 113         contents <- documentContents doc
 114         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
 115
 116   parsingSpec
 117
 118 data ApplyOneParams = AOP
 119   { file      :: Uri
 120   , start_pos :: Position
 121   , hintTitle :: String
 122   } deriving (Generic, ToJSON)
 123
 124 checkNoDiagnostics :: Session ()
 125 checkNoDiagnostics = do
 126   diagsNot <- notification :: Session PublishDiagnosticsNotification
 127   liftIO $ diagsNot ^. params . diagnostics `shouldBe` List []
 128
 129 documentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse
 130 documentSymbols doc = do
 131   sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
 132   response