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