module GHC.Driver.MakeFile
( doMkDependHS
)
where
import GHC.Prelude
import qualified GHC
import GHC.Driver.Monad
import GHC.Driver.Session
import GHC.Driver.Ppr
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.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
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
doMkDependHS :: GhcMonad m => [FilePath] -> m ()
doMkDependHS :: forall (m :: * -> *). GhcMonad m => [String] -> m ()
doMkDependHS [String]
srcs = do
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
DynFlags
dflags0 <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
let dflags1 :: DynFlags
dflags1 = DynFlags
dflags0
{ targetWays_ :: Ways
targetWays_ = forall a. Set a
Set.empty
, hiSuf_ :: String
hiSuf_ = String
"hi"
, objectSuf_ :: String
objectSuf_ = String
"o"
}
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags1
let dflags :: DynFlags
dflags = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> [String]
depSuffixes DynFlags
dflags1)
then DynFlags
dflags1 { depSuffixes :: [String]
depSuffixes = [String
""] }
else DynFlags
dflags1
TmpFs
tmpfs <- HscEnv -> TmpFs
hsc_tmpfs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
MkDepFiles
files <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO MkDepFiles
beginMkDependHS Logger
logger TmpFs
tmpfs DynFlags
dflags
[Target]
targets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
s -> forall (m :: * -> *).
GhcMonad m =>
String -> Maybe UnitId -> Maybe Phase -> m Target
GHC.guessTarget String
s forall a. Maybe a
Nothing forall a. Maybe a
Nothing) [String]
srcs
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
targets
let excl_mods :: [ModuleName]
excl_mods = DynFlags -> [ModuleName]
depExcludeMods DynFlags
dflags
ModuleGraph
module_graph <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
GHC.depanal [ModuleName]
excl_mods Bool
True
let sorted :: [SCC ModuleGraphNode]
sorted = Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
False ModuleGraph
module_graph forall a. Maybe a
Nothing
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (String -> SDoc
text String
"Module dependencies" SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [SCC ModuleGraphNode]
sorted)
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
String
root <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> HscEnv
-> [ModuleName]
-> String
-> Handle
-> SCC ModuleGraphNode
-> IO ()
processDeps DynFlags
dflags HscEnv
hsc_env [ModuleName]
excl_mods String
root (MkDepFiles -> Handle
mkd_tmp_hdl MkDepFiles
files)) [SCC ModuleGraphNode]
sorted
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> ModuleGraph -> IO ()
dumpModCycles Logger
logger ModuleGraph
module_graph
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> MkDepFiles -> IO ()
endMkDependHS Logger
logger MkDepFiles
files
data MkDepFiles
= MkDep { MkDepFiles -> String
mkd_make_file :: FilePath,
MkDepFiles -> Maybe Handle
mkd_make_hdl :: Maybe Handle,
MkDepFiles -> String
mkd_tmp_file :: FilePath,
MkDepFiles -> Handle
mkd_tmp_hdl :: Handle }
beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
beginMkDependHS Logger
logger TmpFs
tmpfs DynFlags
dflags = do
String
tmp_file <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule String
"dep"
Handle
tmp_hdl <- String -> IOMode -> IO Handle
openFile String
tmp_file IOMode
WriteMode
let makefile :: String
makefile = DynFlags -> String
depMakefile DynFlags
dflags
Bool
exists <- String -> IO Bool
doesFileExist String
makefile
Maybe Handle
mb_make_hdl <-
if Bool -> Bool
not Bool
exists
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else do
Handle
makefile_hdl <- String -> IOMode -> IO Handle
openFile String
makefile IOMode
ReadMode
let slurp :: IO ()
slurp = do
String
l <- Handle -> IO String
hGetLine Handle
makefile_hdl
if (String
l forall a. Eq a => a -> a -> Bool
== String
depStartMarker)
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do Handle -> String -> IO ()
hPutStrLn Handle
tmp_hdl String
l; IO ()
slurp
let chuck :: IO ()
chuck = do
String
l <- Handle -> IO String
hGetLine Handle
makefile_hdl
if (String
l forall a. Eq a => a -> a -> Bool
== String
depEndMarker)
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else IO ()
chuck
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO ()
slurp
(\IOException
e -> if IOException -> Bool
isEOFError IOException
e then forall (m :: * -> *) a. Monad m => a -> m a
return () else forall a. IOException -> IO a
ioError IOException
e)
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO ()
chuck
(\IOException
e -> if IOException -> Bool
isEOFError IOException
e then forall (m :: * -> *) a. Monad m => a -> m a
return () else forall a. IOException -> IO a
ioError IOException
e)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Handle
makefile_hdl)
Handle -> String -> IO ()
hPutStrLn Handle
tmp_hdl String
depStartMarker
forall (m :: * -> *) a. Monad m => a -> m a
return (MkDep { mkd_make_file :: String
mkd_make_file = String
makefile, mkd_make_hdl :: Maybe Handle
mkd_make_hdl = Maybe Handle
mb_make_hdl,
mkd_tmp_file :: String
mkd_tmp_file = String
tmp_file, mkd_tmp_hdl :: Handle
mkd_tmp_hdl = Handle
tmp_hdl})
processDeps :: DynFlags
-> HscEnv
-> [ModuleName]
-> FilePath
-> Handle
-> SCC ModuleGraphNode
-> IO ()
processDeps :: DynFlags
-> HscEnv
-> [ModuleName]
-> String
-> Handle
-> SCC ModuleGraphNode
-> IO ()
processDeps DynFlags
dflags HscEnv
_ [ModuleName]
_ String
_ Handle
_ (CyclicSCC [ModuleGraphNode]
nodes)
=
forall a. GhcException -> IO a
throwGhcExceptionIO forall a b. (a -> b) -> a -> b
$ String -> GhcException
ProgramError forall a b. (a -> b) -> a -> b
$
DynFlags -> SDoc -> String
showSDoc DynFlags
dflags forall a b. (a -> b) -> a -> b
$ [ModuleGraphNode] -> SDoc
GHC.cyclicModuleErr [ModuleGraphNode]
nodes
processDeps DynFlags
dflags HscEnv
_ [ModuleName]
_ String
_ Handle
_ (AcyclicSCC (InstantiationNode UnitId
_uid InstantiatedUnit
node))
=
forall a. GhcException -> IO a
throwGhcExceptionIO forall a b. (a -> b) -> a -> b
$ String -> GhcException
ProgramError forall a b. (a -> b) -> a -> b
$
DynFlags -> SDoc -> String
showSDoc DynFlags
dflags forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unexpected backpack instantiation in dependency graph while constructing Makefile:"
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
node ]
processDeps DynFlags
_dflags HscEnv
_ [ModuleName]
_ String
_ Handle
_ (AcyclicSCC (LinkNode {})) = 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 { Maybe String
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 Maybe String
mb_hi of {
Maybe String
Nothing -> 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
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, String) -> IO ()
write_dep ([String]
obj_files forall a b. [a] -> [b] -> [(a, b)]
`zip` [String]
hi_files) }}}
; String -> Handle -> [String] -> String -> IO ()
writeDependency String
root Handle
hdl [String]
obj_files String
src_file
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModSummary -> IsBootInterface
isBootSummary ModSummary
node forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) forall a b. (a -> b) -> a -> b
$ do
let hi_boot :: String
hi_boot = ModSummary -> String
msHiFilePath ModSummary
node
let obj :: String
obj = String -> String
removeBootSuffix (ModSummary -> String
msObjFilePath ModSummary
node)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
extra_suffixes 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]
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
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
depIncludeCppDeps DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ do
{ Session
session <- IORef HscEnv -> Session
Session forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef HscEnv
hsc_env
; ParsedModule
parsedMod <- forall a. Ghc a -> Session -> IO a
reflectGhc (forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
GHC.parseModule ModSummary
node) Session
session
; 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]
obj_files)
(ParsedModule -> [String]
GHC.pm_extra_src_files ParsedModule
parsedMod)
}
; let do_imps :: IsBootInterface
-> [(PkgQual, GenLocated SrcSpan ModuleName)] -> IO ()
do_imps IsBootInterface
is_boot [(PkgQual, GenLocated SrcSpan ModuleName)]
idecls = 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 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
-> ModuleName
-> IsBootInterface
-> Bool
-> IO (Maybe FilePath)
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
FindResult
r <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
imp PkgQual
pkg
case FindResult
r of
Found ModLocation
loc Module
_
| forall a. Maybe a -> Bool
isJust (ModLocation -> Maybe String
ml_hs_file ModLocation
loc) Bool -> Bool -> Bool
|| Bool
include_pkg_deps
-> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (IsBootInterface -> String -> String
addBootSuffix_maybe IsBootInterface
is_boot (ModLocation -> String
ml_hi_file ModLocation
loc)))
| Bool
otherwise
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
FindResult
fail ->
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
srcloc forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
imp FindResult
fail
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
writeDependency :: String -> Handle -> [String] -> String -> IO ()
writeDependency String
root Handle
hdl [String]
targets String
dep
= do let
dep' :: String
dep' = String -> String -> String
makeRelative String
root String
dep
forOutput :: String -> String
forOutput = String -> String
escapeSpaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> String -> String
reslash Direction
Forwards forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
normalise
output :: String
output = [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map String -> String
forOutput [String]
targets) forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ String -> String
forOutput String
dep'
Handle -> String -> IO ()
hPutStrLn Handle
hdl String
output
insertSuffixes
:: FilePath
-> [String]
-> [FilePath]
insertSuffixes :: String -> [String] -> [String]
insertSuffixes String
file_name [String]
extras
= [ String
basename String -> String -> String
<.> (String
extra 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
(String
b, String
s) -> (String
b, forall a. Int -> [a] -> [a]
drop Int
1 String
s)
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
Handle -> String -> IO ()
hPutStrLn Handle
tmp_hdl String
depEndMarker
case Maybe Handle
makefile_hdl of
Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Handle
hdl -> do
Handle -> Handle -> IO ()
SysTools.copyHandle Handle
hdl Handle
tmp_hdl
Handle -> IO ()
hClose Handle
hdl
Handle -> IO ()
hClose Handle
tmp_hdl
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe Handle
makefile_hdl) forall a b. (a -> b) -> a -> b
$ do
Logger -> String -> IO ()
showPass Logger
logger (String
"Backing up " forall a. [a] -> [a] -> [a]
++ String
makefile)
String -> String -> IO ()
SysTools.copyFile String
makefile (String
makefileforall a. [a] -> [a] -> [a]
++String
".bak")
Logger -> String -> IO ()
showPass Logger
logger String
"Installing new makefile"
String -> String -> IO ()
SysTools.copyFile String
tmp_file String
makefile
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)
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ModuleGraphNode]]
cycles
= Logger -> SDoc -> IO ()
putMsg Logger
logger (String -> SDoc
text String
"No module cycles")
| Bool
otherwise
= Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
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 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
vcat [ (String -> SDoc
text String
"---------- Cycle" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"----------")
SDoc -> SDoc -> SDoc
$$ [ModuleGraphNode] -> SDoc
pprCycle [ModuleGraphNode]
c SDoc -> SDoc -> SDoc
$$ SDoc
blankLine
| (Int
n,[ModuleGraphNode]
c) <- [Int
1..] forall a b. [a] -> [b] -> [(a, b)]
`zip` [[ModuleGraphNode]]
cycles ]
pprCycle :: [ModuleGraphNode] -> SDoc
pprCycle :: [ModuleGraphNode] -> SDoc
pprCycle [ModuleGraphNode]
summaries = SCC ModuleGraphNode -> SDoc
pp_group (forall vertex. [vertex] -> SCC vertex
CyclicSCC [ModuleGraphNode]
summaries)
where
cycle_mods :: [ModuleName]
cycle_mods :: [ModuleName]
cycle_mods = forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
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
empty
pp_group (CyclicSCC [ModuleGraphNode]
mss)
= forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleGraphNode]
boot_only)) forall a b. (a -> b) -> a -> b
$
ModSummary -> SDoc
pp_ms ModSummary
loop_breaker SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map SCC ModuleGraphNode -> SDoc
pp_group [SCC ModuleGraphNode]
groups)
where
([ModuleGraphNode]
boot_only, [ModuleGraphNode]
others) = 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 (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated SrcSpan ModuleName -> Bool
in_group (forall a b. (a -> b) -> [a] -> [b]
map 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
group_mods
group_mods :: [ModuleName]
group_mods = forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
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 = forall a. [a] -> a
head ([ModSummary
ms | ModuleNode [NodeKey]
_ ModSummary
ms <- [ModuleGraphNode]
boot_only])
all_others :: [ModuleGraphNode]
all_others = forall a. [a] -> [a]
tail [ModuleGraphNode]
boot_only 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) forall a. Maybe a
Nothing
pp_ms :: ModSummary -> SDoc
pp_ms ModSummary
summary = String -> SDoc
text String
mod_str SDoc -> SDoc -> SDoc
<> String -> SDoc
text (forall a. Int -> [a] -> [a]
take (Int
20 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
mod_str) (forall a. a -> [a]
repeat Char
' '))
SDoc -> SDoc -> SDoc
<+> (SDoc -> [GenLocated SrcSpan ModuleName] -> SDoc
pp_imps SDoc
empty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
summary)) SDoc -> SDoc -> SDoc
$$
SDoc -> [GenLocated SrcSpan ModuleName] -> SDoc
pp_imps (String -> SDoc
text String
"{-# SOURCE #-}") (forall a b. (a -> b) -> [a] -> [b]
map 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 (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
empty
pp_imps SDoc
what [GenLocated SrcSpan ModuleName]
lms
= case [ModuleName
m | L SrcSpan
_ ModuleName
m <- [GenLocated SrcSpan ModuleName]
lms, ModuleName
m forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
cycle_mods] of
[] -> SDoc
empty
[ModuleName]
ms -> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"imports" SDoc -> SDoc -> SDoc
<+>
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr [ModuleName]
ms
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"