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       item:_ <- getCompletions doc (Position 5 5)
 233       liftIO $ do
 234         item ^. label `shouldBe` "interactWithUser"
 235         item ^. kind `shouldBe` Just CiFunction
 236         item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
 237
 238   describe "getReferences" $
 239     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 240       doc <- openDoc "Desktop/simple.hs" "haskell"
 241       let pos = Position 40 3 -- interactWithUser
 242           uri = doc ^. LSP.uri
 243       refs <- getReferences doc pos True
 244       liftIO $ refs `shouldContain` map (Location uri) [
 245           mkRange 41 0 41 16
 246         , mkRange 75 6 75 22
 247         , mkRange 71 6 71 22
 248         ]
 249
 250   describe "getDefinitions" $
 251     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 252       doc <- openDoc "Desktop/simple.hs" "haskell"
 253       let pos = Position 49 25 -- addItem
 254       defs <- getDefinitions doc pos
 255       liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
 256
 257   describe "waitForDiagnosticsSource" $
 258     it "works" $ runSession "hie" fullCaps "test/data" $ do
 259       openDoc "Error.hs" "haskell"
 260       [diag] <- waitForDiagnosticsSource "ghcmod"
 261       liftIO $ do
 262         diag ^. severity `shouldBe` Just DsError
 263         diag ^. source `shouldBe` Just "ghcmod"
 264
 265   describe "rename" $
 266     it "works" $ runSession "hie" fullCaps "test/data" $ do
 267       doc <- openDoc "Rename.hs" "haskell"
 268       rename doc (Position 1 0) "bar"
 269       documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
 270
 271   describe "getHover" $
 272     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 273       doc <- openDoc "Desktop/simple.hs" "haskell"
 274       -- hover returns nothing until module is loaded
 275       skipManyTill loggingNotification $ count 2 noDiagnostics
 276       hover <- getHover doc (Position 45 9) -- putStrLn
 277       liftIO $ hover `shouldSatisfy` isJust
 278
 279   describe "getHighlights" $
 280     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 281       doc <- openDoc "Desktop/simple.hs" "haskell"
 282       skipManyTill loggingNotification $ count 2 noDiagnostics
 283       highlights <- getHighlights doc (Position 27 4) -- addItem
 284       liftIO $ length highlights `shouldBe` 4
 285
 286   describe "formatDoc" $
 287     it "works" $ runSession "hie" fullCaps "test/data" $ do
 288       doc <- openDoc "Format.hs" "haskell"
 289       oldContents <- documentContents doc
 290       formatDoc doc (FormattingOptions 4 True)
 291       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 292
 293   describe "formatRange" $
 294     it "works" $ runSession "hie" fullCaps "test/data" $ do
 295       doc <- openDoc "Format.hs" "haskell"
 296       oldContents <- documentContents doc
 297       formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
 298       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 299
 300   describe "closeDoc" $
 301     it "works" $
 302       let sesh =
 303             runSession "hie" fullCaps "test/data" $ do
 304               doc <- openDoc "Format.hs" "haskell"
 305               closeDoc doc
 306               -- need to evaluate to throw
 307               documentContents doc >>= liftIO . print
 308       in sesh `shouldThrow` anyException
 309
 310 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 311
 312 didChangeCaps :: ClientCapabilities
 313 didChangeCaps = def { _workspace = Just workspaceCaps }
 314   where
 315     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 316     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 317
 318 docChangesCaps :: ClientCapabilities
 319 docChangesCaps = def { _workspace = Just workspaceCaps }
 320   where
 321     workspaceCaps = def { _workspaceEdit = Just editCaps }
 322     editCaps = WorkspaceEditClientCapabilities (Just True)
 323
 324 data ApplyOneParams = AOP
 325   { file      :: Uri
 326   , start_pos :: Position
 327   , hintTitle :: String
 328   } deriving (Generic, ToJSON)