X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=81bdc8a8b465087baa960fbc6b1303e8497fcff7;hp=b3f535f3ca59f1616cee0bfb1dc1898ff68e1472;hb=a7fd35b1582f9816d8caa90a7b2e3aa765fb0446;hpb=80a27eb1c9cb59c25bdf8c80926b897bc48f3672

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index b3f535f..81bdc8a 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -41,8 +41,8 @@ module Language.Haskell.LSP.Test
   -- ** Initialization
   , initializeResponse
   -- ** Documents
+  , createDoc
   , openDoc
-  , openDoc'
   , closeDoc
   , changeDoc
   , documentContents
@@ -82,6 +82,8 @@ module Language.Haskell.LSP.Test
   , applyEdit
   -- ** Code lenses
   , getCodeLenses
+  -- ** Capabilities
+  , getRegisteredCapabilities
   ) where
 
 import Control.Applicative.Combinators
@@ -90,12 +92,13 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Exception
 import Control.Lens hiding ((.=), List)
+import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Aeson
 import Data.Default
 import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Map as Map
+import Data.List
 import Data.Maybe
 import Language.Haskell.LSP.Types
 import Language.Haskell.LSP.Types.Lens hiding
@@ -114,6 +117,7 @@ import System.Environment
 import System.IO
 import System.Directory
 import System.FilePath
+import qualified System.FilePath.Glob as Glob
 
 -- | Starts a new session.
 --
@@ -160,7 +164,9 @@ runSessionWithConfig config' serverExe caps rootDir session = do
       -- collect them and then...
       (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId)
 
-      liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
+      case initRspMsg ^. LSP.result of
+        Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)
+        Right _ -> pure ()
 
       initRspVar <- initRsp <$> ask
       liftIO $ putMVar initRspVar initRspMsg
@@ -343,7 +349,61 @@ sendResponse = sendMessage
 initializeResponse :: Session InitializeResponse
 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 
--- | Opens a text document and sends a notification to the client.
+-- | /Creates/ a new text document. This is different from 'openDoc'
+-- as it sends a workspace/didChangeWatchedFiles notification letting the server
+-- know that a file was created within the workspace, __provided that the server
+-- has registered for it__, and the file matches any patterns the server
+-- registered for.
+-- It /does not/ actually create a file on disk, but is useful for convincing
+-- the server that one does exist.
+--
+-- @since 11.0.0.0
+createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__.
+          -> String -- ^ The text document's language identifier, e.g. @"haskell"@.
+          -> T.Text -- ^ The content of the text document to create.
+          -> Session TextDocumentIdentifier -- ^ The identifier of the document just created.
+createDoc file languageId contents = do
+  dynCaps <- curDynCaps <$> get
+  rootDir <- asks rootDir
+  caps <- asks sessionCapabilities
+  absFile <- liftIO $ canonicalizePath (rootDir </> file)
+  let regs = filter (\r -> r ^. method == WorkspaceDidChangeWatchedFiles) $
+              Map.elems dynCaps
+      watchHits :: FileSystemWatcher -> Bool
+      watchHits (FileSystemWatcher pattern kind) =
+        -- If WatchKind is exlcuded, defaults to all true as per spec
+        fileMatches pattern && createHits (fromMaybe (WatchKind True True True) kind)
+
+      fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs
+        -- If the pattern is absolute then match against the absolute fp
+        where relOrAbs
+                | isAbsolute pattern = absFile
+                | otherwise = file
+
+      createHits (WatchKind create _ _) = create
+
+      regHits :: Registration -> Bool
+      regHits reg = isJust $ do
+        opts <- reg ^. registerOptions
+        fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of
+          Success x -> Just x
+          Error _ -> Nothing
+        if foldl' (\acc w -> acc || watchHits w) False (fileWatchOpts ^. watchers)
+          then Just ()
+          else Nothing
+
+      clientCapsSupports =
+          caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just
+            == Just True
+      shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs
+
+  when shouldSend $
+    sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
+      List [ FileEvent (filePathToUri (rootDir </> file)) FcCreated ]
+  openDoc' file languageId contents
+
+-- | Opens a text document that /exists on disk/, and sends a
+-- textDocument/didOpen notification to the server.
 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 openDoc file languageId = do
   context <- ask
@@ -352,6 +412,7 @@ openDoc file languageId = do
   openDoc' file languageId contents
 
 -- | This is a variant of `openDoc` that takes the file content as an argument.
+-- Use this is the file exists /outside/ of the current workspace.
 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
 openDoc' file languageId contents = do
   context <- ask
@@ -361,13 +422,13 @@ openDoc' file languageId contents = do
   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
   pure $ TextDocumentIdentifier uri
 
--- | Closes a text document and sends a notification to the client.
+-- | Closes a text document and sends a textDocument/didOpen notification to the server.
 closeDoc :: TextDocumentIdentifier -> Session ()
 closeDoc docId = do
   let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
   sendNotification TextDocumentDidClose params
 
--- | Changes a text document and sends a notification to the client
+-- | Changes a text document and sends a textDocument/didOpen notification to the server.
 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
 changeDoc docId changes = do
   verDoc <- getVersionedDoc docId
@@ -412,12 +473,11 @@ noDiagnostics = do
 -- | Returns the symbols in a document.
 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
 getDocumentSymbols doc = do
-  ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
-  maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
-  case mRes of
-    Just (DSDocumentSymbols (List xs)) -> return (Left xs)
-    Just (DSSymbolInformation (List xs)) -> return (Right xs)
-    Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
+  ResponseMessage _ rspLid res <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
+  case res of
+    Right (DSDocumentSymbols (List xs)) -> return (Left xs)
+    Right (DSSymbolInformation (List xs)) -> return (Right xs)
+    Left err -> throw (UnexpectedResponseError rspLid err)
 
 -- | Returns the code actions in the specified range.
 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
@@ -426,8 +486,8 @@ getCodeActions doc range = do
   rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
 
   case rsp ^. result of
-    Just (List xs) -> return xs
-    _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
+    Right (List xs) -> return xs
+    Left error -> throw (UnexpectedResponseError (rsp ^. LSP.id) error)
 
 -- | Returns all the code actions in a document by
 -- querying the code actions at each of the current
@@ -441,13 +501,11 @@ getAllCodeActions doc = do
   where
     go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
     go ctx acc diag = do
-      ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
+      ResponseMessage _ rspLid res <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
 
-      case mErr of
-        Just e -> throw (UnexpectedResponseError rspLid e)
-        Nothing ->
-          let Just (List cmdOrCAs) = mRes
-            in return (acc ++ cmdOrCAs)
+      case res of
+        Left e -> throw (UnexpectedResponseError rspLid e)
+        Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)
 
 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
 getCodeActionContext doc = do
@@ -581,9 +639,10 @@ getHighlights doc pos =
 -- | Checks the response for errors and throws an exception if needed.
 -- Returns the result if successful.
 getResponseResult :: ResponseMessage a -> a
-getResponseResult rsp = fromMaybe exc (rsp ^. result)
-  where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
-                                              (fromJust $ rsp ^. LSP.error)
+getResponseResult rsp =
+  case rsp ^. result of
+    Right x -> x
+    Left err -> throw $ UnexpectedResponseError (rsp ^. LSP.id) err
 
 -- | Applies formatting to the specified document.
 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
@@ -611,3 +670,10 @@ getCodeLenses tId = do
     rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
     case getResponseResult rsp of
         List res -> pure res
+
+-- | Returns a list of capabilities that the server has requested to /dynamically/
+-- register during the 'Session'.
+--
+-- @since 0.11.0.0
+getRegisteredCapabilities :: Session [Registration]
+getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get
\ No newline at end of file