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