Commit 2fac2ec6 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Add support for register --assume-deps-up-to-date. (#3287)


Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 1d27ac71
......@@ -367,7 +367,7 @@ registerAction hooks flags args = do
flags' = flags { regDistPref = toFlag distPref }
hookedAction preReg regHook postReg
(getBuildConfig hooks verbosity distPref)
hooks flags' args
hooks flags' { regArgs = args } args
unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO ()
unregisterAction hooks flags args = do
......
......@@ -53,6 +53,7 @@ import qualified Distribution.Simple.LHC as LHC
import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import Distribution.Simple.BuildTarget
import Distribution.Simple.Compiler
import Distribution.Simple.Program
import Distribution.Simple.Program.Script
......@@ -82,22 +83,41 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Char8
register :: PackageDescription -> LocalBuildInfo
-> RegisterFlags -- ^Install in the user's database?; verbose
-> IO ()
register pkg lbi regFlags =
-- We do NOT register libraries outside of the inplace database
-- if there is no public library, since no one else can use it
-- usefully (they're not public.) If we start supporting scoped
-- packages, we'll have to relax this.
when (hasPublicLib pkg) $ do
-- It's important to register in build order, because ghc-pkg
-- will complain if a dependency is not registered.
let maybeGenerateOne clbi
| CLib lib <- getLocalComponent pkg clbi
= fmap Just (generateOne pkg lib lbi clbi regFlags)
| otherwise = return Nothing
ipis <- fmap catMaybes
$ mapM maybeGenerateOne (allComponentsInBuildOrder lbi)
registerAll pkg lbi regFlags ipis
return ()
register pkg_descr lbi flags = when (hasPublicLib pkg_descr) doRegister
where
-- We do NOT register libraries outside of the inplace database
-- if there is no public library, since no one else can use it
-- usefully (they're not public.) If we start supporting scoped
-- packages, we'll have to relax this.
doRegister = do
targets <- readBuildTargets pkg_descr (regArgs flags)
targets' <- checkBuildTargets verbosity pkg_descr targets
-- It's important to register in build order, because ghc-pkg
-- will complain if a dependency is not registered.
let maybeGenerateOne clbi
| CLib lib <- getLocalComponent pkg_descr clbi
= fmap Just (generateOne pkg_descr lib lbi clbi flags)
| otherwise = return Nothing
ipis <-
if fromFlag (regAssumeDepsUpToDate flags)
then
case targets' of
[(cname, _)] -> do
mb_ipi <- maybeGenerateOne (getComponentLocalBuildInfo lbi cname)
case mb_ipi of
Nothing -> die "Cannot --assume-deps-up-to-date register non-library target"
Just ipi -> return [ipi]
[] -> die "In --assume-deps-up-to-date mode you must specify a target"
_ -> die "In --assume-deps-up-to-date mode you can only register a single target"
else fmap catMaybes
. mapM maybeGenerateOne
$ componentsInBuildOrder lbi (map fst targets')
registerAll pkg_descr lbi flags ipis
return ()
where
verbosity = fromFlag (regVerbosity flags)
generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo
-> RegisterFlags
......
......@@ -1041,7 +1041,12 @@ data RegisterFlags = RegisterFlags {
regInPlace :: Flag Bool,
regDistPref :: Flag FilePath,
regPrintId :: Flag Bool,
regVerbosity :: Flag Verbosity
regVerbosity :: Flag Verbosity,
-- | If this is true, we don't register all libraries,
-- only directly referenced library in 'regArgs'.
regAssumeDepsUpToDate :: Flag Bool,
-- Same as in 'buildArgs' and 'copyArgs'
regArgs :: [String]
}
deriving (Show, Generic)
......@@ -1053,7 +1058,9 @@ defaultRegisterFlags = RegisterFlags {
regInPlace = Flag False,
regDistPref = NoFlag,
regPrintId = Flag False,
regVerbosity = Flag normal
regVerbosity = Flag normal,
regAssumeDepsUpToDate = Flag False,
regArgs = []
}
registerCommand :: CommandUI RegisterFlags
......@@ -1084,6 +1091,11 @@ registerCommand = CommandUI
regInPlace (\v flags -> flags { regInPlace = v })
trueArg
,option "" ["assume-deps-up-to-date"]
"One-shot registration"
regAssumeDepsUpToDate (\c flags -> flags { regAssumeDepsUpToDate = c })
trueArg
,option "" ["gen-script"]
"instead of registering, generate a script to register later"
regGenScript (\v flags -> flags { regGenScript = v })
......
......@@ -182,7 +182,7 @@ emptyUserHooks
preSDist = rn,
sDistHook = ru,
postSDist = ru,
preReg = rn,
preReg = rn',
regHook = ru,
postReg = ru,
preUnreg = rn,
......
......@@ -1998,7 +1998,10 @@ setupHsRegisterFlags ElaboratedConfiguredPackage {pkgBuildStyle} _
_ -> toFlag False,
regPrintId = mempty, -- never use
regDistPref = toFlag builddir,
regVerbosity = toFlag verbosity
regVerbosity = toFlag verbosity,
-- Currently not used, because this is per-package.
regAssumeDepsUpToDate = toFlag False,
regArgs = []
}
setupHsHaddockFlags :: ElaboratedConfiguredPackage
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment