+  depJson               :: Maybe FilePath,

+        depJson           = Nothing,

+{-# LANGUAGE DerivingVia #-}

+{-# LANGUAGE RecordWildCards #-}

+import GHC qualified

+

+import GHC.Data.Bag (listToBag)

+import GHC.Data.FastString (lexicalCompareFS, unpackFS)

+import GHC.Data.Graph.Directed (SCC (..))

+import GHC.Data.OsPath

+

+import GHC.Driver.Make

+import GHC.Driver.Monad

+import GHC.Driver.Phases

+import GHC.Driver.Pipeline

+import GHC.Driver.Pipeline.Monad

+import GHC.Driver.Session

+import GHC.Iface.Errors.Types

+import GHC.SysTools qualified as SysTools

+import GHC.Types.PkgQual

+import GHC.Types.SourceError

+import GHC.Types.SrcLoc

+import GHC.Types.Unique.Set (UniqSet)

+import GHC.Types.Unique.Set qualified as UniqSet

+import GHC.Types.UnresolvedImport

+

+import GHC.Unit.Finder

+import GHC.Unit.Info

+import GHC.Unit.Module.ModSummary

+import GHC.Unit.State (lookupUnitId)

+import GHC.Utils.Exception

+import GHC.Utils.Json

+import GHC.Utils.Misc

+import GHC.Utils.Outputable

+import GHC.Utils.Panic

+import GHC.Utils.TmpFs

+import Control.Monad (when)

+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 qualified System.Directory as Directory

+import System.OsPath as OsPath

+import System.IO.Error (isEOFError)

+import qualified System.OsString as OsString

+import qualified Data.Monoid as Monoid

+import qualified System.FilePath as FilePath

+    hsc_env <- getSession

+    let

+      tmpfs = hsc_tmpfs hsc_env

+      excl_mods = depExcludeMods dflags

+    root_ <- liftIO getCurrentDirectory

+    root <- encodeUtf root_

+    let

+      backends = concat

+        [ [ initFileDepWriter logger root tmpfs dflags

+          ]

+        , [ initJsonDepWriter json_output dflags

+          | Just json_output <- [depJson dflags]

+          ]

+        ]

+

+

+    let sorted = GHC.topSortModuleGraph False module_graph Nothing

+    liftIO $ do

+

+      -- Setup the writers

+      writers <- sequenceA backends

+      sinks <- traverse dw_beginWriter writers

+

+      -- Do the actual work

+      do

+        -- Process them one by one, dumping results and complaining about cycles

+        mapM_ (processDeps dflags hsc_env (UniqSet.mkUniqSet excl_mods) sinks) sorted

+        -- If -ddump-mod-cycles, show cycles in the module graph

+        liftIO $ dumpModCycles logger module_graph

+

+      -- Tidy up

+      do

+        traverse_ dw_endWriter writers

+--------------------------------------------------------------------------------

+-- Types abstracting over the output

+--------------------------------------------------------------------------------

+

+data DepNode =

+  DepNode

+    { dn_mod :: ModuleWithIsBoot

+    , dn_src :: OsPath

+    , dn_obj :: OsPath

+    , dn_hi :: OsPath

+    , dn_preprocessing :: PreprocessingNode

+    }

+

+data PreprocessingNode = PreprocessingNode

+  { pn_preprocessor :: Maybe String

+  , pn_options :: [String]

+  }

+

+data Dep

+  = DepHi

+    { dep_mod :: Module

+    , dep_path :: OsPath

+    , dep_unit :: Maybe UnitInfo

+    , dep_local :: Bool

+    , dep_level :: ImportLevel

+    , dep_boot :: IsBootInterface

+    }

+  | DepCpp

+    { dep_path :: OsPath

+    }

+

+data DependencyWriter = DependencyWriter

+  { dw_beginWriter :: IO DepSink

+  , dw_endWriter :: IO ()

+  }

+

+data DepSink = DepSink

+  { ds_writeDependency :: DepNode -> [Dep] -> IO ()

+  }

+

+-----------------------------------------------------------------

+--

+--              processDeps

+--

+-----------------------------------------------------------------

+

+processDeps :: DynFlags

+            -> HscEnv

+            -> UniqSet ModuleName -- ^ Excludes

+            -> [DepSink]

+            -> SCC ModuleGraphNode

+            -> IO ()

+-- Write suitable dependencies to handle

+-- Always:

+--                      this.o : this.hs

+--

+-- If the dependency is on something other than a .hi file:

+--                      this.o this.p_o ... : dep

+-- otherwise

+--                      this.o ...   : dep.hi

+--                      this.p_o ... : dep.p_hi

+--                      ...

+-- (where .o is $osuf, and the other suffixes come from

+-- the cmdline -s options).

+--

+-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".

+

+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))

+  =     -- 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 {})))

+  -- No dependencies needed for fixed modules (already compiled)

+  = return ()

+

+processDeps dflags hsc_env excl_mods sinks (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do

+  pp <- preprocessor

+  let

+    dep_node = mkDepNode pp

+    find_deps imps = do

+      cpp_deps <- find_cpp_deps

+      import_deps <- find_import_deps imps

+      pure $ map Right cpp_deps ++ import_deps

+  (missing_dep_errs, deps) <- partitionEithers <$> find_deps (ms_imps node)

+

+  if null missing_dep_errs

+    then do

+      traverse_ (\ sink -> ds_writeDependency sink dep_node deps) sinks

+    else do

+      let sec = initSourceErrorContext (hsc_dflags hsc_env)

+      throwErrors sec (mkMessages (listToBag missing_dep_errs))

+  where

+    src_file = msHsFileOsPath node

+    mkDepNode preproc =

+      DepNode

+        { dn_mod = GWIB (ms_mod node) (isBootSummary node)

+        , dn_src = src_file

+        , dn_obj = msObjFileOsPath node

+        , dn_hi = msHiFileOsPath node

+        , dn_preprocessing = preproc

+        }

+

+    preprocessor :: IO PreprocessingNode

+    preprocessor

+      | Just src <- ml_hs_file (ms_location node)

+      = runPipeline (hsc_hooks hsc_env) $ do

+        let

+          (_, suffix) = FilePath.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

+        (dflags1, opts, _, _) <- use (T_FileArgs (hsc_logger hsc_env) (ms_hspp_opts node) unlit_fn)

+        let pp = pgm_F dflags1

+        pure PreprocessingNode

+          { pn_preprocessor = if null pp then global_preprocessor else Just pp

+          , pn_options = opts

+          }

+      | otherwise

+      = pure PreprocessingNode

+          { pn_preprocessor = global_preprocessor

+          , pn_options = []

+          }

+

+    global_preprocessor :: Maybe String

+    global_preprocessor

+      | let pp = pgm_F dflags

+      , not (null pp)

+      = Just pp

+      | otherwise

+      = Nothing

+

+    -- Emit a dependency for each CPP import

+    -- CPP deps are discovered in the module parsing phase by parsing

+    -- comment lines left by the preprocessor.

+    -- 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 =

+      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]

+    find_import_deps idecls =

+      sequence

+        [ findDependency hsc_env decl

+        | decl <- idecls

+        , let L _loc mod = ui_mod_name decl

+        , not $ mod `UniqSet.elementOfUniqSet` excl_mods

+        ]

+

+findDependency  :: HscEnv

+                -> UnresolvedImport PkgQual   -- The import to find

+                -> IO (Either (MsgEnvelope GhcMessage) Dep)  -- Interface file

+findDependency hsc_env imp = do

+  -- Find the module; this will be fast because

+  -- we've done it once during downsweep.

+  r <- resolveImport hsc_env imp

+  case r of

+    Found loc dep_mod ->

+      pure $ Right

+        DepHi

+          { dep_mod = dep_mod

+          , 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

+          , dep_level = ui_level imp

+          }

+

+    fail ->

+      return $

+        Left $

+          mkPlainErrorMsgEnvelope srcloc $

+          GhcDriverMessage $ DriverInterfaceError $

+             (Can'tFindInterface (cannotFindModule hsc_env mod_name fail) (LookingForModule mod_name is_boot))

+  where

+    L srcloc mod_name = ui_mod_name imp

+    is_boot           = ui_boot imp

+

+initFileDepWriter :: Logger -> OsPath -> TmpFs -> DynFlags -> IO DependencyWriter

+initFileDepWriter logger root tmpfs dflags = do

+  files <- beginMkDependHS logger tmpfs dflags

+  pure DependencyWriter

+    { dw_beginWriter = do

+        pure $ DepSink $ \ node deps -> do

+          writeDependencies (depIncludePkgDeps dflags) root (mkd_tmp_hdl files) suffixes node deps

+    , dw_endWriter = endMkDependHS logger files

+    }

+  where

+    suffixes = map unsafeEncodeUtf (depSuffixes dflags)

+

+  exists <- Directory.doesFileExist makefile

+writeDependencies ::

+  Bool ->

+  OsPath ->

+  Handle ->

+  [OsString] ->

+  -- ^ Suffixes

+  DepNode ->

+  [Dep] ->

+  IO ()

+writeDependencies include_pkgs root hdl suffixes node deps =

+  traverse_ write tasks

+  where

+    tasks = source_dep : boot_dep ++ concatMap import_dep deps

+

+    -- Emit std dependency of the object(s) on the source file

+    -- Something like       A.o : A.hs

+    source_dep = (obj_files, dn_src)

+

+    -- add dependency between objects and their corresponding .hi-boot

+    -- files if the module has a corresponding .hs-boot file (#14482)

+    boot_dep = case gwib_isBoot dn_mod of

+      IsBoot -> [([obj], hi) | (obj, hi) <- zip (suffixed (removeBootSuffix dn_obj)) (suffixed dn_hi)]

+      NotBoot -> []

+

+    -- Add one dependency for each suffix;

+    -- e.g.         A.o   : B.hi

+    --              A.x_o : B.x_hi

+    import_dep = \case

+      DepHi {dep_path, dep_unit}

+        | isNothing dep_unit || include_pkgs

+        -> [([obj], hi) | (obj, hi) <- zip obj_files (suffixed dep_path)]

+        | otherwise

+        -> []

+      DepCpp {dep_path} -> [(obj_files, dep_path)]

+    write (from, to) = writeDependency root hdl from to

+    obj_files = suffixed dn_obj

+    suffixed f = insertSuffixes f suffixes

+    DepNode {dn_src, dn_obj, dn_hi, dn_mod} = node

+writeDependency :: OsPath -> Handle -> [OsPath] -> OsPath -> IO ()

+           dep' = OsPath.makeRelative root dep

+           forOutput = escapeSpaces . reslash Forwards . unsafeDecodeUtf . OsPath.normalise

+        :: 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"]

+  = [ basename <.> (extra Monoid.<> suffix) | extra <- extras ]

+    (basename, suffix) = case OsPath.splitExtension file_name of

+                         (b, s) -> (b, OsString.drop 1 s)

+-- endMkDependHs

+-- Complete the makefile, close the tmp file etc

+-----------------------------------------------------------------

+--

+--              JSON MkDepends output

+--

+-----------------------------------------------------------------

+

+initJsonDepWriter :: FilePath -> DynFlags -> IO DependencyWriter

+initJsonDepWriter output dflags = do

+  json_var <- mkJsonOutput output initDepJson

+  pure DependencyWriter

+    { dw_beginWriter =

+        pure $ DepSink $ \ node deps ->

+          updateJson json_var (updateDepJson (depIncludePkgDeps dflags) node deps)

+    , dw_endWriter =

+        writeJsonOutput json_var

+    }

+

+--------------------------------------------------------------------------------

+-- 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 DPackageId = DPackageId PackageId

+  deriving newtype (Eq)

+

+instance Ord DPackageId where

+  DPackageId (PackageId d1) `compare` DPackageId (PackageId d2) = d1 `lexicalCompareFS` d2

+

+data ModuleNodeDeps = ModuleNodeDeps

+  { source :: OsPath

+  , imports :: ImportDeps

+  , cpp :: Set.Set OsPath

+  , options :: [String]

+  , preprocessor :: Maybe FilePath

+  }

+  deriving stock (Generic)

+  deriving (Semigroup, Monoid) via (Generically ModuleNodeDeps)

+

+addImport :: ImportDep -> ModuleNodeDeps -> ModuleNodeDeps

+addImport import_dep mod_node_deps =

+  mod_node_deps

+    { imports = ImportDeps $ Map.insertWith Set.union uid (Set.singleton import_dep) (getImports $ imports mod_node_deps)

+    }

+  where

+    uid = toUnitId $ moduleUnit $ imp_mod import_dep

+

+addCpp :: OsPath -> ModuleNodeDeps -> ModuleNodeDeps

+addCpp p mod_node_deps =

+  mod_node_deps

+    { cpp = Set.insert p (cpp mod_node_deps)

+    }

+

+newtype ImportDeps = ImportDeps { getImports :: Map.Map UnitId (Set.Set ImportDep) }

+  deriving stock (Generic)

+  deriving (Semigroup, Monoid) via (Generically ImportDeps)

+

+data ImportDep = ImportDep

+  { imp_mod :: Module

+  , imp_level :: ImportLevel

+  , imp_isBoot :: IsBootInterface

+  } deriving (Eq, Ord)

+

+mkImportDep :: Module -> ImportLevel -> IsBootInterface -> ImportDep

+mkImportDep modl level isBoot = ImportDep

+  { imp_mod = modl

+  , imp_level = level

+  , imp_isBoot = isBoot

+  }

+

+data HomeUnitDeps = HomeUnitDeps

+  { homeModules :: Map.Map ModuleWithIsBoot ModuleNodeDeps

+  }

+  deriving stock (Generic)

+  deriving (Semigroup, Monoid) via (Generically HomeUnitDeps)

+

+data ExtUnitDep = ExtUnitDep

+  { extUnitId :: UnitId

+  -- ^ The 'UnitId' of a unit. This is assumed to be globally unique.

+  , extUnitName :: String

+  , extUnitPackageId :: DPackageId

+  } deriving (Eq, Ord)

+

+data DepJson = DepJson

+  { homeUnitDeps :: Map.Map UnitId HomeUnitDeps

+  , externalDeps :: Set.Set ExtUnitDep

+  }

+

+instance ToJson DepJson where

+  json (DepJson homeUnits extDeps) =

+    JSObject $

+      [ homeUnit huid hud

+      | (huid, hud) <- Map.toList homeUnits

+      ] ++

+      [ mkExtDepObj dep

+      | dep <- Set.toList extDeps

+      ]

+    where

+      homeUnit uid hud =

+        ( unitIdString uid

+        , JSObject

+            [

+              ( "modules"

+              , JSObject

+                  [ (homeUnitModuleKey modl, homeUnitModule deps)

+                  | (modl, deps) <- Map.toList $ homeModules hud

+                  ]

+              )

+            ]

+        )

+

+      homeUnitModuleKey :: ModuleWithIsBoot -> String

+      homeUnitModuleKey t = moduleKey (gwib_mod t) (gwib_isBoot t)

+

+      moduleKey :: Module -> IsBootInterface -> String

+      moduleKey t b = moduleNameString (moduleName t) ++ case b of

+        IsBoot -> "[boot]"

+        NotBoot -> ""

+

+      homeUnitModule :: ModuleNodeDeps -> JsonDoc

+      homeUnitModule ModuleNodeDeps {source, imports, cpp, options, preprocessor} =