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