Fix two regressions since 0.1.0 (#471)

* Fix isWorkspaceFile for relative paths

This fixes a performance regression on GetFileExists

* Avoid interrupting hie-bios when it's doing its thing

I noticed that the GHC hie-bios direct cradle, which uses Hadrian, a Shake build
system, was failing to start due to the following problem:

1. ghcide starts evaluating the LoadCradle node
2. The evaluation gets cancelled
3. Immediately after, ghcide starts evaluating LoadCradle again
4. Hadrian fails, since there is still another Hadrian process alive taking its
Shake lock

* Improve watched files test suite

Author: pepeiborra

exe/Rules.hs

@@ -14,10 +14,10 @@ import           Data.ByteString.Base16         (encode)
 import qualified Data.ByteString.Char8          as B
 import           Data.Functor                   ((<&>))
 import           Data.Maybe                     (fromMaybe)
-import           Data.Text                      (Text)
+import           Data.Text                      (pack, Text)
 import           Development.IDE.Core.Rules     (defineNoFile)
 import           Development.IDE.Core.Service   (getIdeOptions)
-import           Development.IDE.Core.Shake     (sendEvent, define, useNoFile_)
+import           Development.IDE.Core.Shake     (actionLogger, sendEvent, define, useNoFile_)
 import           Development.IDE.GHC.Util
 import           Development.IDE.Types.Location (fromNormalizedFilePath)
 import           Development.IDE.Types.Options  (IdeOptions(IdeOptions, optTesting))
@@ -39,6 +39,7 @@ import           System.FilePath.Posix          (addTrailingPathSeparator,
 import Language.Haskell.LSP.Messages as LSP
 import Language.Haskell.LSP.Types as LSP
 import Data.Aeson (ToJSON(toJSON))
+import Development.IDE.Types.Logger (logDebug)
 
 -- Prefix for the cache path
 cacheDir :: String
@@ -60,18 +61,23 @@ loadGhcSession =
 
 cradleToSession :: Rules ()
 cradleToSession = define $ \LoadCradle nfp -> do
+
     let f = fromNormalizedFilePath nfp
 
     IdeOptions{optTesting} <- getIdeOptions
 
+    logger <- actionLogger
+    liftIO $ logDebug logger $ "Running cradle " <> pack (fromNormalizedFilePath nfp)
+
     -- If the path points to a directory, load the implicit cradle
     mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f
-    cradle <- liftIO $  maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml
+    cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml
 
     when optTesting $
         sendEvent $ notifyCradleLoaded f
 
-    cmpOpts <- liftIO $ getComponentOptions cradle
+    -- Avoid interrupting `getComponentOptions` since it calls external processes
+    cmpOpts <- liftIO $ mask $ \_ -> getComponentOptions cradle
     let opts = componentOptions cmpOpts
         deps = componentDependencies cmpOpts
         deps' = case mbYaml of

src/Development/IDE/Core/FileExists.hs

@@ -22,6 +22,7 @@ import           Development.IDE.Core.FileStore
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.Shake
 import           Development.IDE.Types.Location
+import           Development.IDE.Types.Logger
 import           Development.Shake
 import           Development.Shake.Classes
 import           GHC.Generics
@@ -90,20 +91,25 @@ getFileExists fp = use_ GetFileExists fp
 --   Provides a fast implementation if client supports dynamic watched files.
 --   Creates a global state as a side effect in that case.
 fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
-fileExistsRules getLspId ClientCapabilities{_workspace}
+fileExistsRules getLspId ClientCapabilities{_workspace} vfs
   | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
   , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
   , Just True <- _dynamicRegistration
-  = fileExistsRulesFast getLspId
-  | otherwise = fileExistsRulesSlow
+  = fileExistsRulesFast getLspId vfs
+  | otherwise = do
+      logger <- logger <$> getShakeExtrasRules
+      liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling"
+      fileExistsRulesSlow vfs
 
 --   Requires an lsp client that provides WatchedFiles notifications.
 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
+    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

src/Development/IDE/Core/IdeConfiguration.hs

@@ -17,6 +17,7 @@ import           Development.IDE.Core.Shake
 import           Development.IDE.Types.Location
 import           Development.Shake
 import           Language.Haskell.LSP.Types
+import           System.FilePath (isRelative)
 
 -- | Lsp client relevant configuration details
 data IdeConfiguration = IdeConfiguration
@@ -58,9 +59,13 @@ modifyWorkspaceFolders ide f = do
   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
+isWorkspaceFile file =
+  if isRelative (fromNormalizedFilePath file)
+    then return True
+    else do
+      IdeConfiguration {..} <- getIdeConfiguration
+      let toText = getUri . fromNormalizedUri
+      return $
+        any
+          (\root -> toText root `isPrefixOf` toText (filePathToUri' file))
+          workspaceFolders

src/Development/IDE/Core/Shake.hs

@@ -20,7 +20,7 @@
 --   between runs. To deserialise a Shake value, we just consult Values.
 module Development.IDE.Core.Shake(
     IdeState, shakeExtras,
-    ShakeExtras(..), getShakeExtras,
+    ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
     IdeRule, IdeResult, GetModificationTime(..),
     shakeOpen, shakeShut,
     shakeRun,

test/exe/Main.hs

@@ -12,6 +12,7 @@ import Control.Applicative.Combinators
 import Control.Exception (catch)
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (Value)
 import Data.Char (toLower)
 import Data.Foldable
 import Data.List
@@ -429,21 +430,28 @@ codeLensesTests = testGroup "code lenses"
 
 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 @?= []
+  [ testSession' "workspace files" $ \sessionDir -> do
+      liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"
+      _ <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport B"
+      watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
+
+      -- Expect 6 subscriptions (A does not get any because it's VFS):
+      --  - /path-to-workspace/B.hs
+      --  - /path-to-workspace/B.lhs
+      --  - B.hs
+      --  - B.lhs
+      --  - src/B.hs
+      --  - src/B.lhs
+      liftIO $ length watchedFileRegs @?= 6
+
+  , testSession' "non workspace file" $ \sessionDir -> do
+      liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
+      _ <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport B"
+      watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
+
+      -- Expect 4 subscriptions:
+      liftIO $ length watchedFileRegs @?= 4
+
   -- TODO add a test for didChangeWorkspaceFolder
   ]
 
@@ -2229,3 +2237,12 @@ nthLine i r
     | i == 0 && Rope.rows r == 0 = r
     | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
     | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
+
+getWatchedFilesSubscriptionsUntilProgressEnd :: Session [Maybe Value]
+getWatchedFilesSubscriptionsUntilProgressEnd = do
+      msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)
+      return
+            [ args
+            | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
+            , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
+            ]