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         in sesh `shouldThrow` (== Timeout)
  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       item:_ <- getCompletions doc (Position 5 5)
 244       liftIO $ do
 245         item ^. label `shouldBe` "interactWithUser"
 246         item ^. kind `shouldBe` Just CiFunction
 247         item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
 248
 249   describe "getReferences" $
 250     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 251       doc <- openDoc "Desktop/simple.hs" "haskell"
 252       let pos = Position 40 3 -- interactWithUser
 253           uri = doc ^. LSP.uri
 254       refs <- getReferences doc pos True
 255       liftIO $ refs `shouldContain` map (Location uri) [
 256           mkRange 41 0 41 16
 257         , mkRange 75 6 75 22
 258         , mkRange 71 6 71 22
 259         ]
 260
 261   describe "getDefinitions" $
 262     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 263       doc <- openDoc "Desktop/simple.hs" "haskell"
 264       let pos = Position 49 25 -- addItem
 265       defs <- getDefinitions doc pos
 266       liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
 267
 268   describe "getTypeDefinitions" $
 269     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 270       doc <- openDoc "Desktop/simple.hs" "haskell"
 271       let pos = Position 20 23  -- Quit value
 272       defs <- getTypeDefinitions doc pos
 273       liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)]  -- Type definition
 274
 275   describe "waitForDiagnosticsSource" $
 276     it "works" $ runSession "hie" fullCaps "test/data" $ do
 277       openDoc "Error.hs" "haskell"
 278       [diag] <- waitForDiagnosticsSource "ghcmod"
 279       liftIO $ do
 280         diag ^. severity `shouldBe` Just DsError
 281         diag ^. source `shouldBe` Just "ghcmod"
 282
 283   describe "rename" $
 284     it "works" $ runSession "hie" fullCaps "test/data" $ do
 285       doc <- openDoc "Rename.hs" "haskell"
 286       rename doc (Position 1 0) "bar"
 287       documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
 288
 289   describe "getHover" $
 290     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 291       doc <- openDoc "Desktop/simple.hs" "haskell"
 292       -- hover returns nothing until module is loaded
 293       skipManyTill loggingNotification $ count 2 noDiagnostics
 294       hover <- getHover doc (Position 45 9) -- putStrLn
 295       liftIO $ hover `shouldSatisfy` isJust
 296
 297   describe "getHighlights" $
 298     it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
 299       doc <- openDoc "Desktop/simple.hs" "haskell"
 300       skipManyTill loggingNotification $ count 2 noDiagnostics
 301       highlights <- getHighlights doc (Position 27 4) -- addItem
 302       liftIO $ length highlights `shouldBe` 4
 303
 304   describe "formatDoc" $
 305     it "works" $ runSession "hie" fullCaps "test/data" $ do
 306       doc <- openDoc "Format.hs" "haskell"
 307       oldContents <- documentContents doc
 308       formatDoc doc (FormattingOptions 4 True)
 309       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 310
 311   describe "formatRange" $
 312     it "works" $ runSession "hie" fullCaps "test/data" $ do
 313       doc <- openDoc "Format.hs" "haskell"
 314       oldContents <- documentContents doc
 315       formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
 316       documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
 317
 318   describe "closeDoc" $
 319     it "works" $
 320       let sesh =
 321             runSession "hie" fullCaps "test/data" $ do
 322               doc <- openDoc "Format.hs" "haskell"
 323               closeDoc doc
 324               -- need to evaluate to throw
 325               documentContents doc >>= liftIO . print
 326       in sesh `shouldThrow` anyException
 327
 328   describe "satisfy" $
 329     it "works" $ runSession "hie" fullCaps "test/data" $ do
 330       openDoc "Format.hs" "haskell"
 331       let pred (NotLogMessage _) = True
 332           pred _ = False
 333       void $ satisfy pred
 334
 335 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
 336
 337 didChangeCaps :: ClientCapabilities
 338 didChangeCaps = def { _workspace = Just workspaceCaps }
 339   where
 340     workspaceCaps = def { _didChangeConfiguration = Just configCaps }
 341     configCaps = DidChangeConfigurationClientCapabilities (Just True)
 342
 343 docChangesCaps :: ClientCapabilities
 344 docChangesCaps = def { _workspace = Just workspaceCaps }
 345   where
 346     workspaceCaps = def { _workspaceEdit = Just editCaps }
 347     editCaps = WorkspaceEditClientCapabilities (Just True)
 348
 349 data ApplyOneParams = AOP
 350   { file      :: Uri
 351   , start_pos :: Position
 352   , hintTitle :: String
 353   } deriving (Generic, ToJSON)