From ece301d67a0e17397578369e8c230287562af2ca Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 4 May 2026 12:36:44 +0200 Subject: [PATCH 1/2] Allow watching globs as well as simple filepaths This adds a new 'globWatchers' alongside the 'filesMap' for watching glob patterns. This is used for cradle dependencies, so that HLS reloads the cradle when these change. The intended usage is to allow HLS to re-run the Cabal pre-build stage when dependent files are modified, in particular with build-type: Hooks and pre-build rules (but that part is left to a separate commit). --- .../session-loader/Development/IDE/Session.hs | 30 +++++++++++++++---- ghcide/src/Development/IDE/Core/RuleTypes.hs | 15 +++++++++- ghcide/src/Development/IDE/Core/Rules.hs | 8 ++--- 3 files changed, 42 insertions(+), 11 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7e1a062a7a..01bee0db97 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -107,6 +107,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 +447,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 +525,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 +622,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 +698,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 +737,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 diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index e10c26e953..877ce2ce2e 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 723e1784e6..23d9bd74ac 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -745,17 +745,17 @@ loadGhcSession recorder ghcSessionDepsConfig = do defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO -- loading is always returning a absolute path now - (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file + (val, CradleDeps { cradleFileDeps = deps, cradleGlobDeps = globs }) + <- liftIO $ loadSessionFun $ fromNormalizedFilePath file -- add the deps to the Shake graph let addDependency fp = do -- VSCode uses absolute paths in its filewatch notifications let nfp = toNormalizedFilePath' fp itExists <- getFileExists nfp - when itExists $ void $ do - use_ GetPhysicalModificationTime nfp - + when itExists $ void $ use_ GetPhysicalModificationTime nfp mapM_ addDependency deps + mapM_ (\(GlobPattern fp) -> void $ use AddWatchedFile (toNormalizedFilePath' fp)) globs let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) return (Just cutoffHash, val) From a9c9fa4e71ebfd9cc047985fb00d66d9e8b8c8a2 Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 4 May 2026 20:07:29 +0200 Subject: [PATCH 2/2] SetupHooks integration: monitor pre-build rules HLS now reads the pre-build rule monitor manifest file to determine which files and file globs to monitor in order to detect when to re-run pre-build rules. --- ghcide-test/data/setup-hooks/Gen.myPP | 2 + ghcide-test/data/setup-hooks/Lib.hs | 4 + ghcide-test/data/setup-hooks/SetupHooks.hs | 77 +++++++++++++++ ghcide-test/data/setup-hooks/cabal.project | 10 ++ .../data/setup-hooks/setup-hooks-test.cabal | 19 ++++ ghcide-test/exe/Main.hs | 2 + ghcide-test/exe/SetupHooksTests.hs | 80 +++++++++++++++ ghcide/ghcide.cabal | 1 + .../session-loader/Development/IDE/Session.hs | 26 ++++- .../IDE/Core/Rules/PreBuildHooks.hs | 98 +++++++++++++++++++ haskell-language-server.cabal | 2 + 11 files changed, 316 insertions(+), 5 deletions(-) create mode 100644 ghcide-test/data/setup-hooks/Gen.myPP create mode 100644 ghcide-test/data/setup-hooks/Lib.hs create mode 100644 ghcide-test/data/setup-hooks/SetupHooks.hs create mode 100644 ghcide-test/data/setup-hooks/cabal.project create mode 100644 ghcide-test/data/setup-hooks/setup-hooks-test.cabal create mode 100644 ghcide-test/exe/SetupHooksTests.hs create mode 100644 ghcide/src/Development/IDE/Core/Rules/PreBuildHooks.hs diff --git a/ghcide-test/data/setup-hooks/Gen.myPP b/ghcide-test/data/setup-hooks/Gen.myPP new file mode 100644 index 0000000000..1670103faa --- /dev/null +++ b/ghcide-test/data/setup-hooks/Gen.myPP @@ -0,0 +1,2 @@ +genVal :: Int +genVal = 42 diff --git a/ghcide-test/data/setup-hooks/Lib.hs b/ghcide-test/data/setup-hooks/Lib.hs new file mode 100644 index 0000000000..8a761ef916 --- /dev/null +++ b/ghcide-test/data/setup-hooks/Lib.hs @@ -0,0 +1,4 @@ +module Lib where +import Gen (genVal) +libVal :: Int +libVal = genVal diff --git a/ghcide-test/data/setup-hooks/SetupHooks.hs b/ghcide-test/data/setup-hooks/SetupHooks.hs new file mode 100644 index 0000000000..047147d1da --- /dev/null +++ b/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 diff --git a/ghcide-test/data/setup-hooks/cabal.project b/ghcide-test/data/setup-hooks/cabal.project new file mode 100644 index 0000000000..0cbf941197 --- /dev/null +++ b/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 diff --git a/ghcide-test/data/setup-hooks/setup-hooks-test.cabal b/ghcide-test/data/setup-hooks/setup-hooks-test.cabal new file mode 100644 index 0000000000..8e79a3f29e --- /dev/null +++ b/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 diff --git a/ghcide-test/exe/Main.hs b/ghcide-test/exe/Main.hs index b41290198e..e7550853d6 100644 --- a/ghcide-test/exe/Main.hs +++ b/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 diff --git a/ghcide-test/exe/SetupHooksTests.hs b/ghcide-test/exe/SetupHooksTests.hs new file mode 100644 index 0000000000..a2559e77bd --- /dev/null +++ b/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")] diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 98a1580ccb..2d8ad94415 100644 --- a/ghcide/ghcide.cabal +++ b/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 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 01bee0db97..ca49deae86 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/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) @@ -897,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 @@ -920,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) @@ -933,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 diff --git a/ghcide/src/Development/IDE/Core/Rules/PreBuildHooks.hs b/ghcide/src/Development/IDE/Core/Rules/PreBuildHooks.hs new file mode 100644 index 0000000000..7a79cc3e1e --- /dev/null +++ b/ghcide/src/Development/IDE/Core/Rules/PreBuildHooks.hs @@ -0,0 +1,98 @@ +-- | Handling of pre-build rules for packages with @build-type: Hooks@. +module Development.IDE.Core.Rules.PreBuildHooks + ( PreBuildHookInfo (..) + , emptyPreBuildHookInfo + , parseManifestWatchFiles + , preBuildHookDeps + ) where + +import Control.Exception (evaluate, throwIO) +import Data.Char (isSpace) +import Data.List (isPrefixOf, stripPrefix) +import Data.Maybe (fromMaybe, listToMaybe, + mapMaybe) +import Development.IDE.Core.RuleTypes (GlobPattern (..)) +import System.Directory (doesFileExist) +import System.FilePath (dropTrailingPathSeparator, + isAbsolute, normalise, + takeDirectory, takeFileName, + ()) + +-- | Information extracted from the @pre-build-monitors@ manifest for a +-- @build-type: Hooks@ component. +data PreBuildHookInfo = PreBuildHookInfo + { hookDepFiles :: [FilePath] + -- ^ Monitored files + rule file dependencies + , hookDepGlobs :: [GlobPattern] + -- ^ Monitored globs + } + +emptyPreBuildHookInfo :: PreBuildHookInfo +emptyPreBuildHookInfo = PreBuildHookInfo [] [] + +-- | Parse the @pre-build-monitors@ manifest into a 'PreBuildHookInfo'. +parseManifestWatchFiles :: FilePath -> IO PreBuildHookInfo +parseManifestWatchFiles manifestPath = do + content <- readFile manifestPath + -- Force the contents of the entire manifest before proceeding, in order to + -- avoid keeping the file handle open. + !_ <- evaluate $ length content + case filter (not . all isSpace) $ lines content of + versionLine : pkgRootLine : ls + | Just _ver <- stripPrefix "pre-build-monitors-v" versionLine + , Just pkgRoot <- dropWhile isSpace <$> stripPrefix "pkg-root:" pkgRootLine + -> + let resolve p = normalise $ if isAbsolute p then p else pkgRoot p + monitorLines = sectionLines "monitors" ls + files = map resolve (sectionLines "inputs" ls) + ++ mapMaybe (fmap resolve . parseMonitorEntry "file:") monitorLines + globs = map GlobPattern $ + mapMaybe (fmap resolve . parseMonitorEntry "glob:") monitorLines + in return $ PreBuildHookInfo { hookDepFiles = files, hookDepGlobs = globs } + _ -> throwIO $ userError $ + "could not parse pre-build-monitors manifest at " ++ manifestPath + where + sectionLines section ls = + let marker = "[" ++ section ++ "]" + in takeWhile (\l -> not ("[" `isPrefixOf` l)) $ + drop 1 $ -- drop the marker line + dropWhile (/= marker) ls + + parseMonitorEntry prefix l = do + rest1 <- stripPrefix prefix l + let (_, rest2) = break (== ':') rest1 + rest3 <- stripPrefix ":" rest2 + let (_, rest4) = break (== ':') rest3 + stripPrefix ":" rest4 + +-- | Parse the @pre-build-monitors@ manifest into a 'PreBuildHookInfo' +-- for a @build-type: Hooks@ component. +preBuildHookDeps :: [String] -> IO PreBuildHookInfo +preBuildHookDeps flags = do + let mbManifest = findPreBuildRulesManifest flags + case mbManifest of + Nothing -> return emptyPreBuildHookInfo + Just manifestPath -> do + exists <- doesFileExist manifestPath + if not exists + then return emptyPreBuildHookInfo + else do + info <- parseManifestWatchFiles manifestPath + -- Monitor the manifest itself so that if cabal regenerates it (e.g. + -- after the user runs `cabal build`), HLS picks up any changes to + -- the set of inputs and monitors. + return info { hookDepFiles = manifestPath : hookDepFiles info } + +-- | Derive the @pre-build-monitors@ manifest path from the flags passed to GHC. +findPreBuildRulesManifest :: [FilePath] -> Maybe FilePath +findPreBuildRulesManifest flags = + -- Looks for a path ending in @autogen\/cabal_macros.h@; the pre-build rules + -- manifest file is a sibling of the @autogen@ directory. + listToMaybe + [ takeDirectory autogenDir "pre-build-monitors" + | flag <- flags + , let cabalMacrosPath = fromMaybe flag (stripPrefix "-optP" flag) + , takeFileName cabalMacrosPath == "cabal_macros.h" + , let autogenDir = dropTrailingPathSeparator (takeDirectory cabalMacrosPath) + , takeFileName autogenDir == "autogen" + ] diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 26017297a4..36b5e18902 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -35,6 +35,7 @@ extra-source-files: ghcide-test/data/**/*.cabal ghcide-test/data/**/*.hs ghcide-test/data/**/*.hs-boot + ghcide-test/data/**/*.myPP ghcide-test/data/**/*.project ghcide-test/data/**/*.yaml @@ -2163,6 +2164,7 @@ test-suite ghcide-tests ResolveTests RootUriTests SafeTests + SetupHooksTests SymlinkTests THTests UnitTests