{-# LANGUAGE CPP #-}

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

module DriverMkDepend (
        doMkDependHS
  ) where

#include "HsVersions.h"

import GhcPrelude

import qualified GHC
import GhcMonad
import DynFlags
import Util
import HscTypes
import qualified SysTools
import Module
import Digraph          ( SCC(..) )
import Finder
import Outputable
import Panic
import SrcLoc
import Data.List
import FastString
import FileCleanup

import Exception
import ErrUtils

import System.Directory
import System.FilePath
import System.IO
import System.IO.Error  ( isEOFError )
import Control.Monad    ( when )
import Data.Maybe       ( isJust )

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

doMkDependHS :: GhcMonad m => [FilePath] -> m ()
doMkDependHS :: [FilePath] -> m ()
doMkDependHS srcs :: [FilePath]
srcs = do
    -- Initialisation
    DynFlags
dflags0 <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
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 dflags :: DynFlags
dflags = DynFlags
dflags0 {
                     ways :: [Way]
ways = [],
                     buildTag :: FilePath
buildTag = [Way] -> FilePath
mkBuildTag [],
                     hiSuf :: FilePath
hiSuf = "hi",
                     objectSuf :: FilePath
objectSuf = "o"
                 }
    [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> [FilePath]
depSuffixes DynFlags
dflags)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError "You must specify at least one -dep-suffix")

    MkDepFiles
files <- IO MkDepFiles -> m MkDepFiles
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MkDepFiles -> m MkDepFiles) -> IO MkDepFiles -> m MkDepFiles
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO MkDepFiles
beginMkDependHS DynFlags
dflags

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

    -- Sort into dependency order
    -- There should be no cycles
    let sorted :: [SCC ModSummary]
sorted = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
GHC.topSortModuleGraph Bool
False ModuleGraph
module_graph Maybe ModuleName
forall a. Maybe a
Nothing

    -- Print out the dependencies if wanted
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 (FilePath -> MsgDoc
text "Module dependencies" MsgDoc -> MsgDoc -> MsgDoc
$$ [SCC ModSummary] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [SCC ModSummary]
sorted)

    -- Prcess them one by one, dumping results into makefile
    -- and complaining about cycles
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    FilePath
root <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getCurrentDirectory
    (SCC ModSummary -> m ()) -> [SCC ModSummary] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (SCC ModSummary -> IO ()) -> SCC ModSummary -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> HscEnv
-> [ModuleName]
-> FilePath
-> Handle
-> SCC ModSummary
-> IO ()
processDeps DynFlags
dflags HscEnv
hsc_env [ModuleName]
excl_mods FilePath
root (MkDepFiles -> Handle
mkd_tmp_hdl MkDepFiles
files)) [SCC ModSummary]
sorted

    -- If -ddump-mod-cycles, show cycles in the module graph
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleGraph -> IO ()
dumpModCycles DynFlags
dflags ModuleGraph
module_graph

    -- Tidy up
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> MkDepFiles -> IO ()
endMkDependHS DynFlags
dflags MkDepFiles
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 -> FilePath
mkd_make_file :: FilePath,          -- Name of the makefile
            MkDepFiles -> Maybe Handle
mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile
            MkDepFiles -> FilePath
mkd_tmp_file  :: FilePath,          -- Name of the temporary file
            MkDepFiles -> Handle
mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file

beginMkDependHS :: DynFlags -> IO MkDepFiles
beginMkDependHS :: DynFlags -> IO MkDepFiles
beginMkDependHS dflags :: DynFlags
dflags = do
        -- open a new temp file in which to stuff the dependency info
        -- as we go along.
  FilePath
tmp_file <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule "dep"
  Handle
tmp_hdl <- FilePath -> IOMode -> IO Handle
openFile FilePath
tmp_file IOMode
WriteMode

        -- open the makefile
  let makefile :: FilePath
makefile = DynFlags -> FilePath
depMakefile DynFlags
dflags
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
makefile
  Maybe Handle
mb_make_hdl <-
        if Bool -> Bool
not Bool
exists
        then Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
        else do
           Handle
makefile_hdl <- FilePath -> IOMode -> IO Handle
openFile FilePath
makefile IOMode
ReadMode

                -- slurp through until we get the magic start string,
                -- copying the contents into dep_makefile
           let slurp :: IO ()
slurp = do
                FilePath
l <- Handle -> IO FilePath
hGetLine Handle
makefile_hdl
                if (FilePath
l FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
depStartMarker)
                        then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        else do Handle -> FilePath -> IO ()
hPutStrLn Handle
tmp_hdl FilePath
l; IO ()
slurp

                -- slurp through until we get the magic end marker,
                -- throwing away the contents
           let chuck :: IO ()
chuck = do
                FilePath
l <- Handle -> IO FilePath
hGetLine Handle
makefile_hdl
                if (FilePath
l FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
depEndMarker)
                        then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        else IO ()
chuck

           IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO ()
slurp
                (\e :: IOException
e -> if IOException -> Bool
isEOFError IOException
e then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e)
           IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO ()
chuck
                (\e :: IOException
e -> if IOException -> Bool
isEOFError IOException
e then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e)

           Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
makefile_hdl)


        -- write the magic marker into the tmp file
  Handle -> FilePath -> IO ()
hPutStrLn Handle
tmp_hdl FilePath
depStartMarker

  MkDepFiles -> IO MkDepFiles
forall (m :: * -> *) a. Monad m => a -> m a
return (MkDep :: FilePath -> Maybe Handle -> FilePath -> Handle -> MkDepFiles
MkDep { mkd_make_file :: FilePath
mkd_make_file = FilePath
makefile, mkd_make_hdl :: Maybe Handle
mkd_make_hdl = Maybe Handle
mb_make_hdl,
                  mkd_tmp_file :: FilePath
mkd_tmp_file  = FilePath
tmp_file, mkd_tmp_hdl :: Handle
mkd_tmp_hdl  = Handle
tmp_hdl})


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

processDeps :: DynFlags
            -> HscEnv
            -> [ModuleName]
            -> FilePath
            -> Handle           -- Write dependencies to here
            -> SCC ModSummary
            -> 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]
-> FilePath
-> Handle
-> SCC ModSummary
-> IO ()
processDeps dflags :: DynFlags
dflags _ _ _ _ (CyclicSCC nodes :: [ModSummary]
nodes)
  =     -- There shouldn't be any cycles; report them
    GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError (DynFlags -> MsgDoc -> FilePath
showSDoc DynFlags
dflags (MsgDoc -> FilePath) -> MsgDoc -> FilePath
forall a b. (a -> b) -> a -> b
$ [ModSummary] -> MsgDoc
GHC.cyclicModuleErr [ModSummary]
nodes))

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

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

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


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

                -- Emit a dependency for each import

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

        ; Bool
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)] -> IO ()
do_imps Bool
True  (ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
node)
        ; Bool
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)] -> IO ()
do_imps Bool
False (ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
node)
        }


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

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

            fail :: FindResult
fail ->
                let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
                in ErrMsg -> IO (Maybe FilePath)
forall (m :: * -> *) ab. MonadIO m => ErrMsg -> m ab
throwOneError (ErrMsg -> IO (Maybe FilePath)) -> ErrMsg -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
srcloc (MsgDoc -> ErrMsg) -> MsgDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                        DynFlags -> ModuleName -> FindResult -> MsgDoc
cannotFindModule DynFlags
dflags ModuleName
imp FindResult
fail
        }

-----------------------------
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
--      t1 t2 : dep
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
writeDependency root :: FilePath
root hdl :: Handle
hdl targets :: [FilePath]
targets dep :: FilePath
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' :: FilePath
dep' = FilePath -> FilePath -> FilePath
makeRelative FilePath
root FilePath
dep
           forOutput :: FilePath -> FilePath
forOutput = FilePath -> FilePath
escapeSpaces (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> FilePath -> FilePath
reslash Direction
Forwards (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
normalise
           output :: FilePath
output = [FilePath] -> FilePath
unwords ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
forOutput [FilePath]
targets) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " : " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forOutput FilePath
dep'
       Handle -> FilePath -> IO ()
hPutStrLn Handle
hdl FilePath
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 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 :: FilePath -> [FilePath] -> [FilePath]
insertSuffixes file_name :: FilePath
file_name extras :: [FilePath]
extras
  = [ FilePath
basename FilePath -> FilePath -> FilePath
<.> (FilePath
extra FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
suffix) | FilePath
extra <- [FilePath]
extras ]
  where
    (basename :: FilePath
basename, suffix :: FilePath
suffix) = case FilePath -> (FilePath, FilePath)
splitExtension FilePath
file_name of
                         -- Drop the "." from the extension
                         (b :: FilePath
b, s :: FilePath
s) -> (FilePath
b, Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 1 FilePath
s)


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

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

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

  case Maybe Handle
makefile_hdl of
     Nothing  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     Just hdl :: Handle
hdl -> do

          -- slurp the rest of the original makefile and copy it into the output
        let slurp :: IO b
slurp = do
                FilePath
l <- Handle -> IO FilePath
hGetLine Handle
hdl
                Handle -> FilePath -> IO ()
hPutStrLn Handle
tmp_hdl FilePath
l
                IO b
slurp

        IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO ()
forall b. IO b
slurp
                (\e :: IOException
e -> if IOException -> Bool
isEOFError IOException
e then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e)

        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)
       (DynFlags -> FilePath -> FilePath -> FilePath -> IO ()
SysTools.copy DynFlags
dflags ("Backing up " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
makefile)
          FilePath
makefile (FilePath
makefileFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++".bak"))

        -- Copy the new makefile in place
  DynFlags -> FilePath -> FilePath -> FilePath -> IO ()
SysTools.copy DynFlags
dflags "Installing new makefile" FilePath
tmp_file FilePath
makefile


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

dumpModCycles :: DynFlags -> ModuleGraph -> IO ()
dumpModCycles :: DynFlags -> ModuleGraph -> IO ()
dumpModCycles dflags :: DynFlags
dflags module_graph :: ModuleGraph
module_graph
  | Bool -> Bool
not (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_mod_cycles DynFlags
dflags)
  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  | [[ModSummary]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ModSummary]]
cycles
  = DynFlags -> MsgDoc -> IO ()
putMsg DynFlags
dflags (FilePath -> MsgDoc
text "No module cycles")

  | Bool
otherwise
  = DynFlags -> MsgDoc -> IO ()
putMsg DynFlags
dflags (MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (FilePath -> MsgDoc
text "Module cycles found:") 2 MsgDoc
pp_cycles)
  where

    cycles :: [[ModSummary]]
    cycles :: [[ModSummary]]
cycles =
      [ [ModSummary]
c | CyclicSCC c :: [ModSummary]
c <- Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
GHC.topSortModuleGraph Bool
True ModuleGraph
module_graph Maybe ModuleName
forall a. Maybe a
Nothing ]

    pp_cycles :: MsgDoc
pp_cycles = [MsgDoc] -> MsgDoc
vcat [ (FilePath -> MsgDoc
text "---------- Cycle" MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> MsgDoc
int Int
n MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (FilePath -> PtrString
sLit "----------"))
                        MsgDoc -> MsgDoc -> MsgDoc
$$ [ModSummary] -> MsgDoc
pprCycle [ModSummary]
c MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
blankLine
                     | (n :: Int
n,c :: [ModSummary]
c) <- [1..] [Int] -> [[ModSummary]] -> [(Int, [ModSummary])]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [[ModSummary]]
cycles ]

pprCycle :: [ModSummary] -> SDoc
-- Print a cycle, but show only the imports within the cycle
pprCycle :: [ModSummary] -> MsgDoc
pprCycle summaries :: [ModSummary]
summaries = SCC ModSummary -> MsgDoc
pp_group ([ModSummary] -> SCC ModSummary
forall vertex. [vertex] -> SCC vertex
CyclicSCC [ModSummary]
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
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) [ModSummary]
summaries

    pp_group :: SCC ModSummary -> MsgDoc
pp_group (AcyclicSCC ms :: ModSummary
ms) = ModSummary -> MsgDoc
pp_ms ModSummary
ms
    pp_group (CyclicSCC mss :: [ModSummary]
mss)
        = ASSERT( not (null boot_only) )
                -- The boot-only list must be non-empty, else there would
                -- be an infinite chain of non-boot imoprts, and we've
                -- already checked for that in processModDeps
          ModSummary -> MsgDoc
pp_ms ModSummary
loop_breaker MsgDoc -> MsgDoc -> MsgDoc
$$ [MsgDoc] -> MsgDoc
vcat ((SCC ModSummary -> MsgDoc) -> [SCC ModSummary] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map SCC ModSummary -> MsgDoc
pp_group [SCC ModSummary]
groups)
        where
          (boot_only :: [ModSummary]
boot_only, others :: [ModSummary]
others) = (ModSummary -> Bool)
-> [ModSummary] -> ([ModSummary], [ModSummary])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ModSummary -> Bool
is_boot_only [ModSummary]
mss
          is_boot_only :: ModSummary -> Bool
is_boot_only ms :: 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
forall l. GenLocated l ModuleName -> Bool
in_group (((Maybe FastString, GenLocated SrcSpan ModuleName)
 -> GenLocated SrcSpan ModuleName)
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [GenLocated SrcSpan ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FastString, GenLocated SrcSpan ModuleName)
-> GenLocated SrcSpan ModuleName
forall a b. (a, b) -> b
snd (ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
ms)))
          in_group :: GenLocated l ModuleName -> Bool
in_group (L _ m :: ModuleName
m) = ModuleName
m ModuleName -> [ModuleName] -> 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
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) [ModSummary]
mss

          loop_breaker :: ModSummary
loop_breaker = [ModSummary] -> ModSummary
forall a. [a] -> a
head [ModSummary]
boot_only
          all_others :: [ModSummary]
all_others   = [ModSummary] -> [ModSummary]
forall a. [a] -> [a]
tail [ModSummary]
boot_only [ModSummary] -> [ModSummary] -> [ModSummary]
forall a. [a] -> [a] -> [a]
++ [ModSummary]
others
          groups :: [SCC ModSummary]
groups =
            Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
GHC.topSortModuleGraph Bool
True ([ModSummary] -> ModuleGraph
mkModuleGraph [ModSummary]
all_others) Maybe ModuleName
forall a. Maybe a
Nothing

    pp_ms :: ModSummary -> MsgDoc
pp_ms summary :: ModSummary
summary = FilePath -> MsgDoc
text FilePath
mod_str MsgDoc -> MsgDoc -> MsgDoc
<> FilePath -> MsgDoc
text (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take (20 Int -> Int -> Int
forall a. Num a => a -> a -> a
- FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
mod_str) (Char -> FilePath
forall a. a -> [a]
repeat ' '))
                       MsgDoc -> MsgDoc -> MsgDoc
<+> (MsgDoc -> [GenLocated SrcSpan ModuleName] -> MsgDoc
pp_imps MsgDoc
empty (((Maybe FastString, GenLocated SrcSpan ModuleName)
 -> GenLocated SrcSpan ModuleName)
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [GenLocated SrcSpan ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FastString, GenLocated SrcSpan ModuleName)
-> GenLocated SrcSpan ModuleName
forall a b. (a, b) -> b
snd (ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
summary)) MsgDoc -> MsgDoc -> MsgDoc
$$
                            MsgDoc -> [GenLocated SrcSpan ModuleName] -> MsgDoc
pp_imps (FilePath -> MsgDoc
text "{-# SOURCE #-}") (((Maybe FastString, GenLocated SrcSpan ModuleName)
 -> GenLocated SrcSpan ModuleName)
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [GenLocated SrcSpan ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FastString, GenLocated SrcSpan ModuleName)
-> GenLocated SrcSpan ModuleName
forall a b. (a, b) -> b
snd (ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
summary)))
        where
          mod_str :: FilePath
mod_str = ModuleName -> FilePath
moduleNameString (Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
summary))

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

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

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