cabal-install: call Cabal in-library

This commit modifies the SetupWrapper mechanism, adding a new way of
building a package: directly calling Cabal library functions (e.g.
'build', 'configure' etc).

This currently requires a bit of GADT trickery to accomodate the fact
that configure returns a LocalBuildInfo which must then be passed to
subsequent phases, while with the old Setup interface everything returns
IO () and communication is done through the filesystem
(the local build info file).

To handle 'build-type: Hooks', this commit introduces the hooks-exe
package, which contains:

  - the hooks-exe library, used to compile a set of SetupHooks into an
    external executable,
  - the hooks-cli library, which is used by cabal-install to communicate
    with an external hooks executable.

This package depends on the new `CommunicationHandle` functionality from
haskell/process#308.

Author: sheaf

Cabal/src/Distribution/Simple.hs

@@ -155,6 +155,15 @@ defaultMainWithSetupHooksArgs setupHooks =
       , hscolourHook = setup_hscolourHook
       }
   where
+    preBuildHook =
+      case SetupHooks.preBuildComponentRules (SetupHooks.buildHooks setupHooks) of
+        Nothing -> const $ return []
+        Just pbcRules -> \pbci -> runPreBuildHooks pbci pbcRules
+    postBuildHook =
+      case SetupHooks.postBuildComponentHook (SetupHooks.buildHooks setupHooks) of
+        Nothing -> const $ return ()
+        Just hk -> hk
+
     setup_confHook
       :: (GenericPackageDescription, HookedBuildInfo)
       -> ConfigFlags
@@ -170,12 +179,13 @@ defaultMainWithSetupHooksArgs setupHooks =
       -> BuildFlags
       -> IO ()
     setup_buildHook pkg_descr lbi hooks flags =
-      build_setupHooks
-        (SetupHooks.buildHooks setupHooks)
-        pkg_descr
-        lbi
-        flags
-        (allSuffixHandlers hooks)
+      void $
+        build_setupHooks
+          (preBuildHook, postBuildHook)
+          pkg_descr
+          lbi
+          flags
+          (allSuffixHandlers hooks)
 
     setup_copyHook
       :: PackageDescription
@@ -209,7 +219,7 @@ defaultMainWithSetupHooksArgs setupHooks =
       -> IO ()
     setup_replHook pkg_descr lbi hooks flags args =
       repl_setupHooks
-        (SetupHooks.buildHooks setupHooks)
+        preBuildHook
         pkg_descr
         lbi
         flags
@@ -223,12 +233,13 @@ defaultMainWithSetupHooksArgs setupHooks =
       -> HaddockFlags
       -> IO ()
     setup_haddockHook pkg_descr lbi hooks flags =
-      haddock_setupHooks
-        (SetupHooks.buildHooks setupHooks)
-        pkg_descr
-        lbi
-        (allSuffixHandlers hooks)
-        flags
+      void $
+        haddock_setupHooks
+          preBuildHook
+          pkg_descr
+          lbi
+          (allSuffixHandlers hooks)
+          flags
 
     setup_hscolourHook
       :: PackageDescription
@@ -238,7 +249,7 @@ defaultMainWithSetupHooksArgs setupHooks =
       -> IO ()
     setup_hscolourHook pkg_descr lbi hooks flags =
       hscolour_setupHooks
-        (SetupHooks.buildHooks setupHooks)
+        preBuildHook
         pkg_descr
         lbi
         (allSuffixHandlers hooks)

Cabal/src/Distribution/Simple/Build.hs

@@ -26,6 +26,8 @@ module Distribution.Simple.Build
   ( -- * Build
     build
   , build_setupHooks
+  , buildComponent
+  , runPostBuildHooks
 
     -- * Repl
   , repl
@@ -34,6 +36,7 @@ module Distribution.Simple.Build
 
     -- * Build preparation
   , preBuildComponent
+  , runPreBuildHooks
   , AutogenFile (..)
   , AutogenFileContents
   , writeBuiltinAutogenFiles
@@ -93,6 +96,7 @@ import Distribution.Simple.BuildPaths
 import Distribution.Simple.BuildTarget
 import Distribution.Simple.BuildToolDepends
 import Distribution.Simple.Configure
+import Distribution.Simple.Errors
 import Distribution.Simple.Flag
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.PreProcess
@@ -107,9 +111,8 @@ import Distribution.Simple.Setup.Common
 import Distribution.Simple.Setup.Config
 import Distribution.Simple.Setup.Repl
 import Distribution.Simple.SetupHooks.Internal
-  ( BuildHooks (..)
-  , BuildingWhat (..)
-  , noBuildHooks
+  ( BuildingWhat (..)
+  , buildingWhatVerbosity
   )
 import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks
 import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks
@@ -129,7 +132,6 @@ import Distribution.Compat.Graph (IsNode (..))
 import Control.Monad
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Map as Map
-import Distribution.Simple.Errors
 import System.Directory (doesFileExist, removeFile)
 import System.FilePath (takeDirectory)
 
@@ -146,10 +148,16 @@ build
   -> [PPSuffixHandler]
   -- ^ preprocessors to run before compiling
   -> IO ()
-build = build_setupHooks noBuildHooks
+build pkg lbi flags suffixHandlers =
+  void $ build_setupHooks noHooks pkg lbi flags suffixHandlers
+  where
+    noHooks = (const $ return [], const $ return ())
 
 build_setupHooks
-  :: BuildHooks
+  :: ( SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath]
+     , SetupHooks.PostBuildComponentInputs -> IO ()
+     )
+  -- ^ build hooks
   -> PackageDescription
   -- ^ Mostly information from the .cabal file
   -> LocalBuildInfo
@@ -158,13 +166,15 @@ build_setupHooks
   -- ^ Flags that the user passed to build
   -> [PPSuffixHandler]
   -- ^ preprocessors to run before compiling
-  -> IO ()
+  -> IO [SetupHooks.MonitorFilePath]
 build_setupHooks
-  (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild})
+  (preBuildHook, postBuildHook)
   pkg_descr
   lbi
   flags
   suffixHandlers = do
+    let verbosity = fromFlag $ buildVerbosity flags
+        distPref = fromFlag $ buildDistPref flags
     checkSemaphoreSupport verbosity (compiler lbi) flags
     targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags)
     let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
@@ -189,7 +199,7 @@ build_setupHooks
     dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags
 
     -- Now do the actual building
-    (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do
+    (mons, _) <- (\f -> foldM f ([], installedPkgs lbi) componentsToBuild) $ \(monsAcc, index) target -> do
       let comp = targetComponent target
           clbi = targetCLBI target
           bi = componentBuildInfo comp
@@ -201,18 +211,8 @@ build_setupHooks
               , withPackageDB = withPackageDB lbi ++ [internalPackageDB]
               , installedPkgs = index
               }
-          runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()
-          runPreBuildHooks lbi2 tgt =
-            let inputs =
-                  SetupHooks.PreBuildComponentInputs
-                    { SetupHooks.buildingWhat = BuildNormal flags
-                    , SetupHooks.localBuildInfo = lbi2
-                    , SetupHooks.targetInfo = tgt
-                    }
-             in for_ mbPbcRules $ \pbcRules -> do
-                  (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules
-                  SetupHooks.executeRules verbosity lbi2 tgt ruleFromId
-      preBuildComponent runPreBuildHooks verbosity lbi' target
+          pbci = SetupHooks.PreBuildComponentInputs (BuildNormal flags) lbi' target
+      mons <- preBuildComponent (preBuildHook pbci) verbosity lbi' target
       let numJobs = buildNumJobs flags
       par_strat <-
         toFlag <$> case buildUseSemaphore flags of
@@ -240,13 +240,40 @@ build_setupHooks
               , SetupHooks.localBuildInfo = lbi'
               , SetupHooks.targetInfo = target
               }
-      for_ mbPostBuild ($ postBuildInputs)
-      return (maybe index (Index.insert `flip` index) mb_ipi)
+      postBuildHook postBuildInputs
+      return (monsAcc ++ mons, maybe index (Index.insert `flip` index) mb_ipi)
+    return mons
+
+runPreBuildHooks
+  :: SetupHooks.PreBuildComponentInputs
+  -> SetupHooks.Rules SetupHooks.PreBuildComponentInputs
+  -> IO [SetupHooks.MonitorFilePath]
+runPreBuildHooks
+  pbci@SetupHooks.PreBuildComponentInputs
+    { SetupHooks.buildingWhat = what
+    , SetupHooks.localBuildInfo = lbi
+    , SetupHooks.targetInfo = tgt
+    }
+  pbRules = do
+    let verbosity = buildingWhatVerbosity what
+    (rules, monitors) <- SetupHooks.computeRules verbosity pbci pbRules
+    SetupHooks.executeRules verbosity lbi tgt rules
+    return monitors
 
-    return ()
-    where
-      distPref = fromFlag (buildDistPref flags)
-      verbosity = fromFlag (buildVerbosity flags)
+runPostBuildHooks
+  :: BuildFlags
+  -> LocalBuildInfo
+  -> TargetInfo
+  -> (SetupHooks.PostBuildComponentInputs -> IO ())
+  -> IO ()
+runPostBuildHooks flags lbi tgt postBuild =
+  let inputs =
+        SetupHooks.PostBuildComponentInputs
+          { SetupHooks.buildFlags = flags
+          , SetupHooks.localBuildInfo = lbi
+          , SetupHooks.targetInfo = tgt
+          }
+   in postBuild inputs
 
 -- | Check for conditions that would prevent the build from succeeding.
 checkSemaphoreSupport
@@ -333,11 +360,11 @@ repl
   -- ^ preprocessors to run before compiling
   -> [String]
   -> IO ()
-repl = repl_setupHooks noBuildHooks
+repl = repl_setupHooks (const $ return [])
 
 repl_setupHooks
-  :: BuildHooks
-  -- ^ build hook
+  :: (SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath])
+  -- ^ pre-build hook
   -> PackageDescription
   -- ^ Mostly information from the .cabal file
   -> LocalBuildInfo
@@ -349,7 +376,7 @@ repl_setupHooks
   -> [String]
   -> IO ()
 repl_setupHooks
-  (BuildHooks{preBuildComponentRules = mbPbcRules})
+  preBuildHook
   pkg_descr
   lbi
   flags
@@ -389,25 +416,16 @@ repl_setupHooks
                   (componentBuildInfo comp)
                   (withPrograms lbi')
             }
-        runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()
-        runPreBuildHooks lbi2 tgt =
-          let inputs =
-                SetupHooks.PreBuildComponentInputs
-                  { SetupHooks.buildingWhat = BuildRepl flags
-                  , SetupHooks.localBuildInfo = lbi2
-                  , SetupHooks.targetInfo = tgt
-                  }
-           in for_ mbPbcRules $ \pbcRules -> do
-                (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules
-                SetupHooks.executeRules verbosity lbi2 tgt ruleFromId
+        pbci lbi' tgt = SetupHooks.PreBuildComponentInputs (BuildRepl flags) lbi' tgt
 
     -- build any dependent components
     sequence_
       [ do
         let clbi = targetCLBI subtarget
             comp = targetComponent subtarget
             lbi' = lbiForComponent comp lbi
-        preBuildComponent runPreBuildHooks verbosity lbi' subtarget
+        _monitors <-
+          preBuildComponent (preBuildHook (pbci lbi' subtarget)) verbosity lbi' subtarget
         buildComponent
           (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}})
           NoFlag
@@ -424,7 +442,8 @@ repl_setupHooks
     let clbi = targetCLBI target
         comp = targetComponent target
         lbi' = lbiForComponent comp lbi
-    preBuildComponent runPreBuildHooks verbosity lbi' target
+    _monitors <-
+      preBuildComponent (preBuildHook (pbci lbi' target)) verbosity lbi' target
     replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref
 
 -- | Start an interpreter without loading any package files.
@@ -1121,20 +1140,20 @@ componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do
 -- | Creates the autogenerated files for a particular configured component,
 -- and runs the pre-build hook.
 preBuildComponent
-  :: (LocalBuildInfo -> TargetInfo -> IO ())
+  :: IO r
   -- ^ pre-build hook
   -> Verbosity
   -> LocalBuildInfo
   -- ^ Configuration information
   -> TargetInfo
-  -> IO ()
+  -> IO r
 preBuildComponent preBuildHook verbosity lbi tgt = do
   let pkg_descr = localPkgDescr lbi
       clbi = targetCLBI tgt
       compBuildDir = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi
   createDirectoryIfMissingVerbose verbosity True compBuildDir
   writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi
-  preBuildHook lbi tgt
+  preBuildHook
 
 -- | Generate and write to disk all built-in autogenerated files
 -- for the specified component. These files will be put in the