mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Workspace roots and getFileExists (#412)
* parse lsp client configuration to track workspace roots * Only use Watched files on workspace files * Apply suggestions from code review Co-Authored-By: Moritz Kiefer <moritz.kiefer@purelyfunctional.org> * Add tests for watched files Left as future work: adding tests for workspace folder notifications * Add a test for file creation outside workspace Co-authored-by: Moritz Kiefer <moritz.kiefer@purelyfunctional.org>
This commit is contained in:
parent
2d71599faf
commit
ffb05636b6
@ -101,6 +101,7 @@ library
|
||||
exposed-modules:
|
||||
Development.IDE.Core.Debouncer
|
||||
Development.IDE.Core.FileStore
|
||||
Development.IDE.Core.IdeConfiguration
|
||||
Development.IDE.Core.OfInterest
|
||||
Development.IDE.Core.PositionMapping
|
||||
Development.IDE.Core.Rules
|
||||
|
@ -19,6 +19,7 @@ import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Core.FileStore
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import Development.IDE.Core.Shake
|
||||
import Development.IDE.Types.Location
|
||||
import Development.Shake
|
||||
@ -101,6 +102,11 @@ fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
|
||||
fileExistsRulesFast getLspId vfs = do
|
||||
addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
|
||||
defineEarlyCutoff $ \GetFileExists file -> do
|
||||
isWf <- isWorkspaceFile file
|
||||
if isWf then fileExistsFast getLspId vfs file else fileExistsSlow vfs file
|
||||
|
||||
fileExistsFast :: IO LspId -> VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
|
||||
fileExistsFast getLspId vfs file = do
|
||||
fileExistsMap <- getFileExistsMapUntracked
|
||||
let mbFilesWatched = HashMap.lookup file fileExistsMap
|
||||
case mbFilesWatched of
|
||||
@ -145,8 +151,11 @@ summarizeExists :: Bool -> Maybe BS.ByteString
|
||||
summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
|
||||
|
||||
fileExistsRulesSlow:: VFSHandle -> Rules ()
|
||||
fileExistsRulesSlow vfs = do
|
||||
defineEarlyCutoff $ \GetFileExists file -> do
|
||||
fileExistsRulesSlow vfs =
|
||||
defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file
|
||||
|
||||
fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
|
||||
fileExistsSlow vfs file = do
|
||||
alwaysRerun
|
||||
exist <- liftIO $ getFileExistsVFS vfs file
|
||||
pure (summarizeExists exist, ([], Just exist))
|
||||
|
66
src/Development/IDE/Core/IdeConfiguration.hs
Normal file
66
src/Development/IDE/Core/IdeConfiguration.hs
Normal file
@ -0,0 +1,66 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
module Development.IDE.Core.IdeConfiguration
|
||||
( IdeConfiguration(..)
|
||||
, registerIdeConfiguration
|
||||
, parseConfiguration
|
||||
, parseWorkspaceFolder
|
||||
, isWorkspaceFile
|
||||
, modifyWorkspaceFolders
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Monad
|
||||
import Data.HashSet (HashSet, singleton)
|
||||
import Data.Text (Text, isPrefixOf)
|
||||
import Development.IDE.Core.Shake
|
||||
import Development.IDE.Types.Location
|
||||
import Development.Shake
|
||||
import Language.Haskell.LSP.Types
|
||||
|
||||
-- | Lsp client relevant configuration details
|
||||
data IdeConfiguration = IdeConfiguration
|
||||
{ workspaceFolders :: HashSet NormalizedUri
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}
|
||||
|
||||
instance IsIdeGlobal IdeConfigurationVar
|
||||
|
||||
registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()
|
||||
registerIdeConfiguration extras =
|
||||
addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar
|
||||
|
||||
getIdeConfiguration :: Action IdeConfiguration
|
||||
getIdeConfiguration =
|
||||
getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef
|
||||
|
||||
parseConfiguration :: InitializeRequest -> IdeConfiguration
|
||||
parseConfiguration RequestMessage { _params = InitializeParams {..} } =
|
||||
IdeConfiguration { .. }
|
||||
where
|
||||
workspaceFolders =
|
||||
foldMap (singleton . toNormalizedUri) _rootUri
|
||||
<> (foldMap . foldMap)
|
||||
(singleton . parseWorkspaceFolder)
|
||||
_workspaceFolders
|
||||
|
||||
parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
|
||||
parseWorkspaceFolder =
|
||||
toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)
|
||||
|
||||
modifyWorkspaceFolders
|
||||
:: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
|
||||
modifyWorkspaceFolders ide f = do
|
||||
IdeConfigurationVar var <- getIdeGlobalState ide
|
||||
IdeConfiguration ws <- readVar var
|
||||
writeVar var (IdeConfiguration (f ws))
|
||||
|
||||
isWorkspaceFile :: NormalizedFilePath -> Action Bool
|
||||
isWorkspaceFile file = do
|
||||
IdeConfiguration {..} <- getIdeConfiguration
|
||||
let toText = getUri . fromNormalizedUri
|
||||
return $ any
|
||||
(\root -> toText root `isPrefixOf` toText (filePathToUri' file))
|
||||
workspaceFolders
|
@ -19,7 +19,7 @@
|
||||
-- always stored as real Haskell values, whereas Shake serialises all 'A' values
|
||||
-- between runs. To deserialise a Shake value, we just consult Values.
|
||||
module Development.IDE.Core.Shake(
|
||||
IdeState,
|
||||
IdeState, shakeExtras,
|
||||
ShakeExtras(..), getShakeExtras,
|
||||
IdeRule, IdeResult, GetModificationTime(..),
|
||||
shakeOpen, shakeShut,
|
||||
@ -30,7 +30,7 @@ module Development.IDE.Core.Shake(
|
||||
define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
|
||||
getDiagnostics, unsafeClearDiagnostics,
|
||||
getHiddenDiagnostics,
|
||||
IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
|
||||
IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
|
||||
garbageCollect,
|
||||
setPriority,
|
||||
sendEvent,
|
||||
@ -114,13 +114,15 @@ getShakeExtrasRules = do
|
||||
Just x <- getShakeExtraRules @ShakeExtras
|
||||
return x
|
||||
|
||||
|
||||
|
||||
class Typeable a => IsIdeGlobal a where
|
||||
|
||||
addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
|
||||
addIdeGlobal x@(typeOf -> ty) = do
|
||||
ShakeExtras{globals} <- getShakeExtrasRules
|
||||
addIdeGlobal x = do
|
||||
extras <- getShakeExtrasRules
|
||||
liftIO $ addIdeGlobalExtras extras x
|
||||
|
||||
addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
|
||||
addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
|
||||
liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
|
||||
Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
|
||||
Nothing -> return $! HMap.insert ty (toDyn x) mp
|
||||
|
@ -28,10 +28,11 @@ import GHC.IO.Handle (hDuplicate)
|
||||
import System.IO
|
||||
import Control.Monad.Extra
|
||||
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import Development.IDE.Core.Shake
|
||||
import Development.IDE.LSP.HoverDefinition
|
||||
import Development.IDE.LSP.Notifications
|
||||
import Development.IDE.LSP.Outline
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Types.Logger
|
||||
import Development.IDE.Core.FileStore
|
||||
import Language.Haskell.LSP.Core (LspFuncs(..))
|
||||
@ -105,8 +106,8 @@ runLanguageServer options userHandlers getIdeState = do
|
||||
handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
|
||||
|
||||
let initializeCallbacks = LSP.InitializeCallbacks
|
||||
{ LSP.onInitialConfiguration = const $ Right ()
|
||||
, LSP.onConfigurationChange = const $ Right ()
|
||||
{ LSP.onInitialConfiguration = Right . parseConfiguration
|
||||
, LSP.onConfigurationChange = const $ Left "Configuration changes not supported yet"
|
||||
, LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
|
||||
}
|
||||
|
||||
@ -121,9 +122,13 @@ runLanguageServer options userHandlers getIdeState = do
|
||||
, void $ waitBarrier clientMsgBarrier
|
||||
]
|
||||
where
|
||||
handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
|
||||
handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs IdeConfiguration -> IO (Maybe err)
|
||||
handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
|
||||
|
||||
ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
|
||||
|
||||
mapM_ (registerIdeConfiguration (shakeExtras ide)) =<< config
|
||||
|
||||
_ <- flip forkFinally (const exitClientMsg) $ forever $ do
|
||||
msg <- readChan clientMsgChan
|
||||
case msg of
|
||||
@ -193,12 +198,12 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
|
||||
-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
|
||||
-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
|
||||
data Message
|
||||
= forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp))
|
||||
= forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (Either ResponseError resp))
|
||||
-- | Used for cases in which we need to send not only a response,
|
||||
-- but also an additional request to the client.
|
||||
-- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
|
||||
| forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
|
||||
| forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())
|
||||
| forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
|
||||
| forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO ())
|
||||
|
||||
|
||||
modifyOptions :: LSP.Options -> LSP.Options
|
||||
|
@ -13,6 +13,7 @@ import qualified Language.Haskell.LSP.Core as LSP
|
||||
import Language.Haskell.LSP.Types
|
||||
import qualified Language.Haskell.LSP.Types as LSP
|
||||
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Types.Logger
|
||||
@ -69,4 +70,11 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
|
||||
logInfo (ideLogger ide) $ "Files created or deleted: " <> msg
|
||||
modifyFileExists ide events
|
||||
setSomethingModified ide
|
||||
,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $
|
||||
\_ ide (DidChangeWorkspaceFoldersParams events) -> do
|
||||
let add = S.union
|
||||
substract = flip S.difference
|
||||
modifyWorkspaceFolders ide
|
||||
$ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events))
|
||||
. substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))
|
||||
}
|
||||
|
@ -18,6 +18,7 @@ import Data.Text ( Text
|
||||
)
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Core.Rules
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import Development.IDE.Core.Shake
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Error ( srcSpanToRange )
|
||||
@ -34,7 +35,7 @@ setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x
|
||||
}
|
||||
|
||||
moduleOutline
|
||||
:: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)
|
||||
:: LSP.LspFuncs IdeConfiguration -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)
|
||||
moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
|
||||
= case uriToFilePath uri of
|
||||
Just (toNormalizedFilePath -> fp) -> do
|
||||
|
@ -14,22 +14,23 @@ import Data.Default
|
||||
import Language.Haskell.LSP.Types
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.Messages as LSP
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import Development.IDE.Core.Service
|
||||
|
||||
data WithMessage = WithMessage
|
||||
{withResponse :: forall m req resp . (Show m, Show req) =>
|
||||
(ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
|
||||
(LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
|
||||
(LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
|
||||
Maybe (LSP.Handler (RequestMessage m req resp))
|
||||
,withNotification :: forall m req . (Show m, Show req) =>
|
||||
Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
|
||||
(LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work
|
||||
(LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO ()) -> -- actual work
|
||||
Maybe (LSP.Handler (NotificationMessage m req))
|
||||
,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
|
||||
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
|
||||
(ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
|
||||
(RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
|
||||
(LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
|
||||
(LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
|
||||
Maybe (LSP.Handler (RequestMessage m req resp))
|
||||
}
|
||||
|
||||
|
@ -7,6 +7,7 @@ import Development.IDE.LSP.Server
|
||||
|
||||
import Language.Haskell.LSP.Types
|
||||
import Development.IDE.Core.Rules
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import Language.Haskell.LSP.Messages
|
||||
|
||||
@ -26,7 +27,7 @@ instance Monoid Plugin where
|
||||
mempty = def
|
||||
|
||||
|
||||
codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin
|
||||
codeActionPlugin :: (LSP.LspFuncs IdeConfiguration -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin
|
||||
codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{
|
||||
LSP.codeActionHandler = withResponse RspCodeAction g
|
||||
}
|
||||
|
@ -12,6 +12,7 @@ import Language.Haskell.LSP.Types
|
||||
import Control.Monad (join)
|
||||
import Development.IDE.Plugin
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import Development.IDE.Core.Rules
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Core.Service
|
||||
@ -43,7 +44,7 @@ plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens
|
||||
|
||||
-- | Generate code actions.
|
||||
codeAction
|
||||
:: LSP.LspFuncs ()
|
||||
:: LSP.LspFuncs IdeConfiguration
|
||||
-> IdeState
|
||||
-> TextDocumentIdentifier
|
||||
-> Range
|
||||
@ -65,7 +66,7 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag
|
||||
|
||||
-- | Generate code lenses.
|
||||
codeLens
|
||||
:: LSP.LspFuncs ()
|
||||
:: LSP.LspFuncs IdeConfiguration
|
||||
-> IdeState
|
||||
-> CodeLensParams
|
||||
-> IO (Either ResponseError (List CodeLens))
|
||||
@ -86,7 +87,7 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}
|
||||
|
||||
-- | Execute the "typesignature.add" command.
|
||||
executeAddSignatureCommand
|
||||
:: LSP.LspFuncs ()
|
||||
:: LSP.LspFuncs IdeConfiguration
|
||||
-> IdeState
|
||||
-> ExecuteCommandParams
|
||||
-> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
|
||||
|
@ -17,6 +17,7 @@ import Development.IDE.Plugin
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Plugin.Completions.Logic
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import Development.IDE.Core.PositionMapping
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Core.Shake
|
||||
@ -55,7 +56,7 @@ instance Binary ProduceCompletions
|
||||
|
||||
-- | Generate code actions.
|
||||
getCompletionsLSP
|
||||
:: LSP.LspFuncs ()
|
||||
:: LSP.LspFuncs IdeConfiguration
|
||||
-> IdeState
|
||||
-> CompletionParams
|
||||
-> IO (Either ResponseError CompletionResponseResult)
|
||||
|
@ -63,6 +63,7 @@ main = defaultMain $ testGroup "HIE"
|
||||
, unitTests
|
||||
, haddockTests
|
||||
, positionMappingTests
|
||||
, watchedFilesTests
|
||||
]
|
||||
|
||||
initializeResponseTests :: TestTree
|
||||
@ -99,7 +100,7 @@ initializeResponseTests = withResource acquire release tests where
|
||||
, chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
|
||||
, chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
|
||||
, chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
|
||||
, chk "NO workspace" _workspace nothingWorkspace
|
||||
, chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
|
||||
, chk "NO experimental" _experimental Nothing
|
||||
] where
|
||||
|
||||
@ -110,8 +111,6 @@ initializeResponseTests = withResource acquire release tests where
|
||||
, _willSaveWaitUntil = Nothing
|
||||
, _save = Just (SaveOptions {_includeText = Nothing})}))
|
||||
|
||||
nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})
|
||||
|
||||
chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
|
||||
chk title getActual expected =
|
||||
testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
|
||||
@ -243,6 +242,16 @@ diagnosticTests = testGroup "diagnostics"
|
||||
let contentA = T.unlines [ "module ModuleA where" ]
|
||||
_ <- openDoc' "ModuleA.hs" "haskell" contentA
|
||||
expectDiagnostics [("ModuleB.hs", [])]
|
||||
, testSessionWait "add missing module (non workspace)" $ do
|
||||
let contentB = T.unlines
|
||||
[ "module ModuleB where"
|
||||
, "import ModuleA"
|
||||
]
|
||||
_ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB
|
||||
expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
|
||||
let contentA = T.unlines [ "module ModuleA where" ]
|
||||
_ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA
|
||||
expectDiagnostics [("/tmp/ModuleB.hs", [])]
|
||||
, testSessionWait "cyclic module dependency" $ do
|
||||
let contentA = T.unlines
|
||||
[ "module ModuleA where"
|
||||
@ -415,6 +424,26 @@ codeLensesTests = testGroup "code lenses"
|
||||
[ addSigLensesTests
|
||||
]
|
||||
|
||||
watchedFilesTests :: TestTree
|
||||
watchedFilesTests = testGroup "watched files"
|
||||
[ testSession "workspace file" $ do
|
||||
_ <- openDoc' "A.hs" "haskell" "module A where"
|
||||
RequestMessage{_params = RegistrationParams (List regs)} <- skipManyTill anyMessage (message @RegisterCapabilityRequest)
|
||||
let watchedFileRegs =
|
||||
[ args | Registration _id WorkspaceDidChangeWatchedFiles args <- regs ]
|
||||
liftIO $ assertBool "watches workspace files" $ not $ null watchedFileRegs
|
||||
, testSession "non workspace file" $ do
|
||||
_ <- openDoc' "/tmp/A.hs" "haskell" "module A where"
|
||||
msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)
|
||||
let watchedFileRegs =
|
||||
[ args
|
||||
| Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
|
||||
, Registration _id WorkspaceDidChangeWatchedFiles args <- regs
|
||||
]
|
||||
liftIO $ watchedFileRegs @?= []
|
||||
-- TODO add a test for didChangeWorkspaceFolder
|
||||
]
|
||||
|
||||
renameActionTests :: TestTree
|
||||
renameActionTests = testGroup "rename actions"
|
||||
[ testSession "change to local variable name" $ do
|
||||
@ -1812,9 +1841,16 @@ unitTests = do
|
||||
openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
|
||||
openDoc' fp name contents = do
|
||||
res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
|
||||
-- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them
|
||||
sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
|
||||
return res
|
||||
|
||||
-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace
|
||||
openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
|
||||
-- At the moment this is just LSPTest.openDoc' but it may change in the future
|
||||
-- when/if lsp-test implements WatchedFiles
|
||||
openDoc'' = LSPTest.openDoc'
|
||||
|
||||
positionMappingTests :: TestTree
|
||||
positionMappingTests =
|
||||
testGroup "position mapping"
|
||||
|
Loading…
Reference in New Issue
Block a user