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       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 "getHover" $
 288     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 289       doc <- openDoc "Desktop/simple.hs" "haskell"
 290       -- hover returns nothing until module is loaded
 291       skipManyTill loggingNotification $ count 2 noDiagnostics
 292       hover <- getHover doc (Position 45 9) -- putStrLn
 293       liftIO $ hover `shouldSatisfy` isJust
 294
 295   describe "getHighlights" $
 296     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 297       doc <- openDoc "Desktop/simple.hs" "haskell"
 298       skipManyTill loggingNotification $ count 2 noDiagnostics
 299       highlights <- getHighlights doc (Position 27 4) -- addItem
 300       liftIO $ length highlights `shouldBe` 4
 301
 302   describe "formatDoc" $
 303     it "works" $ runSession "hie" fullCaps "test/data" $ do
 304       doc <- openDoc "Format.hs" "haskell"
 305       oldContents <- documentContents doc
 306       formatDoc doc (FormattingOptions 4 True)
 307       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 308
 309   describe "formatRange" $
 310     it "works" $ runSession "hie" fullCaps "test/data" $ do
 311       doc <- openDoc "Format.hs" "haskell"
 312       oldContents <- documentContents doc
 313       formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
 314       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 315
 316   describe "closeDoc" $
 317     it "works" $
 318       let sesh =
 319             runSession "hie" fullCaps "test/data" $ do
 320               doc <- openDoc "Format.hs" "haskell"
 321               closeDoc doc
 322               -- need to evaluate to throw
 323               documentContents doc >>= liftIO . print
 324       in sesh `shouldThrow` anyException
 325
 326   describe "satisfy" $
 327     it "works" $ runSession "hie" fullCaps "test/data" $ do
 328       openDoc "Format.hs" "haskell"
 329       let pred (NotLogMessage _) = True
 330           pred _ = False
 331       void $ satisfy pred
 332
 333 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 334
 335 didChangeCaps :: ClientCapabilities
 336 didChangeCaps = def { _workspace = Just workspaceCaps }
 337   where
 338     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 339     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 340
 341 docChangesCaps :: ClientCapabilities
 342 docChangesCaps = def { _workspace = Just workspaceCaps }
 343   where
 344     workspaceCaps = def { _workspaceEdit = Just editCaps }
 345     editCaps = WorkspaceEditClientCapabilities (Just True)
 346
 347 data ApplyOneParams = AOP
 348   { file      :: Uri
 349   , start_pos :: Position
 350   , hintTitle :: String
 351   } deriving (Generic, ToJSON)