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