Merge pull request #2633 from tibbe/act-as-setup

Allow using cabal program itself as the external setup method

Author: dcoutts

cabal-install/Distribution/Client/Setup.hs

@@ -35,6 +35,7 @@ module Distribution.Client.Setup
     , initCommand, IT.InitFlags(..)
     , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
     , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
+    , actAsSetupCommand, ActAsSetupFlags(..)
     , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
     , execCommand, ExecFlags(..)
     , userConfigCommand, UserConfigFlags(..)
@@ -79,7 +80,7 @@ import Distribution.Version
 import Distribution.Package
          ( PackageIdentifier, packageName, packageVersion, Dependency(..) )
 import Distribution.PackageDescription
-         ( RepoKind(..) )
+         ( BuildType(..), RepoKind(..) )
 import Distribution.Text
          ( Text(..), display )
 import Distribution.ReadE
@@ -1813,6 +1814,47 @@ instance Monoid Win32SelfUpgradeFlags where
     }
     where combine field = field a `mappend` field b
 
+-- ------------------------------------------------------------
+-- * ActAsSetup flags
+-- ------------------------------------------------------------
+
+data ActAsSetupFlags = ActAsSetupFlags {
+    actAsSetupBuildType :: Flag BuildType
+}
+
+defaultActAsSetupFlags :: ActAsSetupFlags
+defaultActAsSetupFlags = ActAsSetupFlags {
+    actAsSetupBuildType = toFlag Simple
+}
+
+actAsSetupCommand :: CommandUI ActAsSetupFlags
+actAsSetupCommand = CommandUI {
+  commandName         = "act-as-setup",
+  commandSynopsis     = "Run as-if this was a Setup.hs",
+  commandDescription  = Nothing,
+  commandNotes        = Nothing,
+  commandUsage        = \pname ->
+    "Usage: " ++ pname ++ " act-as-setup\n",
+  commandDefaultFlags = defaultActAsSetupFlags,
+  commandOptions      = \_ ->
+      [option "" ["build-type"]
+         "Use the given build type."
+         actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v })
+         (reqArg "BUILD-TYPE" (readP_to_E ("Cannot parse build type: "++)
+                               (fmap toFlag parse))
+                              (map display . flagToList))
+      ]
+}
+
+instance Monoid ActAsSetupFlags where
+  mempty      = ActAsSetupFlags {
+     actAsSetupBuildType = mempty
+    }
+  mappend a b = ActAsSetupFlags {
+    actAsSetupBuildType = combine actAsSetupBuildType
+    }
+    where combine field = field a `mappend` field b
+
 -- ------------------------------------------------------------
 -- * Sandbox-related flags
 -- ------------------------------------------------------------

cabal-install/Distribution/Client/SetupWrapper.hs

@@ -105,6 +105,7 @@ import Control.Monad       ( when, unless )
 import Data.List           ( foldl1' )
 import Data.Maybe          ( fromMaybe, isJust )
 import Data.Char           ( isSpace )
+import Distribution.Client.Compat.ExecutablePath  ( getExecutablePath )
 
 #ifdef mingw32_HOST_OS
 import Distribution.Simple.Utils
@@ -222,12 +223,22 @@ setupWrapper verbosity options mpkg cmd flags extraArgs = do
 --
 determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod
 determineSetupMethod options buildType'
-  | forceExternalSetupMethod options = externalSetupMethod
+    -- This order is picked so that it's stable. The build type and
+    -- required cabal version are external info, coming from .cabal
+    -- files and the command line. Those do switch between the
+    -- external and self & internal methods, but that info itself can
+    -- be considered stable. The logging and force-external conditions
+    -- are internally generated choices but now these only switch
+    -- between the self and internal setup methods, which are
+    -- consistent with each other.
+  | buildType' == Custom             = externalSetupMethod
+  | not (cabalVersion `withinRange`
+         useCabalVersion options)    = externalSetupMethod
   | isJust (useLoggingHandle options)
- || buildType' == Custom             = externalSetupMethod
-  | cabalVersion `withinRange`
-      useCabalVersion options        = internalSetupMethod
-  | otherwise                        = externalSetupMethod
+    -- Forcing is done to use an external process e.g. due to parallel
+    -- build concerns.
+ || forceExternalSetupMethod options = selfExecSetupMethod
+  | otherwise                        = internalSetupMethod
 
 type SetupMethod = Verbosity
                 -> SetupScriptOptions
@@ -255,6 +266,34 @@ buildTypeAction Make      = Make.defaultMainArgs
 buildTypeAction Custom               = error "buildTypeAction Custom"
 buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"
 
+-- ------------------------------------------------------------
+-- * Self-Exec SetupMethod
+-- ------------------------------------------------------------
+
+selfExecSetupMethod :: SetupMethod
+selfExecSetupMethod verbosity options _pkg bt mkargs = do
+  let args = ["act-as-setup",
+              "--build-type=" ++ display bt,
+              "--"] ++ mkargs cabalVersion
+  debug verbosity $ "Using self-exec internal setup method with build-type "
+                 ++ show bt ++ " and args:\n  " ++ show args
+  path <- getExecutablePath
+  info verbosity $ unwords (path : args)
+  case useLoggingHandle options of
+    Nothing        -> return ()
+    Just logHandle -> info verbosity $ "Redirecting build log to "
+                                    ++ show logHandle
+
+  searchpath <- programSearchPathAsPATHVar
+                (getProgramSearchPath (useProgramConfig options))
+  env        <- getEffectiveEnvironment [("PATH", Just searchpath)]
+
+  process <- runProcess path args
+             (useWorkingDir options) env Nothing
+             (useLoggingHandle options) (useLoggingHandle options)
+  exitCode <- waitForProcess process
+  unless (exitCode == ExitSuccess) $ exitWith exitCode
+
 -- ------------------------------------------------------------
 -- * External SetupMethod
 -- ------------------------------------------------------------

cabal-install/Main.hs

@@ -37,6 +37,7 @@ import Distribution.Client.Setup
          , InitFlags(initVerbosity), initCommand
          , SDistFlags(..), SDistExFlags(..), sdistCommand
          , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
+         , ActAsSetupFlags(..), actAsSetupCommand
          , SandboxFlags(..), sandboxCommand
          , ExecFlags(..), execCommand
          , UserConfigFlags(..), userConfigCommand
@@ -112,12 +113,14 @@ import Distribution.Client.Utils              (determineNumJobs
                                               ,existsAndIsMoreRecentThan)
 
 import Distribution.PackageDescription
-         ( Executable(..), benchmarkName, benchmarkBuildInfo, testName
-         , testBuildInfo, buildable )
+         ( BuildType(..), Executable(..), benchmarkName, benchmarkBuildInfo
+         , testName, testBuildInfo, buildable )
 import Distribution.PackageDescription.Parse
          ( readPackageDescription )
 import Distribution.PackageDescription.PrettyPrint
          ( writeGenericPackageDescription )
+import qualified Distribution.Simple as Simple
+import qualified Distribution.Make as Make
 import Distribution.Simple.Build
          ( startInterpreter )
 import Distribution.Simple.Command
@@ -262,6 +265,8 @@ mainWorker args = topHandler $
        upgradeCommand         `commandAddAction` upgradeAction
       ,hiddenCommand $
        win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction
+      ,hiddenCommand $
+       actAsSetupCommand`commandAddAction` actAsSetupAction
       ]
 
 wrapperAction :: Monoid flags
@@ -1155,3 +1160,17 @@ win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do
   let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)
   Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path
 win32SelfUpgradeAction _ _ _ = return ()
+
+-- | Used as an entry point when cabal-install needs to invoke itself
+-- as a setup script. This can happen e.g. when doing parallel builds.
+--
+actAsSetupAction :: ActAsSetupFlags -> [String] -> GlobalFlags -> IO ()
+actAsSetupAction actAsSetupFlags args _globalFlags =
+  let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)
+  in case bt of
+    Simple    -> Simple.defaultMainArgs args
+    Configure -> Simple.defaultMainWithHooksArgs
+                  Simple.autoconfUserHooks args
+    Make      -> Make.defaultMainArgs args
+    Custom               -> error "actAsSetupAction Custom"
+    (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType"