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 Data.List (partition)
import GHC.Data.FastString
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 :: [FilePath] -> m ()
doMkDependHS [FilePath]
srcs = do
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
DynFlags
dflags0 <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
let dflags :: DynFlags
dflags = DynFlags
dflags0
{ targetWays_ :: Ways
targetWays_ = Ways
forall a. Set a
Set.empty
, hiSuf_ :: FilePath
hiSuf_ = FilePath
"hi"
, objectSuf_ :: FilePath
objectSuf_ = FilePath
"o"
}
DynFlags -> m ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
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 FilePath
"You must specify at least one -dep-suffix")
TmpFs
tmpfs <- HscEnv -> TmpFs
hsc_tmpfs (HscEnv -> TmpFs) -> m HscEnv -> m TmpFs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
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
$ Logger -> TmpFs -> DynFlags -> IO MkDepFiles
beginMkDependHS Logger
logger TmpFs
tmpfs DynFlags
dflags
[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 (\FilePath
s -> FilePath -> Maybe UnitId -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe UnitId -> Maybe Phase -> m Target
GHC.guessTarget FilePath
s Maybe UnitId
forall a. Maybe a
Nothing 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
let sorted :: [SCC ModuleGraphNode]
sorted = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
False ModuleGraph
module_graph Maybe ModuleName
forall a. Maybe a
Nothing
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Module dependencies" SDoc -> SDoc -> SDoc
$$ [SCC ModuleGraphNode] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SCC ModuleGraphNode]
sorted)
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 ModuleGraphNode -> m ()) -> [SCC ModuleGraphNode] -> 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 ModuleGraphNode -> IO ()) -> SCC ModuleGraphNode -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> HscEnv
-> [ModuleName]
-> FilePath
-> Handle
-> SCC ModuleGraphNode
-> IO ()
processDeps DynFlags
dflags HscEnv
hsc_env [ModuleName]
excl_mods FilePath
root (MkDepFiles -> Handle
mkd_tmp_hdl MkDepFiles
files)) [SCC ModuleGraphNode]
sorted
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> ModuleGraph -> IO ()
dumpModCycles Logger
logger DynFlags
dflags ModuleGraph
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
$ Logger -> DynFlags -> MkDepFiles -> IO ()
endMkDependHS Logger
logger DynFlags
dflags MkDepFiles
files
data MkDepFiles
= MkDep { MkDepFiles -> FilePath
mkd_make_file :: FilePath,
MkDepFiles -> Maybe Handle
mkd_make_hdl :: Maybe Handle,
MkDepFiles -> FilePath
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
FilePath
tmp_file <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
"dep"
Handle
tmp_hdl <- FilePath -> IOMode -> IO Handle
openFile FilePath
tmp_file IOMode
WriteMode
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
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
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
(\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
(\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)
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 :: DynFlags
-> HscEnv
-> [ModuleName]
-> FilePath
-> Handle
-> SCC ModuleGraphNode
-> IO ()
processDeps :: DynFlags
-> HscEnv
-> [ModuleName]
-> FilePath
-> Handle
-> SCC ModuleGraphNode
-> IO ()
processDeps DynFlags
dflags HscEnv
_ [ModuleName]
_ FilePath
_ Handle
_ (CyclicSCC [ModuleGraphNode]
nodes)
=
GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
ProgramError (FilePath -> GhcException) -> FilePath -> GhcException
forall a b. (a -> b) -> a -> b
$
DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$ [ModuleGraphNode] -> SDoc
GHC.cyclicModuleErr [ModuleGraphNode]
nodes
processDeps DynFlags
dflags HscEnv
_ [ModuleName]
_ FilePath
_ Handle
_ (AcyclicSCC (InstantiationNode InstantiatedUnit
node))
=
GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
ProgramError (FilePath -> GhcException) -> FilePath -> GhcException
forall a b. (a -> b) -> a -> b
$
DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ FilePath -> SDoc
text FilePath
"Unexpected backpack instantiation in dependency graph while constructing Makefile:"
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
node ]
processDeps DynFlags
dflags HscEnv
hsc_env [ModuleName]
excl_mods FilePath
root Handle
hdl (AcyclicSCC (ModuleNode (ExtendedModSummary ModSummary
node [InstantiatedUnit]
_)))
= 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
-> IsBootInterface -> Maybe FastString -> ModuleName -> IO ()
do_imp SrcSpan
loc IsBootInterface
is_boot Maybe FastString
pkg_qual ModuleName
imp_mod
= do { Maybe FilePath
mb_hi <- HscEnv
-> SrcSpan
-> Maybe FastString
-> ModuleName
-> IsBootInterface
-> Bool
-> IO (Maybe FilePath)
findDependency HscEnv
hsc_env SrcSpan
loc Maybe FastString
pkg_qual ModuleName
imp_mod
IsBootInterface
is_boot Bool
include_pkg_deps
; case Maybe FilePath
mb_hi of {
Maybe FilePath
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () ;
Just 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 (FilePath
obj,FilePath
hi) = FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
writeDependency FilePath
root Handle
hdl [FilePath
obj] FilePath
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) }}}
; FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
writeDependency FilePath
root Handle
hdl [FilePath]
obj_files FilePath
src_file
; 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 :: FilePath
hi_boot = ModSummary -> FilePath
msHiFilePath ModSummary
node
let obj :: FilePath
obj = FilePath -> FilePath
removeBootSuffix (ModSummary -> FilePath
msObjFilePath ModSummary
node)
[FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
extra_suffixes ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
suff -> do
let way_obj :: [FilePath]
way_obj = FilePath -> [FilePath] -> [FilePath]
insertSuffixes FilePath
obj [FilePath
suff]
let way_hi_boot :: [FilePath]
way_hi_boot = FilePath -> [FilePath] -> [FilePath]
insertSuffixes FilePath
hi_boot [FilePath
suff]
(FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
writeDependency FilePath
root Handle
hdl [FilePath]
way_obj) [FilePath]
way_hi_boot
; 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
{ Session
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
; ParsedModule
parsedMod <- Ghc ParsedModule -> Session -> IO ParsedModule
forall a. Ghc a -> Session -> IO a
reflectGhc (ModSummary -> Ghc ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
GHC.parseModule ModSummary
node) Session
session
; (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
writeDependency FilePath
root Handle
hdl [FilePath]
obj_files)
(ParsedModule -> [FilePath]
GHC.pm_extra_src_files ParsedModule
parsedMod)
}
; let do_imps :: IsBootInterface
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)] -> IO ()
do_imps IsBootInterface
is_boot [(Maybe FastString, GenLocated SrcSpan ModuleName)]
idecls = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
[ SrcSpan
-> IsBootInterface -> Maybe FastString -> ModuleName -> IO ()
do_imp SrcSpan
loc IsBootInterface
is_boot Maybe FastString
mb_pkg ModuleName
mod
| (Maybe FastString
mb_pkg, L SrcSpan
loc 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 ]
; IsBootInterface
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)] -> IO ()
do_imps IsBootInterface
IsBoot (ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
node)
; IsBootInterface
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)] -> IO ()
do_imps IsBootInterface
NotBoot (ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
node)
}
findDependency :: HscEnv
-> SrcSpan
-> Maybe FastString
-> ModuleName
-> IsBootInterface
-> Bool
-> IO (Maybe FilePath)
findDependency :: HscEnv
-> SrcSpan
-> Maybe FastString
-> ModuleName
-> IsBootInterface
-> Bool
-> IO (Maybe FilePath)
findDependency HscEnv
hsc_env SrcSpan
srcloc Maybe FastString
pkg ModuleName
imp IsBootInterface
is_boot Bool
include_pkg_deps = do
let fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
let units :: UnitState
units = HscEnv -> UnitState
hsc_units HscEnv
hsc_env
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
FindResult
r <- FinderCache
-> UnitState
-> HomeUnit
-> DynFlags
-> ModuleName
-> Maybe FastString
-> IO FindResult
findImportedModule FinderCache
fc UnitState
units HomeUnit
home_unit DynFlags
dflags ModuleName
imp Maybe FastString
pkg
case FindResult
r of
Found ModLocation
loc Module
_
| 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 (IsBootInterface -> FilePath -> FilePath
addBootSuffix_maybe IsBootInterface
is_boot (ModLocation -> FilePath
ml_hi_file ModLocation
loc)))
| Bool
otherwise
-> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
FindResult
fail ->
MsgEnvelope GhcMessage -> IO (Maybe FilePath)
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO (Maybe FilePath))
-> MsgEnvelope GhcMessage -> IO (Maybe FilePath)
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
$ DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage (DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
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 :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
writeDependency FilePath
root Handle
hdl [FilePath]
targets FilePath
dep
= do let
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 -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forOutput FilePath
dep'
Handle -> FilePath -> IO ()
hPutStrLn Handle
hdl FilePath
output
insertSuffixes
:: FilePath
-> [String]
-> [FilePath]
insertSuffixes :: FilePath -> [FilePath] -> [FilePath]
insertSuffixes FilePath
file_name [FilePath]
extras
= [ FilePath
basename FilePath -> FilePath -> FilePath
<.> (FilePath
extra FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
suffix) | FilePath
extra <- [FilePath]
extras ]
where
(FilePath
basename, FilePath
suffix) = case FilePath -> (FilePath, FilePath)
splitExtension FilePath
file_name of
(FilePath
b, FilePath
s) -> (FilePath
b, Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
s)
endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO ()
endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO ()
endMkDependHS Logger
logger 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
Handle -> FilePath -> IO ()
hPutStrLn Handle
tmp_hdl FilePath
depEndMarker
case Maybe Handle
makefile_hdl of
Maybe Handle
Nothing -> () -> IO ()
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
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 -> DynFlags -> FilePath -> IO ()
showPass Logger
logger DynFlags
dflags (FilePath
"Backing up " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
makefile)
FilePath -> FilePath -> IO ()
SysTools.copyFile FilePath
makefile (FilePath
makefileFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
".bak")
Logger -> DynFlags -> FilePath -> IO ()
showPass Logger
logger DynFlags
dflags FilePath
"Installing new makefile"
FilePath -> FilePath -> IO ()
SysTools.copyFile FilePath
tmp_file FilePath
makefile
dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO ()
dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO ()
dumpModCycles Logger
logger DynFlags
dflags 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
= Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags (FilePath -> SDoc
text FilePath
"No module cycles")
| Bool
otherwise
= Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags (SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text FilePath
"Module cycles found:") Int
2 SDoc
pp_cycles)
where
topoSort :: [SCC ModSummary]
topoSort = [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules ([SCC ModuleGraphNode] -> [SCC ModSummary])
-> [SCC ModuleGraphNode] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$
Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
True ModuleGraph
module_graph Maybe ModuleName
forall a. Maybe a
Nothing
cycles :: [[ModSummary]]
cycles :: [[ModSummary]]
cycles =
[ [ModSummary]
c | CyclicSCC [ModSummary]
c <- [SCC ModSummary]
topoSort ]
pp_cycles :: SDoc
pp_cycles = [SDoc] -> SDoc
vcat [ (FilePath -> SDoc
text FilePath
"---------- Cycle" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"----------")
SDoc -> SDoc -> SDoc
$$ [ModSummary] -> SDoc
pprCycle [ModSummary]
c SDoc -> SDoc -> SDoc
$$ SDoc
blankLine
| (Int
n,[ModSummary]
c) <- [Int
1..] [Int] -> [[ModSummary]] -> [(Int, [ModSummary])]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [[ModSummary]]
cycles ]
pprCycle :: [ModSummary] -> SDoc
pprCycle :: [ModSummary] -> SDoc
pprCycle [ModSummary]
summaries = SCC ModSummary -> SDoc
pp_group ([ModSummary] -> SCC ModSummary
forall vertex. [vertex] -> SCC vertex
CyclicSCC [ModSummary]
summaries)
where
cycle_mods :: [ModuleName]
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]
summaries
pp_group :: SCC ModSummary -> SDoc
pp_group (AcyclicSCC ModSummary
ms) = ModSummary -> SDoc
pp_ms ModSummary
ms
pp_group (CyclicSCC [ModSummary]
mss)
= Bool -> SDoc -> SDoc
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModSummary]
boot_only)) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
ModSummary -> SDoc
pp_ms ModSummary
loop_breaker SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((SCC ModSummary -> SDoc) -> [SCC ModSummary] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SCC ModSummary -> SDoc
pp_group [SCC ModSummary]
groups)
where
([ModSummary]
boot_only, [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 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 (((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 SrcSpan ModuleName -> Bool
in_group (L SrcSpan
_ 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
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]
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 = [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules ([SCC ModuleGraphNode] -> [SCC ModSummary])
-> [SCC ModuleGraphNode] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$
Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
True ([ExtendedModSummary] -> ModuleGraph
mkModuleGraph ([ExtendedModSummary] -> ModuleGraph)
-> [ExtendedModSummary] -> ModuleGraph
forall a b. (a -> b) -> a -> b
$ ModSummary -> ExtendedModSummary
extendModSummaryNoDeps (ModSummary -> ExtendedModSummary)
-> [ModSummary] -> [ExtendedModSummary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModSummary]
all_others) Maybe ModuleName
forall a. Maybe a
Nothing
pp_ms :: ModSummary -> SDoc
pp_ms ModSummary
summary = FilePath -> SDoc
text FilePath
mod_str SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take (Int
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 Char
' '))
SDoc -> SDoc -> SDoc
<+> (SDoc -> [GenLocated SrcSpan ModuleName] -> SDoc
pp_imps SDoc
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)) SDoc -> SDoc -> SDoc
$$
SDoc -> [GenLocated SrcSpan ModuleName] -> SDoc
pp_imps (FilePath -> SDoc
text FilePath
"{-# 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
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 ModuleName -> [ModuleName] -> Bool
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
<+> FilePath -> SDoc
text FilePath
"imports" SDoc -> SDoc -> SDoc
<+>
(ModuleName -> SDoc) -> [ModuleName] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
ms
depStartMarker, depEndMarker :: String
depStartMarker :: FilePath
depStartMarker = FilePath
"# DO NOT DELETE: Beginning of Haskell dependencies"
depEndMarker :: FilePath
depEndMarker = FilePath
"# DO NOT DELETE: End of Haskell dependencies"