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