Hassan Al-Awwadi pushed to branch wip/haanss/depdir at Glasgow Haskell Compiler / GHC Commits: 01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00 Fix documentation for HEAP_PROF_SAMPLE_STRING - - - - - ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00 Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE - - - - - 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - 0bfcaf03 by Hassan Al-Awwadi at 2025-07-14T18:54:33+02:00 Adds the fucnction addDependentDirectory to Q, resolving issue #26148. This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide. - - - - - 25 changed files: - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Deps.hs - docs/users_guide/9.14.1-notes.rst - docs/users_guide/eventlog-formats.rst - docs/users_guide/separate_compilation.rst - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/.gitignore - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/th/Makefile - + testsuite/tests/th/TH_Depends_Dir.hs - + testsuite/tests/th/TH_Depends_Dir.stdout - + testsuite/tests/th/TH_Depends_Dir_External.hs - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -75,14 +75,15 @@ data UsageConfig = UsageConfig mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv -> Module -> ImportedMods -> [ImportUserSpec] -> NameSet - -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded + -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IfG [Usage] mkUsageInfo uc plugins fc unit_env this_mod dir_imp_mods imp_decls used_names - dependent_files merged needed_links needed_pkgs + dependent_files dependent_dirs merged needed_links needed_pkgs = do eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env)) - hashes <- liftIO $ mapM getFileHash dependent_files + file_hashes <- liftIO $ mapM getFileHash dependent_files + dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs let hu = ue_unsafeHomeUnit unit_env hug = ue_home_unit_graph unit_env -- Dependencies on object files due to TH and plugins @@ -93,7 +94,11 @@ mkUsageInfo uc plugins fc unit_env let usages = mod_usages ++ [ UsageFile { usg_file_path = mkFastString f , usg_file_hash = hash , usg_file_label = Nothing } - | (f, hash) <- zip dependent_files hashes ] + | (f, hash) <- zip dependent_files file_hashes ] + ++ [ UsageDirectory { usg_dir_path = mkFastString d + , usg_dir_hash = hash + , usg_dir_label = Nothing } + | (d, hash) <- zip dependent_dirs dirs_hashes] ++ [ UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash ===================================== compiler/GHC/Iface/Make.hs ===================================== @@ -269,6 +269,7 @@ mkRecompUsageInfo hsc_env tc_result = do else do let used_names = mkUsedNames tc_result dep_files <- (readIORef (tcg_dependent_files tc_result)) + dep_dirs <- (readIORef (tcg_dependent_dirs tc_result)) (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result) let uc = initUsageConfig hsc_env plugins = hsc_plugins hsc_env @@ -289,6 +290,7 @@ mkRecompUsageInfo hsc_env tc_result = do (tcg_import_decls tc_result) used_names dep_files + dep_dirs (tcg_merged tc_result) needed_links needed_pkgs ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -194,6 +194,7 @@ data RecompReason | ModuleChangedRaw ModuleName | ModuleChangedIface ModuleName | FileChanged FilePath + | DirChanged FilePath | CustomReason String | FlagsChanged | LinkFlagsChanged @@ -230,6 +231,7 @@ instance Outputable RecompReason where ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed" ModuleAdded (_st, _uid, m) -> ppr m <+> text "added" FileChanged fp -> text fp <+> text "changed" + DirChanged dp -> text dp <+> text "changed" CustomReason s -> text s FlagsChanged -> text "Flags changed" LinkFlagsChanged -> text "Flags changed" @@ -815,6 +817,22 @@ checkModUsage fc UsageFile{ usg_file_path = file, then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp else \_ -> return recomp -- if we can't find the file, just recompile, don't fail +checkModUsage fc UsageDirectory{ usg_dir_path = dir, + usg_dir_hash = old_hash, + usg_dir_label = mlabel } = + liftIO $ + handleIO handler $ do + new_hash <- lookupDirCache fc $ unpackFS dir + if (old_hash /= new_hash) + then return recomp + else return UpToDate + where + reason = DirChanged $ unpackFS dir + recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel + handler = if debugIsOn + then \e -> pprTrace "UsageDirectory" (text (show e)) $ return recomp + else \_ -> return recomp -- if we can't find the dir, just recompile, don't fail + -- | We are importing a module whose exports have changed. -- Does this require recompilation? -- ===================================== compiler/GHC/Iface/Recomp/Types.hs ===================================== @@ -140,6 +140,10 @@ pprUsage usage@UsageFile{} = hsep [text "addDependentFile", doubleQuotes (ftext (usg_file_path usage)), ppr (usg_file_hash usage)] +pprUsage usage@UsageDirectory{} + = hsep [text "AddDependentDirectory", + doubleQuotes (ftext (usg_dir_path usage)), + ppr (usg_dir_hash usage)] pprUsage usage@UsageMergedRequirement{} = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] pprUsage usage@UsageHomeModuleInterface{} ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -173,8 +173,6 @@ import GHC.Parser.HaddockLex (lexHsDoc) import GHC.Parser (parseIdentifier) import GHC.Rename.Doc (rnHsDoc) - - {- Note [Template Haskell state diagram] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1524,6 +1522,11 @@ instance TH.Quasi TcM where dep_files <- readTcRef ref writeTcRef ref (fp:dep_files) + qAddDependentDirectory dp = do + ref <- fmap tcg_dependent_dirs getGblEnv + dep_dirs <- readTcRef ref + writeTcRef ref (dp:dep_dirs) + qAddTempFile suffix = do dflags <- getDynFlags logger <- getLogger @@ -1928,6 +1931,7 @@ handleTHMessage msg = case msg of ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f + AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d AddTempFile s -> wrapTHResult $ TH.qAddTempFile s AddModFinalizer r -> do interp <- hscInterp <$> getTopEnv ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -603,6 +603,7 @@ data TcGblEnv -- decls. tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile + tcg_dependent_dirs :: TcRef [FilePath], -- ^ dependencies from addDependentDirectory tcg_th_topdecls :: TcRef [LHsDecl GhcPs], -- ^ Top-level declarations from addTopDecls ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -55,7 +55,7 @@ module GHC.Tc.Utils.Monad( getRdrEnvs, getImports, getFixityEnv, extendFixityEnv, getDeclaredDefaultTys, - addDependentFiles, + addDependentFiles, addDependentDirectories, -- * Error management getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, @@ -274,6 +274,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this let { type_env_var = hsc_type_env_vars hsc_env }; dependent_files_var <- newIORef [] ; + dependent_dirs_var <- newIORef [] ; static_wc_var <- newIORef emptyWC ; cc_st_var <- newIORef newCostCentreState ; th_topdecls_var <- newIORef [] ; @@ -369,6 +370,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_safe_infer = infer_var, tcg_safe_infer_reasons = infer_reasons_var, tcg_dependent_files = dependent_files_var, + tcg_dependent_dirs = dependent_dirs_var, tcg_tc_plugin_solvers = [], tcg_tc_plugin_rewriters = emptyUFM, tcg_defaulting_plugins = [], @@ -957,6 +959,12 @@ addDependentFiles fs = do dep_files <- readTcRef ref writeTcRef ref (fs ++ dep_files) +addDependentDirectories :: [FilePath] -> TcRn () +addDependentDirectories ds = do + ref <- fmap tcg_dependent_dirs getGblEnv + dep_dirs <- readTcRef ref + writeTcRef ref (ds ++ dep_dirs) + {- ************************************************************************ * * ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -31,6 +31,9 @@ module GHC.Unit.Finder ( findObjectLinkableMaybe, findObjectLinkable, + + -- important that GHC.HsToCore.Usage uses the same hashing method for usage dirs as is used here. + getDirHash, ) where import GHC.Prelude @@ -68,7 +71,9 @@ import qualified Data.Map as M import GHC.Driver.Env import GHC.Driver.Config.Finder import qualified Data.Set as Set +import qualified Data.List as L(sort) import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified System.Directory as SD import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE @@ -107,10 +112,12 @@ initFinderCache :: IO FinderCache initFinderCache = do mod_cache <- newIORef emptyInstalledModuleEnv file_cache <- newIORef M.empty + dir_cache <- newIORef M.empty let flushFinderCaches :: UnitEnv -> IO () flushFinderCaches ue = do atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) atomicModifyIORef' file_cache $ \_ -> (M.empty, ()) + atomicModifyIORef' dir_cache $ \_ -> (M.empty, ()) where is_ext mod _ = not (isUnitEnvInstalledModule ue mod) @@ -137,8 +144,29 @@ initFinderCache = do atomicModifyIORef' file_cache $ \c -> (M.insert key hash c, ()) return hash Just fp -> return fp + lookupDirCache :: FilePath -> IO Fingerprint + lookupDirCache key = do + c <- readIORef dir_cache + case M.lookup key c of + Nothing -> do + hash <- getDirHash key + atomicModifyIORef' dir_cache $ \c -> (M.insert key hash c, ()) + return hash + Just fp -> return fp return FinderCache{..} +-- | This function computes a shallow hash of a directory, so really just what files and directories are directly inside it. +-- It does not look at the contents of the files, or the contents of the directories it contains. +getDirHash :: FilePath -> IO Fingerprint +getDirHash dir = do + contents <- SD.listDirectory dir + -- The documentation of Fingerprints describes this as an easy naive implementation + -- I wonder if we should do something more sophisticated here? + let hashes = fingerprintString <$> contents + let s_hashes = L.sort hashes + let hash = fingerprintFingerprints s_hashes + return hash + -- ----------------------------------------------------------------------------- -- The three external entry points ===================================== compiler/GHC/Unit/Finder/Types.hs ===================================== @@ -37,6 +37,7 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO () , lookupFileCache :: FilePath -> IO Fingerprint -- ^ Look for the hash of a file in the cache. This should add it to the -- cache. If the file doesn't exist, raise an IOException. + , lookupDirCache :: FilePath -> IO Fingerprint } data InstalledFindResult ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -357,6 +357,23 @@ data Usage -- contents don't change. This previously lead to odd -- recompilation behaviors; see #8114 } + | UsageDirectory { + usg_dir_path :: FastString, + -- ^ External dir dependency. From TH addDependentFile. + -- Should be absolute. + usg_dir_hash :: Fingerprint, + -- ^ 'Fingerprint' of the directories contents. + + usg_dir_label :: Maybe String + -- ^ An optional string which is used in recompilation messages if + -- dir in question has changed. + + -- Note: We do a very shallow check indeed, just what the contents of + -- the directory are, aka what files and directories are within it. + -- If those files/directories have their own contents changed... + -- We won't spot it here, better recursive add them to your usage + -- seperately. + } | UsageHomeModuleInterface { usg_mod_name :: ModuleName -- ^ Name of the module @@ -395,6 +412,7 @@ instance NFData Usage where rnf (UsagePackageModule mod hash safe) = rnf mod `seq` rnf hash `seq` rnf safe `seq` () rnf (UsageHomeModule mod uid hash entities exports safe) = rnf mod `seq` rnf uid `seq` rnf hash `seq` rnf entities `seq` rnf exports `seq` rnf safe `seq` () rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` () + rnf (UsageDirectory dir hash label) = rnf dir `seq` rnf hash `seq` rnf label `seq` () rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` () rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` () @@ -431,6 +449,12 @@ instance Binary Usage where put_ bh (usg_unit_id usg) put_ bh (usg_iface_hash usg) + put_ bh usg@UsageDirectory{} = do + putByte bh 5 + put_ bh (usg_dir_path usg) + put_ bh (usg_dir_hash usg) + put_ bh (usg_dir_label usg) + get bh = do h <- getByte bh case h of @@ -462,6 +486,12 @@ instance Binary Usage where uid <- get bh hash <- get bh return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash } + 5 -> do + dp <- get bh + hash <- get bh + label <- get bh + return UsageDirectory { usg_dir_path = dp, usg_dir_hash = hash, usg_dir_label = label } + i -> error ("Binary.get(Usage): " ++ show i) -- | Records the imports that we depend on from a home module, ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -232,6 +232,11 @@ Cmm They are replaced, respectively, by ``SpecialiseEP``, ``pragSpecED`` and ``pragSpecInlED``. +- We have added the ``addDependentDirectory`` function to match + ``addDependentFile``, which adds a directory to the list of dependencies that + the recompilation checker will look at to determine if a module needs to be + recompiled. + Included libraries ~~~~~~~~~~~~~~~~~~ ===================================== docs/users_guide/eventlog-formats.rst ===================================== @@ -779,9 +779,9 @@ the total time spent profiling. Cost-centre break-down ^^^^^^^^^^^^^^^^^^^^^^ -A variable-length packet encoding a heap profile sample broken down by, - * cost-centre (:rts-flag:`-hc`) - +A variable-length packet encoding a heap profile sample. +This event is only emitted when the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`. +Otherwise, a :event-type:`HEAP_PROF_SAMPLE_STRING` event is emitted instead. .. event-type:: HEAP_PROF_SAMPLE_COST_CENTRE @@ -796,11 +796,19 @@ A variable-length packet encoding a heap profile sample broken down by, String break-down ^^^^^^^^^^^^^^^^^ -A variable-length event encoding a heap sample broken down by, +A variable-length event encoding a heap sample. +The content of the sample label varies depending on the heap profile type: + + * :rts-flag:`-hT` The sample label contains a closure type, e.g., ``"ghc-bignum:GHC.Num.Integer.IS"``. + * :rts-flag:`-hm` The sample label contains a module name, e.g., ``"GHC.Num.Integer"``. + * :rts-flag:`-hd` The sample label contains a closure description, e.g., ``"IS"``. + * :rts-flag:`-hy` The sample label contains a type description, e.g., ``"Integer"``. + * :rts-flag:`-he` The sample label contains a stringified era, e.g., ``"1"``. + * :rts-flag:`-hr` The sample label contains a retainer set description, e.g., ``"(184)$stoIntegralSized1"``. + * :rts-flag:`-hi` The sample label contains a stringified pointer, e.g., ``"0x1008b7588"``, + which can be matched to an info table description emitted by the :event-type:`IPE` event. - * type description (:rts-flag:`-hy`) - * closure description (:rts-flag:`-hd`) - * module (:rts-flag:`-hm`) +If the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`, a :event-type:`HEAP_PROF_SAMPLE_COST_CENTRE` event is emitted instead. .. event-type:: HEAP_PROF_SAMPLE_STRING @@ -808,7 +816,7 @@ A variable-length event encoding a heap sample broken down by, :length: variable :field Word8: profile ID :field Word64: heap residency in bytes - :field String: type or closure description, or module name + :field String: sample label .. _time-profiler-events: ===================================== docs/users_guide/separate_compilation.rst ===================================== @@ -710,7 +710,7 @@ beautiful sight! You can read about :ghc-wiki:`how all this works ` in the GHC commentary. Recompilation for Template Haskell and Plugins -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Recompilation checking gets a bit more complicated when using Template Haskell or plugins. Both these features execute code at compile time and so if any of the @@ -727,6 +727,19 @@ if ``foo`` is from module ``A`` and ``bar`` is from module ``B``, the module wil now depend on ``A.o`` and ``B.o``, if either of these change then the module will be recompiled. +``addDependentFile`` and ``addDependentDirectory`` +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +When using Template Haskell or plugins, you can use the functions +``addDependentFile`` and ``addDependentDirectory`` to add additional +dependencies to the module being compiled. + +- When adding a file, this means that the contents of the file changing between + compilations will trigger a recompilation of the module. +- When adding a directory, this means that any file or subdirectory *added* to or + *removed* from the directory will trigger recompilation of the module, so + it is not a recursive dependency. + .. _mutual-recursion: Mutually recursive modules and hs-boot files ===================================== libraries/ghc-internal/src/GHC/Internal/Base.hs ===================================== @@ -1047,7 +1047,7 @@ class Functor f where -- * sequence computations and combine their results ('<*>' and 'liftA2'). -- -- A minimal complete definition must include implementations of 'pure' --- and of either '<*>' or 'liftA2'. If it defines both, then they must behave +-- and one of either '<*>' or 'liftA2'. If it defines both, then they must behave -- the same as their default definitions: -- -- @('<*>') = 'liftA2' 'id'@ ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -135,6 +135,9 @@ class (MonadIO m, MonadFail m) => Quasi m where -- | See 'addDependentFile'. qAddDependentFile :: FilePath -> m () + -- | See 'addDependentDirectory'. + qAddDependentDirectory :: FilePath -> m () + -- | See 'addTempFile'. qAddTempFile :: String -> m FilePath @@ -181,30 +184,31 @@ instance Quasi IO where qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - qLookupName _ _ = badIO "lookupName" - qReify _ = badIO "reify" - qReifyFixity _ = badIO "reifyFixity" - qReifyType _ = badIO "reifyFixity" - qReifyInstances _ _ = badIO "reifyInstances" - qReifyRoles _ = badIO "reifyRoles" - qReifyAnnotations _ = badIO "reifyAnnotations" - qReifyModule _ = badIO "reifyModule" - qReifyConStrictness _ = badIO "reifyConStrictness" - qLocation = badIO "currentLocation" - qRecover _ _ = badIO "recover" -- Maybe we could fix this? - qGetPackageRoot = badIO "getProjectRoot" - qAddDependentFile _ = badIO "addDependentFile" - qAddTempFile _ = badIO "addTempFile" - qAddTopDecls _ = badIO "addTopDecls" - qAddForeignFilePath _ _ = badIO "addForeignFilePath" - qAddModFinalizer _ = badIO "addModFinalizer" - qAddCorePlugin _ = badIO "addCorePlugin" - qGetQ = badIO "getQ" - qPutQ _ = badIO "putQ" - qIsExtEnabled _ = badIO "isExtEnabled" - qExtsEnabled = badIO "extsEnabled" - qPutDoc _ _ = badIO "putDoc" - qGetDoc _ = badIO "getDoc" + qLookupName _ _ = badIO "lookupName" + qReify _ = badIO "reify" + qReifyFixity _ = badIO "reifyFixity" + qReifyType _ = badIO "reifyFixity" + qReifyInstances _ _ = badIO "reifyInstances" + qReifyRoles _ = badIO "reifyRoles" + qReifyAnnotations _ = badIO "reifyAnnotations" + qReifyModule _ = badIO "reifyModule" + qReifyConStrictness _ = badIO "reifyConStrictness" + qLocation = badIO "currentLocation" + qRecover _ _ = badIO "recover" -- Maybe we could fix this? + qGetPackageRoot = badIO "getProjectRoot" + qAddDependentFile _ = badIO "addDependentFile" + qAddDependentDirectory _ = badIO "AddDependentDirectory" + qAddTempFile _ = badIO "addTempFile" + qAddTopDecls _ = badIO "addTopDecls" + qAddForeignFilePath _ _ = badIO "addForeignFilePath" + qAddModFinalizer _ = badIO "addModFinalizer" + qAddCorePlugin _ = badIO "addCorePlugin" + qGetQ = badIO "getQ" + qPutQ _ = badIO "putQ" + qIsExtEnabled _ = badIO "isExtEnabled" + qExtsEnabled = badIO "extsEnabled" + qPutDoc _ _ = badIO "putDoc" + qGetDoc _ = badIO "getDoc" instance Quote IO where newName = newNameIO @@ -822,6 +826,26 @@ getPackageRoot :: Q FilePath getPackageRoot = Q qGetPackageRoot +-- | Record external directories that runIO is using (dependent upon). +-- The compiler can then recognize that it should re-compile the Haskell file +-- when a directory changes. +-- +-- Expects an absolute directory path. +-- +-- Notes: +-- +-- * ghc -M does not know about these dependencies - it does not execute TH. +-- +-- * The dependency is shallow, based only on the direct content. +-- Basically, it only sees a list of names. It does not look at directory +-- metadata, recurse into subdirectories, or look at file contents. As +-- long as the list of names remains the same, the directory is considered +-- unchanged. +-- +-- * The state of the directory is read at the interface generation time, +-- not at the time of the function call. +addDependentDirectory :: FilePath -> Q () +addDependentDirectory dp = Q (qAddDependentDirectory dp) -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -833,7 +857,11 @@ getPackageRoot = Q qGetPackageRoot -- -- * ghc -M does not know about these dependencies - it does not execute TH. -- --- * The dependency is based on file content, not a modification time +-- * The dependency is based on file content, not a modification time or +-- any other metadata associated with the file (e.g. permissions). +-- +-- * The state of the file is read at the interface generation time, +-- not at the time of the function call. addDependentFile :: FilePath -> Q () addDependentFile fp = Q (qAddDependentFile fp) @@ -961,32 +989,33 @@ instance MonadIO Q where liftIO = runIO instance Quasi Q where - qNewName = newName - qReport = report - qRecover = recover - qReify = reify - qReifyFixity = reifyFixity - qReifyType = reifyType - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness = reifyConStrictness - qLookupName = lookupName - qLocation = location - qGetPackageRoot = getPackageRoot - qAddDependentFile = addDependentFile - qAddTempFile = addTempFile - qAddTopDecls = addTopDecls - qAddForeignFilePath = addForeignFilePath - qAddModFinalizer = addModFinalizer - qAddCorePlugin = addCorePlugin - qGetQ = getQ - qPutQ = putQ - qIsExtEnabled = isExtEnabled - qExtsEnabled = extsEnabled - qPutDoc = putDoc - qGetDoc = getDoc + qNewName = newName + qReport = report + qRecover = recover + qReify = reify + qReifyFixity = reifyFixity + qReifyType = reifyType + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness = reifyConStrictness + qLookupName = lookupName + qLocation = location + qGetPackageRoot = getPackageRoot + qAddDependentFile = addDependentFile + qAddDependentDirectory = addDependentDirectory + qAddTempFile = addTempFile + qAddTopDecls = addTopDecls + qAddForeignFilePath = addForeignFilePath + qAddModFinalizer = addModFinalizer + qAddCorePlugin = addCorePlugin + qGetQ = getQ + qPutQ = putQ + qIsExtEnabled = isExtEnabled + qExtsEnabled = extsEnabled + qPutDoc = putDoc + qGetDoc = getDoc ---------------------------------------------------- ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -291,6 +291,7 @@ data THMessage a where GetPackageRoot :: THMessage (THResult FilePath) AddDependentFile :: FilePath -> THMessage (THResult ()) + AddDependentDirectory :: FilePath -> THMessage (THResult ()) AddTempFile :: String -> THMessage (THResult FilePath) AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ()) AddCorePlugin :: String -> THMessage (THResult ()) @@ -343,6 +344,7 @@ getTHMessage = do 23 -> THMsg <$> (PutDoc <$> get <*> get) 24 -> THMsg <$> GetDoc <$> get 25 -> THMsg <$> return GetPackageRoot + 26 -> THMsg <$> AddDependentDirectory <$> get n -> error ("getTHMessage: unknown message " ++ show n) putTHMessage :: THMessage a -> Put @@ -373,7 +375,7 @@ putTHMessage m = case m of PutDoc l s -> putWord8 23 >> put l >> put s GetDoc l -> putWord8 24 >> put l GetPackageRoot -> putWord8 25 - + AddDependentDirectory a -> putWord8 26 >> put a data EvalOpts = EvalOpts { useSandboxThread :: Bool ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -198,6 +198,7 @@ instance TH.Quasi GHCiQ where qLocation = fromMaybe noLoc . qsLocation <$> getState qGetPackageRoot = ghcCmd GetPackageRoot qAddDependentFile file = ghcCmd (AddDependentFile file) + qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir) qAddTempFile suffix = ghcCmd (AddTempFile suffix) qAddTopDecls decls = ghcCmd (AddTopDecls decls) qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp) ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -32,6 +32,7 @@ module Language.Haskell.TH.Syntax ( ModName (..), addCorePlugin, addDependentFile, + addDependentDirectory, addForeignFile, addForeignFilePath, addForeignSource, ===================================== testsuite/.gitignore ===================================== @@ -1523,6 +1523,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk /tests/th/T8633 /tests/th/TH_Depends /tests/th/TH_Depends_external.txt +/tests/th/TH_Depends_external/dummy.txt /tests/th/TH_StringPrimL /tests/th/TH_import_loop/ModuleA.hi-boot /tests/th/TH_import_loop/ModuleA.o-boot ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -1715,6 +1715,7 @@ module Language.Haskell.TH.Syntax where qRunIO :: forall a. GHC.Internal.Types.IO a -> m a qGetPackageRoot :: m GHC.Internal.IO.FilePath qAddDependentFile :: GHC.Internal.IO.FilePath -> m () + qAddDependentDirectory :: GHC.Internal.IO.FilePath -> m () qAddTempFile :: GHC.Internal.Base.String -> m GHC.Internal.IO.FilePath qAddTopDecls :: [Dec] -> m () qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m () @@ -1726,7 +1727,7 @@ module Language.Haskell.TH.Syntax where qExtsEnabled :: m [Extension] qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m () qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) - {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-} + {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-} type Quote :: (* -> *) -> Constraint class GHC.Internal.Base.Monad m => Quote m where newName :: GHC.Internal.Base.String -> m Name @@ -1779,6 +1780,7 @@ module Language.Haskell.TH.Syntax where type VarStrictType :: * type VarStrictType = VarBangType addCorePlugin :: GHC.Internal.Base.String -> Q () + addDependentDirectory :: GHC.Internal.IO.FilePath -> Q () addDependentFile :: GHC.Internal.IO.FilePath -> Q () addForeignFile :: ForeignSrcLang -> GHC.Internal.Base.String -> Q () addForeignFilePath :: ForeignSrcLang -> GHC.Internal.IO.FilePath -> Q () ===================================== testsuite/tests/th/Makefile ===================================== @@ -43,6 +43,20 @@ TH_Depends: '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -v0 TH_Depends ./TH_Depends +.PHONY: TH_Depends_Dir +TH_Depends_Dir: + rm -rf TH_Depends_external + $(RM) TH_Depends_Dir TH_Depends_Dir.exe + $(RM) TH_Depends_Dir.o TH_Depends_Dir.hi + $(RM) TH_Depends_Dir_External.o TH_Depends_Dir_External.hi + + mkdir TH_Depends_external + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -v0 TH_Depends_Dir + ./TH_Depends_Dir + sleep 2 + echo "dummy" > TH_Depends_external/dummy.txt + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -v0 TH_Depends_Dir + ./TH_Depends_Dir T8333: '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(ghcThWayFlags) T8333.hs < /dev/null ===================================== testsuite/tests/th/TH_Depends_Dir.hs ===================================== @@ -0,0 +1,9 @@ + +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import TH_Depends_Dir_External (checkDirectoryContent) + +main :: IO () +main = putStrLn $checkDirectoryContent \ No newline at end of file ===================================== testsuite/tests/th/TH_Depends_Dir.stdout ===================================== @@ -0,0 +1,2 @@ +no files? +yes files! \ No newline at end of file ===================================== testsuite/tests/th/TH_Depends_Dir_External.hs ===================================== @@ -0,0 +1,15 @@ + +module TH_Depends_Dir_External where + +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Lib +import System.Directory (listDirectory) + +checkDirectoryContent :: Q Exp +checkDirectoryContent = do + qAddDependentDirectory "TH_Depends_external" + l <- qRunIO $ listDirectory "TH_Depends_external" + let s = case l of + [] -> "no files?" + _ -> "yes files!" + stringE s \ No newline at end of file ===================================== testsuite/tests/th/all.T ===================================== @@ -214,6 +214,7 @@ test('T5434', [], multimod_compile, ['T5434', '-v0 -Wall ' + config.ghc_th_way_flags]) test('T5508', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_Depends', [only_ways(['normal'])], makefile_test, ['TH_Depends']) +test('TH_Depends_Dir', [only_ways(['normal'])], makefile_test, ['TH_Depends_Dir']) test('T5597', [], multimod_compile, ['T5597', '-v0 ' + config.ghc_th_way_flags]) test('T5665', [], multimod_compile, ['T5665', '-v0 ' + config.ghc_th_way_flags]) test('T5700', [], multimod_compile, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/43229cd960b8bcb6476073d57a8c706... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/43229cd960b8bcb6476073d57a8c706... You're receiving this email because of your account on gitlab.haskell.org.