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