-----------------------------------------------------------------------------
--
-- Makefile Dependency Generation
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------

module GHC.Driver.MakeFile
   ( doMkDependHS
   )
where

import GHC.Prelude

import qualified GHC
import GHC.Driver.Make
import GHC.Driver.Monad
import GHC.Driver.DynFlags
import GHC.Utils.Misc
import GHC.Driver.Env
import GHC.Driver.Errors.Types
import qualified GHC.SysTools as SysTools
import GHC.Data.Graph.Directed ( SCC(..) )
import GHC.Data.OsPath (unsafeDecodeUtf)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.PkgQual
import Data.List (partition)
import GHC.Utils.TmpFs

import GHC.Iface.Load (cannotFindModule)

import GHC.Unit.Module
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Finder

import GHC.Utils.Exception
import GHC.Utils.Error
import GHC.Utils.Logger

import System.Directory
import System.FilePath
import System.IO
import System.IO.Error  ( isEOFError )
import Control.Monad    ( when, forM_ )
import Data.Maybe       ( isJust )
import Data.IORef
import qualified Data.Set as Set
import GHC.Iface.Errors.Types

-----------------------------------------------------------------
--
--              The main function
--
-----------------------------------------------------------------

doMkDependHS :: GhcMonad m => [FilePath] -> m ()
doMkDependHS :: forall (m :: * -> *). GhcMonad m => [String] -> m ()
doMkDependHS [String]
srcs = do
    logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger

    -- Initialisation
    dflags0 <- GHC.getSessionDynFlags

    -- We kludge things a bit for dependency generation. Rather than
    -- generating dependencies for each way separately, we generate
    -- them once and then duplicate them for each way's osuf/hisuf.
    -- We therefore do the initial dependency generation with an empty
    -- way and .o/.hi extensions, regardless of any flags that might
    -- be specified.
    let dflags1 = DynFlags
dflags0
            { targetWays_ = Set.empty
            , hiSuf_      = "hi"
            , objectSuf_  = "o"
            }
    GHC.setSessionDynFlags dflags1

    -- If no suffix is provided, use the default -- the empty one
    let dflags = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> [String]
depSuffixes DynFlags
dflags1)
                 then DynFlags
dflags1 { depSuffixes = [""] }
                 else DynFlags
dflags1

    tmpfs <- hsc_tmpfs <$> getSession
    files <- liftIO $ beginMkDependHS logger tmpfs dflags

    -- Do the downsweep to find all the modules
    targets <- mapM (\String
s -> String -> Maybe UnitId -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe UnitId -> Maybe Phase -> m Target
GHC.guessTarget String
s Maybe UnitId
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing) srcs
    GHC.setTargets targets
    let excl_mods = DynFlags -> [ModuleName]
depExcludeMods DynFlags
dflags
    module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}

    -- Sort into dependency order
    -- There should be no cycles
    let sorted = Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
False ModuleGraph
module_graph Maybe HomeUnitModule
forall a. Maybe a
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 excl_mods root (mkd_tmp_hdl files)) sorted

    -- If -ddump-mod-cycles, show cycles in the module graph
    liftIO $ dumpModCycles logger module_graph

    -- 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
    --chance to find out exactly what went wrong.  Uncomment the following
    --line if you disagree.

    --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)

-----------------------------------------------------------------
--
--              beginMkDependHs
--      Create a temporary file,
--      find the Makefile,
--      slurp through it, etc
--
-----------------------------------------------------------------

data MkDepFiles
  = MkDep { MkDepFiles -> String
mkd_make_file :: FilePath,          -- Name of the makefile
            MkDepFiles -> Maybe Handle
mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile
            MkDepFiles -> String
mkd_tmp_file  :: FilePath,          -- Name of the temporary file
            MkDepFiles -> Handle
mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file

beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
beginMkDependHS Logger
logger TmpFs
tmpfs DynFlags
dflags = do
        -- open a new temp file in which to stuff the dependency info
        -- as we go along.
  tmp_file <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule String
"dep"
  tmp_hdl <- openFile tmp_file WriteMode

        -- open the makefile
  let makefile = DynFlags -> String
depMakefile DynFlags
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 <- Handle -> IO String
hGetLine Handle
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 <- Handle -> IO String
hGetLine Handle
makefile_hdl
                if (l == depEndMarker)
                        then return ()
                        else chuck

           catchIO slurp
                (\IOException
e -> if IOException -> Bool
isEOFError IOException
e then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else IOException -> IO ()
forall a. HasCallStack => IOException -> IO a
ioError IOException
e)
           catchIO chuck
                (\IOException
e -> if IOException -> Bool
isEOFError IOException
e then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else IOException -> IO ()
forall a. HasCallStack => IOException -> IO a
ioError IOException
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})


-----------------------------------------------------------------
--
--              processDeps
--
-----------------------------------------------------------------

processDeps :: DynFlags
            -> HscEnv
            -> [ModuleName]
            -> FilePath
            -> Handle           -- Write dependencies to here
            -> 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 :: DynFlags
-> HscEnv
-> [ModuleName]
-> String
-> Handle
-> SCC ModuleGraphNode
-> IO ()
processDeps DynFlags
_ HscEnv
_ [ModuleName]
_ String
_ Handle
_ (CyclicSCC [ModuleGraphNode]
nodes)
  =     -- There shouldn't be any cycles; report them
    MsgEnvelope GhcMessage -> IO ()
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO ())
-> MsgEnvelope GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ [ModuleGraphNode] -> MsgEnvelope GhcMessage
cyclicModuleErr [ModuleGraphNode]
nodes

processDeps DynFlags
_ HscEnv
_ [ModuleName]
_ String
_ Handle
_ (AcyclicSCC (InstantiationNode UnitId
_uid InstantiatedUnit
node))
  =     -- There shouldn't be any backpack instantiations; report them as well
    MsgEnvelope GhcMessage -> IO ()
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO ())
-> MsgEnvelope GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
      DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> DriverMessage
DriverInstantiationNodeInDependencyGeneration InstantiatedUnit
node

processDeps DynFlags
_dflags HscEnv
_ [ModuleName]
_ String
_ Handle
_ (AcyclicSCC (LinkNode {})) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

processDeps DynFlags
dflags HscEnv
hsc_env [ModuleName]
excl_mods String
root Handle
hdl (AcyclicSCC (ModuleNode [NodeKey]
_ ModSummary
node))
  = do  { let extra_suffixes :: [String]
extra_suffixes = DynFlags -> [String]
depSuffixes DynFlags
dflags
              include_pkg_deps :: Bool
include_pkg_deps = DynFlags -> Bool
depIncludePkgDeps DynFlags
dflags
              src_file :: String
src_file  = ModSummary -> String
msHsFilePath ModSummary
node
              obj_file :: String
obj_file  = ModSummary -> String
msObjFilePath ModSummary
node
              obj_files :: [String]
obj_files = String -> [String] -> [String]
insertSuffixes String
obj_file [String]
extra_suffixes

              do_imp :: SrcSpan -> IsBootInterface -> PkgQual -> ModuleName -> IO ()
do_imp SrcSpan
loc IsBootInterface
is_boot PkgQual
pkg_qual ModuleName
imp_mod
                = do { mb_hi <- HscEnv
-> SrcSpan
-> PkgQual
-> ModuleName
-> IsBootInterface
-> Bool
-> IO (Maybe String)
findDependency HscEnv
hsc_env SrcSpan
loc PkgQual
pkg_qual ModuleName
imp_mod
                                               IsBootInterface
is_boot Bool
include_pkg_deps
                     ; case mb_hi of {
                           Maybe String
Nothing      -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () ;
                           Just String
hi_file -> do
                     { let hi_files :: [String]
hi_files = String -> [String] -> [String]
insertSuffixes String
hi_file [String]
extra_suffixes
                           write_dep :: (String, String) -> IO ()
write_dep (String
obj,String
hi) = String -> Handle -> [String] -> String -> IO ()
writeDependency String
root Handle
hdl [String
obj] String
hi

                        -- Add one dependency for each suffix;
                        -- e.g.         A.o   : B.hi
                        --              A.x_o : B.x_hi
                     ; ((String, String) -> IO ()) -> [(String, String)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, String) -> IO ()
write_dep ([String]
obj_files [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [String]
hi_files) }}}


                -- Emit std dependency of the object(s) on the source file
                -- Something like       A.o : A.hs
        ; String -> Handle -> [String] -> String -> IO ()
writeDependency String
root Handle
hdl [String]
obj_files String
src_file

          -- add dependency between objects and their corresponding .hi-boot
          -- files if the module has a corresponding .hs-boot file (#14482)
        ; Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModSummary -> IsBootInterface
isBootSummary ModSummary
node IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let hi_boot :: String
hi_boot = ModSummary -> String
msHiFilePath ModSummary
node
            let obj :: String
obj     = HasCallStack => OsPath -> String
OsPath -> String
unsafeDecodeUtf (OsPath -> String) -> OsPath -> String
forall a b. (a -> b) -> a -> b
$ OsPath -> OsPath
removeBootSuffix (ModSummary -> OsPath
msObjFileOsPath ModSummary
node)
            [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
extra_suffixes ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
suff -> do
               let way_obj :: [String]
way_obj     = String -> [String] -> [String]
insertSuffixes String
obj     [String
suff]
               let way_hi_boot :: [String]
way_hi_boot = String -> [String] -> [String]
insertSuffixes String
hi_boot [String
suff]
               (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Handle -> [String] -> String -> IO ()
writeDependency String
root Handle
hdl [String]
way_obj) [String]
way_hi_boot

                -- Emit a dependency for each CPP import
        ; Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
depIncludeCppDeps DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            -- 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).
          { session <- IORef HscEnv -> Session
Session (IORef HscEnv -> Session) -> IO (IORef HscEnv) -> IO Session
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef HscEnv
hsc_env
          ; parsedMod <- reflectGhc (GHC.parseModule node) session
          ; mapM_ (writeDependency root hdl obj_files)
                  (GHC.pm_extra_src_files parsedMod)
          }

                -- Emit a dependency for each import

        ; let do_imps :: IsBootInterface
-> [(PkgQual, GenLocated SrcSpan ModuleName)] -> IO ()
do_imps IsBootInterface
is_boot [(PkgQual, GenLocated SrcSpan ModuleName)]
idecls = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
                    [ SrcSpan -> IsBootInterface -> PkgQual -> ModuleName -> IO ()
do_imp SrcSpan
loc IsBootInterface
is_boot PkgQual
mb_pkg ModuleName
mod
                    | (PkgQual
mb_pkg, L SrcSpan
loc ModuleName
mod) <- [(PkgQual, GenLocated SrcSpan ModuleName)]
idecls,
                      ModuleName
mod ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
excl_mods ]

        ; IsBootInterface
-> [(PkgQual, GenLocated SrcSpan ModuleName)] -> IO ()
do_imps IsBootInterface
IsBoot (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
node)
        ; IsBootInterface
-> [(PkgQual, GenLocated SrcSpan ModuleName)] -> IO ()
do_imps IsBootInterface
NotBoot (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
node)
        }


findDependency  :: HscEnv
                -> SrcSpan
                -> PkgQual              -- package qualifier, if any
                -> ModuleName           -- Imported module
                -> IsBootInterface      -- Source import
                -> Bool                 -- Record dependency on package modules
                -> IO (Maybe FilePath)  -- Interface file
findDependency :: HscEnv
-> SrcSpan
-> PkgQual
-> ModuleName
-> IsBootInterface
-> Bool
-> IO (Maybe String)
findDependency HscEnv
hsc_env SrcSpan
srcloc PkgQual
pkg ModuleName
imp IsBootInterface
is_boot Bool
include_pkg_deps = do
  -- Find the module; this will be fast because
  -- we've done it once during downsweep
  r <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
imp PkgQual
pkg
  case r of
    Found ModLocation
loc Module
_
        -- Home package: just depend on the .hi or hi-boot file
        | Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (ModLocation -> Maybe String
ml_hs_file ModLocation
loc) Bool -> Bool -> Bool
|| Bool
include_pkg_deps
        -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (HasCallStack => OsPath -> String
OsPath -> String
unsafeDecodeUtf (OsPath -> String) -> OsPath -> String
forall a b. (a -> b) -> a -> b
$ IsBootInterface -> OsPath -> OsPath
addBootSuffix_maybe IsBootInterface
is_boot (ModLocation -> OsPath
ml_hi_file_ospath ModLocation
loc)))

        -- Not in this package: we don't need a dependency
        | Bool
otherwise
        -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

    FindResult
fail ->
        MsgEnvelope GhcMessage -> IO (Maybe String)
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO (Maybe String))
-> MsgEnvelope GhcMessage -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
          SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
srcloc (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
          DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ IfaceMessage -> DriverMessage
DriverInterfaceError (IfaceMessage -> DriverMessage) -> IfaceMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$
             (MissingInterfaceError -> InterfaceLookingFor -> IfaceMessage
Can'tFindInterface (HscEnv -> ModuleName -> FindResult -> MissingInterfaceError
cannotFindModule HscEnv
hsc_env ModuleName
imp FindResult
fail) (ModuleName -> IsBootInterface -> InterfaceLookingFor
LookingForModule ModuleName
imp IsBootInterface
is_boot))

-----------------------------
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
--      t1 t2 : dep
writeDependency :: String -> Handle -> [String] -> String -> IO ()
writeDependency String
root Handle
hdl [String]
targets String
dep
  = do let -- We need to avoid making deps on
           --     c:/foo/...
           -- on cygwin as make gets confused by the :
           -- Making relative deps avoids some instances of this.
           dep' :: String
dep' = String -> String -> String
makeRelative String
root String
dep
           forOutput :: String -> String
forOutput = String -> String
escapeSpaces (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> String -> String
reslash Direction
Forwards (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
normalise
           output :: String
output = [String] -> String
unwords ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forOutput [String]
targets) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forOutput String
dep'
       Handle -> String -> IO ()
hPutStrLn Handle
hdl String
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"]
        -- 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 :: String -> [String] -> [String]
insertSuffixes String
file_name [String]
extras
  = [ String
basename String -> String -> String
<.> (String
extra String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix) | String
extra <- [String]
extras ]
  where
    (String
basename, String
suffix) = case String -> (String, String)
splitExtension String
file_name of
                         -- Drop the "." from the extension
                         (String
b, String
s) -> (String
b, Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
s)


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

endMkDependHS :: Logger -> MkDepFiles -> IO ()

endMkDependHS :: Logger -> MkDepFiles -> IO ()
endMkDependHS Logger
logger
   (MkDep { mkd_make_file :: MkDepFiles -> String
mkd_make_file = String
makefile, mkd_make_hdl :: MkDepFiles -> Maybe Handle
mkd_make_hdl =  Maybe Handle
makefile_hdl,
            mkd_tmp_file :: MkDepFiles -> String
mkd_tmp_file  = String
tmp_file, mkd_tmp_hdl :: MkDepFiles -> Handle
mkd_tmp_hdl  =  Handle
tmp_hdl })
  = do
  -- write the magic marker into the tmp file
  Handle -> String -> IO ()
hPutStrLn Handle
tmp_hdl String
depEndMarker

  case Maybe Handle
makefile_hdl of
     Maybe Handle
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     Just Handle
hdl -> do
        -- slurp the rest of the original makefile and copy it into the output
        Handle -> Handle -> IO ()
SysTools.copyHandle Handle
hdl Handle
tmp_hdl
        Handle -> IO ()
hClose Handle
hdl

  Handle -> IO ()
hClose Handle
tmp_hdl  -- make sure it's flushed

        -- Create a backup of the original makefile
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Handle -> Bool
forall a. Maybe a -> Bool
isJust Maybe Handle
makefile_hdl) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Logger -> String -> IO ()
showPass Logger
logger (String
"Backing up " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
makefile)
    String -> String -> IO ()
SysTools.copyFile String
makefile (String
makefileString -> String -> String
forall a. [a] -> [a] -> [a]
++String
".bak")

        -- Copy the new makefile in place
  Logger -> String -> IO ()
showPass Logger
logger String
"Installing new makefile"
  String -> String -> IO ()
SysTools.copyFile String
tmp_file String
makefile


-----------------------------------------------------------------
--              Module cycles
-----------------------------------------------------------------

dumpModCycles :: Logger -> ModuleGraph -> IO ()
dumpModCycles :: Logger -> ModuleGraph -> IO ()
dumpModCycles Logger
logger ModuleGraph
module_graph
  | Bool -> Bool
not (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_mod_cycles)
  = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  | [[ModuleGraphNode]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ModuleGraphNode]]
cycles
  = Logger -> SDoc -> IO ()
putMsg Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"No module cycles")

  | Bool
otherwise
  = Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Module cycles found:") Int
2 SDoc
pp_cycles)
  where
    topoSort :: [SCC ModuleGraphNode]
topoSort = Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
True ModuleGraph
module_graph Maybe HomeUnitModule
forall a. Maybe a
Nothing

    cycles :: [[ModuleGraphNode]]
    cycles :: [[ModuleGraphNode]]
cycles =
      [ [ModuleGraphNode]
c | CyclicSCC [ModuleGraphNode]
c <- [SCC ModuleGraphNode]
topoSort ]

    pp_cycles :: SDoc
pp_cycles = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"---------- Cycle" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"----------")
                        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [ModuleGraphNode] -> SDoc
pprCycle [ModuleGraphNode]
c SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
blankLine
                     | (Int
n,[ModuleGraphNode]
c) <- [Int
1..] [Int] -> [[ModuleGraphNode]] -> [(Int, [ModuleGraphNode])]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [[ModuleGraphNode]]
cycles ]

pprCycle :: [ModuleGraphNode] -> SDoc
-- Print a cycle, but show only the imports within the cycle
pprCycle :: [ModuleGraphNode] -> SDoc
pprCycle [ModuleGraphNode]
summaries = SCC ModuleGraphNode -> SDoc
pp_group ([ModuleGraphNode] -> SCC ModuleGraphNode
forall vertex. [vertex] -> SCC vertex
CyclicSCC [ModuleGraphNode]
summaries)
  where
    cycle_mods :: [ModuleName]  -- The modules in this cycle
    cycle_mods :: [ModuleName]
cycle_mods = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) [ModSummary
ms | ModuleNode [NodeKey]
_ ModSummary
ms <- [ModuleGraphNode]
summaries]

    pp_group :: SCC ModuleGraphNode -> SDoc
    pp_group :: SCC ModuleGraphNode -> SDoc
pp_group (AcyclicSCC (ModuleNode [NodeKey]
_ ModSummary
ms)) = ModSummary -> SDoc
pp_ms ModSummary
ms
    pp_group (AcyclicSCC ModuleGraphNode
_) = SDoc
forall doc. IsOutput doc => doc
empty
    pp_group (CyclicSCC [ModuleGraphNode]
mss)
        = Bool -> SDoc -> SDoc
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([ModuleGraphNode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleGraphNode]
boot_only)) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                -- The boot-only list must be non-empty, else there would
                -- be an infinite chain of non-boot imports, and we've
                -- already checked for that in processModDeps
          ModSummary -> SDoc
pp_ms ModSummary
loop_breaker SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((SCC ModuleGraphNode -> SDoc) -> [SCC ModuleGraphNode] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SCC ModuleGraphNode -> SDoc
pp_group [SCC ModuleGraphNode]
groups)
        where
          ([ModuleGraphNode]
boot_only, [ModuleGraphNode]
others) = (ModuleGraphNode -> Bool)
-> [ModuleGraphNode] -> ([ModuleGraphNode], [ModuleGraphNode])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ModuleGraphNode -> Bool
is_boot_only [ModuleGraphNode]
mss
          is_boot_only :: ModuleGraphNode -> Bool
is_boot_only (ModuleNode [NodeKey]
_ ModSummary
ms) = Bool -> Bool
not ((GenLocated SrcSpan ModuleName -> Bool)
-> [GenLocated SrcSpan ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated SrcSpan ModuleName -> Bool
in_group (((PkgQual, GenLocated SrcSpan ModuleName)
 -> GenLocated SrcSpan ModuleName)
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [GenLocated SrcSpan ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (PkgQual, GenLocated SrcSpan ModuleName)
-> GenLocated SrcSpan ModuleName
forall a b. (a, b) -> b
snd (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
ms)))
          is_boot_only  ModuleGraphNode
_ = Bool
False
          in_group :: GenLocated SrcSpan ModuleName -> Bool
in_group (L SrcSpan
_ ModuleName
m) = ModuleName
m ModuleName -> [ModuleName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
group_mods
          group_mods :: [ModuleName]
group_mods = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) [ModSummary
ms | ModuleNode [NodeKey]
_ ModSummary
ms <- [ModuleGraphNode]
mss]

          loop_breaker :: ModSummary
loop_breaker = [ModSummary] -> ModSummary
forall a. HasCallStack => [a] -> a
head ([ModSummary
ms | ModuleNode [NodeKey]
_ ModSummary
ms  <- [ModuleGraphNode]
boot_only])
          all_others :: [ModuleGraphNode]
all_others   = [ModuleGraphNode] -> [ModuleGraphNode]
forall a. HasCallStack => [a] -> [a]
tail [ModuleGraphNode]
boot_only [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
others
          groups :: [SCC ModuleGraphNode]
groups =
            Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
True ([ModuleGraphNode] -> ModuleGraph
mkModuleGraph [ModuleGraphNode]
all_others) Maybe HomeUnitModule
forall a. Maybe a
Nothing

    pp_ms :: ModSummary -> SDoc
pp_ms ModSummary
summary = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
mod_str SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (Int -> String -> String
forall a. Int -> [a] -> [a]
take (Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
mod_str) (Char -> String
forall a. a -> [a]
repeat Char
' '))
                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (SDoc -> [GenLocated SrcSpan ModuleName] -> SDoc
pp_imps SDoc
forall doc. IsOutput doc => doc
empty (((PkgQual, GenLocated SrcSpan ModuleName)
 -> GenLocated SrcSpan ModuleName)
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [GenLocated SrcSpan ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (PkgQual, GenLocated SrcSpan ModuleName)
-> GenLocated SrcSpan ModuleName
forall a b. (a, b) -> b
snd (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
summary)) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                            SDoc -> [GenLocated SrcSpan ModuleName] -> SDoc
pp_imps (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"{-# SOURCE #-}") (((PkgQual, GenLocated SrcSpan ModuleName)
 -> GenLocated SrcSpan ModuleName)
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [GenLocated SrcSpan ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (PkgQual, GenLocated SrcSpan ModuleName)
-> GenLocated SrcSpan ModuleName
forall a b. (a, b) -> b
snd (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
summary)))
        where
          mod_str :: String
mod_str = ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
summary))

    pp_imps :: SDoc -> [Located ModuleName] -> SDoc
    pp_imps :: SDoc -> [GenLocated SrcSpan ModuleName] -> SDoc
pp_imps SDoc
_    [] = SDoc
forall doc. IsOutput doc => doc
empty
    pp_imps SDoc
what [GenLocated SrcSpan ModuleName]
lms
        = case [ModuleName
m | L SrcSpan
_ ModuleName
m <- [GenLocated SrcSpan ModuleName]
lms, ModuleName
m ModuleName -> [ModuleName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
cycle_mods] of
            [] -> SDoc
forall doc. IsOutput doc => doc
empty
            [ModuleName]
ms -> SDoc
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"imports" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                                (ModuleName -> SDoc) -> [ModuleName] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
ms

-----------------------------------------------------------------
--
--              Flags
--
-----------------------------------------------------------------

depStartMarker, depEndMarker :: String
depStartMarker :: String
depStartMarker = String
"# DO NOT DELETE: Beginning of Haskell dependencies"
depEndMarker :: String
depEndMarker   = String
"# DO NOT DELETE: End of Haskell dependencies"