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