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