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