Re-run pre-build rules when necessary

ghcide-test/data/setup-hooks/Gen.myPP

@@ -0,0 +1,2 @@
+genVal :: Int
+genVal = 42

ghcide-test/data/setup-hooks/Lib.hs

@@ -0,0 +1,4 @@
+module Lib where
+import Gen (genVal)
+libVal :: Int
+libVal = genVal

ghcide-test/data/setup-hooks/SetupHooks.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE StaticPointers     #-}
+
+module SetupHooks where
+
+-- Cabal
+import Distribution.Compat.Binary
+import Distribution.Simple.LocalBuildInfo  (interpretSymbolicPathLBI)
+import Distribution.Simple.SetupHooks
+import Distribution.Simple.Utils           (rewriteFileEx)
+import Distribution.Utils.Path
+import Distribution.Verbosity              (normal, mkVerbosity, defaultVerbosityHandles)
+
+-- base
+import Control.Monad.IO.Class              (liftIO)
+import Data.List                           (isSuffixOf)
+import qualified Data.List.NonEmpty as NE  (NonEmpty (..))
+import Data.String                         (fromString)
+import GHC.Generics
+
+-- directory
+import System.Directory                    (listDirectory)
+
+-- filepath
+import System.FilePath                     (dropExtension)
+
+-- This import is unnecessary, but it's kept around so that this file would
+-- fail to compile were we to use a version of Cabal that doesn't write out
+-- a pre-build rule manifest file.
+import Distribution.Simple.BuildPaths (preBuildMonitorManifestFile)
+
+--------------------------------------------------------------------------------
+
+setupHooks :: SetupHooks
+setupHooks = noSetupHooks
+  { buildHooks = noBuildHooks
+    { preBuildComponentRules = Just $ rules (static ()) preBuildRules } }
+
+preBuildRules :: PreBuildComponentInputs -> RulesM ()
+preBuildRules (PreBuildComponentInputs { localBuildInfo = lbi, targetInfo = tgt }) = do
+  let clbi       = targetCLBI tgt
+      autogenDir = autogenComponentModulesDir lbi clbi
+      srcDir     = sameDirectory
+  allFiles <- liftIO $ listDirectory (interpretSymbolicPathLBI lbi srcDir)
+  mapM_ (registerMyPP srcDir autogenDir) (filter (".myPP" `isSuffixOf`) allFiles)
+
+registerMyPP
+  :: SymbolicPath Pkg (Dir Source)
+  -> SymbolicPath Pkg (Dir Source)
+  -> FilePath
+  -> RulesM ()
+registerMyPP srcDir autogenDir fileName =
+  let baseName = dropExtension fileName
+  in registerRule_ (fromString $ "myPP " ++ baseName) $
+       staticRule
+         (mkCommand (static Dict) (static runMyPP) $
+           MyPPInput { ppSrcDir = srcDir, ppAutogenDir = autogenDir, ppBaseName = baseName })
+         [ FileDependency $ Location srcDir (makeRelativePathEx fileName) ]
+         ( Location autogenDir (makeRelativePathEx baseName <.> "hs") NE.:| [] )
+
+runMyPP :: MyPPInput -> IO ()
+runMyPP MyPPInput{..} = do
+  content <- readFile (getSymbolicPath ppSrcDir </> ppBaseName <.> "myPP")
+  rewriteFileEx (mkVerbosity defaultVerbosityHandles normal)
+    (getSymbolicPath ppAutogenDir </> ppBaseName <.> "hs") $
+    "module " ++ ppBaseName ++ " where\n" ++ content
+
+data MyPPInput = MyPPInput
+  { ppSrcDir     :: SymbolicPath Pkg (Dir Source)
+  , ppAutogenDir :: SymbolicPath Pkg (Dir Source)
+  , ppBaseName   :: String
+  } deriving stock    (Show, Generic)
+    deriving anyclass Binary

ghcide-test/data/setup-hooks/cabal.project

@@ -0,0 +1,10 @@
+packages: .
+
+-- Use a version of Cabal that writes the pre-build rule manifest.
+--
+-- TODO: remove this.
+source-repository-package
+   type:     git
+   location: https://github.com/sheaf/cabal.git
+   subdir:   Cabal-syntax Cabal Cabal-hooks
+   tag:      2a320cac93255683829768517ceadcd25cbf8f11

ghcide-test/data/setup-hooks/setup-hooks-test.cabal

@@ -0,0 +1,19 @@
+cabal-version:      3.14
+name:               setup-hooks-test
+version:            0.1.0.0
+synopsis:           HLS test fixture for build-type: Hooks
+build-type:         Hooks
+
+custom-setup
+  setup-depends:
+      base
+    , Cabal
+    , Cabal-hooks
+    , directory
+    , filepath
+
+library
+  autogen-modules:  Gen
+  exposed-modules:  Gen, Lib
+  build-depends:    base
+  default-language: Haskell2010

ghcide-test/exe/Main.hs

@@ -63,6 +63,7 @@ import           ReferenceTests
 import           ResolveTests
 import           RootUriTests
 import           SafeTests
+import           SetupHooksTests
 import           SymlinkTests
 import           THTests
 import           UnitTests
@@ -88,6 +89,7 @@ main = do
     , THTests.tests
     , SymlinkTests.tests
     , SafeTests.tests
+    , SetupHooksTests.tests
     , UnitTests.tests
     , HaddockTests.tests
     , PositionMappingTests.tests

ghcide-test/exe/SetupHooksTests.hs

@@ -0,0 +1,80 @@
+-- | Tests for @build-type: Hooks@ support in HLS.
+module SetupHooksTests (tests) where
+
+import           Config                      (runWithExtraFiles)
+import           Control.Exception           (bracket_)
+import           Control.Monad.IO.Class      (liftIO)
+import           System.Environment.Blank    (setEnv, unsetEnv)
+import           Development.IDE.GHC.Util    (readFileUtf8)
+import           Development.IDE.Plugin.Test (WaitForIdeRuleResult (..))
+import           Development.IDE.Test        (expectCurrentDiagnostics,
+                                              waitForAction,
+                                              waitForTypecheck)
+import           Language.LSP.Protocol.Message
+import           Language.LSP.Protocol.Types hiding
+                                             (SemanticTokenAbsolute (..),
+                                              SemanticTokenRelative (..),
+                                              SemanticTokensEdit (..),
+                                              mkRange)
+import           Language.LSP.Test
+import           System.FilePath
+import           Test.Hls                    (waitForProgressDone,
+                                              waitForAllProgressDone)
+import           Test.Hls.FileSystem         (atomicFileWriteString)
+import           Test.Tasty
+import           Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "build-type: Hooks"
+  [ testCase "loads generated modules" hooksInitialLoad
+  , testCase "re-runs rules when rule input changes" hooksRuleInputChange
+  ]
+
+-- | Increased timeout for setup-hooks tests, which need to compile
+-- @Cabal-syntax@, @Cabal@ and @Cabal-hooks@ in order to compile @SetupHooks.hs@.
+withHooksTimeout :: IO a -> IO a
+withHooksTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")
+  -- LSP_TIMEOUT = 120 seconds = 2 minutes
+
+-- | Open a module that imports module generated by a pre-build rule,
+-- ensuring that it successfully compiles.
+hooksInitialLoad :: IO ()
+hooksInitialLoad = withHooksTimeout $ runWithExtraFiles "setup-hooks" $ \dir -> do
+  let libPath = dir </> "Lib.hs"
+  libSrc <- liftIO $ readFileUtf8 libPath
+  libDoc <- createDoc libPath "haskell" libSrc
+  waitForProgressDone
+  expectCurrentDiagnostics libDoc []
+
+-- | Modify a .myPP pre-build rule input, notify HLS, and verify the regenerated
+-- module causes an expected type error.
+--
+-- This checks that HLS re-runs pre-build rules when necessary.
+hooksRuleInputChange :: IO ()
+hooksRuleInputChange = withHooksTimeout $ runWithExtraFiles "setup-hooks" $ \dir -> do
+  let libPath = dir </> "Lib.hs"
+      genMyPP = dir </> "Gen.myPP"
+  libSrc <- liftIO $ readFileUtf8 libPath
+  libDoc <- createDoc libPath "haskell" libSrc
+
+  -- Check the package builds. This ensures SetupHooks.hs compiled successfully,
+  -- and that the pre-build rules were run (generating Gen.hs).
+  waitForAllProgressDone
+  expectCurrentDiagnostics libDoc []
+
+  -- Modify Gen.myPP, changing the type of 'genVal'.
+  liftIO $ atomicFileWriteString genMyPP "genVal :: Bool\ngenVal = True\n"
+
+  -- Notify HLS that Gen.myPP has changed. HLS should trigger a re-run of
+  -- pre-build rules.
+  sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
+    [FileEvent (filePathToUri genMyPP) FileChangeType_Changed]
+
+  -- Wait for the session to reload, which should re-run pre-build rules.
+  WaitForIdeRuleResult { ideResultSuccess = sessionOk } <- waitForAction "GhcSession" libDoc
+  liftIO $ assertBool "GhcSession should succeed after reload" sessionOk
+
+  -- We now expect a type error from the change in type of 'genVal'.
+  _ <- waitForTypecheck libDoc
+  expectCurrentDiagnostics libDoc
+    [(DiagnosticSeverity_Error, (3, 9), "Couldn't match", Just "GHC-83865")]

ghcide/ghcide.cabal

@@ -139,6 +139,7 @@ library
     Development.IDE.Core.Preprocessor
     Development.IDE.Core.ProgressReporting
     Development.IDE.Core.Rules
+    Development.IDE.Core.Rules.PreBuildHooks
     Development.IDE.Core.RuleTypes
     Development.IDE.Core.Service
     Development.IDE.Core.Shake

ghcide/session-loader/Development/IDE/Session.hs

@@ -42,6 +42,8 @@ import           Data.Maybe
 import           Data.Proxy
 import qualified Data.Text                           as T
 import           Data.Version
+import           Development.IDE.Core.Rules.PreBuildHooks (PreBuildHookInfo (..),
+                                                           preBuildHookDeps)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake          hiding (Log, knownTargets,
                                                       withHieDb)
@@ -107,6 +109,7 @@ import           Text.ParserCombinators.ReadP        (readP_to_S)
 
 import           Control.Concurrent.STM              (STM, TVar)
 import qualified Control.Monad.STM                   as STM
+import           Control.Monad.Trans.Class           (lift)
 import           Control.Monad.Trans.Reader
 import qualified Development.IDE.Session.Ghc         as Ghc
 import qualified Development.IDE.Session.OrderedSet  as S
@@ -446,6 +449,11 @@ data SessionState = SessionState
   -- ^ Map @hie.yaml@ to all modules that have this @hie.yaml@ as the root location.
   , filesMap     :: !FilesMap
   -- ^ Maps a 'NormalizedFilePath' to its @hie.yaml@, the reverse of 'fileToFlags'.
+  , globWatchers :: !(STM.Map (Maybe FilePath) [GlobPattern])
+  -- ^ Glob patterns to watch.
+  --
+  -- NB: for now, we only store the patterns themselves, not the files that
+  -- matched them (e.g. at session-load time).
   , version      :: !(Var Int)
     -- ^ Session loading version, incremented whenever the shake cache needs to be invalidated.
   , sessionLoadingPreferenceConfig :: !(Var (Maybe SessionLoadingPreferenceConfig))
@@ -519,6 +527,7 @@ resetFileMaps :: SessionState -> STM ()
 resetFileMaps state = do
   STM.reset (filesMap state)
   STM.reset (fileToFlags state)
+  STM.reset (globWatchers state)
 
 -- | Insert or update file flags for a specific hieYaml and normalized file path
 insertFileFlags :: SessionState -> Maybe FilePath -> NormalizedFilePath -> (IdeResult HscEnvEq, DependencyInfo) -> STM ()
@@ -615,6 +624,7 @@ newSessionState = do
     <*> newVar Map.empty            -- hscEnvs
     <*> STM.newIO                   -- fileToFlags
     <*> STM.newIO                   -- filesMap
+    <*> STM.newIO                   -- globWatchers
     <*> newVar 0                    -- version
     <*> newVar Nothing              -- sessionLoadingPreferenceConfig
   return sessionState
@@ -690,21 +700,29 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
     -- The GlobPattern of a FileSystemWatcher can be absolute or relative.
     -- We use the absolute one because it is supported by more LSP clients.
     -- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern.
-    let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps)
+    let toCradleDeps (deps, globs) = CradleDeps
+          { cradleFileDeps = fmap toAbsolutePath $ Map.keys deps
+          , cradleGlobDeps = map (GlobPattern . toAbsolutePath . getGlobPattern) globs
+          }
     returnWithVersion $ \file -> do
       let absFile = toAbsolutePath file
-      absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile
+      (eq, deps, globs) <- lookupOrWaitCache recorder sessionState absFile
+      return (eq, toCradleDeps (deps, globs))
 
 -- | Given a file, this function will return the HscEnv and the dependencies
 -- it would look up the cache first, if the cache is not available, it would
 -- submit a request to the getOptionsLoop to get the options for the file
 -- and wait until the options are available
-lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo)
+lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo, [GlobPattern])
 lookupOrWaitCache recorder sessionState absFile = do
   let ncfp = toNormalizedFilePath' absFile
   cacheResult <- maybeM
     (return Nothing)
-    (guardedA (checkDependencyInfo . snd))
+    -- Check file dependencies for staleness.
+    --
+    -- We don't do this for globs, as we (currently) only store the
+    -- glob patterns themselves, not the files that matched them.
+    (guardedA (\(_,di,_globPatterns) -> checkDependencyInfo di))
     (atomically $ do
       -- wait until target file is not in pendingFiles
       Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry
@@ -721,11 +739,13 @@ lookupOrWaitCache recorder sessionState absFile = do
       atomically $ addToPending sessionState absFile
       lookupOrWaitCache recorder sessionState absFile
 
-checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo))
+checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo, [GlobPattern]))
 checkInCache sessionState ncfp = runMaybeT $ do
   cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState)
   m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState)
-  MaybeT $ pure $ HM.lookup ncfp m
+  (eq, di) <- MaybeT $ pure $ HM.lookup ncfp m
+  globs <- lift $ STM.lookup cachedHieYamlLocation (globWatchers sessionState)
+  return (eq, di, fromMaybe [] globs)
 
 -- | Modify the shake state.
 data SessionShake = SessionShake
@@ -879,7 +899,8 @@ session ::
     SessionM ()
 session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do
   let initEmptyHscEnv = emptyHscEnvM libDir
-  (new_components_info, old_components_info) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts)
+  hookInfo <- liftIO $ preBuildHookDeps (componentOptions opts)
+  (new_components_info, old_components_info) <- packageSetup recorder sessionState initEmptyHscEnv hookInfo (hieYaml, cfp, opts)
 
   -- For each component, now make a new HscEnvEq which contains the
   -- HscEnv for the hie.yaml file but the DynFlags for that component
@@ -902,6 +923,7 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l
         handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets
         keys2 <- invalidateCache sessionShake
         keys1 <- extendKnownTargets recorder knownTargetsVar all_targets
+
         -- Typecheck all files in the project on startup
         unless (null new_components_info || not checkProject) $ do
             cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)
@@ -915,17 +937,29 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l
                 liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)
         return [keys1, keys2]
 
--- | Create a new HscEnv from a hieYaml root and a set of options
-packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo])
-packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do
+-- | Create a new HscEnv from a hieYaml root and a set of options.
+packageSetup
+  :: Recorder (WithPriority Log)
+  -> SessionState
+  -> SessionM HscEnv
+  -> PreBuildHookInfo
+  -> (Maybe FilePath, NormalizedFilePath, ComponentOptions)
+  -> SessionM ([ComponentInfo], [ComponentInfo])
+packageSetup recorder sessionState newEmptyHscEnv hookInfo (hieYaml, cfp, opts) = do
   getCacheDirs <- asks (getCacheDirs . sessionLoadingOptions)
   haddockparse <- asks (optHaddockParse . sessionIdeOptions)
   rootDir <- asks sessionRootDir
   -- Parse DynFlags for the newly discovered component
   hscEnv <- newEmptyHscEnv
   newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions haddockparse cfp opts (hsc_dflags hscEnv) rootDir
-  let deps = componentDependencies opts ++ maybeToList hieYaml
+  let PreBuildHookInfo{hookDepFiles, hookDepGlobs} = hookInfo
+      deps = componentDependencies opts ++ maybeToList hieYaml ++ hookDepFiles
   dep_info <- liftIO $ getDependencyInfo (fmap (toAbsolute rootDir) deps)
+  liftIO $ atomically $
+    STM.insert
+      (map (GlobPattern . toAbsolute rootDir . getGlobPattern) hookDepGlobs)
+      hieYaml
+      (globWatchers sessionState)
   -- Now lookup to see whether we are combining with an existing HscEnv
   -- or making a new one. The lookup returns the HscEnv and a list of
   -- information about other components loaded into the HscEnv

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -547,8 +547,21 @@ instance NFData   AddWatchedFile
 -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
 type instance RuleResult GhcSessionIO = IdeGhcSession
 
+-- | An absolute glob pattern to be registered as an LSP @FileSystemWatcher@.
+newtype GlobPattern = GlobPattern { getGlobPattern :: FilePath }
+  deriving (Show, Eq, Ord)
+
+-- | The dependencies of a loaded cradle component.
+data CradleDeps = CradleDeps
+  { cradleFileDeps :: ![FilePath]
+  -- ^ File paths that, when modified, should trigger a session reload.
+  , cradleGlobDeps :: ![GlobPattern]
+  -- ^ Glob patterns to register as LSP @FileSystemWatcher@ globs so that
+  -- newly created or deleted matching files also trigger a reload.
+  }
+
 data IdeGhcSession = IdeGhcSession
-  { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
+  { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, CradleDeps)
   -- ^ Returns the Ghc session and the cradle dependencies
   , sessionVersion :: !Int
   -- ^ Used as Shake key, versions must be unique and not reused