From d838e9f84a1436ee6b20b9f95b723ad4130573c0 Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 25 Apr 2024 12:20:58 +0200 Subject: [PATCH] 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 https://github.com/haskell/process/pull/308. --- Cabal/src/Distribution/Simple.hs | 39 +- Cabal/src/Distribution/Simple/Build.hs | 113 +++-- Cabal/src/Distribution/Simple/Configure.hs | 298 ++++++------ Cabal/src/Distribution/Simple/GHC.hs | 1 + Cabal/src/Distribution/Simple/Haddock.hs | 80 ++-- Cabal/src/Distribution/Simple/Program/Db.hs | 34 ++ Cabal/src/Distribution/Simple/Register.hs | 2 +- .../Distribution/Simple/SetupHooks/Errors.hs | 26 +- .../Simple/SetupHooks/Internal.hs | 17 +- .../Distribution/Simple/SetupHooks/Rule.hs | 47 ++ Cabal/src/Distribution/Simple/Test/ExeV10.hs | 3 +- bootstrap/bootstrap.py | 4 +- cabal-install/cabal-install.cabal | 6 +- .../src/Distribution/Client/CmdLegacy.hs | 4 +- .../src/Distribution/Client/CmdRun.hs | 4 - .../src/Distribution/Client/Configure.hs | 9 +- .../src/Distribution/Client/InLibrary.hs | 352 ++++++++++++++ .../src/Distribution/Client/Install.hs | 13 +- .../src/Distribution/Client/InstallSymlink.hs | 4 +- cabal-install/src/Distribution/Client/Main.hs | 14 +- .../Client/ProjectBuilding/UnpackedPackage.hs | 180 +++++--- .../src/Distribution/Client/ProjectConfig.hs | 1 - .../Distribution/Client/ProjectPlanning.hs | 41 +- .../Client/ProjectPlanning/Types.hs | 2 + .../src/Distribution/Client/SetupWrapper.hs | 433 +++++++++++++----- .../src/Distribution/Client/SourceFiles.hs | 4 +- .../SetupHooksRecompilation/SetupHooks.hs | 6 + .../SetupHooksRecompilation.cabal | 17 + .../SetupHooksRecompilation/cabal.project | 1 + .../SetupHooksRecompilation/cabal.test.hs | 17 + .../SetupHooksRecompilation/src/MyLib.hs | 4 + cabal-testsuite/main/cabal-tests.hs | 5 +- cabal.bootstrap.project | 10 +- cabal.release.project | 2 +- hooks-exe/changelog.md | 6 + .../Client/SetupHooks/CallHooksExe.hs | 228 +++++++++ .../Client/SetupHooks/CallHooksExe/Errors.hs | 92 ++++ .../Distribution/Client/SetupHooks/Errors.hs | 104 +++++ .../Client/SetupHooks/HooksExe.hs | 202 ++++++++ .../Client/SetupHooks/HooksExe/Errors.hs | 116 +++++ hooks-exe/hooks-exe.cabal | 87 ++++ hooks-exe/readme.md | 4 + .../Distribution/Client/SetupHooks/Version.hs | 87 ++++ project-cabal/pkgs/install.config | 1 + 44 files changed, 2226 insertions(+), 494 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/InLibrary.hs create mode 100644 cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooks.hs create mode 100644 cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooksRecompilation.cabal create mode 100644 cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.project create mode 100644 cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/src/MyLib.hs create mode 100644 hooks-exe/changelog.md create mode 100644 hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe.hs create mode 100644 hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe/Errors.hs create mode 100644 hooks-exe/exe/Distribution/Client/SetupHooks/Errors.hs create mode 100644 hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe.hs create mode 100644 hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe/Errors.hs create mode 100644 hooks-exe/hooks-exe.cabal create mode 100644 hooks-exe/readme.md create mode 100644 hooks-exe/version/Distribution/Client/SetupHooks/Version.hs diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 1423ed8f992..663df1fcb4c 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/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) diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index f22b5790239..6deb82776af 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/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,17 +416,7 @@ 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_ @@ -407,7 +424,8 @@ repl_setupHooks 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 diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 8d90b0d8822..1d78d20f1e2 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -33,6 +33,17 @@ module Distribution.Simple.Configure ( configure , configure_setupHooks + , runPreConfPackageHook + , runPostConfPackageHook + , runPreConfComponentHook + , configurePackage + , PackageInfo (..) + , mkProgramDb + , finalCheckPackage + , configureComponents + , configureDependencies + , mkPromisedDepsSet + , combinedConstraints , writePersistBuildConfig , getConfigStateFile , getPersistBuildConfig @@ -467,81 +478,145 @@ configure_setupHooks -- Package-wide pre-configure hook lbc1 <- - case preConfPackageHook of - Nothing -> return lbc0 - Just pre_conf -> do - let programDb0 = LBC.withPrograms lbc0 - programDb0' = programDb0{unconfiguredProgs = Map.empty} - input = - SetupHooks.PreConfPackageInputs - { SetupHooks.configFlags = cfg - , SetupHooks.localBuildConfig = lbc0{LBC.withPrograms = programDb0'} - , -- Unconfigured programs are not supplied to the hook, - -- as these cannot be passed over a serialisation boundary - -- (see the "Binary ProgramDb" instance). - SetupHooks.compiler = comp - , SetupHooks.platform = platform - } - SetupHooks.PreConfPackageOutputs - { SetupHooks.buildOptions = opts1 - , SetupHooks.extraConfiguredProgs = progs1 - } <- - pre_conf input - -- The package-wide pre-configure hook returns BuildOptions that - -- overrides the one it was passed in, as well as an update to - -- the ProgramDb in the form of new configured programs to add - -- to the program database. - return $ - lbc0 - { LBC.withBuildOptions = opts1 - , LBC.withPrograms = - updateConfiguredProgs - (`Map.union` progs1) - programDb0 - } + maybe + (return lbc0) + (runPreConfPackageHook cfg comp platform lbc0) + preConfPackageHook -- Cabal package-wide configure - (lbc2, pbd2, pkg_info) <- + ( lbc2 + , pbd2 + , pkg_info@( PackageInfo + { installedPackageSet = installedPkgs + , promisedDepsSet = promisedDeps + } + ) + ) <- finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps -- Package-wide post-configure hook - for_ postConfPackageHook $ \postConfPkg -> do - let input = - SetupHooks.PostConfPackageInputs - { SetupHooks.localBuildConfig = lbc2 - , SetupHooks.packageBuildDescr = pbd2 - } - postConfPkg input + for_ postConfPackageHook $ runPostConfPackageHook lbc2 pbd2 -- Per-component pre-configure hook pkg_descr <- do let pkg_descr2 = LBC.localPkgDescr pbd2 applyComponentDiffs verbosity - ( \c -> for preConfComponentHook $ \computeDiff -> do - let input = - SetupHooks.PreConfComponentInputs - { SetupHooks.localBuildConfig = lbc2 - , SetupHooks.packageBuildDescr = pbd2 - , SetupHooks.component = c - } - SetupHooks.PreConfComponentOutputs - { SetupHooks.componentDiff = diff - } <- - computeDiff input - return diff - ) + (for preConfComponentHook . runPreConfComponentHook lbc2 pbd2) pkg_descr2 let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr} -- Cabal per-component configure - externalPkgDeps <- finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo pkg_info - lbi <- configureComponents lbc2 pbd3 pkg_info externalPkgDeps + finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo + let + use_external_internal_deps = + case enabledComps of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + -- The list of 'InstalledPackageInfo' recording the selected + -- dependencies on external packages. + -- + -- Invariant: For any package name, there is at most one package + -- in externalPackageDeps which has that name. + -- + -- NB: The dependency selection is global over ALL components + -- in the package (similar to how allConstraints and + -- requiredDepsMap are global over all components). In particular, + -- if *any* component (post-flag resolution) has an unsatisfiable + -- dependency, we will fail. This can sometimes be undesirable + -- for users, see #1786 (benchmark conflicts with executable), + -- + -- In the presence of Backpack, these package dependencies are + -- NOT complete: they only ever include the INDEFINITE + -- dependencies. After we apply an instantiation, we'll get + -- definite references which constitute extra dependencies. + -- (Why not have cabal-install pass these in explicitly? + -- For one it's deterministic; for two, we need to associate + -- them with renamings which would require a far more complicated + -- input scheme than what we have today.) + externalPkgDeps <- + configureDependencies + verbosity + use_external_internal_deps + pkg_info + pkg_descr + enabledComps + lbi <- configureComponents lbc2 pbd3 installedPkgs promisedDeps externalPkgDeps writePersistBuildConfig mbWorkDir distPref lbi return lbi +runPreConfPackageHook + :: ConfigFlags + -> Compiler + -> Platform + -> LBC.LocalBuildConfig + -> (SetupHooks.PreConfPackageInputs -> IO SetupHooks.PreConfPackageOutputs) + -> IO LBC.LocalBuildConfig +runPreConfPackageHook cfg comp platform lbc0 pre_conf = do + let programDb0 = LBC.withPrograms lbc0 + programDb0' = programDb0{unconfiguredProgs = Map.empty} + input = + SetupHooks.PreConfPackageInputs + { SetupHooks.configFlags = cfg + , SetupHooks.localBuildConfig = lbc0{LBC.withPrograms = programDb0'} + , -- Unconfigured programs are not supplied to the hook, + -- as these cannot be passed over a serialisation boundary + -- (see the "Binary ProgramDb" instance). + SetupHooks.compiler = comp + , SetupHooks.platform = platform + } + SetupHooks.PreConfPackageOutputs + { SetupHooks.buildOptions = opts1 + , SetupHooks.extraConfiguredProgs = progs1 + } <- + pre_conf input + -- The package-wide pre-configure hook returns BuildOptions that + -- overrides the one it was passed in, as well as an update to + -- the ProgramDb in the form of new configured programs to add + -- to the program database. + return $ + lbc0 + { LBC.withBuildOptions = opts1 + , LBC.withPrograms = + updateConfiguredProgs + (`Map.union` progs1) + programDb0 + } + +runPostConfPackageHook + :: LBC.LocalBuildConfig + -> LBC.PackageBuildDescr + -> (SetupHooks.PostConfPackageInputs -> IO ()) + -> IO () +runPostConfPackageHook lbc2 pbd2 postConfPkg = + let input = + SetupHooks.PostConfPackageInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + } + in postConfPkg input + +runPreConfComponentHook + :: LBC.LocalBuildConfig + -> LBC.PackageBuildDescr + -> Component + -> (SetupHooks.PreConfComponentInputs -> IO SetupHooks.PreConfComponentOutputs) + -> IO SetupHooks.ComponentDiff +runPreConfComponentHook lbc pbd c hook = do + let input = + SetupHooks.PreConfComponentInputs + { SetupHooks.localBuildConfig = lbc + , SetupHooks.packageBuildDescr = pbd + , SetupHooks.component = c + } + SetupHooks.PreConfComponentOutputs + { SetupHooks.componentDiff = diff + } <- + hook input + return diff + preConfigurePackage :: ConfigFlags -> GenericPackageDescription @@ -809,18 +884,25 @@ computeLocalBuildConfig cfg comp programDb = do return $ LBC.LocalBuildConfig - { extraConfigArgs = [] -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - , withPrograms = programDb + { extraConfigArgs = [] + , -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + withPrograms = programDb , withBuildOptions = buildOptions } data PackageInfo = PackageInfo { internalPackageSet :: Set LibraryName + -- ^ Libraries internal to the package , promisedDepsSet :: Map (PackageName, ComponentName) ComponentId + -- ^ Collection of components that are promised, i.e. are not installed already. + -- + -- See 'PromisedDependency' for more details. , installedPackageSet :: InstalledPackageIndex + -- ^ Installed packages , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ Packages for which we have been given specific deps to use } configurePackage @@ -831,12 +913,11 @@ configurePackage -> ComponentRequestedSpec -> Compiler -> Platform - -> ProgramDb -> PackageDBStack -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr) -configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 packageDbs = do - let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common +configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform packageDbs = do + let verbosity = fromFlag (configVerbosity cfg) + programDb0 = LBC.withPrograms lbc0 -- add extra include/lib dirs as specified in cfg pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg @@ -892,7 +973,7 @@ configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 pac defaultInstallDirs' use_external_internal_deps (compilerFlavor comp) - (fromFlag (configUserInstall cfg)) + (fromFlagOrDefault True (configUserInstall cfg)) (hasLibs pkg_descr2) let installDirs = @@ -939,7 +1020,7 @@ finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do packageDbs :: PackageDBStack packageDbs = interpretPackageDbFlags - (fromFlag (configUserInstall cfg)) + (fromFlagOrDefault True (configUserInstall cfg)) (configPackageDBs cfg) -- The InstalledPackageIndex of all installed packages @@ -1041,7 +1122,6 @@ finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do enabled comp platform - programDb0 packageDbs return (lbc, pbd, pkg_info) @@ -1098,8 +1178,7 @@ finalCheckPackage :: GenericPackageDescription -> LBC.PackageBuildDescr -> HookedBuildInfo - -> PackageInfo - -> IO ([PreExistingComponent], [PromisedComponent]) + -> IO () finalCheckPackage g_pkg_descr ( LBC.PackageBuildDescr @@ -1110,16 +1189,11 @@ finalCheckPackage , componentEnabledSpec = enabled } ) - hookedBuildInfo - (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) = + hookedBuildInfo = do let common = configCommonFlags cfg verbosity = fromFlag $ setupVerbosity common cabalFileDir = packageRoot common - use_external_internal_deps = - case enabled of - OneComponentRequestedSpec{} -> True - ComponentRequestedSpec{} -> False checkCompilerProblems verbosity comp pkg_descr enabled checkPackageProblems @@ -1161,41 +1235,12 @@ finalCheckPackage dieWithException verbosity $ CantFindForeignLibraries unsupportedFLibs - -- The list of 'InstalledPackageInfo' recording the selected - -- dependencies on external packages. - -- - -- Invariant: For any package name, there is at most one package - -- in externalPackageDeps which has that name. - -- - -- NB: The dependency selection is global over ALL components - -- in the package (similar to how allConstraints and - -- requiredDepsMap are global over all components). In particular, - -- if *any* component (post-flag resolution) has an unsatisfiable - -- dependency, we will fail. This can sometimes be undesirable - -- for users, see #1786 (benchmark conflicts with executable), - -- - -- In the presence of Backpack, these package dependencies are - -- NOT complete: they only ever include the INDEFINITE - -- dependencies. After we apply an instantiation, we'll get - -- definite references which constitute extra dependencies. - -- (Why not have cabal-install pass these in explicitly? - -- For one it's deterministic; for two, we need to associate - -- them with renamings which would require a far more complicated - -- input scheme than what we have today.) - configureDependencies - verbosity - use_external_internal_deps - internalPackageSet - promisedDepsSet - installedPackageSet - requiredDepsMap - pkg_descr - enabled - configureComponents :: LBC.LocalBuildConfig -> LBC.PackageBuildDescr - -> PackageInfo + -> InstalledPackageIndex + -> Map (PackageName, ComponentName) ComponentId + -- ^ collection of promised dependencies -> ([PreExistingComponent], [PromisedComponent]) -> IO LocalBuildInfo configureComponents @@ -1207,7 +1252,8 @@ configureComponents , componentEnabledSpec = enabled } ) - (PackageInfo{promisedDepsSet, installedPackageSet}) + installedPackageSet + promisedDepsSet externalPkgDeps = do let common = configCommonFlags cfg @@ -1619,22 +1665,14 @@ checkCompilerProblems verbosity comp pkg_descr enabled = do configureDependencies :: Verbosity -> UseExternalInternalDeps - -> Set LibraryName - -> Map (PackageName, ComponentName) ComponentId - -> InstalledPackageIndex - -- ^ installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required deps + -> PackageInfo -> PackageDescription -> ComponentRequestedSpec -> IO ([PreExistingComponent], [PromisedComponent]) configureDependencies verbosity use_external_internal_deps - packageLibraries - promisedDeps - installedPackageSet - requiredDepsMap + pkg_info pkg_descr enableSpec = do let failedDeps :: [FailedDependency] @@ -1647,10 +1685,7 @@ configureDependencies , let status = selectDependency (package pkg_descr) - packageLibraries - promisedDeps - installedPackageSet - requiredDepsMap + pkg_info use_external_internal_deps dep ] @@ -1872,15 +1907,7 @@ data DependencyResolution selectDependency :: PackageId -- ^ Package id of current package - -> Set LibraryName - -- ^ package libraries - -> Map (PackageName, ComponentName) ComponentId - -- ^ Set of components that are promised, i.e. are not installed already. See 'PromisedDependency' for more details. - -> InstalledPackageIndex - -- ^ Installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ Packages for which we have been given specific deps to - -- use + -> PackageInfo -> UseExternalInternalDeps -- ^ Are we configuring a -- single component? @@ -1888,10 +1915,13 @@ selectDependency -> [Either FailedDependency DependencyResolution] selectDependency pkgid - internalIndex - promisedIndex - installedIndex - requiredDepsMap + ( PackageInfo + { internalPackageSet = internalIndex + , promisedDepsSet = promisedIndex + , installedPackageSet = installedIndex + , requiredDepsMap + } + ) use_external_internal_deps (Dependency dep_pkgname vr libs) = -- If the dependency specification matches anything in the internal package diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 095e657264e..9268f4d15f2 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -97,6 +97,7 @@ import Distribution.Simple.Build.Inputs (PreBuildComponentInputs (..)) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors +import Distribution.Simple.Flag import qualified Distribution.Simple.GHC.Build as GHC import Distribution.Simple.GHC.Build.Utils import Distribution.Simple.GHC.EnvironmentParser diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs index 2429362d72e..9b9732cb269 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Haddock.hs @@ -56,6 +56,9 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.BuildTarget import Distribution.Simple.Compiler import Distribution.Simple.Errors +import Distribution.Simple.FileMonitor.Types + ( MonitorFilePath + ) import Distribution.Simple.Flag import Distribution.Simple.Glob (matchDirFileGlob) import Distribution.Simple.InstallDirs @@ -71,12 +74,11 @@ import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Haddock import Distribution.Simple.Setup.Hscolour import Distribution.Simple.SetupHooks.Internal - ( BuildHooks (..) - , BuildingWhat (..) - , noBuildHooks + ( BuildingWhat (..) ) import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks -import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks + ( PreBuildComponentInputs (..) + ) import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentLocalBuildInfo @@ -94,7 +96,6 @@ import Distribution.Version import Language.Haskell.Extension -import Control.Monad import Data.Either (rights) import System.Directory (doesDirectoryExist, doesFileExist) import System.FilePath (isAbsolute, normalise) @@ -228,15 +229,17 @@ haddock -> [PPSuffixHandler] -> HaddockFlags -> IO () -haddock = haddock_setupHooks noBuildHooks +haddock pkg lbi suffixHandlers flags = + void $ haddock_setupHooks (const $ return []) pkg lbi suffixHandlers flags haddock_setupHooks - :: BuildHooks + :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath]) + -- ^ pre-build hook -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags - -> IO () + -> IO [MonitorFilePath] haddock_setupHooks _ pkg_descr @@ -247,13 +250,14 @@ haddock_setupHooks && not (fromFlag $ haddockExecutables haddockFlags) && not (fromFlag $ haddockTestSuites haddockFlags) && not (fromFlag $ haddockBenchmarks haddockFlags) - && not (fromFlag $ haddockForeignLibs haddockFlags) = - warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ + && not (fromFlag $ haddockForeignLibs haddockFlags) = do + warn (fromFlag $ haddockVerbosity haddockFlags) $ "No documentation was generated as this package does not contain " ++ "a library. Perhaps you want to use the --executables, --tests," ++ " --benchmarks or --foreign-libraries flags." + return [] haddock_setupHooks - (BuildHooks{preBuildComponentRules = mbPbcRules}) + preBuildHook pkg_descr lbi suffixes @@ -310,7 +314,7 @@ haddock_setupHooks let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] when using_hscolour $ hscolour' - noBuildHooks + (const $ return []) -- NB: we are not passing the user BuildHooks here, -- because we are already running the pre/post build hooks -- for Haddock. @@ -332,7 +336,7 @@ haddock_setupHooks internalPackageDB <- createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags) - (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + (mons, _mbIPI) <- (\f -> foldM f ([], installedPkgs lbi) targets') $ \(monsAcc, index) target -> do let component = targetComponent target clbi = targetCLBI target @@ -345,19 +349,8 @@ haddock_setupHooks , withPackageDB = withPackageDB lbi ++ [internalPackageDB] , installedPkgs = index } - - runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () - runPreBuildHooks lbi2 tgt = - let inputs = - SetupHooks.PreBuildComponentInputs - { SetupHooks.buildingWhat = BuildHaddock 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 (BuildHaddock flags) lbi' target + mons <- preBuildComponent (preBuildHook pbci) verbosity lbi' target preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes let doExe com = case (compToExe com) of @@ -468,13 +461,15 @@ haddock_setupHooks CTest _ -> when (flag haddockTestSuites) (smsg >> doExe component) >> return index CBench _ -> when (flag haddockBenchmarks) (smsg >> doExe component) >> return index - return ipi + return (monsAcc ++ mons, ipi) for_ (extraDocFiles pkg_descr) $ \fpath -> do files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath for_ files $ copyFileToCwd verbosity mbWorkDir (unDir $ argOutputDir commonArgs) + return mons + -- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build -- index and contents for documentation of multiple packages. createHaddockIndex @@ -1181,20 +1176,22 @@ hscolour -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour = hscolour_setupHooks noBuildHooks +hscolour = hscolour_setupHooks (const $ return []) hscolour_setupHooks - :: BuildHooks + :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath]) + -- ^ pre-build hook -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour_setupHooks setupHooks = - hscolour' setupHooks dieNoVerbosity ForDevelopment +hscolour_setupHooks preBuildHook = + hscolour' preBuildHook dieNoVerbosity ForDevelopment hscolour' - :: BuildHooks + :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath]) + -- ^ pre-build hook -> (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. -> HaddockTarget @@ -1204,7 +1201,7 @@ hscolour' -> HscolourFlags -> IO () hscolour' - (BuildHooks{preBuildComponentRules = mbPbcRules}) + preBuildHook onNoHsColour haddockTarget pkg_descr @@ -1239,19 +1236,10 @@ hscolour' hscolourPref haddockTarget distPref pkg_descr withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do - let tgt = TargetInfo clbi comp - runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () - runPreBuildHooks lbi2 target = - let inputs = - SetupHooks.PreBuildComponentInputs - { SetupHooks.buildingWhat = BuildHscolour flags - , SetupHooks.localBuildInfo = lbi2 - , SetupHooks.targetInfo = target - } - in for_ mbPbcRules $ \pbcRules -> do - (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules - SetupHooks.executeRules verbosity lbi2 tgt ruleFromId - preBuildComponent runPreBuildHooks verbosity lbi tgt + let + target = TargetInfo clbi comp + pbci = SetupHooks.PreBuildComponentInputs (BuildHscolour flags) lbi target + _monitors <- preBuildComponent (preBuildHook pbci) verbosity lbi target preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes let doExe com = case (compToExe com) of diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index a9aefa7d649..101561313fe 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -68,6 +68,7 @@ module Distribution.Simple.Program.Db , ConfiguredProgs , updateUnconfiguredProgs , updateConfiguredProgs + , updatePathProgDb ) where import Distribution.Compat.Prelude @@ -485,6 +486,39 @@ reconfigurePrograms verbosity paths argss progdb = do where progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths] +-- | Update the PATH and environment variables of already-configured programs +-- in the program database. +-- +-- This is a somewhat sketchy operation, but it handles the following situation: +-- +-- - we add a build-tool-depends executable to the program database, with its +-- associated data directory environment variables; +-- - we want invocations of GHC (an already configured program) to be able to +-- find this program (e.g. if the build-tool-depends executable is used +-- in a Template Haskell splice). +-- +-- In this case, we want to add the build tool to the PATH of GHC, even though +-- GHC is already configured which in theory means we shouldn't touch it any +-- more. +updatePathProgDb :: Verbosity -> ProgramDb -> IO ProgramDb +updatePathProgDb verbosity progdb = + updatePathProgs verbosity progs progdb + where + progs = Map.elems $ configuredProgs progdb + +-- | See 'updatePathProgDb' +updatePathProgs :: Verbosity -> [ConfiguredProgram] -> ProgramDb -> IO ProgramDb +updatePathProgs verbosity progs progdb = + foldM (flip (updatePathProg verbosity)) progdb progs + +-- | See 'updatePathProgDb'. +updatePathProg :: Verbosity -> ConfiguredProgram -> ProgramDb -> IO ProgramDb +updatePathProg _verbosity prog progdb = do + newPath <- programSearchPathAsPATHVar (progSearchPath progdb) + let envOverrides = progOverrideEnv progdb + prog' = prog{programOverrideEnv = [("PATH", Just newPath)] ++ envOverrides} + return $ updateProgram prog' progdb + -- | Check that a program is configured and available to be run. -- -- It raises an exception if the program could not be configured, otherwise diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs index 78053111a4a..1bb8f40dfab 100644 --- a/Cabal/src/Distribution/Simple/Register.hs +++ b/Cabal/src/Distribution/Simple/Register.hs @@ -170,7 +170,7 @@ registerAll -> IO () registerAll pkg lbi regFlags ipis = do - when (fromFlag (regPrintId regFlags)) $ do + when (Just True == flagToMaybe (regPrintId regFlags)) $ do for_ ipis $ \installedPkgInfo -> -- Only print the public library's IPI when diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs index 11577f3506b..8a2b36a6c72 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs @@ -20,7 +20,6 @@ module Distribution.Simple.SetupHooks.Errors , RulesException (..) , setupHooksExceptionCode , setupHooksExceptionMessage - , showLocs ) where import Distribution.PackageDescription @@ -29,9 +28,6 @@ import qualified Distribution.Simple.SetupHooks.Rule as Rule import Distribution.Types.Component import qualified Data.Graph as Graph -import Data.List - ( intercalate - ) import qualified Data.List.NonEmpty as NE import qualified Data.Tree as Tree @@ -132,7 +128,7 @@ rulesExceptionMessage = \case showCycle (r, rs) = unlines . map (" " ++) . lines $ Tree.drawTree $ - fmap showRule $ + fmap show $ Tree.Node r rs CantFindSourceForRuleDependencies _r deps -> unlines $ @@ -175,29 +171,13 @@ rulesExceptionMessage = \case DuplicateRuleId rId r1 r2 -> unlines $ [ "Duplicate pre-build rule (" <> show rId <> ")" - , " - " <> showRule (ruleBinary r1) - , " - " <> showRule (ruleBinary r2) + , " - " <> show r1 + , " - " <> show r2 ] - where - showRule :: RuleBinary -> String - showRule (Rule{staticDependencies = deps, results = reslts}) = - "Rule: " ++ showDeps deps ++ " --> " ++ showLocs (NE.toList reslts) locPath :: Location -> String locPath (base, fp) = normalise $ base fp -showLocs :: [Location] -> String -showLocs locs = "[" ++ intercalate ", " (map locPath locs) ++ "]" - -showDeps :: [Rule.Dependency] -> String -showDeps deps = "[" ++ intercalate ", " (map showDep deps) ++ "]" - -showDep :: Rule.Dependency -> String -showDep = \case - RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) -> - "(" ++ show rId ++ ")[" ++ show i ++ "]" - FileDependency loc -> locPath loc - cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int cannotApplyComponentDiffCode = \case MismatchedComponentTypes{} -> 9491 diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs index 25e2f39b1ad..fd233f6a856 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} @@ -78,6 +79,7 @@ module Distribution.Simple.SetupHooks.Internal -- ** Executing build rules , executeRules + , executeRulesUserOrSystem -- ** HookedBuildInfo compatibility code , hookedBuildInfoComponents @@ -110,7 +112,9 @@ import Distribution.Simple.SetupHooks.Rule import qualified Distribution.Simple.SetupHooks.Rule as Rule import Distribution.Simple.Utils import Distribution.System (Platform (..)) -import Distribution.Utils.Path (getSymbolicPath) +import Distribution.Utils.Path + ( getSymbolicPath + ) import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo) import Distribution.Types.LocalBuildConfig as LBC @@ -122,6 +126,7 @@ import Data.Coerce (coerce) import qualified Data.Graph as Graph import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map +import Data.Monoid (Ap (..)) import qualified Data.Set as Set import System.Directory (doesFileExist) @@ -792,8 +797,8 @@ applyComponentDiffs verbosity f = traverseComponents apply_diff Just diff -> applyComponentDiff verbosity c diff Nothing -> return c -forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO () -forComponents_ pd f = getConst $ traverseComponents (Const . f) pd +forComponents_ :: Applicative m => PackageDescription -> (Component -> m ()) -> m () +forComponents_ pd f = getAp . getConst $ traverseComponents (Const . Ap . f) pd applyComponentDiff :: Verbosity @@ -981,6 +986,12 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a SetupHooksException $ RulesException e +showLocs :: [Location] -> String +showLocs locs = "[" ++ intercalate ", " (map showLoc locs) ++ "]" + +showLoc :: Location -> String +showLoc (base, rel) = base rel + directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep directRuleDependencyMaybe (FileDependency{}) = Nothing diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs index afbabb859f6..18f0e304b4d 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs @@ -98,6 +98,11 @@ import Distribution.Types.UnitId import Distribution.Utils.ShortText ( ShortText ) +import Distribution.Utils.Structured + ( Structure (..) + , Structured (..) + , nominalStructure + ) import Distribution.Verbosity ( Verbosity ) @@ -132,6 +137,9 @@ import Data.Type.Equality ) import GHC.Show (showCommaSpace) import GHC.StaticPtr +import GHC.TypeLits + ( Symbol + ) import System.IO.Unsafe ( unsafePerformIO ) @@ -250,6 +258,8 @@ deriving stock instance Eq (RuleData User) deriving stock instance Eq (RuleData System) deriving anyclass instance Binary (RuleData User) deriving anyclass instance Binary (RuleData System) +deriving anyclass instance Structured (RuleData User) +deriving anyclass instance Structured (RuleData System) -- | Trimmed down 'Show' instance, mostly for error messages. instance Show RuleBinary where @@ -611,6 +621,10 @@ data } -> RuleCommands scope deps ruleCmd +-- NB: whenever you change this datatype, you **must** also update its +-- 'Structured' instance. The structure hash is used as a handshake when +-- communicating with an external hooks executable. + {- Note [Hooks Binary instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Hooks API is strongly typed: users can declare rule commands with varying @@ -1015,6 +1029,39 @@ instance } _ -> error "internal error when decoding dynamic rule commands" +instance + (Typeable scope, Typeable ruleCmd, Typeable deps) + => Structured (RuleCommands scope deps ruleCmd) + where + structure _ = + Structure + tr + 0 + (show tr) + [ + ( "StaticRuleCommand" + , + [ nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (IO ())) + , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "arg")) + ] + ) + , + ( "DynamicRuleCommands" + , + [ nominalStructure $ Proxy @(Static scope (Dict (Binary (Tok "depsRes"), Show (Tok "depsRes"), Eq (Tok "depsRes")))) + , nominalStructure $ Proxy @(deps scope (Tok "depsArg") (Tok "depsRes")) + , nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (Tok "depsRes" -> IO ())) + , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "depsArg", Tok "depsRes", Tok "arg")) + ] + ) + ] + where + tr = Typeable.SomeTypeRep $ Typeable.typeRep @(RuleCommands scope deps ruleCmd) + +-- | A token constructor used to define 'Structured' instances on types +-- that involve existential quantification. +data Tok (arg :: Symbol) + instance ( forall res. Binary (ruleCmd System LBS.ByteString res) , Binary (deps System LBS.ByteString LBS.ByteString) diff --git a/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/Cabal/src/Distribution/Simple/Test/ExeV10.hs index a90ce833703..baf88e87891 100644 --- a/Cabal/src/Distribution/Simple/Test/ExeV10.hs +++ b/Cabal/src/Distribution/Simple/Test/ExeV10.hs @@ -21,6 +21,7 @@ import qualified Distribution.Simple.LocalBuildInfo as LBI , buildDir , depLibraryPaths ) + import Distribution.Simple.Program.Db import Distribution.Simple.Program.Find import Distribution.Simple.Program.Run @@ -28,7 +29,7 @@ import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils -import Distribution.System +import Distribution.System (Platform (Platform)) import Distribution.TestSuite import qualified Distribution.Types.LocalBuildInfo as LBI ( LocalBuildInfo (..) diff --git a/bootstrap/bootstrap.py b/bootstrap/bootstrap.py index ba8327433aa..f5f05f2e702 100755 --- a/bootstrap/bootstrap.py +++ b/bootstrap/bootstrap.py @@ -87,7 +87,9 @@ class PackageSource(Enum): , "Cabal-tests" , "Cabal-tree-diff" , "cabal-install-solver" - , "cabal-install" ] + , "cabal-install" + , "hooks-exe" + ] class Compiler: def __init__(self, ghc_path: Path): diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 230e72c533b..d3537ec10fa 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -1,4 +1,4 @@ -Cabal-Version: 2.2 +Cabal-Version: 3.0 Name: cabal-install Version: 3.13.0.0 @@ -148,6 +148,7 @@ library Distribution.Client.Init.Simple Distribution.Client.Init.Types Distribution.Client.Init.Utils + Distribution.Client.InLibrary Distribution.Client.Install Distribution.Client.InstallPlan Distribution.Client.InstallSymlink @@ -219,6 +220,7 @@ library Distribution.Client.Win32SelfUpgrade build-depends: + hooks-exe:hooks-version, hooks-exe:hooks-cli, async >= 2.0 && < 2.3, array >= 0.4 && < 0.6, base16-bytestring >= 0.1.1 && < 1.1.0.0, @@ -236,7 +238,7 @@ library mtl >= 2.0 && < 2.4, network-uri >= 2.6.0.2 && < 2.7, pretty >= 1.1 && < 1.2, - process >= 1.2.3.0 && < 1.7, + process >= 1.2.3.0 && < 1.8, random >= 1.2 && < 1.3, stm >= 2.0 && < 2.6, tar >= 0.5.0.3 && < 0.7, diff --git a/cabal-install/src/Distribution/Client/CmdLegacy.hs b/cabal-install/src/Distribution/Client/CmdLegacy.hs index 128d5fb4251..7f1540dfb8e 100644 --- a/cabal-install/src/Distribution/Client/CmdLegacy.hs +++ b/cabal-install/src/Distribution/Client/CmdLegacy.hs @@ -15,7 +15,8 @@ import Distribution.Client.Sandbox ) import qualified Distribution.Client.Setup as Client import Distribution.Client.SetupWrapper - ( SetupScriptOptions (..) + ( SetupRunnerArgs (NotInLibrary) + , SetupScriptOptions (..) , defaultSetupScriptOptions , setupWrapper ) @@ -80,6 +81,7 @@ wrapperAction command getCommonFlags = getCommonFlags (const flags) (const extraArgs) + NotInLibrary -- diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 5c481ae1c76..77074cf7398 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -63,7 +63,6 @@ import Distribution.Client.ProjectPlanning.Types , dataDirsEnvironmentForPlan , elabExeDependencyPaths ) - import Distribution.Client.ScriptUtils ( AcceptNoTargets (..) , TargetContext (..) @@ -118,9 +117,6 @@ import Distribution.Types.ComponentName ( componentNameRaw ) import Distribution.Types.Executable as PD - ( buildInfo - , exeName - ) import qualified Distribution.Types.PackageDescription as PD ( executables ) diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index fc7ea49fe31..6d716a613eb 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -47,7 +47,8 @@ import Distribution.Client.Setup , filterConfigureFlags ) import Distribution.Client.SetupWrapper - ( SetupScriptOptions (..) + ( SetupRunnerArgs (NotInLibrary) + , SetupScriptOptions (..) , defaultSetupScriptOptions , setupWrapper ) @@ -205,6 +206,7 @@ configure configCommonFlags (const configFlags) (const extraArgs) + NotInLibrary Right installPlan0 -> let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 in case fst (InstallPlan.ready installPlan) of @@ -248,7 +250,6 @@ configure (flagToMaybe (configCabalVersion configExFlags)) ) Nothing - False logMsg message rest = debug verbosity message >> rest @@ -260,7 +261,6 @@ configureSetupScript -> SymbolicPath Pkg (Dir Dist) -> VersionRange -> Maybe Lock - -> Bool -> InstalledPackageIndex -> Maybe ReadyPackage -> SetupScriptOptions @@ -272,7 +272,6 @@ configureSetupScript distPref cabalVersion lock - forceExternal index mpkg = SetupScriptOptions @@ -290,7 +289,6 @@ configureSetupScript , useExtraEnvOverrides = [] , setupCacheLock = lock , useWin32CleanHack = False - , forceExternalSetupMethod = forceExternal , -- If we have explicit setup dependencies, list them; otherwise, we give -- the empty list of dependencies; ideally, we would fix the version of -- Cabal here, so that we no longer need the special case for that in @@ -507,6 +505,7 @@ configurePackage configCommonFlags configureFlags (const extraArgs) + NotInLibrary where gpkg :: PkgDesc.GenericPackageDescription gpkg = srcpkgDescription spkg diff --git a/cabal-install/src/Distribution/Client/InLibrary.hs b/cabal-install/src/Distribution/Client/InLibrary.hs new file mode 100644 index 00000000000..3e77c2f5165 --- /dev/null +++ b/cabal-install/src/Distribution/Client/InLibrary.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} + +module Distribution.Client.InLibrary + ( libraryConfigureInputsFromElabPackage + , configure + , build + , haddock + , copy + , register + , repl + , test + , bench + ) +where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Backpack.DescribeUnitId (setupMessage') +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.RebuildMonad +import qualified Distribution.Client.SetupHooks.CallHooksExe as ExternalHooksExe + ( buildTypePreBuildHooks + , buildTypeSetupHooks + ) +import Distribution.Client.Types + +import qualified Distribution.PackageDescription as PD +import Distribution.Simple (Compiler, PackageDBStack) +import qualified Distribution.Simple.Bench as Cabal +import Distribution.Simple.Build (build_setupHooks, repl_setupHooks) +import qualified Distribution.Simple.Configure as Cabal +import Distribution.Simple.Haddock (haddock_setupHooks) +import Distribution.Simple.Install (install_setupHooks) +import Distribution.Simple.LocalBuildInfo + ( Component + , componentName + , mbWorkDirLBI + ) +import qualified Distribution.Simple.PreProcess as Cabal +import Distribution.Simple.Program.Db +import qualified Distribution.Simple.Register as Cabal +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.SetupHooks.Internal +import qualified Distribution.Simple.Test as Cabal +import Distribution.Simple.Utils +import Distribution.System (Platform) +import Distribution.Types.BuildType +import Distribution.Types.ComponentRequestedSpec +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.LocalBuildInfo +import Distribution.Utils.Path + ( relativeSymbolicPath + ) + +import qualified Data.Set as Set + +-------------------------------------------------------------------------------- +-- Configure + +data LibraryConfigureInputs = LibraryConfigureInputs + { compiler :: Compiler + , platform :: Platform + , buildType :: BuildType + , compRequested :: Maybe PD.ComponentName + , localBuildConfig :: LBC.LocalBuildConfig + , packageDBStack :: PackageDBStack + , packageDescription :: PD.PackageDescription + , gPackageDescription :: PD.GenericPackageDescription + , flagAssignment :: PD.FlagAssignment + } + +libraryConfigureInputsFromElabPackage + :: ProgramDb + -> ElaboratedSharedConfig + -> ElaboratedReadyPackage + -> [String] + -- ^ targets + -> LibraryConfigureInputs +libraryConfigureInputsFromElabPackage + progDb + -- NB: don't use the ProgramDb from the ElaboratedSharedConfig; + -- that one is only for the compiler itself and not for the package. + ElaboratedSharedConfig + { pkgConfigPlatform = platform + , pkgConfigCompiler = compiler + } + (ReadyPackage pkg) + userTargets = + LibraryConfigureInputs + { compiler + , platform + , buildType = PD.buildType pkgDescr + , compRequested = + case elabPkgOrComp pkg of + ElabComponent elabComp + | Just elabCompNm <- compComponentName elabComp -> + Just elabCompNm + _ -> Nothing + , localBuildConfig = + LBC.LocalBuildConfig + { LBC.extraConfigArgs = userTargets + , LBC.withPrograms = progDb + , LBC.withBuildOptions = elabBuildOptions pkg + } + , packageDBStack = elabBuildPackageDBStack pkg + , packageDescription = pkgDescr + , gPackageDescription = gpkgDescr + , flagAssignment = elabFlagAssignment pkg + } + where + pkgDescr = elabPkgDescription pkg + gpkgDescr = elabGPkgDescription pkg + +configure + :: LibraryConfigureInputs + -> Cabal.ConfigFlags + -> IO LocalBuildInfo +configure + LibraryConfigureInputs + { platform + , compiler + , buildType = bt + , compRequested = mbComp + , localBuildConfig = lbc0 + , packageDBStack = packageDBs + , packageDescription = pkgDesc + , gPackageDescription = gpkgDescr + , flagAssignment + } + cfg = + -- SetupHooks TODO: the following code should not live in cabal-install. + -- We should be able to directly call into the library, + -- similar to what we do for other phases (see e.g. inLibraryBuild). + -- + -- The issue is mainly about 'finalizeAndConfigurePackage' vs 'configurePackage'. + do + let verbosity = Cabal.fromFlag $ Cabal.configVerbosity cfg + mbWorkDir = Cabal.flagToMaybe $ Cabal.configWorkingDir cfg + distPref = Cabal.fromFlag $ Cabal.configDistPref cfg + confHooks = configureHooks $ ExternalHooksExe.buildTypeSetupHooks mbWorkDir distPref bt + + -- Configure package + let pkgId :: PD.PackageIdentifier + pkgId = PD.package pkgDesc + case mbComp of + Nothing -> setupMessage verbosity "Configuring" pkgId + Just cname -> + setupMessage' + verbosity + "Configuring" + pkgId + cname + (Just (Cabal.configInstantiateWith cfg)) + + -- SetupHooks TODO: we should avoid re-doing package-wide things + -- over and over in the per-component world, e.g. + -- cabal build comp1 && cabal build comp2 + -- should only run the per-package configuration (including hooks) a single time. + lbc1 <- case preConfPackageHook confHooks of + Nothing -> return lbc0 + Just hk -> Cabal.runPreConfPackageHook cfg compiler platform lbc0 hk + let compRequested = case mbComp of + Just compName -> OneComponentRequestedSpec compName + Nothing -> + ComponentRequestedSpec + { testsRequested = Cabal.fromFlag (Cabal.configTests cfg) + , benchmarksRequested = Cabal.fromFlag (Cabal.configBenchmarks cfg) + } + (lbc2, pbd2) <- + Cabal.configurePackage + cfg + lbc1 + pkgDesc + flagAssignment + compRequested + compiler + platform + packageDBs + for_ (postConfPackageHook confHooks) $ Cabal.runPostConfPackageHook lbc2 pbd2 + let pkg_descr2 = LBC.localPkgDescr pbd2 + + -- Configure component(s) + pkg_descr <- + applyComponentDiffs + verbosity + ( \comp -> + if wantComponent compRequested comp + then traverse (Cabal.runPreConfComponentHook lbc2 pbd2 comp) $ preConfComponentHook confHooks + else return Nothing + ) + pkg_descr2 + let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr} + + -- Emit any errors/warnings on problems in the .cabal file. + -- + -- TODO: it might make sense to move this check earlier, perhaps somewhere + -- in Distribution.Client.ProjectPlanning.elaborateInstallPlan. + Cabal.finalCheckPackage gpkgDescr pbd3 PD.emptyHookedBuildInfo + + -- SetupHooks TODO: the following is a significant amount of faff, + -- just in order to call 'configureComponents'. Do we really need to + -- do all of this? This complexity is bad, as it risks going out + -- of sync with the implementation in Cabal. + let progdb = LBC.withPrograms lbc2 + promisedDeps = Cabal.mkPromisedDepsSet (Cabal.configPromisedDependencies cfg) + installedPkgs <- Cabal.getInstalledPackages verbosity compiler mbWorkDir packageDBs progdb + (_, depsMap) <- + either (dieWithException verbosity) return $ + Cabal.combinedConstraints + (Cabal.configConstraints cfg) + (Cabal.configDependencies cfg) + installedPkgs + let pkg_info = + Cabal.PackageInfo + { internalPackageSet = Set.fromList (map PD.libName (PD.allLibraries pkg_descr)) + , promisedDepsSet = promisedDeps + , installedPackageSet = installedPkgs + , requiredDepsMap = depsMap + } + useExternalInternalDeps = case compRequested of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + externalPkgDeps <- Cabal.configureDependencies verbosity useExternalInternalDeps pkg_info pkg_descr compRequested + lbi1 <- Cabal.configureComponents lbc2 pbd3 installedPkgs promisedDeps externalPkgDeps + + pkgDescrFile <- + case Cabal.flagToMaybe $ Cabal.configCabalFilePath cfg of + Just pkgFile -> return pkgFile + Nothing -> relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir + let lbi2 = lbi1{pkgDescrFile = Just pkgDescrFile} + return lbi2 + +-- NB: this function might match multiple components, +-- due to Backpack instantiations. +wantComponent :: ComponentRequestedSpec -> Component -> Bool +wantComponent compReq comp = case compReq of + ComponentRequestedSpec{} -> True + OneComponentRequestedSpec reqComp -> + componentName comp == reqComp + +-------------------------------------------------------------------------------- +-- Build + +build + :: Cabal.BuildFlags + -> LocalBuildInfo + -> [String] + -> IO [MonitorFilePath] +build flags lbi _args = + build_setupHooks (preBuildHook, postBuildHook) pkgDescr lbi flags Cabal.knownSuffixHandlers + where + hooks = ExternalHooksExe.buildTypeSetupHooks mbWorkDir distPref bt + preBuildHook = ExternalHooksExe.buildTypePreBuildHooks mbWorkDir distPref bt + postBuildHook + | Just postBuild <- postBuildComponentHook $ buildHooks hooks = + postBuild + | otherwise = + const $ return () + pkgDescr = localPkgDescr lbi + bt = PD.buildType pkgDescr + mbWorkDir = mbWorkDirLBI lbi + distPref = Cabal.fromFlag $ Cabal.buildDistPref flags + +-------------------------------------------------------------------------------- +-- Haddock + +haddock + :: Cabal.HaddockFlags + -> LocalBuildInfo + -> [String] + -> IO [MonitorFilePath] +haddock flags lbi _args = + haddock_setupHooks preBuildHook pkgDescr lbi Cabal.knownSuffixHandlers flags + where + preBuildHook = ExternalHooksExe.buildTypePreBuildHooks mbWorkDir distPref bt + pkgDescr = localPkgDescr lbi + bt = PD.buildType pkgDescr + mbWorkDir = mbWorkDirLBI lbi + distPref = Cabal.fromFlag $ Cabal.haddockDistPref flags + +-------------------------------------------------------------------------------- +-- Repl + +repl + :: Cabal.ReplFlags + -> LocalBuildInfo + -> [String] + -> IO () +repl flags lbi _args = + repl_setupHooks preBuildHook pkgDescr lbi flags Cabal.knownSuffixHandlers [] + where + preBuildHook = ExternalHooksExe.buildTypePreBuildHooks mbWorkDir distPref bt + pkgDescr = localPkgDescr lbi + bt = PD.buildType pkgDescr + mbWorkDir = mbWorkDirLBI lbi + distPref = Cabal.fromFlag $ Cabal.replDistPref flags + +-------------------------------------------------------------------------------- +-- Copy + +copy + :: Cabal.CopyFlags + -> LocalBuildInfo + -> [String] + -> IO () +copy flags lbi _args = + install_setupHooks hooks pkgDescr lbi flags + where + hooks = installHooks $ ExternalHooksExe.buildTypeSetupHooks mbWorkDir distPref bt + pkgDescr = localPkgDescr lbi + bt = PD.buildType pkgDescr + mbWorkDir = mbWorkDirLBI lbi + distPref = Cabal.fromFlag $ Cabal.copyDistPref flags + +-------------------------------------------------------------------------------- +-- Test, bench, register. +-- +-- NB: no hooks into these phases. + +test + :: Cabal.TestFlags + -> LocalBuildInfo + -> [String] + -> IO () +test flags lbi args = + Cabal.test args pkgDescr lbi flags + where + pkgDescr = localPkgDescr lbi + +bench + :: Cabal.BenchmarkFlags + -> LocalBuildInfo + -> [String] + -> IO () +bench flags lbi args = + Cabal.bench args pkgDescr lbi flags + where + pkgDescr = localPkgDescr lbi + +register + :: Cabal.RegisterFlags + -> LocalBuildInfo + -> [String] + -> IO () +register flags lbi _args = Cabal.register pkgDescr lbi flags + where + pkgDescr = localPkgDescr lbi diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index a31e4d2ce62..679106b8a01 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -117,7 +117,8 @@ import Distribution.Client.Setup , filterTestFlags ) import Distribution.Client.SetupWrapper - ( SetupScriptOptions (..) + ( SetupRunnerArgs (NotInLibrary) + , SetupScriptOptions (..) , defaultSetupScriptOptions , setupWrapper ) @@ -336,7 +337,7 @@ install ++ "see https://github.com/haskell/cabal/issues/3353" ++ " (if you didn't type --root-cmd, comment out root-cmd" ++ " in your ~/.config/cabal/config file)" - let userOrSandbox = fromFlag (configUserInstall configFlags) + let userOrSandbox = fromFlagOrDefault defaultUserInstall (configUserInstall configFlags) unless userOrSandbox $ warn verbosity $ "the --global flag is deprecated -- " @@ -1246,7 +1247,7 @@ regenerateHaddockIndex defaultDirs <- InstallDirs.defaultInstallDirs (compilerFlavor comp) - (fromFlag (configUserInstall configFlags)) + (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags)) True let indexFileTemplate = fromFlag (installHaddockIndex installFlags) indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate @@ -1501,7 +1502,6 @@ performInstallations distPref (chooseCabalVersion configExFlags (libVersion miscOptions)) (Just lock) - parallelInstall index (Just rpkg) @@ -1966,7 +1966,7 @@ installUnpackedPackage _ -> ipkgs let packageDBs = interpretPackageDbFlags - (fromFlag (configUserInstall configFlags)) + (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags)) (configPackageDBs configFlags) for_ ipkgs' $ \ipkg' -> registerPackage @@ -2088,6 +2088,7 @@ installUnpackedPackage getCommonFlags flags (const []) + NotInLibrary ) -- helper @@ -2122,7 +2123,7 @@ withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do defaultDirs <- InstallDirs.defaultInstallDirs compFlavor - (fromFlag (configUserInstall configFlags)) + (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags)) (PackageDescription.hasLibs pkg) Win32SelfUpgrade.possibleSelfUpgrade diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs index 1701aa1f652..f89d09ed237 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -67,7 +67,6 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.Setup ( ConfigFlags (..) , flagToMaybe - , fromFlag , fromFlagOrDefault ) import Distribution.Simple.Utils (info, withTempDirectory) @@ -98,6 +97,7 @@ import System.IO.Error ) import Distribution.Client.Compat.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink) +import Distribution.Client.Config (defaultUserInstall) import Distribution.Client.Init.Prompt (promptYesNo) import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt)) import Distribution.Client.Types.OverwritePolicy @@ -220,7 +220,7 @@ symlinkBinaries defaultDirs <- InstallDirs.defaultInstallDirs compilerFlavor - (fromFlag (configUserInstall configFlags)) + (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags)) (PackageDescription.hasLibs pkg) let templateDirs = InstallDirs.combineInstallDirs diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 99bdc48357b..0db3e26973d 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -101,6 +101,7 @@ import Distribution.Client.Config ( SavedConfig (..) , createDefaultConfigFile , defaultConfigFile + , defaultUserInstall , getConfigFilePath , loadConfig , userConfigDiff @@ -111,7 +112,8 @@ import qualified Distribution.Client.List as List , list ) import Distribution.Client.SetupWrapper - ( SetupScriptOptions (..) + ( SetupRunnerArgs (NotInLibrary) + , SetupScriptOptions (..) , defaultSetupScriptOptions , setupWrapper ) @@ -529,6 +531,7 @@ wrapperAction command getCommonFlags = getCommonFlags (const flags) (const extraArgs) + NotInLibrary configureAction :: (ConfigFlags, ConfigExFlags) @@ -554,7 +557,7 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do let packageDBs :: PackageDBStack packageDBs = interpretPackageDbFlags - (fromFlag (configUserInstall configFlags')) + (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags')) (configPackageDBs configFlags') withRepoContext verbosity globalFlags' $ \repoContext -> @@ -638,6 +641,7 @@ build verbosity config distPref buildFlags extraArgs = buildCommonFlags mkBuildFlags (const extraArgs) + NotInLibrary where progDb = defaultProgramDb setupOptions = defaultSetupScriptOptions{useDistPref = distPref} @@ -731,6 +735,7 @@ replAction replFlags extraArgs globalFlags = do Cabal.replCommonFlags (const replFlags') (const extraArgs) + NotInLibrary -- No .cabal file in the current directory: just start the REPL (possibly -- using the sandbox package DB). @@ -778,6 +783,7 @@ installAction (configFlags, _, installFlags, _, _, _) _ globalFlags (const common) (const (mempty, mempty, mempty, mempty, mempty, mempty)) (const []) + NotInLibrary installAction ( configFlags , configExFlags @@ -945,6 +951,7 @@ testAction (buildFlags, testFlags) extraArgs globalFlags = do Cabal.testCommonFlags (const testFlags') (const extraArgs') + NotInLibrary data ComponentNames = ComponentNamesUnknown @@ -1066,6 +1073,7 @@ benchmarkAction Cabal.benchmarkCommonFlags (const benchmarkFlags') (const extraArgs') + NotInLibrary haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do @@ -1106,6 +1114,7 @@ haddockAction haddockFlags extraArgs globalFlags = do haddockCommonFlags (const haddockFlags') (const extraArgs) + NotInLibrary when (haddockForHackage haddockFlags == Flag ForHackage) $ do pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig mbWorkDir distPref) let dest = getSymbolicPath distPref name <.> "tar.gz" @@ -1141,6 +1150,7 @@ cleanAction cleanFlags extraArgs globalFlags = do cleanCommonFlags (const cleanFlags') (const extraArgs) + NotInLibrary listAction :: ListFlags -> [String] -> Action listAction listFlags extraArgs globalFlags = do diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 7d9f34a8e8b..0b940119f15 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -1,9 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | This module exposes functions to build and register unpacked packages. -- @@ -75,17 +79,21 @@ import Distribution.Simple.Command (CommandUI) import Distribution.Simple.Compiler ( PackageDBStack ) +import qualified Distribution.Simple.Configure as Cabal import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo ( ComponentName (..) , LibraryName (..) ) +import qualified Distribution.Simple.LocalBuildInfo as Cabal import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import qualified Distribution.Simple.Setup as Cabal import Distribution.Types.BuildType import Distribution.Types.PackageDescription.Lens (componentModules) +import Distribution.Client.Errors +import Distribution.Compat.Directory (listDirectory) import Distribution.Simple.Utils import Distribution.System (Platform (..)) import Distribution.Utils.Path hiding @@ -94,6 +102,8 @@ import Distribution.Utils.Path hiding ) import Distribution.Version +import Distribution.Client.ProjectBuilding.PackageFileMonitor + import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 @@ -105,13 +115,9 @@ import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), ()) import System.IO (Handle, IOMode (AppendMode), withFile) import System.Semaphore (SemaphoreName (..)) +import GHC.Stack import Web.Browser (openBrowser) -import Distribution.Client.Errors -import Distribution.Compat.Directory (listDirectory) - -import Distribution.Client.ProjectBuilding.PackageFileMonitor - -- | Each unpacked package is processed in the following phases: -- -- * Configure phase @@ -126,20 +132,21 @@ import Distribution.Client.ProjectBuilding.PackageFileMonitor -- Depending on whether we are installing the package or building it inplace, -- the phases will be carried out differently. For example, when installing, -- the test, benchmark, and repl phase are ignored. -data PackageBuildingPhase - = PBConfigurePhase {runConfigure :: IO ()} - | PBBuildPhase {runBuild :: IO ()} - | PBHaddockPhase {runHaddock :: IO ()} - | PBInstallPhase - { runCopy :: FilePath -> IO () - , runRegister +data PackageBuildingPhase r where + PBConfigurePhase :: {runConfigure :: IO InLibraryLBI} -> PackageBuildingPhase InLibraryLBI + PBBuildPhase :: {runBuild :: IO [MonitorFilePath]} -> PackageBuildingPhase () + PBHaddockPhase :: {runHaddock :: IO [MonitorFilePath]} -> PackageBuildingPhase () + PBInstallPhase + :: { runCopy :: FilePath -> IO () + , runRegister :: PackageDBStack -> Cabal.RegisterOptions -> IO InstalledPackageInfo - } - | PBTestPhase {runTest :: IO ()} - | PBBenchPhase {runBench :: IO ()} - | PBReplPhase {runRepl :: IO ()} + } + -> PackageBuildingPhase () + PBTestPhase :: {runTest :: IO ()} -> PackageBuildingPhase () + PBBenchPhase :: {runBench :: IO ()} -> PackageBuildingPhase () + PBReplPhase :: {runRepl :: IO ()} -> PackageBuildingPhase () -- | Structures the phases of building and registering a package amongst others -- (see t'PackageBuildingPhase'). Delegates logic specific to a certain @@ -162,13 +169,13 @@ buildAndRegisterUnpackedPackage -> SymbolicPath Pkg (Dir Dist) -> Maybe FilePath -- ^ The path to an /initialized/ log file - -> (PackageBuildingPhase -> IO ()) + -> (forall r. PackageBuildingPhase r -> IO r) -> IO () buildAndRegisterUnpackedPackage verbosity distDirLayout@DistDirLayout{distTempDirectory} maybe_semaphore - buildTimeSettings@BuildTimeSettings{buildSettingNumJobs} + buildTimeSettings registerLock cacheLock pkgshared@ElaboratedSharedConfig @@ -182,36 +189,57 @@ buildAndRegisterUnpackedPackage mlogFile delegate = do -- Configure phase - delegate $ - PBConfigurePhase $ - annotateFailure mlogFile ConfigureFailed $ - setup configureCommand Cabal.configCommonFlags configureFlags configureArgs + mbLBI <- + delegate $ + PBConfigurePhase $ + annotateFailure mlogFile ConfigureFailed $ + setup + configureCommand + Cabal.configCommonFlags + configureFlags + configureArgs + (InLibraryArgs $ InLibraryConfigureArgs pkgshared rpkg) -- Build phase delegate $ PBBuildPhase $ - annotateFailure mlogFile BuildFailed $ do - setup buildCommand Cabal.buildCommonFlags buildFlags buildArgs + annotateFailure mlogFile BuildFailed $ + setup + buildCommand + Cabal.buildCommonFlags + buildFlags + buildArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBuildPhase mbLBI) -- Haddock phase whenHaddock $ delegate $ PBHaddockPhase $ - annotateFailure mlogFile HaddocksFailed $ do - setup haddockCommand Cabal.haddockCommonFlags haddockFlags haddockArgs + annotateFailure mlogFile HaddocksFailed $ + setup + haddockCommand + Cabal.haddockCommonFlags + haddockFlags + haddockArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SHaddockPhase mbLBI) -- Install phase delegate $ PBInstallPhase { runCopy = \destdir -> annotateFailure mlogFile InstallFailed $ - setup Cabal.copyCommand Cabal.copyCommonFlags (copyFlags destdir) copyArgs + setup + Cabal.copyCommand + Cabal.copyCommonFlags + (copyFlags destdir) + copyArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SCopyPhase mbLBI) , runRegister = \pkgDBStack registerOpts -> annotateFailure mlogFile InstallFailed $ do -- We register ourselves rather than via Setup.hs. We need to -- grab and modify the InstalledPackageInfo. We decide what -- the installed package id is, not the build system. - ipkg0 <- generateInstalledPackageInfo + ipkg0 <- generateInstalledPackageInfo mbLBI let ipkg = ipkg0{Installed.installedUnitId = uid} criticalSection registerLock $ Cabal.registerPackage @@ -230,21 +258,36 @@ buildAndRegisterUnpackedPackage delegate $ PBTestPhase $ annotateFailure mlogFile TestsFailed $ - setup testCommand Cabal.testCommonFlags testFlags testArgs + setup + testCommand + Cabal.testCommonFlags + testFlags + testArgs + (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI) -- Bench phase whenBench $ delegate $ PBBenchPhase $ annotateFailure mlogFile BenchFailed $ - setup benchCommand Cabal.benchmarkCommonFlags benchFlags benchArgs + setup + benchCommand + Cabal.benchmarkCommonFlags + benchFlags + benchArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) -- Repl phase whenRepl $ delegate $ PBReplPhase $ annotateFailure mlogFile ReplFailed $ - setupInteractive replCommand Cabal.replCommonFlags replFlags replArgs + setupInteractive + replCommand + Cabal.replCommonFlags + replFlags + replArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI) return () where @@ -343,16 +386,17 @@ buildAndRegisterUnpackedPackage distDirLayout srcdir builddir - (isParallelBuild buildSettingNumJobs) cacheLock setup - :: CommandUI flags + :: (HasCallStack, RightFlagsForPhase flags setupSpec) + => CommandUI flags -> (flags -> CommonSetupFlags) -> (Version -> flags) -> (Version -> [String]) - -> IO () - setup cmd getCommonFlags flags args = + -> SetupRunnerArgs setupSpec + -> IO (SetupRunnerRes setupSpec) + setup cmd getCommonFlags flags args wrapperArgs = withLogging $ \mLogFileHandle -> setupWrapper verbosity @@ -368,25 +412,24 @@ buildAndRegisterUnpackedPackage getCommonFlags flags args + wrapperArgs setupInteractive - :: CommandUI flags + :: RightFlagsForPhase flags setupSpec + => CommandUI flags -> (flags -> CommonSetupFlags) -> (Version -> flags) -> (Version -> [String]) - -> IO () - setupInteractive cmd getCommonFlags flags args = + -> SetupRunnerArgs setupSpec + -> IO (SetupRunnerRes setupSpec) + setupInteractive = setupWrapper verbosity scriptOptions{isInteractive = True} (Just (elabPkgDescription pkg)) - cmd - getCommonFlags - flags - args - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = + generateInstalledPackageInfo :: InLibraryLBI -> IO InstalledPackageInfo + generateInstalledPackageInfo mbLBI = withTempInstalledPackageInfoFile verbosity distTempDirectory @@ -397,7 +440,12 @@ buildAndRegisterUnpackedPackage pkgshared (commonFlags v) pkgConfDest - setup (Cabal.registerCommand) Cabal.registerCommonFlags registerFlags (const []) + setup + (Cabal.registerCommand) + Cabal.registerCommonFlags + registerFlags + (const []) + (InLibraryArgs $ InLibraryPostConfigureArgs SRegisterPhase mbLBI) withLogging :: (Maybe Handle -> IO r) -> IO r withLogging action = @@ -471,15 +519,16 @@ buildInplaceUnpackedPackage builddir Nothing -- no log file for inplace builds! $ \case - PBConfigurePhase{runConfigure} -> do - whenReConfigure $ do - runConfigure + PBConfigurePhase{runConfigure} -> + whenReconfigure $ do + mbLBI <- runConfigure invalidatePackageRegFileMonitor packageFileMonitor updatePackageConfigFileMonitor packageFileMonitor (getSymbolicPath srcdir) pkg + return mbLBI PBBuildPhase{runBuild} -> do whenRebuild $ do timestamp <- beginUpdateFileMonitor - runBuild + monitors' <- runBuild let listSimple = execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg) @@ -491,6 +540,7 @@ buildInplaceUnpackedPackage if null xs then m' else return xs monitors <- case PD.buildType (elabPkgDescription pkg) of Simple -> listSimple + Hooks -> listSdist `ifNullThen` listSimple -- If a Custom setup was used, AND the Cabal is recent -- enough to have sdist --list-sources, use that to -- determine the files that we need to track. This can @@ -522,10 +572,10 @@ buildInplaceUnpackedPackage timestamp pkg buildStatus - (monitors ++ dep_monitors) + (monitors ++ monitors' ++ dep_monitors) buildResult PBHaddockPhase{runHaddock} -> do - runHaddock + _monitors <- runHaddock let haddockTarget = elabHaddockForHackage pkg when (haddockTarget == Cabal.ForHackage) $ do let dest = distDirectory name <.> "tar.gz" @@ -581,10 +631,24 @@ buildInplaceUnpackedPackage packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams - whenReConfigure action = case buildStatus of - BuildStatusConfigure _ -> action - _ -> return () - + whenReconfigure :: IO InLibraryLBI -> IO InLibraryLBI + whenReconfigure action = + case buildStatus of + BuildStatusConfigure _ -> action + _ -> do + lbi_wo_programs <- Cabal.getPersistBuildConfig (Just srcdir) builddir + -- Restore info about unconfigured programs, since it is not serialized + -- TODO: copied from Distribution.Simple.getBuildConfig. + let lbi = + lbi_wo_programs + { Cabal.withPrograms = + restoreProgramDb + builtinPrograms + (Cabal.withPrograms lbi_wo_programs) + } + return $ InLibraryLBI lbi + + whenRebuild, whenReRegister :: IO () -> IO () whenRebuild action | null (elabBuildTargets pkg) , -- NB: we have to build the test/bench suite! @@ -679,10 +743,12 @@ buildAndInstallUnpackedPackage runConfigure PBBuildPhase{runBuild} -> do noticeProgress ProgressBuilding - runBuild + _monitors <- runBuild + return () PBHaddockPhase{runHaddock} -> do noticeProgress ProgressHaddock - runHaddock + _monitors <- runHaddock + return () PBInstallPhase{runCopy, runRegister} -> do noticeProgress ProgressInstalling diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index fa38ef21368..9f77953ed5b 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -169,7 +169,6 @@ import Distribution.Simple.Setup import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , dieWithException - , info , maybeExit , notice , rawSystemIOWithEnv diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index d192e7cc4a0..ed00df6ecd1 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1654,11 +1654,14 @@ elaborateInstallPlan -- Once you've implemented this, swap it for the code below. cuz_buildtype = case bt of - PD.Configure -> [CuzBuildType CuzConfigureBuildType] PD.Custom -> [CuzBuildType CuzCustomBuildType] - PD.Hooks -> [CuzBuildType CuzHooksBuildType] PD.Make -> [CuzBuildType CuzMakeBuildType] PD.Simple -> [] + -- TODO: remove the following, once we make Setup a separate + -- component. + PD.Hooks -> [CuzBuildType CuzHooksBuildType] + PD.Configure -> [CuzBuildType CuzConfigureBuildType] + -- cabal-format versions prior to 1.8 have different build-depends semantics -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 -- see, https://github.com/haskell/cabal/issues/4121 @@ -2125,6 +2128,7 @@ elaborateInstallPlan gdesc of Right (desc, _) -> desc Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabGPkgDescription = gdesc elabFlagAssignment = flags elabFlagDefaults = PD.mkFlagAssignment @@ -3670,7 +3674,6 @@ setupHsScriptOptions -> DistDirLayout -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) - -> Bool -> Lock -> SetupScriptOptions -- TODO: Fix this so custom is a separate component. Custom can ALWAYS @@ -3682,7 +3685,6 @@ setupHsScriptOptions distdir srcdir builddir - isParallelBuild cacheLock = SetupScriptOptions { useCabalVersion = thisVersion elabSetupScriptCliVersion @@ -3715,7 +3717,6 @@ setupHsScriptOptions -- for build-tools-depends. useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan , useWin32CleanHack = False -- TODO: [required eventually] - , forceExternalSetupMethod = isParallelBuild , setupCacheLock = Just cacheLock , isInteractive = False } @@ -3835,9 +3836,9 @@ setupHsConfigureFlags , configDynExe , configFullyStaticExe , configGHCiLib - , -- , configProfExe -- overridden + , -- configProfExe -- overridden configProfLib - , -- , configProf -- overridden + , -- configProf -- overridden configProfDetail , configProfLibDetail , configCoverage @@ -3897,8 +3898,8 @@ setupHsConfigureFlags configExtraLibDirsStatic = fmap makeSymbolicPath $ elabExtraLibDirsStatic configExtraFrameworkDirs = fmap makeSymbolicPath $ elabExtraFrameworkDirs configExtraIncludeDirs = fmap makeSymbolicPath $ elabExtraIncludeDirs - configProgPrefix = maybe mempty toFlag elabProgPrefix - configProgSuffix = maybe mempty toFlag elabProgSuffix + configProgPrefix = maybe (Flag (Cabal.toPathTemplate "")) toFlag elabProgPrefix + configProgSuffix = maybe (Flag (Cabal.toPathTemplate "")) toFlag elabProgSuffix configInstallDirs = fmap @@ -4022,11 +4023,11 @@ setupHsTestFlags setupHsTestFlags (ElaboratedConfiguredPackage{..}) common = Cabal.TestFlags { testCommonFlags = common - , testMachineLog = maybe mempty toFlag elabTestMachineLog - , testHumanLog = maybe mempty toFlag elabTestHumanLog + , testMachineLog = maybeToFlag elabTestMachineLog + , testHumanLog = maybeToFlag elabTestHumanLog , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails , testKeepTix = toFlag elabTestKeepTix - , testWrapper = maybe mempty toFlag elabTestWrapper + , testWrapper = maybeToFlag elabTestWrapper , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites , testOptions = elabTestTestOptions } @@ -4128,23 +4129,23 @@ setupHsHaddockFlags , haddockProgramArgs = mempty -- unused, set at configure time , haddockHoogle = toFlag elabHaddockHoogle , haddockHtml = toFlag elabHaddockHtml - , haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation + , haddockHtmlLocation = maybeToFlag elabHaddockHtmlLocation , haddockForHackage = toFlag elabHaddockForHackage , haddockForeignLibs = toFlag elabHaddockForeignLibs , haddockExecutables = toFlag elabHaddockExecutables , haddockTestSuites = toFlag elabHaddockTestSuites , haddockBenchmarks = toFlag elabHaddockBenchmarks , haddockInternal = toFlag elabHaddockInternal - , haddockCss = maybe mempty toFlag elabHaddockCss + , haddockCss = maybeToFlag elabHaddockCss , haddockLinkedSource = toFlag elabHaddockLinkedSource , haddockQuickJump = toFlag elabHaddockQuickJump - , haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss - , haddockContents = maybe mempty toFlag elabHaddockContents + , haddockHscolourCss = maybeToFlag elabHaddockHscolourCss + , haddockContents = maybeToFlag elabHaddockContents , haddockKeepTempFiles = toFlag keepTmpFiles - , haddockIndex = maybe mempty toFlag elabHaddockIndex - , haddockBaseUrl = maybe mempty toFlag elabHaddockBaseUrl - , haddockLib = maybe mempty toFlag elabHaddockLib - , haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir + , haddockIndex = maybeToFlag elabHaddockIndex + , haddockBaseUrl = maybeToFlag elabHaddockBaseUrl + , haddockLib = maybeToFlag elabHaddockLib + , haddockOutputDir = maybeToFlag elabHaddockOutputDir } setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 5b4896b0568..3d4018367a0 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -224,6 +224,8 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage , elabFlagDefaults :: Cabal.FlagAssignment -- ^ The original default flag assignment, used only for reporting. , elabPkgDescription :: Cabal.PackageDescription + , elabGPkgDescription :: Cabal.GenericPackageDescription + -- ^ Original 'GenericPackageDescription' (just used to report errors/warnings) , elabPkgSourceLocation :: PackageLocation (Maybe FilePath) -- ^ Where the package comes from, e.g. tarball, local dir etc. This -- is not the same as where it may be unpacked to for the build. diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 35a4cb59d80..81a0a962f97 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -1,7 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {- FOURMOLU_DISABLE -} ----------------------------------------------------------------------------- @@ -24,9 +30,16 @@ module Distribution.Client.SetupWrapper ( getSetup , runSetup , runSetupCommand + , SetupRunnerArgs(..) + , SPostConfigurePhase(..) + , InLibraryArgs(..) + , SetupRunnerRes + , InLibraryLBI(..) + , RightFlagsForPhase , setupWrapper , SetupScriptOptions (..) , defaultSetupScriptOptions + , externalSetupMethod ) where import Distribution.Client.Compat.Prelude @@ -61,8 +74,7 @@ import Distribution.Simple.Build.Macros ( generatePackageVersionMacros ) import Distribution.Simple.BuildPaths - ( defaultDistPref - , exeExtension + ( exeExtension ) import Distribution.Simple.Compiler ( Compiler (compilerId) @@ -71,8 +83,7 @@ import Distribution.Simple.Compiler , compilerFlavor ) import Distribution.Simple.Configure - ( configCompilerEx - ) + hiding ( getInstalledPackages ) import Distribution.Simple.PackageDescription ( readGenericPackageDescription ) @@ -81,19 +92,7 @@ import Distribution.Simple.PreProcess , runSimplePreProcessor ) import Distribution.Simple.Program - ( ProgramDb - , emptyProgramDb - , getDbProgramOutputCwd - , getProgramSearchPath - , ghcProgram - , ghcjsProgram - , runDbProgramCwd - ) import Distribution.Simple.Program.Db - ( configureAllKnownPrograms - , prependProgramSearchPath - , progOverrideEnv - ) import Distribution.Simple.Program.Find ( programSearchPathAsPATHVar ) @@ -116,6 +115,8 @@ import Distribution.Version import Distribution.Client.Config ( defaultCacheDir ) +import Distribution.Client.FileMonitor + ( MonitorFilePath ) import Distribution.Client.IndexUtils ( getInstalledPackages ) @@ -126,15 +127,16 @@ import Distribution.Client.JobControl import Distribution.Client.Types import Distribution.Client.Utils ( existsAndIsMoreRecentThan -#ifdef mingw32_HOST_OS - , canonicalizePathNoThrow -#endif , moreRecentFile , tryCanonicalizePath , withEnv , withEnvOverrides , withExtraPathEnv ) +#ifdef mingw32_HOST_OS +import Distribution.Client.Utils + ( canonicalizePathNoThrow ) +#endif import Distribution.Utils.Path hiding ( (), (<.>) ) import qualified Distribution.Utils.Path as Cabal.Path @@ -143,6 +145,7 @@ import Distribution.Simple.Command ( CommandUI (..) , commandShowOptions ) +import qualified Distribution.Simple.Configure as Cabal import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Program.GHC @@ -150,9 +153,6 @@ import Distribution.Simple.Program.GHC , GhcOptions (..) , renderGhcOptions ) -import Distribution.Simple.Setup - ( Flag (..), CommonSetupFlags (..), GlobalFlags (..) - ) import Distribution.Simple.Utils ( cabalVersion , copyFileVerbose @@ -175,24 +175,33 @@ import Distribution.Utils.Generic import Distribution.Compat.Stack import Distribution.ReadE +import Distribution.Simple.Setup +import Distribution.Client.Compat.ExecutablePath (getExecutablePath) +import Distribution.Compat.Process (proc) import Distribution.System (Platform (..), buildPlatform) import Distribution.Utils.NubList ( toNubListR ) +import Distribution.Types.LocalBuildInfo ( LocalBuildInfo ) +import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Verbosity +import Distribution.Client.Errors +import qualified Distribution.Client.InLibrary as InLibrary +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.SetupHooks.Version + ( hooksVersion ) +import Distribution.Client.SetupHooks.CallHooksExe + ( externalSetupHooksABI, hooksProgFilePath ) import Data.List (foldl1') -import Distribution.Simple.Setup (globalCommand) -import Distribution.Client.Compat.ExecutablePath (getExecutablePath) -import Distribution.Compat.Process (proc) -import System.Directory (doesFileExist) +import Data.Kind ( Type, Constraint ) +import System.Directory hiding ( exeExtension ) import System.FilePath ((<.>), ()) import System.IO (Handle, hPutStr) import System.Process (StdStream (..)) import qualified System.Process as Process import qualified Data.ByteString.Lazy as BS -import Distribution.Client.Errors #ifdef mingw32_HOST_OS import Distribution.Simple.Utils @@ -200,30 +209,98 @@ import Distribution.Simple.Utils import Control.Exception ( bracket ) import System.FilePath ( equalFilePath, takeDirectory ) -import System.Directory ( doesDirectoryExist ) import qualified System.Win32 as Win32 #endif +data AllowInLibrary + = AllowInLibrary + | Don'tAllowInLibrary + deriving Eq + +data SetupKind + = InLibrary + | GeneralSetup + +-- | If we end up using the in-library method, we use the v'InLibraryLBI' +-- constructor. If not, we use the 'NotInLibraryNoLBI' constructor. +-- +-- NB: we don't know ahead of time whether we can use the in-library method; +-- e.g. for a package with Hooks build-type, it depends on whether the Cabal +-- version used by the package matches with the Cabal version that cabal-install +-- was built against. +data InLibraryLBI + = InLibraryLBI LocalBuildInfo + | NotInLibraryNoLBI + +data SPostConfigurePhase (flags :: Type) where + SBuildPhase :: SPostConfigurePhase BuildFlags + SHaddockPhase :: SPostConfigurePhase HaddockFlags + SReplPhase :: SPostConfigurePhase ReplFlags + SCopyPhase :: SPostConfigurePhase CopyFlags + SRegisterPhase :: SPostConfigurePhase RegisterFlags + STestPhase :: SPostConfigurePhase TestFlags + SBenchPhase :: SPostConfigurePhase BenchmarkFlags + +data SetupWrapperSpec + = TryInLibrary Type + | UseGeneralSetup + +type family RightFlagsForPhase (flags :: Type) (setupSpec :: SetupWrapperSpec) :: Constraint where + RightFlagsForPhase flags UseGeneralSetup = () + RightFlagsForPhase flags (TryInLibrary flags') = flags ~ flags' + +data SetupRunnerArgs (spec :: SetupWrapperSpec) where + NotInLibrary + :: SetupRunnerArgs UseGeneralSetup + InLibraryArgs + :: InLibraryArgs flags + -> SetupRunnerArgs (TryInLibrary flags) + +data InLibraryArgs (flags :: Type) where + InLibraryConfigureArgs + :: ElaboratedSharedConfig + -> ElaboratedReadyPackage + -> InLibraryArgs ConfigFlags + InLibraryPostConfigureArgs + :: SPostConfigurePhase flags + -> InLibraryLBI + -> InLibraryArgs flags + +type family SetupRunnerRes (spec :: SetupWrapperSpec) where + SetupRunnerRes UseGeneralSetup = () + SetupRunnerRes (TryInLibrary phase) = InLibraryPhaseRes phase + +type family InLibraryPhaseRes flags where + InLibraryPhaseRes ConfigFlags = InLibraryLBI + InLibraryPhaseRes BuildFlags = [MonitorFilePath] + InLibraryPhaseRes HaddockFlags = [MonitorFilePath] + InLibraryPhaseRes ReplFlags = () + InLibraryPhaseRes _ = () + -- | @Setup@ encapsulates the outcome of configuring a setup method to build a -- particular package. -data Setup = Setup - { setupMethod :: SetupMethod +data Setup kind = Setup + { setupMethod :: SetupMethod kind , setupScriptOptions :: SetupScriptOptions , setupVersion :: Version , setupBuildType :: BuildType , setupPackage :: PackageDescription } +data ASetup = forall kind. ASetup ( Setup kind ) + -- | @SetupMethod@ represents one of the methods used to run Cabal commands. -data SetupMethod - = -- | run Cabal commands through \"cabal\" in the - -- current process - InternalMethod - | -- | run Cabal commands through \"cabal\" as a - -- child process - SelfExecMethod - | -- | run Cabal commands through a custom \"Setup\" executable - ExternalMethod FilePath +data SetupMethod (kind :: SetupKind) where + -- | run Cabal commands through @cabal@ in the current process + InternalMethod :: SetupMethod GeneralSetup + -- | Directly use Cabal library functions, bypassing the Setup + -- mechanism entirely. + LibraryMethod :: SetupMethod InLibrary + -- | run Cabal commands through @cabal@ as a child process, + -- using @cabal --act-as-setup@ + SelfExecMethod :: SetupMethod GeneralSetup + -- | run Cabal commands through a custom \"Setup\" executable + ExternalMethod :: FilePath -> SetupMethod GeneralSetup -- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two -- parts: one that has no policy and just does as it's told with all the @@ -270,7 +347,6 @@ data SetupScriptOptions = SetupScriptOptions -- -- * @'Just' v@ means \"set the environment variable's value to @v@\". -- * 'Nothing' means \"unset the environment variable\". - , forceExternalSetupMethod :: Bool , useDependencies :: [(ComponentId, PackageId)] -- ^ List of dependencies to use when building Setup.hs. , useDependenciesExclusive :: Bool @@ -340,7 +416,6 @@ defaultSetupScriptOptions = , useExtraPathEnv = [] , useExtraEnvOverrides = [] , useWin32CleanHack = False - , forceExternalSetupMethod = False , setupCacheLock = Nothing , isInteractive = False } @@ -354,12 +429,13 @@ workingDir options = case useWorkingDir options of _ -> "." -- | A @SetupRunner@ implements a 'SetupMethod'. -type SetupRunner = +type SetupRunner kind = Verbosity -> SetupScriptOptions -> BuildType -> [String] - -> IO () + -> SetupRunnerArgs kind + -> IO (SetupRunnerRes kind) -- | Prepare to build a package by configuring a 'SetupMethod'. The returned -- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed @@ -369,8 +445,9 @@ getSetup :: Verbosity -> SetupScriptOptions -> Maybe PackageDescription - -> IO Setup -getSetup verbosity options mpkg = do + -> AllowInLibrary + -> IO ASetup +getSetup verbosity options mpkg allowInLibrary = do pkg <- maybe getPkg return mpkg let options' = options @@ -380,16 +457,15 @@ getSetup verbosity options mpkg = do (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg)))) } buildType' = buildType pkg - (version, method, options'') <- - getSetupMethod verbosity options' pkg buildType' - return - Setup - { setupMethod = method - , setupScriptOptions = options'' - , setupVersion = version - , setupBuildType = buildType' - , setupPackage = pkg - } + withSetupMethod verbosity options' pkg buildType' allowInLibrary $ + \ (version, method, options'') -> + ASetup $ Setup + { setupMethod = method + , setupScriptOptions = options'' + , setupVersion = version + , setupBuildType = buildType' + , setupPackage = pkg + } where mbWorkDir = useWorkingDir options getPkg = @@ -400,26 +476,47 @@ getSetup verbosity options mpkg = do -- | Decide if we're going to be able to do a direct internal call to the -- entry point in the Cabal library or if we're going to have to compile -- and execute an external Setup.hs script. -getSetupMethod +withSetupMethod :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType - -> IO (Version, SetupMethod, SetupScriptOptions) -getSetupMethod verbosity options pkg buildType' + -> AllowInLibrary + -> ( forall kind. (Version, SetupMethod kind, SetupScriptOptions ) -> r ) + -> IO r +withSetupMethod verbosity options pkg buildType' allowInLibrary with | buildType' == Custom - || buildType' == Hooks + || (buildType' == Hooks && isJust (useLoggingHandle options)) || maybe False (cabalVersion /=) (useCabalSpecVersion options) - || not (cabalVersion `withinRange` useCabalVersion options) = - getExternalSetupMethod verbosity options pkg buildType' - | isJust (useLoggingHandle options) - -- Forcing is done to use an external process e.g. due to parallel - -- build concerns. - || forceExternalSetupMethod options = - return (cabalVersion, SelfExecMethod, options) - | otherwise = return (cabalVersion, InternalMethod, options) - -runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner) + || not (cabalVersion `withinRange` useCabalVersion options) + || allowInLibrary == Don'tAllowInLibrary = + with <$> getExternalSetupMethod verbosity options pkg buildType' + | -- TODO: once we refactor the Cabal library to be able to take a logging + -- handle as an argument (e.g. by putting it in Verbosity), we will be able + -- to get rid of the self-exec method. + isJust (useLoggingHandle options) = + return $ with (cabalVersion, SelfExecMethod, options) + | otherwise + = do + abiOK <- + if buildType' == Hooks + then do + -- SetupHooks TODO: getExternalSetupMethod compiles the hooks executable. + -- That functionality should be moved here. + _ <- getExternalSetupMethod verbosity options pkg Hooks + externalHooksABI <- externalSetupHooksABI $ hooksProgFilePath (useWorkingDir options) (useDistPref options) + let internalHooksABI = hooksVersion + return $ externalHooksABI == internalHooksABI + else return True + if abiOK + then do + debug verbosity $ "Using in-library setup method with build-type " ++ show buildType' + return $ with (cabalVersion, LibraryMethod, options) + else do + debug verbosity $ "Hooks ABI mismatch; falling back to external setup method." + with <$> getExternalSetupMethod verbosity options pkg buildType' + +runSetupMethod :: WithCallStack (SetupMethod GeneralSetup -> SetupRunner UseGeneralSetup) runSetupMethod InternalMethod = internalSetupMethod runSetupMethod (ExternalMethod path) = externalSetupMethod path runSetupMethod SelfExecMethod = selfExecSetupMethod @@ -427,11 +524,12 @@ runSetupMethod SelfExecMethod = selfExecSetupMethod -- | Run a configured 'Setup' with specific arguments. runSetup :: Verbosity - -> Setup + -> Setup GeneralSetup -> [String] -- ^ command-line arguments - -> IO () -runSetup verbosity setup args0 = do + -> SetupRunnerArgs UseGeneralSetup + -> IO (SetupRunnerRes UseGeneralSetup) +runSetup verbosity setup args0 setupArgs = do let method = setupMethod setup options = setupScriptOptions setup bt = setupBuildType setup @@ -445,7 +543,7 @@ runSetup verbosity setup args0 = do ++ " After: " ++ show args ++ "\n" - runSetupMethod method verbosity options bt args + runSetupMethod method verbosity options bt args setupArgs -- | This is a horrible hack to make sure passing fancy verbosity -- flags (e.g., @-v'info +callstack'@) doesn't break horribly on @@ -484,7 +582,7 @@ verbosityHack ver args0 -- | Run a command through a configured 'Setup'. runSetupCommand :: Verbosity - -> Setup + -> Setup GeneralSetup -> CommandUI flags -- ^ command definition -> (flags -> CommonSetupFlags) @@ -492,20 +590,23 @@ runSetupCommand -- ^ command flags -> [String] -- ^ extra command-line arguments - -> IO () -runSetupCommand verbosity setup cmd getCommonFlags flags extraArgs = + -> SetupRunnerArgs UseGeneralSetup + -> IO (SetupRunnerRes UseGeneralSetup) +runSetupCommand verbosity setup cmd getCommonFlags flags extraArgs setupArgs = -- The 'setupWorkingDir' flag corresponds to a global argument which needs to -- be passed before the individual command (e.g. 'configure' or 'build'). let common = getCommonFlags flags globalFlags = mempty { globalWorkingDir = setupWorkingDir common } args = commandShowOptions (globalCommand []) globalFlags ++ (commandName cmd : commandShowOptions cmd flags ++ extraArgs) - in runSetup verbosity setup args + in runSetup verbosity setup args setupArgs -- | Configure a 'Setup' and run a command in one step. The command flags -- may depend on the Cabal library version in use. setupWrapper - :: Verbosity + :: forall setupSpec flags + . RightFlagsForPhase flags setupSpec + => Verbosity -> SetupScriptOptions -> Maybe PackageDescription -> CommandUI flags @@ -513,19 +614,97 @@ setupWrapper -> (Version -> flags) -- ^ produce command flags given the Cabal library version -> (Version -> [String]) - -> IO () -setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs = do - setup <- getSetup verbosity options mpkg + -> SetupRunnerArgs setupSpec + -> IO (SetupRunnerRes setupSpec) +setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs wrapperArgs = do + let allowInLibrary = case wrapperArgs of + NotInLibrary -> Don'tAllowInLibrary + InLibraryArgs {} -> AllowInLibrary + ASetup (setup :: Setup kind) <- getSetup verbosity options mpkg allowInLibrary let version = setupVersion setup flags = getFlags version extraArgs = getExtraArgs version - runSetupCommand - verbosity - setup - cmd - getCommonFlags - flags - extraArgs + notInLibraryMethod :: kind ~ GeneralSetup => IO (SetupRunnerRes setupSpec) + notInLibraryMethod = + do runSetupCommand verbosity setup cmd getCommonFlags flags extraArgs NotInLibrary + return $ case wrapperArgs of + NotInLibrary -> () + InLibraryArgs libArgs -> + case libArgs of + InLibraryConfigureArgs {} -> NotInLibraryNoLBI + InLibraryPostConfigureArgs sPhase _ -> + case sPhase of + SBuildPhase -> [] + SHaddockPhase -> [] + SReplPhase -> () + SCopyPhase -> () + SRegisterPhase -> () + STestPhase -> () + SBenchPhase -> () + case setupMethod setup of + LibraryMethod -> + case wrapperArgs of + InLibraryArgs libArgs -> + case libArgs of + InLibraryConfigureArgs elabSharedConfig elabReadyPkg -> do + + -- Construct the appropriate program database for the package. + -- + -- This is quite tricky, as we need to account for: + -- + -- - user-specified PATH and environment variable overrides, + -- - paths and environment variables for any build-tool-depends + -- of the package (both internal to the package and external), + -- - the fact that the program database might have been obtained + -- by deserialising (due to caching), in which case we might + -- be missing unconfigured built-in programs. + setupProgDb <- prependProgramSearchPath verbosity + (useExtraPathEnv options) + (useExtraEnvOverrides options) =<< + Cabal.mkProgramDb flags + (restoreProgramDb builtinPrograms $ + useProgramDb options) + + lbi0 <- + InLibrary.configure + (InLibrary.libraryConfigureInputsFromElabPackage setupProgDb elabSharedConfig elabReadyPkg extraArgs) + flags + let progs0 = LBI.withPrograms lbi0 + progs1 <- updatePathProgDb verbosity progs0 + let + lbi = + lbi0 + { LBI.withPrograms = progs1 + } + mbWorkDir = useWorkingDir options + distPref = useDistPref options + -- Write the LocalBuildInfo to disk. This is needed, for instance, if we + -- skip re-configuring; we retrieve the LocalBuildInfo stored on disk from + -- the previous invocation of 'configure' and pass it to 'build'. + writePersistBuildConfig mbWorkDir distPref lbi + return $ InLibraryLBI lbi + InLibraryPostConfigureArgs sPhase mbLBI -> + case mbLBI of + NotInLibraryNoLBI -> + error "internal error: in-library post-conf but no LBI" + -- To avoid running into the above error, we must ensure that + -- when we skip re-configuring, we retrieve the cached + -- LocalBuildInfo (see "whenReconfigure" + -- in Distribution.Client.ProjectBuilding.UnpackedPackage). + InLibraryLBI lbi -> + case sPhase of + SBuildPhase -> InLibrary.build flags lbi extraArgs + SHaddockPhase -> InLibrary.haddock flags lbi extraArgs + SReplPhase -> InLibrary.repl flags lbi extraArgs + SCopyPhase -> InLibrary.copy flags lbi extraArgs + STestPhase -> InLibrary.test flags lbi extraArgs + SBenchPhase -> InLibrary.bench flags lbi extraArgs + SRegisterPhase -> InLibrary.register flags lbi extraArgs + NotInLibrary -> + error "internal error: NotInLibrary argument but getSetup chose InLibrary" + InternalMethod -> notInLibraryMethod + ExternalMethod {} -> notInLibraryMethod + SelfExecMethod -> notInLibraryMethod -- ------------------------------------------------------------ @@ -534,8 +713,8 @@ setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs = d -- ------------------------------------------------------------ -- | Run a Setup script by directly invoking the @Cabal@ library. -internalSetupMethod :: SetupRunner -internalSetupMethod verbosity options bt args = do +internalSetupMethod :: SetupRunner UseGeneralSetup +internalSetupMethod verbosity options bt args NotInLibrary = do info verbosity $ "Using internal setup method with build-type " ++ show bt @@ -544,7 +723,7 @@ internalSetupMethod verbosity options bt args = do -- NB: we do not set the working directory of the process here, because -- we will instead pass the -working-dir flag when invoking the Setup script. -- Note that the Setup script is guaranteed to support this flag, because - -- the logic in 'getSetupMethod' guarantees we have an up-to-date Cabal version. + -- the logic in 'withSetupMethod' guarantees we have an up-to-date Cabal version. -- -- In the future, it would be desirable to also stop relying on the following -- pieces of process-global state, as this would allow us to use this internal @@ -601,8 +780,8 @@ invoke verbosity path args options = do -- ------------------------------------------------------------ -selfExecSetupMethod :: SetupRunner -selfExecSetupMethod verbosity options bt args0 = do +selfExecSetupMethod :: SetupRunner UseGeneralSetup +selfExecSetupMethod verbosity options bt args0 NotInLibrary = do let args = [ "act-as-setup" , "--build-type=" ++ prettyShow bt @@ -623,8 +802,8 @@ selfExecSetupMethod verbosity options bt args0 = do -- ------------------------------------------------------------ -externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) -externalSetupMethod path verbosity options _ args = +externalSetupMethod :: WithCallStack (FilePath -> SetupRunner UseGeneralSetup) +externalSetupMethod path verbosity options _ args NotInLibrary = #ifndef mingw32_HOST_OS invoke verbosity @@ -649,7 +828,7 @@ externalSetupMethod path verbosity options _ args = (\tmpPath -> invoke' tmpPath) moveOutOfTheWay tmpDir origPath = do - let tmpPath = tmpDir "setup" <.> exeExtension buildPlatform + let tmpPath = tmpDir takeFileName origPath Win32.moveFile origPath tmpPath return tmpPath @@ -667,7 +846,7 @@ getExternalSetupMethod -> SetupScriptOptions -> PackageDescription -> BuildType - -> IO (Version, SetupMethod, SetupScriptOptions) + -> IO (Version, SetupMethod GeneralSetup, SetupScriptOptions) getExternalSetupMethod verbosity options pkg bt = do debug verbosity $ "Using external setup method with build-type " ++ show bt debug verbosity $ @@ -713,13 +892,15 @@ getExternalSetupMethod verbosity options pkg bt = do where mbWorkDir = useWorkingDir options -- See Note [Symbolic paths] in Distribution.Utils.Path + i :: SymbolicPathX allowAbs Pkg to -> FilePath i = interpretSymbolicPath mbWorkDir setupDir = useDistPref options Cabal.Path. makeRelativePathEx "setup" - setupVersionFile = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> "version") - setupHs = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> "hs") - setupHooks = setupDir Cabal.Path. makeRelativePathEx ("SetupHooks" <.> "hs") - setupProgFile = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> exeExtension buildPlatform) - + setupVersionFile = setupDir Cabal.Path. makeRelativePathEx ( "setup" <.> "version" ) + setupHs = setupDir Cabal.Path. makeRelativePathEx ( "setup" <.> "hs" ) + hooksHs = setupDir Cabal.Path. makeRelativePathEx ( "hooks" <.> "hs" ) + setupHooks = setupDir Cabal.Path. makeRelativePathEx ( "SetupHooks" <.> "hs" ) + setupProgFile = setupDir Cabal.Path. makeRelativePathEx ( "setup" <.> exeExtension buildPlatform ) + hooksProgFile = setupDir Cabal.Path. makeRelativePathEx ( "hooks" <.> exeExtension buildPlatform ) platform = fromMaybe buildPlatform (usePlatform options) useCachedSetupExecutable = @@ -854,7 +1035,7 @@ getExternalSetupMethod verbosity options pkg bt = do "Using 'build-type: Hooks' but there is no SetupHooks.hs file." copyFileVerbose verbosity customSetupHooks (i setupHooks) rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) --- rewriteFileLBS verbosity hooksHs hooksScript + rewriteFileLBS verbosity (i hooksHs) hooksScript updateSetupScript cabalLibVersion _ = rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) @@ -875,6 +1056,11 @@ getExternalSetupMethod verbosity options pkg bt = do | otherwise -> error "buildTypeScript Hooks with Cabal < 3.13" Custom -> error "buildTypeScript Custom" + -- TODO: should all of these include {-# LANGUAGE NoImplicitPrelude #-}? + -- What happens if there is no base dependency declared in the Cabal file? + + hooksScript :: BS.ByteString + hooksScript = "import Distribution.Client.SetupHooks.HooksExe (hooksMain); import SetupHooks; main = hooksMain setupHooks\n" installedCabalVersion :: SetupScriptOptions @@ -1055,22 +1241,43 @@ getExternalSetupMethod verbosity options pkg bt = do -- \| If the Setup.hs is out of date wrt the executable then recompile it. -- Currently this is GHC/GHCJS only. It should really be generalised. - compileSetupExecutable + compileSetupExecutable, compileCustomSetupExecutable, compileHooksExecutable :: SetupScriptOptions -> Version -> Maybe ComponentId -> Bool -> IO FilePath - compileSetupExecutable + compileCustomSetupExecutable opts ver mbCompId forceCompile + = compileSetupExecutableX "Setup" [setupHs] setupProgFile opts ver mbCompId forceCompile + compileHooksExecutable opts ver mbCompId forceCompile + = compileSetupExecutableX "SetupHooks" [setupHooks, hooksHs] hooksProgFile opts ver mbCompId forceCompile + compileSetupExecutable opts ver mbCompId forceCompile + = do + when (bt == Hooks) $ + void $ compileHooksExecutable opts ver mbCompId forceCompile + compileCustomSetupExecutable opts ver mbCompId forceCompile + + compileSetupExecutableX + :: String + -> [SymbolicPath Pkg File] -- input files + -> SymbolicPath Pkg File -- output file + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath + compileSetupExecutableX + what + inPaths outPath options' cabalLibVersion maybeCabalLibInstalledPkgId forceCompile = do - setupHsNewer <- i setupHs `moreRecentFile` i setupProgFile + setupXHsNewer <- fmap or $ sequenceA $ fmap ( \ inPath -> i inPath `moreRecentFile` i outPath ) inPaths cabalVersionNewer <- i setupVersionFile `moreRecentFile` i setupProgFile - let outOfDate = setupHsNewer || cabalVersionNewer + let outOfDate = setupXHsNewer || cabalVersionNewer when (outOfDate || forceCompile) $ do - debug verbosity "Setup executable needs to be updated, compiling..." + debug verbosity $ what ++ " executable needs to be updated, compiling..." (compiler, progdb, options'') <- configureCompiler options' let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion (program, extraOpts) = @@ -1108,10 +1315,10 @@ getExternalSetupMethod verbosity options pkg bt = do -- --ghc-option=-v instead! ghcOptVerbosity = Flag (min verbosity normal) , ghcOptMode = Flag GhcModeMake - , ghcOptInputFiles = toNubListR [setupHs] - , ghcOptOutputFile = Flag $ setupProgFile - , ghcOptObjDir = Flag $ setupDir - , ghcOptHiDir = Flag $ setupDir + , ghcOptInputFiles = toNubListR inPaths + , ghcOptOutputFile = Flag outPath + , ghcOptObjDir = Flag setupDir + , ghcOptHiDir = Flag setupDir , ghcOptSourcePathClear = Flag True , ghcOptSourcePath = case bt of Custom -> toNubListR [sameDirectory] @@ -1146,7 +1353,7 @@ getExternalSetupMethod verbosity options pkg bt = do progdb ghcCmdLine hPutStr logHandle output - return $ i setupProgFile + return $ i outPath isCabalPkgId :: PackageIdentifier -> Bool isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" diff --git a/cabal-install/src/Distribution/Client/SourceFiles.hs b/cabal-install/src/Distribution/Client/SourceFiles.hs index 1166f333f3c..9e97af9a50b 100644 --- a/cabal-install/src/Distribution/Client/SourceFiles.hs +++ b/cabal-install/src/Distribution/Client/SourceFiles.hs @@ -81,7 +81,9 @@ needComponent pkg_descr comp = CBench bench -> needBenchmark pkg_descr bench needSetup :: Rebuild () -needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return () +needSetup = do + void $ findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] + void $ findFirstFileMonitored id ["SetupHooks.hs", "SetupHooks.lhs"] needLibrary :: PackageDescription -> Library -> Rebuild () needLibrary diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooks.hs new file mode 100644 index 00000000000..ab5e0c64ba6 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooks.hs @@ -0,0 +1,6 @@ +module SetupHooks where + +import Distribution.Simple.SetupHooks + +setupHooks = noSetupHooks + diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooksRecompilation.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooksRecompilation.cabal new file mode 100644 index 00000000000..f469abdb9e2 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooksRecompilation.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.14 +name: SetupHooksRecompilation +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Hooks +extra-doc-files: CHANGELOG.md + +custom-setup + setup-depends: base, Cabal, Cabal-syntax, Cabal-hooks + +library + exposed-modules: MyLib + build-depends: base >= 4.12 && < 5.0 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.test.hs new file mode 100644 index 00000000000..d91478dc30d --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.test.hs @@ -0,0 +1,17 @@ +import Test.Cabal.Prelude + +import System.Directory ( doesFileExist ) + +main = cabalTest $ do + env <- getTestEnv + case testPackageDbPath env of + Nothing -> skip "Cabal-hooks library unavailable." + Just _pkgdb -> recordMode DoNotRecord $ do + cabal "v2-build" [] + let setupHooksPath = testCurrentDir env "SetupHooks.hs" + setupHooksExists <- liftIO $ doesFileExist setupHooksPath + unless setupHooksExists $ + error "Broken test: tried to write to a SetupHooks.hs file that doesn't exist." + liftIO $ appendFile setupHooksPath "this should fail to compile!" + -- If this doesn't fail, it's because we didn't re-build. + fails $ cabal "v2-build" [] diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/src/MyLib.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/src/MyLib.hs new file mode 100644 index 00000000000..e657c4403f6 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/cabal-testsuite/main/cabal-tests.hs b/cabal-testsuite/main/cabal-tests.hs index f27ea9b6094..c61ce9c8a68 100644 --- a/cabal-testsuite/main/cabal-tests.hs +++ b/cabal-testsuite/main/cabal-tests.hs @@ -143,7 +143,7 @@ buildCabalLibsProject projString verb mbGhc dir = do , "--project-file=" ++ dir "cabal.project-test" , "build" , "-w", programPath ghc - , "Cabal", "Cabal-syntax", "Cabal-hooks" + , "Cabal", "Cabal-syntax", "Cabal-hooks", "hooks-exe" ] ) { progInvokeCwd = Just dir }) -- Determine the path to the packagedb in the store for this ghc version @@ -178,7 +178,8 @@ buildCabalLibsSpecific ver verb mbGhc builddir_rel = do buildCabalLibsIntree :: String -> Verbosity -> Maybe FilePath -> FilePath -> IO [FilePath] buildCabalLibsIntree root verb mbGhc builddir_rel = do dir <- canonicalizePath (builddir_rel "intree") - buildCabalLibsProject ("packages: " ++ root "Cabal" ++ " " ++ root "Cabal-syntax" ++ " " ++ root "Cabal-hooks") verb mbGhc dir + let libs = [ "Cabal", "Cabal-syntax", "Cabal-hooks", "hooks-exe" ] + buildCabalLibsProject ("packages: " ++ unwords ( map ( root ) libs ) ) verb mbGhc dir main :: IO () main = do diff --git a/cabal.bootstrap.project b/cabal.bootstrap.project index 845a3fca7fd..691c567fe29 100644 --- a/cabal.bootstrap.project +++ b/cabal.bootstrap.project @@ -1,12 +1,8 @@ -packages: - Cabal - , Cabal-syntax - , Cabal-hooks - , cabal-install - , cabal-install-solver +import: project-cabal/pkgs/cabal.config +import: project-cabal/pkgs/install.config -- Don't include tests or benchmarks for bootstrapping tests: False benchmarks: False -index-state: hackage.haskell.org 2024-04-22T06:16:57Z +index-state: hackage.haskell.org 2024-04-29T14:30:15Z diff --git a/cabal.release.project b/cabal.release.project index 3d73d2f19a1..dd5f0b87dd8 100644 --- a/cabal.release.project +++ b/cabal.release.project @@ -2,4 +2,4 @@ import: project-cabal/pkgs/cabal.config import: project-cabal/pkgs/install.config import: project-cabal/pkgs/tests.config -index-state: hackage.haskell.org 2024-04-22T06:16:57Z +index-state: hackage.haskell.org 2024-04-29T14:30:15Z diff --git a/hooks-exe/changelog.md b/hooks-exe/changelog.md new file mode 100644 index 00000000000..0248669336a --- /dev/null +++ b/hooks-exe/changelog.md @@ -0,0 +1,6 @@ +# Changelog for `Cabal-hooks` + +## 0.1 – January 2024 + + * Initial release of `Hooks` integration for `cabal-install`. + diff --git a/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe.hs b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe.hs new file mode 100644 index 00000000000..a0a39cd4edc --- /dev/null +++ b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{- HLINT ignore "Use curry" -} + +module Distribution.Client.SetupHooks.CallHooksExe + ( callHooksExe + , externalSetupHooks + , externalSetupHooksABI + , buildTypeSetupHooks + , buildTypePreBuildHooks + , runExternalPreBuildRules + , hooksProgFilePath + ) where + +-- base +import GHC.Stack + +-- bytestring +import Data.ByteString.Lazy as LBS + ( hGetContents + , hPut + , null + ) + +-- process +import qualified System.Process as P +import System.Process.CommunicationHandle + ( readCreateProcessWithExitCodeCommunicationHandle ) + +-- filepath +import System.FilePath + ( (), (<.>) ) + +-- Cabal +import Distribution.Compat.Prelude +import qualified Distribution.Compat.Binary as Binary +import Distribution.Simple + ( autoconfSetupHooks ) +import Distribution.Simple.BuildPaths + ( exeExtension ) +import Distribution.Simple.SetupHooks.Internal +import Distribution.Simple.SetupHooks.Rule +import Distribution.Simple.Utils + ( dieWithException ) +import Distribution.System + ( buildPlatform ) +import Distribution.Types.BuildType + ( BuildType(..) ) +import Distribution.Utils.Path + ( CWD + , Dist + , Pkg + , SymbolicPath + , FileOrDir(..) + , interpretSymbolicPath + ) +import qualified Distribution.Verbosity as Verbosity + +-- hooks-cli +import Distribution.Client.SetupHooks.CallHooksExe.Errors +import Distribution.Client.SetupHooks.Version + ( HooksVersion ) + +-------------------------------------------------------------------------------- + +type HookIO inputs outputs = + ( HasCallStack + , Typeable inputs, Typeable outputs + , Binary inputs, Binary outputs + ) + +-- | Call an external hooks executable in order to execute a Cabal Setup hook. +callHooksExe + :: forall inputs outputs + . HookIO inputs outputs + => FilePath -- ^ path to hooks executable + -> String -- ^ name of the hook to run + -> inputs -- ^ argument to the hook + -> IO outputs +callHooksExe hooksExe hookName input = do + (ex, output) <- + -- The arguments to the external hooks executable are: + -- + -- 1. Input handle, from which the hooks executable receives its input. + -- 2. Output handle, to which the hooks executable writes its output. + -- 3. The hook type to run. + -- + -- The hooks executable will read input from the input handle, decode it, + -- run the necessary hook, producing a result which it encodes and writes + -- to the output handle. + readCreateProcessWithExitCodeCommunicationHandle + ( \(theyRead, theyWrite) -> P.proc hooksExe [show theyRead, show theyWrite, hookName] ) + ( \ hWeRead -> hGetContents hWeRead ) + ( \ hWeWrite -> do + let i = Binary.encode input + unless (LBS.null i) $ + hPut hWeWrite i + ) + case ex of + ExitFailure exitCode -> + dieWithException Verbosity.normal $ + HookFailed hookName $ + HookException exitCode + ExitSuccess -> do + let mbOutput = Binary.decodeOrFail output + case mbOutput of + Left (_, offset, err) -> do + dieWithException Verbosity.normal $ + HookFailed hookName $ + CouldNotDecodeOutput output offset err + Right (_, _, res) -> return res + +-- | Construct a 'SetupHooks' that runs the hooks of the external hooks executable +-- at the given path through the CLI. +-- +-- This should only be used at the final step of compiling a package, when we +-- have all the hooks in hand. The SetupHooks that are returned by this function +-- cannot be combined with any other SetupHooks; they must directly be used to +-- build the package. +externalSetupHooks :: FilePath -> SetupHooks +externalSetupHooks hooksExe = + SetupHooks + { configureHooks = + ConfigureHooks + { preConfPackageHook = Just $ hook "preConfPackage" + , postConfPackageHook = Just $ hook "postConfPackage" + , preConfComponentHook = Just $ hook "preConfComponent" + } + , buildHooks = + BuildHooks + { -- NB: external pre-build rules are special, due to the StaticPtr machinery. + -- To invoke them, we must separately call 'runExternalPreBuildRules'. + preBuildComponentRules = Nothing + , postBuildComponentHook = Just $ hook "postBuildComponent" + } + , installHooks = + InstallHooks + { installComponentHook = Just $ hook "installComponent" + } + } + where + hook :: HookIO inputs outputs => String -> inputs -> IO outputs + hook = callHooksExe hooksExe + +-- | The ABI of an external hooks executable. +-- +-- This information is used to handshake before further communication, +-- in order to avoid a cascade of errors with mismatched 'Binary' instances. +externalSetupHooksABI :: FilePath -> IO HooksVersion +externalSetupHooksABI hooksExe = + callHooksExe hooksExe "version" () + +-- | The 'SetupHooks' associated to a particular 'BuildType'. +-- +-- **Warning:** for @build-type: Hooks@, this does not include the pre-build +-- hooks. Those can be retrieved with 'buildTypePreBuildHooks'. +buildTypeSetupHooks + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> BuildType + -> SetupHooks +buildTypeSetupHooks mbWorkDir distPref = \case + Hooks -> externalSetupHooks $ hooksProgFilePath mbWorkDir distPref + Configure -> autoconfSetupHooks + _ -> noSetupHooks + -- SetupHooks TODO: if any built-in functionality is implemented using SetupHooks, + -- we would also need to include those. + +-- | The pre-build hooks obtained by communication with an external hooks executable. +buildTypePreBuildHooks + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> BuildType + -> ( PreBuildComponentInputs -> IO [MonitorFilePath] ) +buildTypePreBuildHooks mbWorkDir distPref = \ case + Hooks -> runExternalPreBuildRules $ hooksProgFilePath mbWorkDir distPref + _ -> \ _pbci -> return [] + -- SetupHooks TODO: if any built-in functionality is implemented using pre-build hooks, + -- we would also need to include those (for example, pre-processors such as hsc2hs). + +-- | Run all pre-build rules coming from an external hooks executable at the +-- given filepath. +-- +-- TODO: in the future, we will want to keep track of the dependency graph ourselves, +-- and when re-building, only re-build what we need (instead of re-running all rules). +runExternalPreBuildRules :: FilePath -> PreBuildComponentInputs -> IO [MonitorFilePath] +runExternalPreBuildRules hooksExe + pbci@PreBuildComponentInputs + { buildingWhat = what + , localBuildInfo = lbi + , targetInfo = tgt } = do + let verbosity = buildingWhatVerbosity what + -- Here we make sure to use 'RuleBinary' (@'Scope' == 'System'@) + -- to avoid looking up static pointer keys from the hooks executable + -- from the outside (e.g. from within cabal-install). + (rulesMap :: Map RuleId RuleBinary, monitors) <- hook "preBuildRules" pbci + executeRulesUserOrSystem + SSystem + ( \ rId cmd -> case cmd of + StaticRuleCommand {} -> return Nothing + DynamicRuleCommands {} -> hook "runPreBuildRuleDeps" (rId, cmd) + ) + ( \ rId cmd -> hook "runPreBuildRule" (rId, cmd) ) + verbosity lbi tgt rulesMap + return monitors + where + hook :: HookIO inputs outputs => String -> inputs -> IO outputs + hook = callHooksExe hooksExe + +-- | The path to the external hooks executable. +hooksProgFilePath + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> FilePath +hooksProgFilePath mbWorkDir distPref = + interpretSymbolicPath mbWorkDir distPref + "setup" + "hooks" + <.> exeExtension buildPlatform diff --git a/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe/Errors.hs b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe/Errors.hs new file mode 100644 index 00000000000..a890b09d802 --- /dev/null +++ b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe/Errors.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + +module Distribution.Client.SetupHooks.CallHooksExe.Errors + ( HookInput(..) + , SetupHooksCallExeException (..) + , HookFailedReason(..) + , setupHooksCallExeExceptionCode + , setupHooksCallExeExceptionMessage + ) where + +-- Cabal +import Distribution.Compat.Binary + ( Binary ) +import Distribution.Simple.Utils + +-- base +import GHC.Exception +import Data.Typeable + ( Typeable ) +import GHC.Int + ( Int64 ) + +-- bytestring +import Data.ByteString.Lazy + ( ByteString ) + +-------------------------------------------------------------------------------- + +data HookInput where + HookInput :: (Binary input, Typeable input, Show input) + => input -> HookInput +instance Show HookInput where + show (HookInput input) = show input + +data SetupHooksCallExeException + = HookFailed + String + -- ^ hook name + HookFailedReason + -- ^ why did the hook fail? + deriving Show + +data HookFailedReason + -- | The hooks executable terminated with non-zero exit code. + = HookException + Int -- ^ exit code + -- | We failed to decode the output of the hooks executable. + | CouldNotDecodeOutput + ByteString + -- ^ hook output that we failed to decode + Int64 + -- ^ byte offset at which the decoding error took place + String + -- ^ info about the decoding error + deriving Show + +setupHooksCallExeExceptionCode :: SetupHooksCallExeException -> Int +setupHooksCallExeExceptionCode = \case + HookFailed _ reason -> setupHooksCallExeFailedExceptionCode reason + +setupHooksCallExeFailedExceptionCode :: HookFailedReason -> Int +setupHooksCallExeFailedExceptionCode = \case + HookException {} -> 7717 + CouldNotDecodeOutput {} -> 5412 + +setupHooksCallExeExceptionMessage :: SetupHooksCallExeException -> String +setupHooksCallExeExceptionMessage = \case + HookFailed hookName reason -> + setupHooksCallExeFailedMessage hookName reason + +setupHooksCallExeFailedMessage :: String -> HookFailedReason -> String +setupHooksCallExeFailedMessage hookName = \case + HookException {} -> + "An exception occurred when running the " ++ hookName ++ " hook." + CouldNotDecodeOutput _bytes offset err -> + "Failed to decode the output of the " ++ hookName ++ " hook.\n\ + \Decoding failed at position " ++ show offset ++ " with error: " ++ err ++ ".\n\ + \This could be due to a mismatch between the Cabal version of cabal-install and of the hooks executable." + +instance Exception (VerboseException SetupHooksCallExeException) where + displayException (VerboseException stack timestamp verb err) = + withOutputMarker + verb + ( concat + [ "Error: [Cabal-" + , show (setupHooksCallExeExceptionCode err) + , "]\n" + ] + ) + ++ exceptionWithMetadata stack timestamp verb (setupHooksCallExeExceptionMessage err) diff --git a/hooks-exe/exe/Distribution/Client/SetupHooks/Errors.hs b/hooks-exe/exe/Distribution/Client/SetupHooks/Errors.hs new file mode 100644 index 00000000000..7ddbe2a58e9 --- /dev/null +++ b/hooks-exe/exe/Distribution/Client/SetupHooks/Errors.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE InstanceSigs #-} + +module Distribution.Client.SetupHooks.HooksExe.Errors + ( SetupHooksExeException (..) + , BadHooksExecutableArgs (..) + , setupHooksExeExceptionCode + , setupHooksExeExceptionMessage + ) where + +import Distribution.Simple.SetupHooks.Rule (RuleId (..)) +import Distribution.Simple.Utils +import GHC.Exception + +import Data.ByteString.Lazy (ByteString) + +data SetupHooksExeException + = -- | Missing hook type. + NoHookType + | -- | Could not parse communication handle. + NoHandle (Maybe String) + | -- | Incorrect arguments passed to the hooks executable. + BadHooksExeArgs + String + -- ^ hook name + BadHooksExecutableArgs + deriving (Show) + +-- | An error describing an invalid argument passed to an external +-- hooks executable compiled from the @SetupHooks@ module of a package with +-- Hooks build-type. +data BadHooksExecutableArgs + = -- | User queried the external hooks executable with an unknown hook type. + UnknownHookType + { knownHookTypes :: [String] } + | -- | The hooks executable failed to decode the input passed to + -- a particular hook. + CouldNotDecode + { couldNotDecodeWhat :: String + -- ^ A description of what it is that we failed to decode. + , couldNotDecodeData :: ByteString + -- ^ The actual data that we failed to decode. + } + | -- | The rule does not have a dynamic dependency computation. + NoDynDepsCmd RuleId + deriving (Show) + +setupHooksExeExceptionCode :: SetupHooksExeException -> Int +setupHooksExeExceptionCode = \case + NoHookType -> 7982 + NoHandle {} -> 8811 + BadHooksExeArgs _ rea -> + badHooksExeArgsCode rea + +setupHooksExeExceptionMessage :: SetupHooksExeException -> String +setupHooksExeExceptionMessage = \case + NoHookType -> + "Missing argument to Hooks executable.\n\ + \Expected three arguments: input and output communication handles, and hook type." + NoHandle Nothing -> + "Missing argument to Hooks executable.\n\ + \Expected three arguments: input and output communication handles, and hook type." + NoHandle (Just h) -> + "Invalid " ++ what ++ " passed to Hooks executable." + BadHooksExeArgs hookName reason -> + badHooksExeArgsMessage hookName reason + +badHooksExeArgsCode :: BadHooksExecutableArgs -> Int +badHooksExeArgsCode = \case + UnknownHookType{} -> 4229 + CouldNotDecode {} -> 9121 + NoDynDepsCmd{} -> 3231 + +badHooksExeArgsMessage :: String -> BadHooksExecutableArgs -> String +badHooksExeArgsMessage hookName = \case + UnknownHookType knownHookNames -> + "Unknown hook type " + ++ hookName + ++ ".\n\ + \Known hook types are: " + ++ show knownHookNames + ++ "." + CouldNotDecode { couldNotDecodeWhat = what } -> + "Failed to decode " ++ what ++ " of " ++ hookName ++ " hook.\n\ + \This could be due to a mismatch between the Cabal version of cabal-install and of the hooks executable." + NoDynDepsCmd rId -> + unlines $ + [ "Unexpected rule " <> show rId <> " in" <> hookName + , "The rule does not have an associated dynamic dependency computation." + ] + +instance Exception (VerboseException SetupHooksExeException) where + displayException :: VerboseException SetupHooksExeException -> String + displayException (VerboseException stack timestamp verb err) = + withOutputMarker + verb + ( concat + [ "Error: [Cabal-" + , show (setupHooksExeExceptionCode err) + , "]\n" + ] + ) + ++ exceptionWithMetadata stack timestamp verb (setupHooksExeExceptionMessage err) diff --git a/hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe.hs b/hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe.hs new file mode 100644 index 00000000000..821a9cc805f --- /dev/null +++ b/hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Client.SetupHooks.HooksExe + ( hooksMain ) where + +-- base +import System.Environment + ( getArgs ) +import System.IO + ( Handle, hClose, hFlush ) + +-- bytestring +import Data.ByteString.Lazy as LBS + ( hGetContents + , hPutStr + , null + ) + +-- containers +import qualified Data.Map as Map + +-- process +import System.Process.CommunicationHandle + ( openCommunicationHandleRead + , openCommunicationHandleWrite + ) + +-- Cabal +import Distribution.Compat.Prelude +import qualified Distribution.Compat.Binary as Binary +import Distribution.Simple.SetupHooks.Internal +import Distribution.Simple.SetupHooks.Rule +import Distribution.Simple.Utils + ( dieWithException ) +import Distribution.Types.Component + ( componentName ) +import qualified Distribution.Types.LocalBuildConfig as LBC +import qualified Distribution.Verbosity as Verbosity + +-- hooks-exe +import Distribution.Client.SetupHooks.HooksExe.Errors + ( SetupHooksExeException(..) + , BadHooksExecutableArgs(..) + ) +import Distribution.Client.SetupHooks.Version + ( hooksVersion ) + +-------------------------------------------------------------------------------- + +-- | Create a hooks executable given 'SetupHooks': +-- +-- - the first two argument are references to input & output communication +-- handles, +-- - the second argument is the hook type. +-- +-- The hook reads binary data passed to it over the input handle, decodes it, +-- runs the hook, and encodes its result to binary, writing the result to the +-- output handle. +hooksMain :: SetupHooks -> IO () +hooksMain setupHooks = do + args <- getArgs + case args of + -- First two arguments are references to read/write handles the hooks executable should use. + inputFdRef : outputFdRef : hooksExeArgs -> do + hReadMb <- traverse openCommunicationHandleRead $ readMaybe inputFdRef + hWriteMb <- traverse openCommunicationHandleWrite $ readMaybe outputFdRef + case hReadMb of + Nothing -> + dieWithException Verbosity.normal $ + NoHandle (Just $ "hook input communication handle '" ++ inputFdRef ++ "'") + Just hRead -> + case hWriteMb of + Nothing -> + dieWithException Verbosity.normal $ + NoHandle (Just $ "hook output communication handle '" ++ outputFdRef ++ "'") + Just hWrite -> + -- Third argument is the hook to run. + case hooksExeArgs of + hookName : _ -> + case lookup hookName allHookHandlers of + Just handleAction -> + handleAction (hRead, hWrite) setupHooks + Nothing -> + dieWithException Verbosity.normal $ + BadHooksExeArgs hookName $ + UnknownHookType + { knownHookTypes = map fst allHookHandlers + } + _ -> dieWithException Verbosity.normal NoHookType + _ -> dieWithException Verbosity.normal $ + NoHandle Nothing + where + allHookHandlers = + [ (nm, action) + | HookHandler + { hookName = nm + , hookHandler = action + } <- + hookHandlers + ] + +-- | Implementation of a particular hook in a separate hooks executable, +-- which communicates through the given 'Handle's. +runHookHandle + :: forall inputs outputs + . (Binary inputs, Binary outputs) + => (Handle, Handle) + -- ^ Input/output communication handles + -> String + -- ^ Hook name + -> (inputs -> IO outputs) + -- ^ Hook to run + -- + -- Inputs are passed via the input handle, and outputs are written to the + -- output handle. + -> IO () +runHookHandle (hRead, hWrite) hookName hook = do + inputsData <- LBS.hGetContents hRead + let mb_inputs = Binary.decodeOrFail inputsData + case mb_inputs of + Left (_, offset, err) -> + dieWithException Verbosity.normal $ + BadHooksExeArgs hookName $ + CouldNotDecodeInput inputsData offset err + Right (_, _, inputs) -> do + output <- hook inputs + let outputData = Binary.encode output + unless (LBS.null outputData) $ + LBS.hPutStr hWrite outputData + hFlush hWrite + hClose hWrite + +data HookHandler = HookHandler + { hookName :: !String + , hookHandler :: (Handle, Handle) -> SetupHooks -> IO () + } + +hookHandlers :: [HookHandler] +hookHandlers = + [ let hookName = "version" + in HookHandler hookName $ \h _ -> + -- Print the API version and ABI hash for the hooks executable. + runHookHandle h hookName $ \ () -> + return $ hooksVersion + , let hookName = "preConfPackage" + noHook (PreConfPackageInputs{localBuildConfig = lbc}) = + return $ + PreConfPackageOutputs + { buildOptions = LBC.withBuildOptions lbc + , extraConfiguredProgs = Map.empty + } + in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) -> + -- Run the package-wide pre-configure hook. + runHookHandle h hookName $ fromMaybe noHook preConfPackageHook + , let hookName = "postConfPackage" + noHook _ = return () + in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) -> + -- Run the package-wide post-configure hook. + runHookHandle h hookName $ fromMaybe noHook postConfPackageHook + , let hookName = "preConfComponent" + noHook (PreConfComponentInputs{component = c}) = + return $ PreConfComponentOutputs{componentDiff = emptyComponentDiff $ componentName c} + in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) -> + -- Run a per-component pre-configure hook; the choice of component + -- is determined by the input passed to the hook. + runHookHandle h hookName $ fromMaybe noHook preConfComponentHook + , let hookName = "preBuildRules" + in HookHandler hookName $ \h (SetupHooks{buildHooks = BuildHooks{..}}) -> + -- Return all pre-build rules. + runHookHandle h hookName $ \preBuildInputs -> + case preBuildComponentRules of + Nothing -> return (Map.empty, []) + Just pbcRules -> + computeRules Verbosity.normal preBuildInputs pbcRules + , let hookName = "runPreBuildRuleDeps" + in HookHandler hookName $ \h _ -> + -- Run the given pre-build rule dependency computation. + runHookHandle h hookName $ \(ruleId, ruleDeps) -> + case runRuleDynDepsCmd ruleDeps of + Nothing -> dieWithException Verbosity.normal $ BadHooksExeArgs hookName $ NoDynDepsCmd ruleId + Just getDeps -> getDeps + , let hookName = "runPreBuildRule" + in HookHandler hookName $ \h _ -> + -- Run the given pre-build rule. + runHookHandle h hookName $ \(_ruleId :: RuleId, rExecCmd) -> + runRuleExecCmd rExecCmd + , let hookName = "postBuildComponent" + noHook _ = return () + in HookHandler hookName $ \h (SetupHooks{buildHooks = BuildHooks{..}}) -> + -- Run the per-component post-build hook. + runHookHandle h hookName $ fromMaybe noHook postBuildComponentHook + , let hookName = "installComponent" + noHook _ = return () + in HookHandler hookName $ \h (SetupHooks{installHooks = InstallHooks{..}}) -> + -- Run the per-component copy/install hook. + runHookHandle h hookName $ fromMaybe noHook installComponentHook + ] diff --git a/hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe/Errors.hs b/hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe/Errors.hs new file mode 100644 index 00000000000..3e257c47185 --- /dev/null +++ b/hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe/Errors.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE InstanceSigs #-} + +module Distribution.Client.SetupHooks.HooksExe.Errors + ( SetupHooksExeException (..) + , BadHooksExecutableArgs (..) + , setupHooksExeExceptionCode + , setupHooksExeExceptionMessage + ) where + +-- Cabal +import Distribution.Simple.SetupHooks.Rule + ( RuleId (..) ) +import Distribution.Simple.Utils + +-- base +import GHC.Exception +import GHC.Int + ( Int64 ) + +-- bytestring +import Data.ByteString.Lazy + ( ByteString ) + +-------------------------------------------------------------------------------- + +data SetupHooksExeException + = -- | Missing hook type. + NoHookType + | -- | Could not parse communication handle. + NoHandle (Maybe String) + | -- | Incorrect arguments passed to the hooks executable. + BadHooksExeArgs + String + -- ^ hook name + BadHooksExecutableArgs + deriving (Show) + +-- | An error describing an invalid argument passed to an external +-- hooks executable compiled from the @SetupHooks@ module of a package with +-- Hooks build-type. +data BadHooksExecutableArgs + = -- | User queried the external hooks executable with an unknown hook type. + UnknownHookType + { knownHookTypes :: [String] } + | -- | The hooks executable failed to decode the input passed to + -- a particular hook. + CouldNotDecodeInput + ByteString + -- ^ hook input that we failed to decode + Int64 + -- ^ byte offset at which the decoding error took place + String + -- ^ info about the decoding error + | -- | The rule does not have a dynamic dependency computation. + NoDynDepsCmd RuleId + deriving (Show) + +setupHooksExeExceptionCode :: SetupHooksExeException -> Int +setupHooksExeExceptionCode = \case + NoHookType -> 7982 + NoHandle {} -> 8811 + BadHooksExeArgs _ rea -> + badHooksExeArgsCode rea + +setupHooksExeExceptionMessage :: SetupHooksExeException -> String +setupHooksExeExceptionMessage = \case + NoHookType -> + "Missing argument to Hooks executable.\n\ + \Expected two arguments: communication handle and hook type." + NoHandle Nothing -> + "Missing argument to Hooks executable.\n\ + \Expected two arguments: communication handle and hook type." + NoHandle (Just h) -> + "Invalid handle reference passed to Hooks executable: '" ++ h ++ "'." + BadHooksExeArgs hookName reason -> + badHooksExeArgsMessage hookName reason + +badHooksExeArgsCode :: BadHooksExecutableArgs -> Int +badHooksExeArgsCode = \case + UnknownHookType{} -> 4229 + CouldNotDecodeInput {} -> 9121 + NoDynDepsCmd{} -> 3231 + +badHooksExeArgsMessage :: String -> BadHooksExecutableArgs -> String +badHooksExeArgsMessage hookName = \case + UnknownHookType knownHookNames -> + "Unknown hook type " + ++ hookName + ++ ".\n\ + \Known hook types are: " + ++ show knownHookNames + ++ "." + CouldNotDecodeInput _bytes offset err -> + "Failed to decode the input to the " ++ hookName ++ " hook.\n\ + \Decoding failed at position " ++ show offset ++ " with error: " ++ err ++ ".\n\ + \This could be due to a mismatch between the Cabal version of cabal-install and of the hooks executable." + NoDynDepsCmd rId -> + unlines $ + [ "Unexpected rule " <> show rId <> " in the " <> hookName <> " hook." + , "The rule does not have an associated dynamic dependency computation." + ] + +instance Exception (VerboseException SetupHooksExeException) where + displayException :: VerboseException SetupHooksExeException -> String + displayException (VerboseException stack timestamp verb err) = + withOutputMarker + verb + ( concat + [ "Error: [Cabal-" + , show (setupHooksExeExceptionCode err) + , "]\n" + ] + ) + ++ exceptionWithMetadata stack timestamp verb (setupHooksExeExceptionMessage err) diff --git a/hooks-exe/hooks-exe.cabal b/hooks-exe/hooks-exe.cabal new file mode 100644 index 00000000000..faf0b95c81f --- /dev/null +++ b/hooks-exe/hooks-exe.cabal @@ -0,0 +1,87 @@ +cabal-version: 3.0 +name: hooks-exe +version: 0.1 +copyright: 2024, Cabal Development Team +license: BSD-3-Clause +author: Cabal Development Team +maintainer: cabal-devel@haskell.org +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +synopsis: cabal-install integration for Hooks build-type +description: + Layer for integrating Hooks build-type with cabal-install +category: Distribution +build-type: Simple + +extra-source-files: + readme.md changelog.md + +common warnings + ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wincomplete-uni-patterns -Wincomplete-record-updates + if impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + if impl(ghc >=9.0) + -- Warning: even though introduced with GHC 8.10, -Wunused-packages + -- gives false positives with GHC 8.10. + ghc-options: -Wunused-packages + +-- Library that defines a hooks version, to ensure compatibility between the +-- hooks executable and the executable it communicates with. +library hooks-version + import: warnings + hs-source-dirs: version + visibility: public + + build-depends: + base + >= 4.10 && < 4.20, + Cabal-syntax, Cabal + + exposed-modules: Distribution.Client.SetupHooks.Version + default-language: Haskell2010 + +-- Library imported by cabal-install to interface with an external +-- hooks executable. +library hooks-cli + import: warnings + hs-source-dirs: cli + visibility: public + + build-depends: + base + >= 4.10 && < 4.20, + bytestring + >= 0.10.6.0 && < 0.13, + filepath + >= 1.4.0.0 && < 1.6 , + process + >= 1.6.20.0 && < 1.8 , + Cabal-syntax, Cabal, hooks-version + + exposed-modules: Distribution.Client.SetupHooks.CallHooksExe + other-modules: Distribution.Client.SetupHooks.CallHooksExe.Errors + + default-language: Haskell2010 + +-- Library used to create an external hooks executable +-- from a SetupHooks.hs module. +library + import: warnings + hs-source-dirs: exe + + build-depends: + base + >= 4.10 && < 4.20, + bytestring + >= 0.10.6.0 && < 0.13, + containers + >= 0.5.6.2 && < 0.8 , + process + >= 1.6.20.0 && < 1.8 , + Cabal-syntax, Cabal, hooks-version + + exposed-modules: Distribution.Client.SetupHooks.HooksExe + other-modules: Distribution.Client.SetupHooks.HooksExe.Errors + + default-language: + Haskell2010 diff --git a/hooks-exe/readme.md b/hooks-exe/readme.md new file mode 100644 index 00000000000..05614591214 --- /dev/null +++ b/hooks-exe/readme.md @@ -0,0 +1,4 @@ +# `hooks-exe` + +This library integrates `Cabal`'s `Hooks` build-type into `cabal-install`. +It is only meant to be used by `cabal-install`, not imported by users. diff --git a/hooks-exe/version/Distribution/Client/SetupHooks/Version.hs b/hooks-exe/version/Distribution/Client/SetupHooks/Version.hs new file mode 100644 index 00000000000..bfcc1db450d --- /dev/null +++ b/hooks-exe/version/Distribution/Client/SetupHooks/Version.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +module Distribution.Client.SetupHooks.Version + ( HooksVersion(..), hooksVersion ) + where + +-- base +import Data.Proxy + ( Proxy(Proxy) ) +import GHC.Generics + ( Generic ) + +-- Cabal-syntax +import Distribution.Compat.Binary + ( Binary ) +import Distribution.Types.Version + ( Version ) +import Distribution.Utils.Structured + ( Structured, MD5, structureHash ) + +-- Cabal +import Distribution.Simple.SetupHooks.Rule + ( RuleId, Rule, RuleBinary ) +import Distribution.Simple.SetupHooks.Internal + ( PreConfPackageInputs + , PreConfPackageOutputs, PostConfPackageInputs + , PreConfComponentInputs + , PreConfComponentOutputs + , PreBuildComponentInputs, PostBuildComponentInputs + , InstallComponentInputs + ) +import Distribution.Simple.Utils + ( cabalVersion ) +import Distribution.Types.LocalBuildInfo + ( LocalBuildInfo ) + +-------------------------------------------------------------------------------- + +-- | The version of the Hooks API in use. +-- +-- Used for handshake before beginning inter-process communication. +data HooksVersion = + HooksVersion + { hooksAPIVersion :: !Version + , cabalABIHash :: !MD5 + , hooksABIHash :: !MD5 + } + deriving stock ( Eq, Ord, Show, Generic ) + deriving anyclass Binary + +-- | The version of the Hooks API in use. +-- +-- Used for handshake before beginning inter-process communication. +hooksVersion :: HooksVersion +hooksVersion = HooksVersion + { hooksAPIVersion = cabalVersion + , cabalABIHash = structureHash $ Proxy @CabalABI + , hooksABIHash = structureHash $ Proxy @HooksABI + } + +-------------------------------------------------------------------------------- + +-- | This datatype keeps track of the parts of the Cabal API which are +-- relevant to its binary interface. +data CabalABI + = CabalABI + { cabalLocalBuildInfo :: LocalBuildInfo } + deriving stock Generic +deriving anyclass instance Structured CabalABI + +-- | This datatype keeps track of the parts of the Hooks API which are +-- relevant to its binary interface. +data HooksABI + = HooksABI + { confHooks :: ( ( PreConfPackageInputs, PreConfPackageOutputs ) + , PostConfPackageInputs + , ( PreConfComponentInputs, PreConfComponentOutputs ) ) + , buildHooks :: ( PreBuildComponentInputs, ( RuleId, Rule, RuleBinary ) + , PostBuildComponentInputs ) + , installHooks :: InstallComponentInputs + } + deriving stock Generic +deriving anyclass instance Structured HooksABI diff --git a/project-cabal/pkgs/install.config b/project-cabal/pkgs/install.config index 9010d1f332b..328b95385d4 100644 --- a/project-cabal/pkgs/install.config +++ b/project-cabal/pkgs/install.config @@ -1,3 +1,4 @@ packages: cabal-install , cabal-install-solver + , hooks-exe