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

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Cabal/Distribution/Simple.hs

@@ -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

Cabal/Distribution/Simple/Register.hs

@@ -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

Cabal/Distribution/Simple/Setup.hs

@@ -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 })

Cabal/Distribution/Simple/UserHooks.hs

@@ -182,7 +182,7 @@ emptyUserHooks
       preSDist  = rn,
       sDistHook = ru,
       postSDist = ru,
-      preReg    = rn,
+      preReg    = rn',
       regHook   = ru,
       postReg   = ru,
       preUnreg  = rn,

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -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