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>

Author: pepeiborra

ghcide.cabal

@@ -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

src/Development/IDE/Core/FileExists.hs

@@ -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))

src/Development/IDE/Core/IdeConfiguration.hs

@@ -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

src/Development/IDE/Core/Shake.hs

@@ -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

src/Development/IDE/LSP/LanguageServer.hs

@@ -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

src/Development/IDE/LSP/Notifications.hs

@@ -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))
     }

src/Development/IDE/LSP/Outline.hs

@@ -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

src/Development/IDE/LSP/Server.hs

@@ -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))
     }
 

src/Development/IDE/Plugin.hs

@@ -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
     }

src/Development/IDE/Plugin/CodeAction.hs

@@ -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))