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
 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)
 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]))
 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]))
 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       item:_ <- getCompletions doc (Position 5 5)
 242       liftIO $ do
 243         item ^. label `shouldBe` "interactWithUser"
 244         item ^. kind `shouldBe` Just CiFunction
 245         item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
 246
 247   describe "getReferences" $
 248     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 249       doc <- openDoc "Desktop/simple.hs" "haskell"
 250       let pos = Position 40 3 -- interactWithUser
 251           uri = doc ^. LSP.uri
 252       refs <- getReferences doc pos True
 253       liftIO $ refs `shouldContain` map (Location uri) [
 254           mkRange 41 0 41 16
 255         , mkRange 75 6 75 22
 256         , mkRange 71 6 71 22
 257         ]
 258
 259   describe "getDefinitions" $
 260     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 261       doc <- openDoc "Desktop/simple.hs" "haskell"
 262       let pos = Position 49 25 -- addItem
 263       defs <- getDefinitions doc pos
 264       liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
 265
 266   describe "getTypeDefinitions" $
 267     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 268       doc <- openDoc "Desktop/simple.hs" "haskell"
 269       let pos = Position 20 23  -- Quit value
 270       defs <- getTypeDefinitions doc pos
 271       liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)]  -- Type definition
 272
 273   describe "waitForDiagnosticsSource" $
 274     it "works" $ runSession "hie" fullCaps "test/data" $ do
 275       openDoc "Error.hs" "haskell"
 276       [diag] <- waitForDiagnosticsSource "ghcmod"
 277       liftIO $ do
 278         diag ^. severity `shouldBe` Just DsError
 279         diag ^. source `shouldBe` Just "ghcmod"
 280
 281   describe "rename" $
 282     it "works" $ runSession "hie" fullCaps "test/data" $ do
 283       doc <- openDoc "Rename.hs" "haskell"
 284       rename doc (Position 1 0) "bar"
 285       documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
 286
 287   describe "rename suggestion" $
 288     it "works" $ runSession "hie" fullCaps "test/data" $ do
 289       doc <- openDoc "RenameSuggestion.hs" "haskell"
 290
 291       _ <- waitForDiagnosticsSource "ghcmod"
 292
 293       CACodeAction cmd:_ <- getAllCodeActions doc
 294       executeCodeAction cmd
 295
 296       x:_ <- T.lines <$> documentContents doc
 297       liftIO $ x `shouldBe` "main = putStrLn \"hello\""
 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 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 346
 347 didChangeCaps :: ClientCapabilities
 348 didChangeCaps = def { _workspace = Just workspaceCaps }
 349   where
 350     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 351     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 352
 353 docChangesCaps :: ClientCapabilities
 354 docChangesCaps = def { _workspace = Just workspaceCaps }
 355   where
 356     workspaceCaps = def { _workspaceEdit = Just editCaps }
 357     editCaps = WorkspaceEditClientCapabilities (Just True)
 358
 359 data ApplyOneParams = AOP
 360   { file      :: Uri
 361   , start_pos :: Position
 362   , hintTitle :: String
 363   } deriving (Generic, ToJSON)