Hannes Siebenhandl pushed to branch wip/fendor/dep-json at Glasgow Haskell Compiler / GHC Commits: 3dece9c4 by fendor at 2026-09-24T13:22:00+02:00 Abstract dependency processing from Makefile generation Allows multiple consumers - - - - - 147961b3 by fendor at 2026-09-24T13:22:54+02:00 Add json output format - - - - - 51dc8da5 by fendor at 2026-09-24T13:22:56+02:00 Add -dep-json test with multiple deps - - - - - 20 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Session.hs - docs/users_guide/separate_compilation.rst - + testsuite/tests/driver/T24384/A.hs - + testsuite/tests/driver/T24384/C.hs - + testsuite/tests/driver/T24384/C.hs-boot - + testsuite/tests/driver/T24384/D.hs - + testsuite/tests/driver/T24384/E.hs - + testsuite/tests/driver/T24384/Makefile - + testsuite/tests/driver/T24384/T24384.stdout - + testsuite/tests/driver/T24384/all.T - + testsuite/tests/driver/T24384/dep-internal/DepInternal.hs - + testsuite/tests/driver/T24384/dep-internal/dep-internal.pkg - + testsuite/tests/driver/T24384/dep-public/DepPublic.hs - + testsuite/tests/driver/T24384/dep-public/dep-public.pkg - + testsuite/tests/driver/T24384/dep/Dep.hs - + testsuite/tests/driver/T24384/dep/dep.pkg - + testsuite/tests/driver/T24384/lib/B.hs - + testsuite/tests/driver/T24384/preproc.sh Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -351,6 +351,7 @@ data DynFlags = DynFlags { -- For ghc -M depMakefile :: FilePath, + depJson :: Maybe FilePath, depIncludePkgDeps :: Bool, depIncludeCppDeps :: Bool, depExcludeMods :: [ModuleName], @@ -694,6 +695,7 @@ defaultDynFlags mySettings = -- ghc -M values depMakefile = "Makefile", + depJson = Nothing, depIncludePkgDeps = False, depIncludeCppDeps = False, depExcludeMods = [], ===================================== compiler/GHC/Driver/MakeFile.hs ===================================== @@ -7,6 +7,8 @@ -- (c) The University of Glasgow 2005 -- ----------------------------------------------------------------------------- +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RecordWildCards #-} module GHC.Driver.MakeFile ( doMkDependHS @@ -19,8 +21,9 @@ import GHC.Prelude import GHC qualified import GHC.Data.Bag (listToBag) +import GHC.Data.FastString (lexicalCompareFS, unpackFS) import GHC.Data.Graph.Directed (SCC (..)) -import GHC.Data.OsPath (unsafeDecodeUtf, unsafeEncodeUtf) +import GHC.Data.OsPath import GHC.Driver.DynFlags import GHC.Driver.Env @@ -52,6 +55,7 @@ import GHC.Unit.State (lookupUnitId) import GHC.Utils.Error import GHC.Utils.Exception +import GHC.Utils.Json import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Outputable @@ -63,12 +67,18 @@ import Data.Either import Data.Foldable (traverse_) import Data.IORef import Data.List (partition) +import Data.Map.Strict qualified as Map import Data.Maybe (isJust, isNothing) +import Data.Semigroup qualified as Semigroup import Data.Set qualified as Set +import GHC.Generics (Generic, Generically (..)) import System.Directory -import System.FilePath +import qualified System.Directory as Directory +import System.OsPath as OsPath import System.IO import System.IO.Error (isEOFError) +import qualified System.OsString as OsString +import qualified Data.Monoid as Monoid ----------------------------------------------------------------- -- @@ -110,27 +120,53 @@ doMkDependHS srcs = do doMkDependModuleGraph :: GhcMonad m => DynFlags -> ModuleGraph -> m () doMkDependModuleGraph dflags module_graph = do + hsc_env <- getSession logger <- getLogger - tmpfs <- hsc_tmpfs <$> getSession - let excl_mods = depExcludeMods dflags + let + tmpfs = hsc_tmpfs hsc_env + excl_mods = depExcludeMods dflags + + root_ <- liftIO getCurrentDirectory + root <- encodeUtf root_ + let + dep_writer = + concat + [ [ SomeDependencyWriter $ initFileDepWriter logger root tmpfs dflags + ] + , [ SomeDependencyWriter $ initJsonDepWriter json_output dflags + | Just json_output <- [depJson dflags] + ] + ] - files <- liftIO $ beginMkDependHS logger tmpfs dflags - let sorted = GHC.topSortModuleGraph False module_graph Nothing + let sorted = GHC.topSortModuleGraph False module_graph Nothing -- Print out the dependencies if wanted liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted) - -- Process them one by one, dumping results into makefile - -- and complaining about cycles - hsc_env <- getSession - root <- liftIO getCurrentDirectory - mapM_ (liftIO . processDeps dflags hsc_env (UniqSet.mkUniqSet excl_mods) root (mkd_tmp_hdl files)) sorted + liftIO $ do - -- If -ddump-mod-cycles, show cycles in the module graph - liftIO $ dumpModCycles logger module_graph + writers <- traverse + (\ (SomeDependencyWriter writer) -> do + backend <- dw_beginWriter writer + pure $ SomeActiveDependencyWriter (writer, backend) + ) + dep_writer + + do + -- Process them one by one, dumping results and complaining about cycles + mapM_ (processDeps dflags hsc_env (UniqSet.mkUniqSet excl_mods) writers) sorted + + -- If -ddump-mod-cycles, show cycles in the module graph + liftIO $ dumpModCycles logger module_graph + + -- Tidy up + do + traverse_ + (\ (SomeActiveDependencyWriter (writer, backend)) -> do + dw_endWriter writer backend + ) + writers - -- Tidy up - liftIO $ endMkDependHS logger files -- Unconditional exiting is a bad idea. If an error occurs we'll get an --exception; if that is not caught it's fine, but at least we have a @@ -139,67 +175,6 @@ doMkDependModuleGraph dflags module_graph = do --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) ------------------------------------------------------------------ --- --- beginMkDependHs --- Create a temporary file, --- find the Makefile, --- slurp through it, etc --- ------------------------------------------------------------------ - -data MkDepFiles - = MkDep { mkd_make_file :: FilePath, -- Name of the makefile - mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile - mkd_tmp_file :: FilePath, -- Name of the temporary file - mkd_tmp_hdl :: Handle } -- Handle of the open temporary file - -beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles -beginMkDependHS logger tmpfs dflags = do - -- open a new temp file in which to stuff the dependency info - -- as we go along. - tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep" - tmp_hdl <- openFile tmp_file WriteMode - - -- open the makefile - let makefile = depMakefile dflags - exists <- doesFileExist makefile - mb_make_hdl <- - if not exists - then return Nothing - else do - makefile_hdl <- openFile makefile ReadMode - - -- slurp through until we get the magic start string, - -- copying the contents into dep_makefile - let slurp = do - l <- hGetLine makefile_hdl - if (l == depStartMarker) - then return () - else do hPutStrLn tmp_hdl l; slurp - - -- slurp through until we get the magic end marker, - -- throwing away the contents - let chuck = do - l <- hGetLine makefile_hdl - if (l == depEndMarker) - then return () - else chuck - - catchIO slurp - (\e -> if isEOFError e then return () else ioError e) - catchIO chuck - (\e -> if isEOFError e then return () else ioError e) - - return (Just makefile_hdl) - - - -- write the magic marker into the tmp file - hPutStrLn tmp_hdl depStartMarker - - return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, - mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) - -------------------------------------------------------------------------------- -- Types abstracting over the output -------------------------------------------------------------------------------- @@ -207,9 +182,9 @@ beginMkDependHS logger tmpfs dflags = do data DepNode = DepNode { dn_mod :: Module - , dn_src :: FilePath - , dn_obj :: FilePath - , dn_hi :: FilePath + , dn_src :: OsPath + , dn_obj :: OsPath + , dn_hi :: OsPath , dn_boot :: IsBootInterface , dn_preprocessing :: PreprocessingNode } @@ -222,15 +197,24 @@ data PreprocessingNode = PreprocessingNode data Dep = DepHi { dep_mod :: Module - , dep_path :: FilePath + , dep_path :: OsPath , dep_unit :: Maybe UnitInfo , dep_local :: Bool , dep_boot :: IsBootInterface } | DepCpp - { dep_path :: FilePath + { dep_path :: OsPath } +data SomeDependencyWriter = forall backend . SomeDependencyWriter (DependencyWriter backend) + +data SomeActiveDependencyWriter = forall backend . SomeActiveDependencyWriter (DependencyWriter backend, backend) + +data DependencyWriter backend = DependencyWriter + { dw_beginWriter :: IO backend + , dw_writeDependency :: backend -> DepNode -> [Dep] -> IO () + , dw_endWriter :: backend -> IO () + } ----------------------------------------------------------------- -- @@ -241,8 +225,7 @@ data Dep processDeps :: DynFlags -> HscEnv -> UniqSet ModuleName -- ^ Excludes - -> FilePath - -> Handle -- Write dependencies to here + -> [SomeActiveDependencyWriter] -> SCC ModuleGraphNode -> IO () -- Write suitable dependencies to handle @@ -260,23 +243,23 @@ processDeps :: DynFlags -- -- For {-# SOURCE #-} imports the "hi" will be "hi-boot". -processDeps _ hsc_env _ _ _ (CyclicSCC nodes) +processDeps _ hsc_env _ _ (CyclicSCC nodes) = -- There shouldn't be any cycles; report them throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ cyclicModuleErr nodes -processDeps _ hsc_env _ _ _ (AcyclicSCC (InstantiationNode _uid node)) +processDeps _ hsc_env _ _ (AcyclicSCC (InstantiationNode _uid node)) = -- There shouldn't be any backpack instantiations; report them as well throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ mkPlainErrorMsgEnvelope noSrcSpan $ GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node -processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return () -processDeps _dflags _ _ _ _ (AcyclicSCC (UnitNode {})) = return () -processDeps _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) +processDeps _dflags _ _ _ (AcyclicSCC (LinkNode {})) = return () +processDeps _dflags _ _ _ (AcyclicSCC (UnitNode {})) = return () +processDeps _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) -- No dependencies needed for fixed modules (already compiled) = return () -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do +processDeps dflags hsc_env excl_mods backends (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do pp <- preprocessor let dep_node = mkDepNode pp @@ -288,33 +271,33 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleN if null missing_dep_errs then do - writeDependencies include_pkg_deps root hdl extra_suffixes dep_node deps + traverse_ (\ (SomeActiveDependencyWriter (writer, backend)) -> dw_writeDependency writer backend dep_node deps) backends else do let sec = initSourceErrorContext (hsc_dflags hsc_env) throwErrors sec (mkMessages (listToBag missing_dep_errs)) where - extra_suffixes = depSuffixes dflags - include_pkg_deps = depIncludePkgDeps dflags - src_file = msHsFilePath node - mkDepNode opts = - DepNode { - dn_mod = ms_mod node, - dn_src = src_file, - dn_obj = msObjFilePath node, - dn_hi = msHiFilePath node, - dn_boot = isBootSummary node, - dn_preprocessing = opts - } + src_file = msHsFileOsPath node + mkDepNode preproc = + DepNode + { dn_mod = ms_mod node + , dn_src = src_file + , dn_obj = msObjFileOsPath node + , dn_hi = msHiFileOsPath node + , dn_boot = isBootSummary node + , dn_preprocessing = preproc + } preprocessor :: IO PreprocessingNode preprocessor - | Just src <- ml_hs_file (ms_location node) + | Just src <- ml_hs_file_ospath (ms_location node) = runPipeline (hsc_hooks hsc_env) $ do - let (_, suffix) = splitExtension src - lit | Unlit _ <- startPhase suffix = True - | otherwise = False - pipe_env = mkPipeEnv StopPreprocess src Nothing NoOutputFile - unlit_fn <- if lit then use (T_Unlit pipe_env hsc_env src) else pure src + let + (_, suffix) = OsPath.splitExtension src + srcFn = unsafeDecodeUtf src + lit | Unlit _ <- startPhase (unsafeDecodeUtf suffix) = True + | otherwise = False + pipe_env = mkPipeEnv StopPreprocess srcFn Nothing NoOutputFile + unlit_fn <- if lit then use (T_Unlit pipe_env hsc_env srcFn) else pure srcFn (dflags1, opts, _, _) <- use (T_FileArgs (hsc_logger hsc_env) (hsc_dflags hsc_env) unlit_fn) let pp = pgm_F dflags1 pure PreprocessingNode @@ -341,10 +324,14 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleN -- Note that GHC.parseModule may throw an exception if the module -- fails to parse, which may not be desirable (see #16616). find_cpp_deps :: IO [Dep] - find_cpp_deps = do - session <- Session <$> newIORef hsc_env - parsedMod <- reflectGhc (GHC.parseModule node) session - pure (DepCpp <$> GHC.pm_extra_src_files parsedMod) + find_cpp_deps = + if depIncludeCppDeps dflags + then do + session <- Session <$> newIORef hsc_env + parsedMod <- reflectGhc (GHC.parseModule node) session + pure (DepCpp . unsafeEncodeUtf <$> GHC.pm_extra_src_files parsedMod) + else + pure [] -- Emit a dependency for each import find_import_deps :: [UnresolvedImport PkgQual] -> IO [Either (MsgEnvelope GhcMessage) Dep] @@ -356,7 +343,6 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleN , not $ mod `UniqSet.elementOfUniqSet` excl_mods ] - findDependency :: HscEnv -> UnresolvedImport PkgQual -- The import to find -> IO (Either (MsgEnvelope GhcMessage) Dep) -- Interface file @@ -369,7 +355,7 @@ findDependency hsc_env imp = do pure $ Right DepHi { dep_mod = dep_mod - , dep_path = ml_hi_file loc + , dep_path = ml_hi_file_ospath loc , dep_unit = lookupUnitId (hsc_units hsc_env) (moduleUnitId dep_mod) , dep_local = isJust (ml_hs_file loc) , dep_boot = is_boot @@ -385,11 +371,83 @@ findDependency hsc_env imp = do L srcloc mod_name = ui_mod_name imp is_boot = ui_boot imp +----------------------------------------------------------------- +-- +-- beginMkDependHs +-- Create a temporary file, +-- find the Makefile, +-- slurp through it, etc +-- +----------------------------------------------------------------- + +initFileDepWriter :: Logger -> OsPath -> TmpFs -> DynFlags -> DependencyWriter MkDepFiles +initFileDepWriter logger root tmpfs dflags = DependencyWriter + { dw_beginWriter = beginMkDependHS logger tmpfs dflags + , dw_writeDependency = \ backend node deps -> do + writeDependencies (depIncludePkgDeps dflags) root (mkd_tmp_hdl backend) suffixes node deps + , dw_endWriter = endMkDependHS logger + } + where + suffixes = map unsafeEncodeUtf (depSuffixes dflags) + +data MkDepFiles + = MkDep { mkd_make_file :: FilePath, -- Name of the makefile + mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile + mkd_tmp_file :: FilePath, -- Name of the temporary file + mkd_tmp_hdl :: Handle } -- Handle of the open temporary file + +beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles +beginMkDependHS logger tmpfs dflags = do + -- open a new temp file in which to stuff the dependency info + -- as we go along. + tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep" + tmp_hdl <- openFile tmp_file WriteMode + + -- open the makefile + let makefile = depMakefile dflags + exists <- Directory.doesFileExist makefile + mb_make_hdl <- + if not exists + then return Nothing + else do + makefile_hdl <- openFile makefile ReadMode + + -- slurp through until we get the magic start string, + -- copying the contents into dep_makefile + let slurp = do + l <- hGetLine makefile_hdl + if (l == depStartMarker) + then return () + else do hPutStrLn tmp_hdl l; slurp + + -- slurp through until we get the magic end marker, + -- throwing away the contents + let chuck = do + l <- hGetLine makefile_hdl + if (l == depEndMarker) + then return () + else chuck + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + catchIO chuck + (\e -> if isEOFError e then return () else ioError e) + + return (Just makefile_hdl) + + + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depStartMarker + + return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) + writeDependencies :: Bool -> - FilePath -> + OsPath -> Handle -> - [FilePath] -> + [OsString] -> + -- ^ Suffixes DepNode -> [Dep] -> IO () @@ -406,7 +464,7 @@ writeDependencies include_pkgs root hdl suffixes node deps = -- files if the module has a corresponding .hs-boot file (#14482) boot_dep | IsBoot <- dn_boot - = [([obj], hi) | (obj, hi) <- zip (suffixed (viaOsPath removeBootSuffix dn_obj)) (suffixed dn_hi)] + = [([obj], hi) | (obj, hi) <- zip (suffixed (removeBootSuffix dn_obj)) (suffixed dn_hi)] | otherwise = [] @@ -414,10 +472,9 @@ writeDependencies include_pkgs root hdl suffixes node deps = -- e.g. A.o : B.hi -- A.x_o : B.x_hi import_dep = \case - DepHi {dep_path, dep_boot, dep_unit} + DepHi {dep_path, dep_unit} | isNothing dep_unit || include_pkgs - , let path = if dep_boot == IsBoot then viaOsPath addBootSuffix dep_path else dep_path - -> [([obj], hi) | (obj, hi) <- zip obj_files (suffixed path)] + -> [([obj], hi) | (obj, hi) <- zip obj_files (suffixed dep_path)] | otherwise -> [] @@ -432,10 +489,8 @@ writeDependencies include_pkgs root hdl suffixes node deps = DepNode {dn_src, dn_obj, dn_hi, dn_boot} = node - viaOsPath f a = unsafeDecodeUtf (f (unsafeEncodeUtf a)) - ----------------------------- -writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () +writeDependency :: OsPath -> Handle -> [OsPath] -> OsPath -> IO () -- (writeDependency r h [t1,t2] dep) writes to handle h the dependency -- t1 t2 : dep writeDependency root hdl targets dep @@ -443,33 +498,30 @@ writeDependency root hdl targets dep -- c:/foo/... -- on cygwin as make gets confused by the : -- Making relative deps avoids some instances of this. - dep' = makeRelative root dep - forOutput = escapeSpaces . reslash Forwards . normalise + dep' = OsPath.makeRelative root dep + forOutput = escapeSpaces . reslash Forwards . unsafeDecodeUtf . OsPath.normalise output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' hPutStrLn hdl output ----------------------------- insertSuffixes - :: FilePath -- Original filename; e.g. "foo.o" - -> [String] -- Suffix prefixes e.g. ["x_", "y_"] - -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] + :: OsPath -- Original filename; e.g. "foo.o" + -> [OsString] -- Suffix prefixes e.g. ["x_", "y_"] + -> [OsPath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] -- Note that the extra bit gets inserted *before* the old suffix -- We assume the old suffix contains no dots, so we know where to -- split it insertSuffixes file_name extras - = [ basename <.> (extra ++ suffix) | extra <- extras ] + = [ basename <.> (extra Monoid.<> suffix) | extra <- extras ] where - (basename, suffix) = case splitExtension file_name of + (basename, suffix) = case OsPath.splitExtension file_name of -- Drop the "." from the extension - (b, s) -> (b, drop 1 s) + (b, s) -> (b, OsString.drop 1 s) ----------------------------------------------------------------- --- --- endMkDependHs --- Complete the makefile, close the tmp file etc --- ------------------------------------------------------------------ +-- endMkDependHs +-- Complete the makefile, close the tmp file etc endMkDependHS :: Logger -> MkDepFiles -> IO () @@ -498,6 +550,185 @@ endMkDependHS logger showPass logger "Installing new makefile" SysTools.copyFile tmp_file makefile +----------------------------------------------------------------- +-- +-- JSON MkDepends output +-- +----------------------------------------------------------------- + +initJsonDepWriter :: FilePath -> DynFlags -> DependencyWriter (JsonOutput DepJson) +initJsonDepWriter output dflags = DependencyWriter + { dw_beginWriter = do + mkJsonOutput output initDepJson + , dw_writeDependency = \ backend node deps -> do + updateJson backend (updateDepJson (depIncludePkgDeps dflags) node deps) + , dw_endWriter = + writeJsonOutput + } + +-------------------------------------------------------------------------------- +-- Output interface for json dumps + +-- | Resources for a json dump option, used in "GHC.Driver.MakeFile". +-- The flag @-dep-json@ add an additional output target for dependency +-- diagnostics. +data JsonOutput a = + JsonOutput { + -- | This ref is updated in @processDeps@ incrementally, using a + -- flag-specific type. + json_ref :: IORef a, + + -- | The output file path specified as argument to the flag. + json_path :: FilePath + } + +-- | TODO: @fendor +mkJsonOutput :: + FilePath -> + IO (IORef a) -> + IO (JsonOutput a) +mkJsonOutput json_path mk_ref = do + json_ref <- mk_ref + pure JsonOutput {json_ref, json_path} + +-- | Update the dump data in 'json_ref' if the output target is present. +updateJson :: JsonOutput a -> (a -> a) -> IO () +updateJson JsonOutput {json_ref} f = modifyIORef' json_ref f + +-- | Write a json object to the flag-dependent file if the output target is +-- present. +writeJsonOutput :: + ToJson a => + JsonOutput a -> + IO () +writeJsonOutput JsonOutput {json_ref, json_path} = do + payload <- readIORef json_ref + writeJsonFile payload json_path + +-------------------------------------------------------------------------------- +-- Output helpers + +writeJsonFile :: ToJson a => a -> FilePath -> IO () +writeJsonFile doc p = do + withAtomicRename p + $ \tmp -> writeFile tmp $ showSDocUnsafe $ renderJSON $ json doc + +-------------------------------------------------------------------------------- +-- Payload for -dep-json + +newtype PackageDeps + = PackageDeps (Map.Map (String, UnitId, DPackageId) (Set.Set ModuleName)) + deriving newtype (Monoid) + +newtype DPackageId = DPackageId PackageId + deriving newtype (Eq) + +instance Ord DPackageId where + DPackageId (PackageId d1) `compare` DPackageId (PackageId d2) = d1 `lexicalCompareFS` d2 + +instance Semigroup PackageDeps where + PackageDeps l <> PackageDeps r = PackageDeps (Map.unionWith (Semigroup.<>) l r) + +data Deps + = Deps + { sources :: Set.Set OsPath + , modules :: (Set.Set ModuleName, Set.Set ModuleName) + , packages :: PackageDeps + , cpp :: Set.Set OsPath + , options :: [String] + , preprocessor :: Maybe FilePath + } + deriving stock (Generic) + deriving (Semigroup, Monoid) via (Generically Deps) + +newtype DepJson = DepJson (Map.Map ModuleName Deps) + +instance ToJson DepJson where + json (DepJson m) = + JSObject [ + (moduleNameString target, JSObject [ + ("sources", array sources (showOsPath . normalise)), + ("modules", array (fst modules) moduleNameString), + ("modules-boot", array (snd modules) moduleNameString), + ("packages", + JSArray + [ package name unit_id package_id mods + | ((name, unit_id, dpkd_id), mods) <- Map.toList packages + , let DPackageId package_id = dpkd_id + ] + ), + ("cpp", array cpp showOsPath), + ("options", JSArray $ map JSString options), + ("preprocessor", maybe JSNull JSString preprocessor) + ]) + | (target, Deps {packages = PackageDeps packages, ..}) <- Map.toList m + ] + where + package name unit_id (PackageId package_id) mods = + JSObject [ + ("id", JSString (unitIdString unit_id)), + ("name", JSString name), + ("package-id", JSString (unpackFS package_id)), + ("modules", array mods moduleNameString) + ] + + array values render = JSArray (fmap (JSString . render) (Set.toList values)) + + showOsPath = unsafeDecodeUtf + +initDepJson :: IO (IORef DepJson) +initDepJson = newIORef $ DepJson Map.empty + +insertDepJson :: [ModuleName] -> Deps -> DepJson -> DepJson +insertDepJson targets dep (DepJson m0) = + DepJson + $ foldl' + ( \acc target -> + Map.insertWith + (Semigroup.<>) + target + dep + acc + ) + m0 + targets + +updateDepJson :: Bool -> DepNode -> [Dep] -> DepJson -> DepJson +updateDepJson include_pkgs DepNode {..} deps = + insertDepJson [moduleName dn_mod] payload + where + payload = node_data Semigroup.<> foldMap dep deps + + node_data = + mempty { + sources = Set.singleton dn_src, + preprocessor = pn_preprocessor dn_preprocessing, + options = pn_options dn_preprocessing + } + + dep = \case + DepHi {dep_mod, dep_local, dep_unit, dep_boot} + | dep_local + , let set = Set.singleton $ moduleName dep_mod + value | IsBoot <- dep_boot = (Set.empty, set) + | otherwise = (set, Set.empty) + -> mempty {modules = value} + + | include_pkgs + , Just unit <- dep_unit + , let PackageName nameFS = unitPackageName unit + name = unpackFS nameFS + withLibName (PackageName c) = name ++ ":" ++ unpackFS c + lname = maybe name withLibName (unitComponentName unit) + key = (lname, unitId unit, DPackageId $ unitPackageId unit) + -> mempty {packages = PackageDeps (Map.singleton key (Set.singleton $ moduleName dep_mod))} + + | otherwise + -> mempty + + DepCpp {dep_path} -> + mempty {cpp = Set.singleton dep_path} + ----------------------------------------------------------------- -- Module cycles ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -760,6 +760,12 @@ addOptCmmP f = alterToolSettings $ \s -> s setDepMakefile :: FilePath -> DynFlags -> DynFlags setDepMakefile f d = d { depMakefile = f } +setDepJson :: FilePath -> DynFlags -> DynFlags +setDepJson f d = d { depJson = Just f } + +unsetDepJson :: DynFlags -> DynFlags +unsetDepJson d = d { depJson = Nothing } + setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } @@ -1245,6 +1251,8 @@ dynamic_flags_deps = [ -------- ghc -M ----------------------------------------------------- , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , make_ord_flag defGhcFlag "dep-json" (hasArg setDepJson) + , make_ord_flag defGhcFlag "no-dep-json" (noArg unsetDepJson) , make_ord_flag defGhcFlag "include-cpp-deps" (noArg (setDepIncludeCppDeps True)) , make_ord_flag defGhcFlag "include-pkg-deps" ===================================== docs/users_guide/separate_compilation.rst ===================================== @@ -1503,6 +1503,23 @@ generation are: ``.depend`` and then ``include`` the file ``.depend`` into ``Makefile``. +.. ghc-flag:: -dep-json ⟨file⟩ + :shortdesc: Also emit ⟨file⟩ as a JSON file containing dependencies + :type: dynamic + :reverse: -no-dep-json + :category: redirect-output + + In addition to the makefile, also emit ⟨file⟩ as a JSON file + containing the same dependencies info, so it can be parsed by + external build systems. The JSON file contains a single object, + mapping each target to a list of dependencies. + In addition to the makefile, each module's payload will contain the + values of ``OPTIONS`` and ``LANGUAGE`` pragmas of the source + file, so it can be parsed by external build systems. Each ``LANGUAGE`` + pragma is represented as an option as well, e.g. + ``{-# LANGUAGE TemplateHaskell #-}`` is represented as + ``"-XTemplateHaskell"``. + .. ghc-flag:: -dep-suffix ⟨suffix⟩ :shortdesc: Make dependencies that declare that files with suffix ``.⟨suf⟩⟨osuf⟩`` depend on interface files with suffix ``.⟨suf⟩hi`` ===================================== testsuite/tests/driver/T24384/A.hs ===================================== @@ -0,0 +1,5 @@ +{-# language Strict #-} +{-# options_ghc -fexpose-all-unfoldings #-} +module A where + +import {-# source #-} C ===================================== testsuite/tests/driver/T24384/C.hs ===================================== @@ -0,0 +1,6 @@ +module C where + +import A +import Data.Set + +data C = C ===================================== testsuite/tests/driver/T24384/C.hs-boot ===================================== @@ -0,0 +1,5 @@ +module C where + +import E + +data C ===================================== testsuite/tests/driver/T24384/D.hs ===================================== @@ -0,0 +1,4 @@ +module D where + +import B +import C ===================================== testsuite/tests/driver/T24384/E.hs ===================================== @@ -0,0 +1,14 @@ +module E where + +import Language.Haskell.TH.Syntax +import Dep +import DepPublic + +e :: Q Exp +e = lift (5 :: Integer) + +edep :: () +edep = dep + +edepPub :: () +edepPub = depPub ===================================== testsuite/tests/driver/T24384/Makefile ===================================== @@ -0,0 +1,38 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + + +PKGCONF_LOCAL=./db.package.conf +GHC_PKG_LOCAL='$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_LOCAL) + +T24384: + $(GHC_PKG_LOCAL) init $(PKGCONF_LOCAL) 2>&1 >/dev/null + + cd dep-internal && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir outdir -this-unit-id dep-internal-1-XXX \ + -package base \ + -i. DepInternal + $(GHC_PKG_LOCAL) register --force dep-internal/dep-internal.pkg 2>&1 >/dev/null + + cd dep-public && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir outdir -this-unit-id dep-public-1-XXX \ + -package base \ + -i. DepPublic + $(GHC_PKG_LOCAL) register --force dep-public/dep-public.pkg 2>&1 >/dev/null + + cd dep && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir outdir -this-unit-id dep-1-XXX \ + -package-db ../$(PKGCONF_LOCAL) -package-id dep-internal-1-XXX \ + -i. Dep + $(GHC_PKG_LOCAL) register --force dep/dep.pkg 2>&1 >/dev/null + + '$(TEST_HC)' -M -dep-json dep.json -include-pkg-deps -include-cpp-deps \ + -hide-all-packages -package base -package containers -package template-haskell \ + -package-db ./$(PKGCONF_LOCAL) -package-id dep-1-XXX -package-id dep-public-1-XXX \ + A.hs lib/B.hs C.hs D.hs E.hs + + cat dep.json | jq --sort-keys ===================================== testsuite/tests/driver/T24384/T24384.stdout ===================================== @@ -0,0 +1,157 @@ +{ + "A": { + "cpp": [], + "modules": [], + "modules-boot": [ + "C" + ], + "options": [ + "-XStrict", + "-fexpose-all-unfoldings" + ], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + } + ], + "preprocessor": null, + "sources": [ + "A.hs" + ] + }, + "B": { + "cpp": [], + "modules": [ + "A" + ], + "modules-boot": [], + "options": [ + "-F", + "-pgmF", + "./preproc.sh" + ], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + } + ], + "preprocessor": "./preproc.sh", + "sources": [ + "lib/B.hs" + ] + }, + "C": { + "cpp": [], + "modules": [ + "A", + "E" + ], + "modules-boot": [], + "options": [], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + }, + { + "id": "containers-0.8-inplace", + "modules": [ + "Data.Set" + ], + "name": "containers", + "package-id": "containers-0.8" + } + ], + "preprocessor": null, + "sources": [ + "C.hs", + "C.hs-boot" + ] + }, + "D": { + "cpp": [], + "modules": [ + "B", + "C" + ], + "modules-boot": [], + "options": [], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + } + ], + "preprocessor": null, + "sources": [ + "D.hs" + ] + }, + "E": { + "cpp": [], + "modules": [], + "modules-boot": [], + "options": [], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + }, + { + "id": "dep-1-XXX", + "modules": [ + "Dep" + ], + "name": "dep", + "package-id": "dep-1" + }, + { + "id": "dep-public-1-XXX", + "modules": [ + "DepPublic" + ], + "name": "dep-public", + "package-id": "dep-public-1" + }, + { + "id": "template-haskell-2.25.0.0-inplace", + "modules": [ + "Language.Haskell.TH.Syntax" + ], + "name": "template-haskell", + "package-id": "template-haskell-2.25.0.0" + } + ], + "preprocessor": null, + "sources": [ + "E.hs" + ] + } +} ===================================== testsuite/tests/driver/T24384/all.T ===================================== @@ -0,0 +1,7 @@ +test('T24384', + [ extra_files(['A.hs', 'lib/', 'C.hs', 'C.hs-boot', 'D.hs', 'E.hs', + 'dep', 'dep-internal', 'dep-public', + 'preproc.sh' + ]) + ], + makefile_test, []) ===================================== testsuite/tests/driver/T24384/dep-internal/DepInternal.hs ===================================== @@ -0,0 +1,3 @@ +module DepInternal where +depInt :: () +depInt = () ===================================== testsuite/tests/driver/T24384/dep-internal/dep-internal.pkg ===================================== @@ -0,0 +1,11 @@ +name: dep-internal +version: 1 +id: dep-internal-1-XXX +key: dep-internal-1-XXX +visibility: public +abi: inplace +exposed-modules: DepInternal +depends: +import-dirs: ${pkgroot}/dep-internal/outdir +library-dirs: ${pkgroot}/dep-internal/outdir +include-dirs: ===================================== testsuite/tests/driver/T24384/dep-public/DepPublic.hs ===================================== @@ -0,0 +1,3 @@ +module DepPublic where +depPub :: () +depPub = () ===================================== testsuite/tests/driver/T24384/dep-public/dep-public.pkg ===================================== @@ -0,0 +1,11 @@ +name: dep-public +version: 1 +id: dep-public-1-XXX +key: dep-public-1-XXX +visibility: public +abi: inplace +exposed-modules: DepPublic +depends: +import-dirs: ${pkgroot}/dep-public/outdir +library-dirs: ${pkgroot}/dep-public/outdir +include-dirs: ===================================== testsuite/tests/driver/T24384/dep/Dep.hs ===================================== @@ -0,0 +1,4 @@ +module Dep where +import DepInternal +dep :: () +dep = depInt ===================================== testsuite/tests/driver/T24384/dep/dep.pkg ===================================== @@ -0,0 +1,11 @@ +name: dep +version: 1 +id: dep-1-XXX +key: dep-1-XXX +visibility: public +abi: inplace +exposed-modules: Dep +depends: dep-internal-1-XXX +import-dirs: ${pkgroot}/dep/outdir +library-dirs: ${pkgroot}/dep/outdir +include-dirs: ===================================== testsuite/tests/driver/T24384/lib/B.hs ===================================== @@ -0,0 +1,2 @@ +{-# options_ghc -F -pgmF ./preproc.sh #-} +module B where ===================================== testsuite/tests/driver/T24384/preproc.sh ===================================== @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +sed '/preproc/d' $2 > $3 +echo 'import A' >> $3 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92d1b66eeb430a86a5453dd8e4c47ac... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92d1b66eeb430a86a5453dd8e4c47ac... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help