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