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.Messages
  15 import           Language.Haskell.LSP.Test
  16 import           Language.Haskell.LSP.Test.Replay
  17 import           Language.Haskell.LSP.TH.ClientCapabilities
  18 import           Language.Haskell.LSP.Types hiding (capabilities)
  19 import           ParsingTests
  20
  21 main = hspec $ do
  22   describe "manual session" $ do
  23     it "passes a test" $
  24       runSession "hie --lsp" "test/data/renamePass" $ do
  25         doc <- openDoc "Desktop/simple.hs" "haskell"
  26
  27         skipMany loggingNotification
  28
  29         checkNoDiagnostics
  30
  31         rspSymbols <- documentSymbols doc
  32
  33         liftIO $ do
  34           let (List symbols) = fromJust (rspSymbols ^. result)
  35               mainSymbol = head symbols
  36           mainSymbol ^. name `shouldBe` "main"
  37           mainSymbol ^. kind `shouldBe` SkFunction
  38           mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
  39           mainSymbol ^. containerName `shouldBe` Nothing
  40
  41     it "fails a test" $
  42       -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
  43       let session = runSession "hie --lsp" "test/data/renamePass" $ do
  44                       openDoc "Desktop/simple.hs" "haskell"
  45                       skipMany loggingNotification
  46                       anyRequest
  47         in session `shouldThrow` anyException
  48     it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do
  49       rsp <- getInitializeResponse
  50       liftIO $ rsp ^. result `shouldNotBe` Nothing
  51
  52     it "can register specific capabilities" $ do
  53       let caps = def { _workspace = Just workspaceCaps }
  54           workspaceCaps = def { _didChangeConfiguration = Just configCaps }
  55           configCaps = DidChangeConfigurationClientCapabilities (Just True)
  56           conf = def { capabilities = caps }
  57       runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return ()
  58
  59     describe "exceptions" $ do
  60       it "throw on time out" $
  61         let sesh = runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do
  62                 skipMany loggingNotification
  63                 _ <- request :: Session ApplyWorkspaceEditRequest
  64                 return ()
  65         in sesh `shouldThrow` anySessionException
  66
  67       it "don't throw when no time out" $ runSessionWithConfig (def {timeout = 5}) "hie --lsp" "test/data/renamePass" $ do
  68         loggingNotification
  69         liftIO $ threadDelay 10
  70         _ <- openDoc "Desktop/simple.hs" "haskell"
  71         return ()
  72
  73       it "throw when there's an unexpected message" $
  74         let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True
  75             selector _ = False
  76           in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
  77
  78       it "throw when there's an unexpected message 2" $
  79         let selector (UnexpectedMessageException "Response" (NotPublishDiagnostics _)) = True
  80             selector _ = False
  81             sesh = do
  82               doc <- openDoc "Desktop/simple.hs" "haskell"
  83               sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
  84               skipMany anyNotification
  85               response :: Session RenameResponse -- the wrong type
  86           in runSession "hie --lsp" "test/data/renamePass" sesh
  87             `shouldThrow` selector
  88
  89   describe "replay session" $ do
  90     it "passes a test" $
  91       replaySession "hie --lsp" "test/data/renamePass"
  92     it "fails a test" $
  93       let selector (ReplayOutOfOrderException _ _) = True
  94           selector _ = False
  95         in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
  96
  97   describe "manual javascript session" $
  98     it "passes a test" $
  99       runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
 100         doc <- openDoc "test.js" "javascript"
 101
 102         checkNoDiagnostics
 103
 104         rspSymbols <- documentSymbols doc
 105
 106         let (List symbols) = fromJust (rspSymbols ^. result)
 107             fooSymbol = head symbols
 108         liftIO $ do
 109           fooSymbol ^. name `shouldBe` "foo"
 110           fooSymbol ^. kind `shouldBe` SkFunction
 111
 112   describe "text document state" $
 113     it "sends back didChange notifications" $
 114       runSession "hie --lsp" "test/data/refactor" $ do
 115         doc <- openDoc "Main.hs" "haskell"
 116
 117         let args = toJSON $ AOP (doc ^. uri)
 118                                 (Position 1 14)
 119                                 "Redundant bracket"
 120             reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
 121         sendRequest WorkspaceExecuteCommand reqParams
 122         skipMany anyNotification
 123         _ <- response :: Session ExecuteCommandResponse
 124
 125         editReq <- request :: Session ApplyWorkspaceEditRequest
 126         liftIO $ do
 127           let (Just cs) = editReq ^. params . edit . changes
 128               [(u, List es)] = HM.toList cs
 129           u `shouldBe` doc ^. uri
 130           es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
 131
 132         checkNoDiagnostics
 133
 134         contents <- documentContents doc
 135         liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
 136
 137   parsingSpec
 138
 139 data ApplyOneParams = AOP
 140   { file      :: Uri
 141   , start_pos :: Position
 142   , hintTitle :: String
 143   } deriving (Generic, ToJSON)
 144
 145 checkNoDiagnostics :: Session ()
 146 checkNoDiagnostics = do
 147   diagsNot <- notification :: Session PublishDiagnosticsNotification
 148   liftIO $ diagsNot ^. params . diagnostics `shouldBe` List []
 149
 150 documentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse
 151 documentSymbols doc = do
 152   sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
 153   response