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.Directory
  27 import           System.FilePath
  28 import           System.Timeout
  29
  30 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
  31 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
  32
  33
  34 main = findServer >>= \serverExe -> hspec $ do
  35   describe "Session" $ do
  36     it "fails a test" $ do
  37       let session = runSession serverExe fullCaps "test/data/renamePass" $ do
  38                       openDoc "Desktop/simple.hs" "haskell"
  39                       anyRequest
  40         in session `shouldThrow` anySessionException
  41     it "initializeResponse" $ runSession serverExe fullCaps "test/data/renamePass" $ do
  42       rsp <- initializeResponse
  43       liftIO $ rsp ^. result `shouldSatisfy` isRight
  44
  45     it "runSessionWithConfig" $
  46       runSession serverExe didChangeCaps "test/data/renamePass" $ return ()
  47
  48     describe "withTimeout" $ do
  49       it "times out" $
  50         let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
  51                     openDoc "Desktop/simple.hs" "haskell"
  52                     -- won't receive a request - will timeout
  53                     -- incoming logging requests shouldn't increase the
  54                     -- timeout
  55                     withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
  56           -- wait just a bit longer than 5 seconds so we have time
  57           -- to open the document
  58           in timeout 6000000 sesh `shouldThrow` anySessionException
  59
  60       it "doesn't time out" $
  61         let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
  62                     openDoc "Desktop/simple.hs" "haskell"
  63                     withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
  64           in void $ timeout 6000000 sesh
  65
  66       it "further timeout messages are ignored" $ runSession serverExe fullCaps "test/data/renamePass" $ do
  67         doc <- openDoc "Desktop/simple.hs" "haskell"
  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 }) serverExe 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 }) serverExe 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}) serverExe 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}) serverExe fullCaps "test/data/renamePass" $ do
 109         loggingNotification
 110         liftIO $ threadDelay $ 6 * 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 serverExe 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 serverExe 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 serverExe "test/data/renamePass"
 134     it "fails a test" $
 135       let selector (ReplayOutOfOrder _ _) = True
 136           selector _ = False
 137         in replaySession serverExe "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 serverExe def "test/data/refactor" $ do
 155         doc <- openDoc "Main.hs" "haskell"
 156
 157         let args = toJSON (doc ^. uri)
 158             reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
 159         request_ WorkspaceExecuteCommand reqParams
 160
 161         editReq <- message :: Session ApplyWorkspaceEditRequest
 162         liftIO $ do
 163           let (Just cs) = editReq ^. params . edit . changes
 164               [(u, List es)] = HM.toList cs
 165           u `shouldBe` doc ^. uri
 166           es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"]
 167         contents <- documentContents doc
 168         liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
 169
 170   describe "getDocumentEdit" $
 171     it "automatically consumes applyedit requests" $
 172       runSession serverExe fullCaps "test/data/refactor" $ do
 173         doc <- openDoc "Main.hs" "haskell"
 174
 175         let args = toJSON (doc ^. uri)
 176             reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
 177         request_ WorkspaceExecuteCommand reqParams
 178         contents <- getDocumentEdit doc
 179         liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
 180
 181   -- describe "getCodeActions" $
 182   --   it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
 183   --     doc <- openDoc "Main.hs" "haskell"
 184   --     waitForDiagnostics
 185   --     [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
 186   --     liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
 187
 188   describe "getAllCodeActions" $
 189     it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
 190       doc <- openDoc "Main.hs" "haskell"
 191       _ <- waitForDiagnostics
 192       actions <- getAllCodeActions doc
 193       liftIO $ do
 194         let [CACodeAction action] = actions
 195         action ^. title `shouldBe` "Delete this"
 196         action ^. command . _Just . command `shouldBe` "deleteThis"
 197
 198   -- describe "getDocumentSymbols" $
 199   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 200   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 201
 202   --     skipMany loggingNotification
 203
 204   --     noDiagnostics
 205
 206   --     Left (mainSymbol:_) <- getDocumentSymbols doc
 207
 208   --     liftIO $ do
 209   --       mainSymbol ^. name `shouldBe` "main"
 210   --       mainSymbol ^. kind `shouldBe` SkFunction
 211   --       mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
 212
 213   describe "applyEdit" $ do
 214     it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do
 215       doc <- openDoc "Desktop/simple.hs" "haskell"
 216       VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
 217       let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
 218       VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
 219       liftIO $ newVersion `shouldBe` oldVersion + 1
 220     it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 221       doc <- openDoc "Desktop/simple.hs" "haskell"
 222       let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
 223       applyEdit doc edit
 224       contents <- documentContents doc
 225       liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
 226
 227   -- describe "getCompletions" $
 228   --   it "works" $ runSession serverExe def "test/data/renamePass" $ do
 229   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 230
 231   --     -- wait for module to be loaded
 232   --     skipMany loggingNotification
 233   --     noDiagnostics
 234   --     noDiagnostics
 235
 236   --     comps <- getCompletions doc (Position 5 5)
 237   --     let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
 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 serverExe 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 serverExe 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 serverExe 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 0 14 19)]  -- Type definition
 268
 269   -- describe "waitForDiagnosticsSource" $
 270   --   it "works" $ runSession serverExe fullCaps "test/data" $ do
 271   --     openDoc "Error.hs" "haskell"
 272   --     [diag] <- waitForDiagnosticsSource "bios"
 273   --     liftIO $ do
 274   --       diag ^. severity `shouldBe` Just DsError
 275   --       diag ^. source `shouldBe` Just "bios"
 276
 277   -- describe "rename" $ do
 278   --   it "works" $ pendingWith "HaRe not in hie-bios yet"
 279   --   it "works on javascript" $
 280   --     runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
 281   --       doc <- openDoc "test.js" "javascript"
 282   --       rename doc (Position 2 11) "bar"
 283   --       documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
 284
 285   -- describe "getHover" $
 286   --   it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
 287   --     doc <- openDoc "Desktop/simple.hs" "haskell"
 288   --     hover <- getHover doc (Position 45 9)
 289   --     liftIO $ hover `shouldSatisfy` isJust
 290
 291   -- describe "getHighlights" $
 292   --   it "works" $ runSession serverExe 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 serverExe 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 serverExe 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 serverExe 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 serverExe fullCaps "test/data" $ do
 324       openDoc "Format.hs" "haskell"
 325       let pred (NotLogMessage _) = True
 326           pred _ = False
 327       void $ satisfy pred
 328
 329   describe "ignoreLogNotifications" $
 330     it "works" $
 331       runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe  fullCaps "test/data" $ do
 332         openDoc "Format.hs" "haskell"
 333         void publishDiagnosticsNotification
 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
 350 findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)
 351 findExeRecursive exe dir = do
 352   me <- listToMaybe <$> findExecutablesInDirectories [dir] exe
 353   case me of
 354     Just e -> return (Just e)
 355     Nothing -> do
 356       subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
 357       foldM (\acc subdir -> case acc of
 358                               Just y -> pure $ Just y
 359                               Nothing -> findExeRecursive exe subdir)
 360             Nothing
 361             subdirs
 362
 363 -- | So we can find the dummy-server with cabal run
 364 -- since it doesnt put build tools on the path (only cabal test)
 365 findServer = do
 366   let serverName = "dummy-server"
 367   e <- findExecutable serverName
 368   e' <- findExeRecursive serverName "dist-newstyle"
 369   pure $ fromJust $ e <|> e'