diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 114c60a1add..5b98ad9438d 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -172,6 +172,15 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles = , hscolourHook = setup_hscolourHook } where + preBuildHook = + case SetupHooks.preBuildComponentRules (SetupHooks.buildHooks setupHooks) of + Nothing -> const $ return [] + Just pbcRules -> \pbci -> runPreBuildHooks verbHandles pbci pbcRules + postBuildHook = + case SetupHooks.postBuildComponentHook (SetupHooks.buildHooks setupHooks) of + Nothing -> const $ return () + Just hk -> hk + setup_confHook :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags @@ -189,13 +198,14 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles = -> BuildFlags -> IO () setup_buildHook pkg_descr lbi hooks flags = - build_setupHooks - (SetupHooks.buildHooks setupHooks) - verbHandles - pkg_descr - lbi - flags - (allSuffixHandlers hooks) + void $ + build_setupHooks + (preBuildHook, postBuildHook) + verbHandles + pkg_descr + lbi + flags + (allSuffixHandlers hooks) setup_copyHook :: PackageDescription @@ -230,14 +240,15 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles = -> [String] -> IO () setup_replHook pkg_descr lbi hooks flags args = - repl_setupHooks - (SetupHooks.buildHooks setupHooks) - verbHandles - pkg_descr - lbi - flags - (allSuffixHandlers hooks) - args + void $ + repl_setupHooks + preBuildHook + verbHandles + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + args setup_haddockHook :: PackageDescription @@ -246,13 +257,14 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles = -> HaddockFlags -> IO () setup_haddockHook pkg_descr lbi hooks flags = - haddock_setupHooks - (SetupHooks.buildHooks setupHooks) - verbHandles - pkg_descr - lbi - (allSuffixHandlers hooks) - flags + void $ + haddock_setupHooks + preBuildHook + verbHandles + pkg_descr + lbi + (allSuffixHandlers hooks) + flags setup_hscolourHook :: PackageDescription @@ -261,13 +273,14 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles = -> HscolourFlags -> IO () setup_hscolourHook pkg_descr lbi hooks flags = - hscolour_setupHooks - (SetupHooks.buildHooks setupHooks) - verbHandles - pkg_descr - lbi - (allSuffixHandlers hooks) - flags + void $ + hscolour_setupHooks + preBuildHook + verbHandles + pkg_descr + lbi + (allSuffixHandlers hooks) + flags -- | A customizable version of 'defaultMain'. defaultMainWithHooks :: UserHooks -> IO () @@ -931,12 +944,13 @@ simpleUserHooksWithHandles verbHandles = , testHook = defaultTestHook verbHandles , benchHook = defaultBenchHook verbHandles , cleanHook = \p _ _ f -> clean verbHandles p f - , hscolourHook = \p l h f -> hscolour_setupHooks SetupHooks.noBuildHooks verbHandles p l (allSuffixHandlers h) f - , haddockHook = \p l h f -> haddock_setupHooks SetupHooks.noBuildHooks verbHandles p l (allSuffixHandlers h) f + , hscolourHook = \p l h f -> void $ hscolour_setupHooks noBuildHooks verbHandles p l (allSuffixHandlers h) f + , haddockHook = \p l h f -> void $ haddock_setupHooks noBuildHooks verbHandles p l (allSuffixHandlers h) f , regHook = defaultRegHook verbHandles , unregHook = \p l _ f -> unregisterWithHandles verbHandles p l f } where + noBuildHooks = const (pure []) finalChecks _args flags pkg_descr lbi = checkForeignDeps pkg_descr lbi (modifyVerbosityFlags lessVerbose verbosity) where @@ -1156,13 +1170,14 @@ defaultBuildHook -> BuildFlags -> IO () defaultBuildHook verbHandles pkg_descr localbuildinfo hooks flags = - build_setupHooks - SetupHooks.noBuildHooks - verbHandles - pkg_descr - localbuildinfo - flags - (allSuffixHandlers hooks) + void $ + build_setupHooks + (const $ return [], const $ pure ()) + verbHandles + pkg_descr + localbuildinfo + flags + (allSuffixHandlers hooks) defaultReplHook :: VerbosityHandles @@ -1173,14 +1188,15 @@ defaultReplHook -> [String] -> IO () defaultReplHook verbHandles pkg_descr localbuildinfo hooks flags args = - repl_setupHooks - SetupHooks.noBuildHooks - verbHandles - pkg_descr - localbuildinfo - flags - (allSuffixHandlers hooks) - args + void $ + repl_setupHooks + (const $ return []) + verbHandles + pkg_descr + localbuildinfo + flags + (allSuffixHandlers hooks) + args defaultRegHook :: VerbosityHandles diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 3e32d2ccfe5..073de95c9ce 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -25,6 +25,7 @@ module Distribution.Simple.Build ( -- * Build build , build_setupHooks + , buildComponent -- * Repl , repl @@ -33,6 +34,7 @@ module Distribution.Simple.Build -- * Build preparation , preBuildComponent + , runPreBuildHooks , AutogenFile (..) , AutogenFileContents , writeBuiltinAutogenFiles @@ -105,9 +107,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 @@ -143,10 +144,16 @@ build -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> IO () -build = build_setupHooks noBuildHooks defaultVerbosityHandles +build pkg lbi flags pps = + void $ build_setupHooks noHooks defaultVerbosityHandles pkg lbi flags pps + where + noHooks = (const $ return [], const $ return ()) build_setupHooks - :: BuildHooks + :: ( SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath] + , SetupHooks.PostBuildComponentInputs -> IO () + ) + -- ^ build hooks -> VerbosityHandles -> PackageDescription -- ^ Mostly information from the .cabal file @@ -156,14 +163,16 @@ 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) verbHandles pkg_descr lbi flags suffixHandlers = do + let verbosity = mkVerbosity verbHandles (fromFlag $ buildVerbosity flags) + distPref = fromFlag $ buildDistPref flags checkSemaphoreSupport verbosity (compiler lbi) flags targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) @@ -192,7 +201,7 @@ build_setupHooks curDir <- absoluteWorkingDirLBI lbi -- 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 @@ -204,18 +213,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 @@ -244,13 +243,10 @@ build_setupHooks , SetupHooks.localBuildInfo = lbi' , SetupHooks.targetInfo = target } - for_ mbPostBuild ($ postBuildInputs) - return (maybe index (`Index.insert` index) mb_ipi) + postBuildHook postBuildInputs + return (monsAcc <> mons, maybe index (`Index.insert` index) mb_ipi) - return () - where - distPref = fromFlag (buildDistPref flags) - verbosity = mkVerbosity verbHandles (fromFlag (buildVerbosity flags)) + return mons -- | Check for conditions that would prevent the build from succeeding. checkSemaphoreSupport @@ -333,11 +329,20 @@ repl -- ^ preprocessors to run before compiling -> [String] -> IO () -repl = repl_setupHooks noBuildHooks defaultVerbosityHandles +repl pkg lbi flags pps args = + void $ + repl_setupHooks + (const $ return []) + defaultVerbosityHandles + pkg + lbi + flags + pps + args repl_setupHooks - :: BuildHooks - -- ^ build hook + :: (SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath]) + -- ^ pre-build hook -> VerbosityHandles -> PackageDescription -- ^ Mostly information from the .cabal file @@ -348,9 +353,9 @@ repl_setupHooks -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> [String] - -> IO () + -> IO [SetupHooks.MonitorFilePath] repl_setupHooks - (BuildHooks{preBuildComponentRules = mbPbcRules}) + preBuildHook verbHandles pkg_descr lbi @@ -394,25 +399,16 @@ repl_setupHooks (componentBuildInfo comp) (withPrograms lbi') } - runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () - runPreBuildHooks lbi2 tgt = - let inputs = - SetupHooks.PreBuildComponentInputs - { SetupHooks.buildingWhat = BuildRepl flags - , SetupHooks.localBuildInfo = lbi2 - , SetupHooks.targetInfo = tgt - } - in for_ mbPbcRules $ \pbcRules -> do - (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules - SetupHooks.executeRules verbosity lbi2 tgt ruleFromId - - -- build any dependent components - sequence_ - [ do - let clbi = targetCLBI subtarget - comp = targetComponent subtarget - lbi' <- lbiForComponent comp lbi - preBuildComponent runPreBuildHooks verbosity lbi' subtarget + pbci lbi' tgt = SetupHooks.PreBuildComponentInputs (BuildRepl flags) lbi' tgt + + -- build any dependent components and collect their monitored file paths + depMonitors <- fmap concat $ for (safeInit componentsToBuild) $ \subtarget -> do + let clbi = targetCLBI subtarget + comp = targetComponent subtarget + lbi' <- lbiForComponent comp lbi + monitors <- preBuildComponent (preBuildHook (pbci lbi' subtarget)) verbosity lbi' subtarget + + _mb_ipi <- buildComponent verbHandles (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag $ verbosityFlags verbosity}}) @@ -423,16 +419,21 @@ repl_setupHooks comp clbi distPref - | subtarget <- safeInit componentsToBuild - ] + + return monitors -- REPL for target components let clbi = targetCLBI target comp = targetComponent target lbi' <- lbiForComponent comp lbi - preBuildComponent runPreBuildHooks verbosity lbi' target + + targetMonitors <- + preBuildComponent (preBuildHook (pbci lbi' target)) verbosity lbi' target + replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref + return (depMonitors <> targetMonitors) + -- | Start an interpreter without loading any package files. startInterpreter :: Verbosity @@ -1133,20 +1134,41 @@ 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 + +-- | Compute and execute 'PreBuildComponentRules', returning the monitored +-- files declared by the rules. +runPreBuildHooks + :: VerbosityHandles + -> SetupHooks.PreBuildComponentInputs + -> SetupHooks.PreBuildComponentRules + -> IO [SetupHooks.MonitorFilePath] +runPreBuildHooks + verbHandles + pbci@( SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = what + , SetupHooks.localBuildInfo = lbi + , SetupHooks.targetInfo = tgt + } + ) + pbcRules = do + let verbosity = mkVerbosity verbHandles $ buildingWhatVerbosity what + (rules, mons) <- SetupHooks.computeRules verbosity pbci pbcRules + SetupHooks.executeRules verbosity lbi tgt rules + return mons -- | 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 5d8ab963c7c..7f99b9a346d 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -33,6 +33,18 @@ module Distribution.Simple.Configure ( configure , configure_setupHooks + , computePackageInfo + , configureFinal + , runPreConfPackageHook + , runPostConfPackageHook + , runPreConfComponentHook + , configurePackage + , PackageInfo (..) + , mkProgramDb + , finalCheckPackage + , configureComponents + , mkPromisedDepsSet + , combinedConstraints , writePersistBuildConfig , getConfigStateFile , getPersistBuildConfig @@ -457,99 +469,208 @@ configure_setupHooks -> ConfigFlags -> IO LocalBuildInfo configure_setupHooks - (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook}) + confHooks@(ConfigureHooks{preConfPackageHook}) (g_pkg_descr, hookedBuildInfo) verbHandles cfg = do - -- Cabal pre-configure - let verbosity = mkVerbosity verbHandles (fromFlag (configVerbosity cfg)) - distPref = fromFlag $ configDistPref cfg - mbWorkDir = flagToMaybe $ configWorkingDir cfg (lbc0, comp, platform, enabledComps) <- preConfigurePackage verbHandles cfg g_pkg_descr -- 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) <- - finalizeAndConfigurePackage + (allConstraints, pkgInfo) <- + computePackageInfo verbHandles cfg lbc1 g_pkg_descr comp + (packageDbs, pkg_descr0, flags) <- + finalizePackageDescription verbHandles cfg - lbc1 g_pkg_descr comp platform enabledComps + allConstraints + pkgInfo - -- Package-wide post-configure hook - for_ postConfPackageHook $ \postConfPkg -> do - let input = - SetupHooks.PostConfPackageInputs - { SetupHooks.localBuildConfig = lbc2 - , SetupHooks.packageBuildDescr = pbd2 - } - postConfPkg input + configureFinal + verbHandles + confHooks + hookedBuildInfo + cfg + lbc1 + (g_pkg_descr, pkg_descr0) + flags + enabledComps + comp + platform + packageDbs + pkgInfo - -- 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 - ) - pkg_descr2 - let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr} +configureFinal + :: VerbosityHandles + -> ConfigureHooks + -> HookedBuildInfo + -> ConfigFlags + -> LBC.LocalBuildConfig + -> (GenericPackageDescription, PackageDescription) + -> FlagAssignment + -> ComponentRequestedSpec + -> Compiler + -> Platform + -> PackageDBStack + -> PackageInfo + -> IO LocalBuildInfo +configureFinal + verbHandles + (ConfigureHooks{postConfPackageHook, preConfComponentHook}) + hookedBuildInfo + cfg + lbc1 + (gpkgDescr, pkgDescr0) + flags + enabledComps + comp + platform + packageDbs + pkgInfo@PackageInfo + { installedPackageSet = installedPkgSet + , promisedDepsSet = promisedDeps + } = + do + let verbosity = mkVerbosity verbHandles (fromFlag (configVerbosity cfg)) + distPref = fromFlag $ configDistPref cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg - -- Cabal per-component configure - externalPkgDeps <- finalCheckPackage verbHandles g_pkg_descr pbd3 hookedBuildInfo pkg_info - lbi <- configureComponents verbHandles lbc2 pbd3 pkg_info externalPkgDeps + -- Cabal per-component configure + (lbc2, pbd2) <- + configurePackage verbHandles cfg lbc1 pkgDescr0 flags enabledComps comp platform packageDbs - writePersistBuildConfig mbWorkDir distPref lbi + -- Package-wide post-configure hook + for_ postConfPackageHook $ runPostConfPackageHook lbc2 pbd2 - return lbi + -- Per-component pre-configure hook + pkgDescr <- do + let pkgDescr2 = LBC.localPkgDescr pbd2 + applyComponentDiffs + verbosity + (for preConfComponentHook . runPreConfComponentHook lbc2 pbd2) + pkgDescr2 + let pbd3 = pbd2{LBC.localPkgDescr = pkgDescr} + + -- Cabal per-component configure + finalCheckPackage verbHandles gpkgDescr 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 <- + selectDependencies + verbosity + use_external_internal_deps + pkgInfo + pkgDescr + enabledComps + lbi <- configureComponents verbHandles lbc2 pbd3 installedPkgSet 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 :: VerbosityHandles @@ -842,18 +963,25 @@ computeLocalBuildConfig verbHandles 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) PromisedComponent + -- ^ 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 @@ -865,12 +993,12 @@ configurePackage -> ComponentRequestedSpec -> Compiler -> Platform - -> ProgramDb -> PackageDBStack -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr) -configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 packageDbs = do +configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform packageDbs = do let common = configCommonFlags cfg verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + programDb0 = LBC.withPrograms lbc0 -- add extra include/lib dirs as specified in cfg pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg @@ -930,7 +1058,7 @@ configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform pr defaultInstallDirs' use_external_internal_deps (compilerFlavor comp) - (fromFlag (configUserInstall cfg)) + (fromFlagOrDefault True (configUserInstall cfg)) (hasLibs pkg_descr2) let installDirs = @@ -959,16 +1087,14 @@ configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform pr return (lbc, pbd) -finalizeAndConfigurePackage +computePackageInfo :: VerbosityHandles -> ConfigFlags -> LBC.LocalBuildConfig -> GenericPackageDescription -> Compiler - -> Platform - -> ComponentRequestedSpec - -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr, PackageInfo) -finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabled = do + -> IO ([PackageVersionConstraint], PackageInfo) +computePackageInfo verbHandles cfg lbc0 g_pkg_descr comp = do let common = configCommonFlags cfg verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common @@ -978,7 +1104,7 @@ finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabl packageDbs :: PackageDBStack packageDbs = interpretPackageDbFlags - (fromFlag (configUserInstall cfg)) + (fromFlagOrDefault True (configUserInstall cfg)) (configPackageDBs cfg) -- The InstalledPackageIndex of all installed packages @@ -1023,13 +1149,36 @@ finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabl let promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg) - pkg_info = - PackageInfo + return + ( allConstraints + , PackageInfo { internalPackageSet , promisedDepsSet , installedPackageSet , requiredDepsMap } + ) + +finalizePackageDescription + :: VerbosityHandles + -> ConfigFlags + -> GenericPackageDescription + -> Compiler + -> Platform + -> ComponentRequestedSpec + -> [PackageVersionConstraint] + -> PackageInfo + -> IO (PackageDBStack, PackageDescription, FlagAssignment) +finalizePackageDescription verbHandles cfg g_pkg_descr comp platform enabled allConstraints pkgInfo = do + let common = configCommonFlags cfg + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + + -- What package database(s) to use + let packageDbs :: PackageDBStack + packageDbs = + interpretPackageDbFlags + (fromFlagOrDefault True (configUserInstall cfg)) + (configPackageDBs cfg) -- pkg_descr: The resolved package description, that does not contain any -- conditionals, because we have an assignment for @@ -1052,7 +1201,7 @@ finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabl ( pkg_descr0 :: PackageDescription , flags :: FlagAssignment ) <- - configureFinalizedPackage + finalizePackageDescription2 verbosity cfg enabled @@ -1062,28 +1211,12 @@ finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabl (fromFlagOrDefault False (configExactConfiguration cfg)) (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) (packageName g_pkg_descr) - installedPackageSet - internalPackageSet - promisedDepsSet - requiredDepsMap + pkgInfo ) comp platform g_pkg_descr - - (lbc, pbd) <- - configurePackage - verbHandles - cfg - lbc0 - pkg_descr0 - flags - enabled - comp - platform - programDb0 - packageDbs - return (lbc, pbd, pkg_info) + return (packageDbs, pkg_descr0, flags) addExtraIncludeLibDirsFromConfigFlags :: PackageDescription -> ConfigFlags -> PackageDescription @@ -1139,8 +1272,7 @@ finalCheckPackage -> GenericPackageDescription -> LBC.PackageBuildDescr -> HookedBuildInfo - -> PackageInfo - -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) + -> IO () finalCheckPackage verbHandles g_pkg_descr @@ -1152,16 +1284,11 @@ finalCheckPackage , componentEnabledSpec = enabled } ) - hookedBuildInfo - (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) = + hookedBuildInfo = do let common = configCommonFlags cfg verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) cabalFileDir = packageRoot common - use_external_internal_deps = - case enabled of - OneComponentRequestedSpec{} -> True - ComponentRequestedSpec{} -> False checkCompilerProblems verbosity comp pkg_descr enabled checkPackageProblems @@ -1182,7 +1309,7 @@ finalCheckPackage let langs = unsupportedLanguages comp langlist unless (null langs) $ dieWithException verbosity $ - UnsupportedLanguages (packageId g_pkg_descr) (compilerId comp) (map prettyShow langs) + UnsupportedLanguages (packageId pkg_descr) (compilerId comp) (map prettyShow langs) let extlist = nub $ concatMap @@ -1191,7 +1318,7 @@ finalCheckPackage let exts = unsupportedExtensions comp extlist unless (null exts) $ dieWithException verbosity $ - UnsupportedLanguageExtension (packageId g_pkg_descr) (compilerId comp) (map prettyShow exts) + UnsupportedLanguageExtension (packageId pkg_descr) (compilerId comp) (map prettyShow exts) -- Check foreign library build requirements let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] @@ -1200,42 +1327,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 :: VerbosityHandles -> LBC.LocalBuildConfig -> LBC.PackageBuildDescr - -> PackageInfo + -> InstalledPackageIndex + -> Map (PackageName, ComponentName) PromisedComponent -> ([PreExistingComponent], [ConfiguredPromisedComponent]) -> IO LocalBuildInfo configureComponents @@ -1248,7 +1345,8 @@ configureComponents , componentEnabledSpec = enabled } ) - (PackageInfo{promisedDepsSet, installedPackageSet}) + installedPackageSet + promisedDepsSet externalPkgDeps = do let common = configCommonFlags cfg @@ -1502,23 +1600,19 @@ dependencySatisfiable -> Bool -- ^ allow depending on private libs? -> PackageName - -> InstalledPackageIndex - -- ^ installed set - -> Set LibraryName - -- ^ library components - -> Map (PackageName, ComponentName) PromisedComponent - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required dependencies + -> PackageInfo -> (Dependency -> DependencySatisfaction) dependencySatisfiable use_external_internal_deps exact_config allow_private_deps pn - installedPackageSet - packageLibraries - promisedDeps - requiredDepsMap + PackageInfo + { internalPackageSet = packageLibraries + , promisedDepsSet = promisedDeps + , installedPackageSet + , requiredDepsMap + } (Dependency depName vr sublibs) | exact_config = -- When we're given '--exact-configuration', we assume that all @@ -1613,7 +1707,7 @@ dependencySatisfiable -- | Finalize a generic package description. -- -- The workhorse is 'finalizePD'. -configureFinalizedPackage +finalizePackageDescription2 :: Verbosity -> ConfigFlags -> ComponentRequestedSpec @@ -1625,7 +1719,7 @@ configureFinalizedPackage -> Platform -> GenericPackageDescription -> IO (PackageDescription, FlagAssignment) -configureFinalizedPackage +finalizePackageDescription2 verbosity cfg enabled @@ -1681,25 +1775,17 @@ checkCompilerProblems verbosity comp pkg_descr enabled = do $ dieWithException verbosity CompilerDoesn'tSupportBackpack -- | Select dependencies for the package. -configureDependencies +selectDependencies :: Verbosity -> UseExternalInternalDeps - -> Set LibraryName - -> Map (PackageName, ComponentName) PromisedComponent - -> InstalledPackageIndex - -- ^ installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required deps + -> PackageInfo -> PackageDescription -> ComponentRequestedSpec -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) -configureDependencies +selectDependencies verbosity use_external_internal_deps - packageLibraries - promisedDeps - installedPackageSet - requiredDepsMap + pkgInfo pkg_descr enableSpec = do let failedDeps :: [FailedDependency] @@ -1712,10 +1798,7 @@ configureDependencies , let status = selectDependency (package pkg_descr) - packageLibraries - promisedDeps - installedPackageSet - requiredDepsMap + pkgInfo use_external_internal_deps dep ] @@ -1969,15 +2052,7 @@ data DependencyResolution selectDependency :: PackageId -- ^ Package id of current package - -> Set LibraryName - -- ^ package libraries - -> Map (PackageName, ComponentName) PromisedComponent - -- ^ 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? @@ -1985,10 +2060,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 c1eece45c3f..d2983a0ddd3 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -99,6 +99,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.Modules (BuildWay (..)) import Distribution.Simple.GHC.Build.Utils diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs index e6e619fe8ce..d22645d5970 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Haddock.hs @@ -55,6 +55,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 @@ -67,12 +70,9 @@ import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Register import Distribution.Simple.Setup -import Distribution.Simple.SetupHooks.Internal - ( BuildHooks (..) - , noBuildHooks - ) 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 @@ -87,7 +87,6 @@ import qualified Distribution.Utils.ShortText as ShortText import Distribution.Verbosity import Distribution.Version -import Control.Monad import Data.Bool (bool) import Data.Either (lefts, rights) import System.Directory (doesDirectoryExist, doesFileExist) @@ -227,16 +226,25 @@ haddock -> [PPSuffixHandler] -> HaddockFlags -> IO () -haddock = haddock_setupHooks noBuildHooks defaultVerbosityHandles +haddock pkg lbi suffixHandlers flags = + void $ + haddock_setupHooks + (const $ return []) + defaultVerbosityHandles + pkg + lbi + suffixHandlers + flags haddock_setupHooks - :: BuildHooks + :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath]) + -- ^ pre-build hook -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags - -> IO () + -> IO [MonitorFilePath] haddock_setupHooks _ verbHandles @@ -248,13 +256,16 @@ haddock_setupHooks && not (fromFlag $ haddockExecutables haddockFlags) && not (fromFlag $ haddockTestSuites haddockFlags) && not (fromFlag $ haddockBenchmarks haddockFlags) - && not (fromFlag $ haddockForeignLibs haddockFlags) = - warn (mkVerbosity verbHandles $ fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ + && not (fromFlag $ haddockForeignLibs haddockFlags) = do + warn verb $ "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 [] + where + verb = mkVerbosity verbHandles $ fromFlag $ haddockVerbosity haddockFlags haddock_setupHooks - (BuildHooks{preBuildComponentRules = mbPbcRules}) + preBuildHook verbHandles pkg_descr lbi @@ -310,18 +321,19 @@ haddock_setupHooks -- support '--hyperlinked-sources'. let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] when using_hscolour $ - hscolour' - noBuildHooks - -- NB: we are not passing the user BuildHooks here, - -- because we are already running the pre/post build hooks - -- for Haddock. - verbHandles - (warn verbosity) - haddockTarget - pkg_descr - lbi - suffixes - (defaultHscolourFlags `mappend` haddockToHscolour flags) + void $ + hscolour' + (const $ return []) + -- NB: we are not passing the user BuildHooks here, + -- because we are already running the pre/post build hooks + -- for Haddock. + verbHandles + (warn verbosity) + haddockTarget + pkg_descr + lbi + suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags) @@ -334,7 +346,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 curDir <- absoluteWorkingDirLBI lbi let component = targetComponent target @@ -349,21 +361,11 @@ haddock_setupHooks , 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 + pbci = SetupHooks.PreBuildComponentInputs (BuildHaddock flags) lbi' target -- See Note [Hi Haddock Recompilation Avoidance] reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version $ \haddockArtifactsDirs -> do - preBuildComponent runPreBuildHooks verbosity 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 @@ -533,7 +535,7 @@ haddock_setupHooks benchArgs return index - return ipi + return (monsAcc ++ mons, ipi) for_ (extraDocFiles pkg_descr) $ \fpath -> do files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath @@ -541,6 +543,8 @@ haddock_setupHooks for_ files $ copyFileToCwd verbosity mbWorkDir (unDir targetDir) + return mons + -- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build -- index and contents for documentation of multiple packages. createHaddockIndex @@ -1471,21 +1475,31 @@ hscolour -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour = hscolour_setupHooks noBuildHooks defaultVerbosityHandles +hscolour pkg lbi pps flags = + void $ + hscolour_setupHooks + (const $ return []) + defaultVerbosityHandles + pkg + lbi + pps + flags hscolour_setupHooks - :: BuildHooks + :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath]) + -- ^ pre-build hook -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags - -> IO () -hscolour_setupHooks setupHooks verbHandles = - hscolour' setupHooks verbHandles dieNoVerbosity ForDevelopment + -> IO [MonitorFilePath] +hscolour_setupHooks preBuildHook verbHandles = + hscolour' preBuildHook verbHandles dieNoVerbosity ForDevelopment hscolour' - :: BuildHooks + :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath]) + -- ^ pre-build hook -> VerbosityHandles -> (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. @@ -1494,9 +1508,9 @@ hscolour' -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags - -> IO () + -> IO [MonitorFilePath] hscolour' - (BuildHooks{preBuildComponentRules = mbPbcRules}) + preBuildHook verbHandles onNoHsColour haddockTarget @@ -1504,13 +1518,16 @@ hscolour' lbi suffixes flags = - either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg) + either noHsColourPath (\(hscolourProg, _, _) -> go hscolourProg) =<< lookupProgramVersion verbosity hscolourProgram (orLaterVersion (mkVersion [1, 8])) (withPrograms lbi) where + noHsColourPath excep = do + onNoHsColour $ exceptionMessage excep + return [] common = hscolourCommonFlags flags verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) distPref = fromFlag $ setupDistPref common @@ -1519,7 +1536,7 @@ hscolour' u :: SymbolicPath Pkg to -> FilePath u = interpretSymbolicPathCWD - go :: ConfiguredProgram -> IO () + go :: ConfiguredProgram -> IO [MonitorFilePath] go hscolourProg = do warn verbosity $ "the 'cabal hscolour' command is deprecated in favour of 'cabal " @@ -1531,23 +1548,22 @@ hscolour' i $ 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 targets = allTargetsInBuildOrder' pkg_descr lbi + + -- 'foldM' with arguments flipped for readability + forFoldM acc xs f = foldM f acc xs + + forFoldM [] targets $ \monsAcc target -> do + let + comp = targetComponent target + clbi = targetCLBI target + pbci = SetupHooks.PreBuildComponentInputs (BuildHscolour flags) lbi target + + mons <- preBuildComponent (preBuildHook pbci) verbosity lbi target preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + let - doExe com = case (compToExe com) of + doExe com = case compToExe com of Just exe -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr @@ -1556,6 +1572,8 @@ hscolour' Nothing -> do warn verbosity "Unsupported component, skipping..." return () + + -- Execute the component-specific hscolour actions case comp of CLib lib -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr makeRelativePathEx "src" @@ -1572,6 +1590,8 @@ hscolour' CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + return (monsAcc <> mons) + stylesheet = flagToMaybe (hscolourCSS flags) runHsColour diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index c76b38e9923..929b3dd6372 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -67,6 +67,7 @@ module Distribution.Simple.Program.Db , ConfiguredProgs , updateUnconfiguredProgs , updateConfiguredProgs + , updatePathProgDb ) where import Distribution.Compat.Prelude @@ -483,6 +484,45 @@ 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 + progOverrides = programOverrideEnv prog + prog' = + prog + { programOverrideEnv = + [("PATH", Just newPath)] + ++ filter ((/= "PATH") . fst) (envOverrides ++ progOverrides) + } + 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 61ac50f1ff9..d469ec5ae8f 100644 --- a/Cabal/src/Distribution/Simple/Register.hs +++ b/Cabal/src/Distribution/Simple/Register.hs @@ -183,7 +183,7 @@ registerAll -> IO () registerAll verbHandles 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 dce0d3f4c55..2daf040d894 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs @@ -28,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 @@ -129,7 +126,7 @@ rulesExceptionMessage = \case showCycle (r, rs) = unlines . map (" " ++) . lines $ Tree.drawTree $ - fmap showRule $ + fmap show $ Tree.Node r rs CantFindSourceForRuleDependencies _r deps -> unlines $ @@ -172,22 +169,9 @@ rulesExceptionMessage = \case DuplicateRuleId rId r1 r2 -> unlines [ "Duplicate pre-build rule (" <> show rId <> ")" - , " - " <> showRule (ruleBinary r1) - , " - " <> showRule (ruleBinary r2) + , " - " <> show (ruleBinary r1) + , " - " <> show (ruleBinary r2) ] - where - showRule :: RuleBinary -> String - showRule (Rule{staticDependencies = deps, results = reslts}) = - "Rule: " ++ showDeps deps ++ " --> " ++ show (NE.toList reslts) - -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 -> show loc cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int cannotApplyComponentDiffCode = \case diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs index 2de7ff1f622..91ca27e7cd2 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 TypeApplications #-} @@ -77,6 +78,7 @@ module Distribution.Simple.SetupHooks.Internal -- ** Executing build rules , executeRules + , executeRulesUserOrSystem -- ** HookedBuildInfo compatibility code , hookedBuildInfoComponents @@ -120,6 +122,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) @@ -789,8 +792,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 diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs index 53b89a1e41a..1cee0fa14c8 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs @@ -267,6 +267,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 @@ -673,6 +675,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 @@ -1081,6 +1087,35 @@ instance -- that involve existential quantification. data family Tok (arg :: Symbol) :: k +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" :: Hs.Type)) + ] + ) + , + ( "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) + 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 fb3e0a8b9a8..722d83d554e 100644 --- a/Cabal/src/Distribution/Simple/Test/ExeV10.hs +++ b/Cabal/src/Distribution/Simple/Test/ExeV10.hs @@ -20,6 +20,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 @@ -27,7 +28,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 47ce691abfc..5638b13648c 100755 --- a/bootstrap/bootstrap.py +++ b/bootstrap/bootstrap.py @@ -89,7 +89,9 @@ class PackageSource(Enum): , "Cabal-tests" , "Cabal-tree-diff" , "cabal-install-solver" - , "cabal-install" ] + , "cabal-install" + , "hooks-exe" + ] # Value passed to setup build -j {jobs_amount} # 1 is not set by default. diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 62c5ac63e45..cf69a26a715 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -167,6 +167,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 @@ -253,6 +254,7 @@ library , edit-distance >= 0.2.2 && < 0.3 , exceptions >= 0.10.4 && < 0.11 , filepath >= 1.4.0.0 && < 1.6 + , hooks-exe ^>= 0.1 , HTTP >= 4000.1.5 && < 4000.6 , mtl >= 2.0 && < 2.4 , network-uri >= 2.6.2.0 && < 2.7 diff --git a/cabal-install/src/Distribution/Client/CmdLegacy.hs b/cabal-install/src/Distribution/Client/CmdLegacy.hs index d849fbfb535..024bb074ac9 100644 --- a/cabal-install/src/Distribution/Client/CmdLegacy.hs +++ b/cabal-install/src/Distribution/Client/CmdLegacy.hs @@ -14,7 +14,8 @@ import Distribution.Client.Sandbox ) import qualified Distribution.Client.Setup as Client import Distribution.Client.SetupWrapper - ( SetupScriptOptions (..) + ( SetupRunnerArgs (NotInLibrary) + , SetupScriptOptions (..) , defaultSetupScriptOptions , setupWrapper ) @@ -84,6 +85,7 @@ wrapperAction command getCommonFlags = getCommonFlags (const (return flags)) (const extraArgs) + NotInLibrary -- diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index a5389c68d1b..d72518f79ee 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -61,7 +61,6 @@ import Distribution.Client.ProjectPlanning.Types , dataDirsEnvironmentForPlan , elabExeDependencyPaths ) - import Distribution.Client.ScriptUtils ( AcceptNoTargets (..) , TargetContext (..) diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 5d1a1f9bc9f..6cc4bfec285 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -42,7 +42,8 @@ import Distribution.Client.Setup , filterConfigureFlags ) import Distribution.Client.SetupWrapper - ( SetupScriptOptions (..) + ( SetupRunnerArgs (NotInLibrary) + , SetupScriptOptions (..) , defaultSetupScriptOptions , setupWrapper ) @@ -204,6 +205,7 @@ configure configCommonFlags (const (return configFlags)) (const extraArgs) + NotInLibrary Right installPlan0 -> let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 in case fst (InstallPlan.ready installPlan) of @@ -247,7 +249,6 @@ configure (flagToMaybe (configCabalVersion configExFlags)) ) Nothing - False logMsg message rest = debug verbosity message >> rest @@ -259,7 +260,6 @@ configureSetupScript -> SymbolicPath Pkg (Dir Dist) -> VersionRange -> Maybe Lock - -> Bool -> InstalledPackageIndex -> Maybe ReadyPackage -> SetupScriptOptions @@ -271,7 +271,6 @@ configureSetupScript distPref cabalVersion lock - forceExternal index mpkg = SetupScriptOptions @@ -289,7 +288,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 (return . configureFlags) (const extraArgs) + NotInLibrary where gpkg :: PkgDesc.GenericPackageDescription gpkg = srcpkgDescription spkg diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index fcad8210b04..c4ece818fd9 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -1,6 +1,3 @@ ------------------------------------------------------------------------------ -{-# LANGUAGE LambdaCase #-} - ----------------------------------------------------------------------------- -- | @@ -66,6 +63,8 @@ module Distribution.Client.Dependency , addSetupCabalMinVersionConstraint , addSetupCabalMaxVersionConstraint , addSetupCabalProfiledDynamic + , setImplicitSetupInfo + , extendSetupBuildInfoSetupDepends ) where import Distribution.Client.Compat.Prelude @@ -615,55 +614,48 @@ removeBound RelaxUpper RelaxDepModNone = removeUpperBound removeBound RelaxLower RelaxDepModCaret = transformCaretLower removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper --- | Supply defaults for packages without explicit Setup dependencies +-- | Supply defaults for packages without explicit Setup dependencies. +-- It also serves to add the implicit dependency on @hooks-exe@ needed to +-- compile the @Setup.hs@ executable produced from 'SetupHooks' when +-- @build-type: Hooks@. The first argument function determines which implicit +-- dependencies are needed (including the one on @hooks-exe@). -- -- Note: It's important to apply 'addDefaultSetupDepends' after -- 'addSourcePackages'. Otherwise, the packages inserted by -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. addDefaultSetupDependencies - :: (UnresolvedSourcePackage -> Maybe [Dependency]) + :: (Maybe [Dependency] -> PD.BuildType -> Maybe PD.SetupBuildInfo -> Maybe PD.SetupBuildInfo) + -- ^ Function to update the SetupBuildInfo of the package using those dependencies + -> (UnresolvedSourcePackage -> Maybe [Dependency]) + -- ^ Function to determine extra setup dependencies -> DepResolverParams -> DepResolverParams -addDefaultSetupDependencies defaultSetupDeps params = +addDefaultSetupDependencies applyDefaultSetupDeps defaultSetupDeps params = params { depResolverSourcePkgIndex = - fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params) + fmap go (depResolverSourcePkgIndex params) } where - applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage - applyDefaultSetupDeps srcpkg = + go :: UnresolvedSourcePackage -> UnresolvedSourcePackage + go srcpkg = srcpkg { srcpkgDescription = gpkgdesc { PD.packageDescription = pkgdesc { PD.setupBuildInfo = - applyDefaultSetupBuildInfo - (PD.setupBuildInfo pkgdesc) + addCabalDepForHooks (PD.buildType pkgdesc) $ + applyDefaultSetupDeps + (defaultSetupDeps srcpkg) + (PD.buildType pkgdesc) + (PD.setupBuildInfo pkgdesc) } } } where - mbSetupDeps = defaultSetupDeps srcpkg gpkgdesc = srcpkgDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc - applyDefaultSetupBuildInfo :: Maybe PD.SetupBuildInfo -> Maybe PD.SetupBuildInfo - applyDefaultSetupBuildInfo = \case - Just sbi - | PD.Hooks <- PD.buildType pkgdesc -> - -- Fix for #11331; see 'addCabalDepForHooks' for more details. - Just $ addCabalDepForHooks sbi - Nothing - | Just deps <- mbSetupDeps - , PD.buildType pkgdesc == PD.Custom || PD.buildType pkgdesc == PD.Hooks -> - Just $ - PD.SetupBuildInfo - { PD.defaultSetupDepends = True - , PD.setupDepends = deps - } - mbSBI -> mbSBI - -- | Add an implicit dependency on @Cabal@ for a @build-type: Hooks@ package -- that doesn't explicitly depend on @Cabal@. Rationale: we need the @Cabal@ -- library in order to compile @main = defaultMainWithSetupHooks setupHooks@. @@ -675,14 +667,57 @@ addDefaultSetupDependencies defaultSetupDeps params = -- NB: don't do this for @build-type: Custom@, as it is possible for such -- packages to not depend on @Cabal@ at all (although basically unheard of -- in practice). -addCabalDepForHooks :: PD.SetupBuildInfo -> PD.SetupBuildInfo -addCabalDepForHooks sbi@(PD.SetupBuildInfo{PD.setupDepends = deps}) - | any ((== cabalPkgName) . depPkgName) deps = - sbi - | otherwise = - sbi{PD.setupDepends = Dependency cabalPkgName anyVersion mainLibSet : deps} +addCabalDepForHooks :: PD.BuildType -> Maybe PD.SetupBuildInfo -> Maybe PD.SetupBuildInfo +addCabalDepForHooks PD.Hooks = fmap addDep where + addDep sbi@(PD.SetupBuildInfo{PD.setupDepends = deps}) + | any ((== cabalPkgName) . depPkgName) deps = + sbi + | otherwise = + sbi{PD.setupDepends = Dependency cabalPkgName anyVersion mainLibSet : deps} cabalPkgName = mkPackageName "Cabal" +addCabalDepForHooks _ = id + +-- | Provides the fallback default "setup-depends", when: +-- +-- 1. There is no 'SetupBuildInfo' to start with, +-- 2. The passed-in optional default dependencies are not @Nothing@. +setImplicitSetupInfo + :: Maybe [Dependency] + -- ^ optional default dependencies + -> PD.BuildType + -> Maybe PD.SetupBuildInfo + -> Maybe PD.SetupBuildInfo +setImplicitSetupInfo mdeps buildty msetupinfo = + case msetupinfo of + Just sbi -> Just sbi + Nothing -> case mdeps of + Nothing -> Nothing + Just deps + | hasSetupStanza -> + Just + PD.SetupBuildInfo + { PD.defaultSetupDepends = True + , PD.setupDepends = deps + } + | otherwise -> Nothing + where + hasSetupStanza = buildty == PD.Custom || buildty == PD.Hooks + +-- | Extends the 'setupDepends' field of 'SetupBuildInfo' with the given +-- dependencies. +extendSetupBuildInfoSetupDepends + :: Maybe [Dependency] + -> PD.BuildType + -> Maybe PD.SetupBuildInfo + -> Maybe PD.SetupBuildInfo +extendSetupBuildInfoSetupDepends mDeps buildTy mSetupInfo + | Nothing <- mSetupInfo = + assert + (buildTy /= PD.Hooks) -- Hooks needs explicit setup-depends + Nothing + | Just setupInfo <- mSetupInfo = + Just setupInfo{PD.setupDepends = PD.setupDepends setupInfo ++ fromMaybe [] mDeps} -- | If a package has a custom setup then we need to add a setup-depends -- on Cabal. @@ -779,7 +814,7 @@ standardInstallPolicy -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = - addDefaultSetupDependencies mkDefaultSetupDeps $ + addDefaultSetupDependencies setImplicitSetupInfo mkDefaultSetupDeps $ basicInstallPolicy installedPkgIndex sourcePkgDb diff --git a/cabal-install/src/Distribution/Client/InLibrary.hs b/cabal-install/src/Distribution/Client/InLibrary.hs new file mode 100644 index 00000000000..78977a9a1a7 --- /dev/null +++ b/cabal-install/src/Distribution/Client/InLibrary.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} + +{- HLINT ignore "Replace case with maybe" -} + +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, PackageDBStackCWD) +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 (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 + ( makeSymbolicPath + , relativeSymbolicPath + ) +import Distribution.Verbosity + ( VerbosityHandles + , mkVerbosity + ) + +import Distribution.Types.HookedBuildInfo (emptyHookedBuildInfo) +import System.Directory (canonicalizePath) + +-------------------------------------------------------------------------------- +-- Configure + +data LibraryConfigureInputs = LibraryConfigureInputs + { verbosityHandles :: VerbosityHandles + , compiler :: Compiler + , platform :: Platform + , buildType :: BuildType + , compRequested :: Maybe PD.ComponentName + , localBuildConfig :: LBC.LocalBuildConfig + , packageDBStack :: PackageDBStackCWD + , packageDescription :: PD.PackageDescription + , gPackageDescription :: PD.GenericPackageDescription + , flagAssignment :: PD.FlagAssignment + } + +libraryConfigureInputsFromElabPackage + :: VerbosityHandles + -> BuildType + -> ProgramDb + -> ElaboratedSharedConfig + -> ElaboratedReadyPackage + -> [String] + -- ^ targets + -> LibraryConfigureInputs +libraryConfigureInputsFromElabPackage + verbHandles + bt + 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 = plat + , pkgConfigCompiler = compil + } + (ReadyPackage pkg) + userTargets = + LibraryConfigureInputs + { verbosityHandles = verbHandles + , compiler = compil + , platform = plat + , buildType = + -- NB: don't get the build-type from 'pkgDescr', + -- because for Configure build-type we rewrite the build-type + -- to Simple for components that are neither the main library + -- nor an executable. + -- + -- See also 'isMainLibOrExeComponent'. + bt + , 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 + { verbosityHandles = verbHandles + , platform = plat + , compiler = compil + , buildType = bt + , compRequested = mbComp + , localBuildConfig = lbc0 + , packageDBStack = packageDBs + , packageDescription = pkgDescr + , gPackageDescription = gpkgDescr + , flagAssignment = flagAssgn + } + cfg = do + -- Here, we essentially want to call the Cabal library 'configure' function, + -- but skipping over all the steps we don't need such as rediscovering the + -- compiler or re-resolving the conditionals in the package, as we have done + -- all of that already. + -- + -- To achieve this, we call the Cabal 'configureFinal' function which skips + -- these preparatory steps. + -- This code can still be improved, as it seems like 'configureFinal' still + -- does a fair bit of redundant work. In the end, it would be ideal if the + -- entirety of this function body was a single call to a function in the + -- Cabal library that gets called within the Cabal configure function. + let verbFlags = Cabal.fromFlag $ Cabal.configVerbosity cfg + verbosity = mkVerbosity verbHandles verbFlags + mbWorkDir = Cabal.flagToMaybe $ Cabal.configWorkingDir cfg + distPref = Cabal.fromFlag $ Cabal.configDistPref cfg + confHooks = + configureHooks $ + ExternalHooksExe.buildTypeSetupHooks verbosity mbWorkDir distPref bt + + -- cabal-install uses paths relative to the current working directory, + -- while the Cabal library expects symbolic paths. Perform the conversion here + -- by making the paths absolute. + packageDBs' <- traverse (traverse $ fmap makeSymbolicPath . canonicalizePath) packageDBs + + -- Configure package + let pkgId :: PD.PackageIdentifier + pkgId = PD.package pkgDescr + case mbComp of + Nothing -> setupMessage verbosity "Configuring" pkgId + Just cname -> + setupMessage' + verbosity + "Configuring" + pkgId + cname + (Just (Cabal.configInstantiateWith cfg)) + + -- 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. + -- + -- This seemingly requires a rethinking of + -- Distribution.Client.ProjectBuilding.UnpackedPackage.buildAndRegisterUnpackedPackage + -- to allow more granular recompilation checking, at the level of components. + lbc1 <- case preConfPackageHook confHooks of + Nothing -> return lbc0 + Just hk -> Cabal.runPreConfPackageHook cfg compil plat lbc0 hk + let compRequestedSpec = case mbComp of + Just compName -> OneComponentRequestedSpec compName + Nothing -> + ComponentRequestedSpec + { testsRequested = Cabal.fromFlag (Cabal.configTests cfg) + , benchmarksRequested = Cabal.fromFlag (Cabal.configBenchmarks cfg) + } + (_allConstraints, pkgInfo) <- + Cabal.computePackageInfo verbHandles cfg lbc1 gpkgDescr compil + -- NB: no need to re-apply "allConstraints", as we already have a + -- finalized package description in hand. + + -- Post-configure hooks & per-component configure + lbi1 <- + Cabal.configureFinal + verbHandles + confHooks + emptyHookedBuildInfo + cfg + lbc1 + (gpkgDescr, pkgDescr) + flagAssgn + compRequestedSpec + compil + plat + packageDBs' + pkgInfo + + -- Remember the .cabal filename if we know it. + pkgDescrFilePath <- + case Cabal.flagToMaybe $ Cabal.configCabalFilePath cfg of + Just pkgFile -> return pkgFile + Nothing -> relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir + return $ lbi1{pkgDescrFile = Just pkgDescrFilePath} + +-------------------------------------------------------------------------------- +-- Build + +build + :: VerbosityHandles + -> Cabal.BuildFlags + -> LocalBuildInfo + -> [String] + -> IO [MonitorFilePath] +build verbHandles flags lbi _args = + build_setupHooks (preBuildHook, postBuildHook) verbHandles pkgDescr lbi flags Cabal.knownSuffixHandlers + where + verb = mkVerbosity verbHandles $ Cabal.fromFlag $ Cabal.buildVerbosity flags + hooks = ExternalHooksExe.buildTypeSetupHooks verb mbWorkDir distPref bt + -- (Recall that pre-build hooks are treated specially; + -- see the 'buildTypeSetupHooks' and 'buildTypePreBuildHooks' functions.) + preBuildHook = ExternalHooksExe.buildTypePreBuildHooks verbHandles 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 + :: VerbosityHandles + -> Cabal.HaddockFlags + -> LocalBuildInfo + -> [String] + -> IO [MonitorFilePath] +haddock verbHandles flags lbi _args = + haddock_setupHooks preBuildHook verbHandles pkgDescr lbi Cabal.knownSuffixHandlers flags + where + preBuildHook = ExternalHooksExe.buildTypePreBuildHooks verbHandles mbWorkDir distPref bt + pkgDescr = localPkgDescr lbi + bt = PD.buildType pkgDescr + mbWorkDir = mbWorkDirLBI lbi + distPref = Cabal.fromFlag $ Cabal.haddockDistPref flags + +-------------------------------------------------------------------------------- +-- Repl + +repl + :: VerbosityHandles + -> Cabal.ReplFlags + -> LocalBuildInfo + -> [String] + -> IO [MonitorFilePath] +repl verbHandles flags lbi _args = + repl_setupHooks preBuildHook verbHandles pkgDescr lbi flags Cabal.knownSuffixHandlers [] + where + preBuildHook = ExternalHooksExe.buildTypePreBuildHooks verbHandles mbWorkDir distPref bt + pkgDescr = localPkgDescr lbi + bt = PD.buildType pkgDescr + mbWorkDir = mbWorkDirLBI lbi + distPref = Cabal.fromFlag $ Cabal.replDistPref flags + +-------------------------------------------------------------------------------- +-- Copy + +copy + :: VerbosityHandles + -> Cabal.CopyFlags + -> LocalBuildInfo + -> [String] + -> IO () +copy verbHandles flags lbi _args = + install_setupHooks hooks verbHandles pkgDescr lbi flags + where + verb = mkVerbosity verbHandles $ Cabal.fromFlag $ Cabal.copyVerbosity flags + hooks = installHooks $ ExternalHooksExe.buildTypeSetupHooks verb 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 + :: VerbosityHandles + -> Cabal.TestFlags + -> LocalBuildInfo + -> [String] + -> IO () +test verb flags lbi args = + Cabal.test args verb pkgDescr lbi flags + where + pkgDescr = localPkgDescr lbi + +bench + :: VerbosityHandles + -> Cabal.BenchmarkFlags + -> LocalBuildInfo + -> [String] + -> IO () +bench verb flags lbi args = + Cabal.bench args verb 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 f7eeae2803b..58c24f8a768 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -116,7 +116,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 -- " @@ -1240,7 +1241,7 @@ regenerateHaddockIndex defaultDirs <- InstallDirs.defaultInstallDirs (compilerFlavor comp) - (fromFlag (configUserInstall configFlags)) + (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags)) True let indexFileTemplate = fromFlag (installHaddockIndex installFlags) indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate @@ -1494,7 +1495,6 @@ performInstallations distPref (chooseCabalVersion configExFlags (libVersion miscOptions)) (Just lock) - parallelInstall index (Just rpkg) @@ -1959,7 +1959,7 @@ installUnpackedPackage _ -> ipkgs let packageDBs = interpretPackageDbFlags - (fromFlag (configUserInstall configFlags)) + (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags)) (configPackageDBs configFlags) for_ ipkgs' $ \ipkg' -> registerPackage @@ -2080,6 +2080,7 @@ installUnpackedPackage getCommonFlags flags (const []) + NotInLibrary ) -- helper @@ -2114,7 +2115,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 1e708a626af..959e1f20a3d 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -61,7 +61,6 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.Setup ( ConfigFlags (..) , flagToMaybe - , fromFlag , fromFlagOrDefault ) import Distribution.Simple.Utils (info, removeFileForcibly, withTempDirectory) @@ -96,6 +95,7 @@ import System.IO.Error , isDoesNotExistError ) +import Distribution.Client.Config (defaultUserInstall) import Distribution.Client.Init.Prompt (promptYesNo) import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt), runPromptIO) import Distribution.Client.Types.OverwritePolicy @@ -218,7 +218,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 d571851a8e2..f160d38a76c 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 ) @@ -572,6 +574,7 @@ wrapperAction command getCommonFlags = getCommonFlags (const (return flags)) (const extraArgs) + NotInLibrary configureAction :: (ConfigFlags, ConfigExFlags) @@ -600,7 +603,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 -> @@ -687,6 +690,7 @@ build verbosity config distPref buildFlags extraArgs = buildCommonFlags (return . mkBuildFlags) (const extraArgs) + NotInLibrary where progDb = defaultProgramDb setupOptions = defaultSetupScriptOptions{useDistPref = distPref} @@ -782,6 +786,7 @@ replAction replFlags extraArgs globalFlags = do Cabal.replCommonFlags (const (return replFlags')) (const extraArgs) + NotInLibrary -- No .cabal file in the current directory: just start the REPL (possibly -- using the sandbox package DB). @@ -831,6 +836,7 @@ installAction (configFlags, _, installFlags, _, _, _) _ globalFlags (const common) (const (return (mempty, mempty, mempty, mempty, mempty, mempty))) (const []) + NotInLibrary installAction ( configFlags , configExFlags @@ -1004,6 +1010,7 @@ testAction (buildFlags, testFlags) extraArgs globalFlags = do Cabal.testCommonFlags (const (return testFlags')) (const extraArgs') + NotInLibrary data ComponentNames = ComponentNamesUnknown @@ -1127,6 +1134,7 @@ benchmarkAction Cabal.benchmarkCommonFlags (const (return benchmarkFlags')) (const extraArgs') + NotInLibrary haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do @@ -1171,6 +1179,7 @@ haddockAction haddockFlags extraArgs globalFlags = do haddockCommonFlags (const (return haddockFlags')) (const extraArgs) + NotInLibrary when (haddockForHackage haddockFlags == Flag ForHackage) $ do pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig mbWorkDir distPref) @@ -1210,6 +1219,7 @@ cleanAction cleanFlags extraArgs globalFlags = do cleanCommonFlags (const (return 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 11549063549..d514c91a20e 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -80,25 +82,31 @@ import Distribution.Simple.Compiler ( PackageDBStackCWD , coercePackageDBStack ) +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.Simple.Utils import Distribution.System (Platform (..)) import Distribution.Utils.Path hiding ( (<.>) , () ) +import Distribution.Verbosity (setVerbosityHandles) 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 @@ -110,13 +118,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.Client.ProjectBuilding.PackageFileMonitor -import Distribution.Verbosity (setVerbosityHandles) - -- | Each unpacked package is processed in the following phases: -- -- * Configure phase @@ -131,20 +135,21 @@ import Distribution.Verbosity (setVerbosityHandles) -- 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 () + PBReplPhase :: {runRepl :: IO [MonitorFilePath]} -> PackageBuildingPhase () + PBInstallPhase + :: { runCopy :: FilePath -> IO () + , runRegister :: PackageDBStackCWD -> Cabal.RegisterOptions -> IO InstalledPackageInfo - } - | PBTestPhase {runTest :: IO ()} - | PBBenchPhase {runBench :: IO ()} - | PBReplPhase {runRepl :: IO ()} + } + -> PackageBuildingPhase () + PBTestPhase :: {runTest :: IO ()} -> PackageBuildingPhase () + PBBenchPhase :: {runBench :: IO ()} -> PackageBuildingPhase () -- | Structures the phases of building and registering a package amongst others -- (see t'PackageBuildingPhase'). Delegates logic specific to a certain @@ -167,13 +172,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, buildSettingKeepTempFiles} + buildTimeSettings@BuildTimeSettings{buildSettingKeepTempFiles} registerLock cacheLock pkgshared@ElaboratedSharedConfig @@ -187,36 +192,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 (return . buildFlags) buildArgs + setup + buildCommand + Cabal.buildCommonFlags + (return . buildFlags) + buildArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBuildPhase mbLBI) -- Haddock phase whenHaddock $ delegate $ PBHaddockPhase $ annotateFailure mlogFile HaddocksFailed $ do - setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs + setup + haddockCommand + Cabal.haddockCommonFlags + (return . haddockFlags) + haddockArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SHaddockPhase mbLBI) -- Install phase delegate $ PBInstallPhase { runCopy = \destdir -> annotateFailure mlogFile InstallFailed $ - setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs + setup + Cabal.copyCommand + Cabal.copyCommonFlags + (return . 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 @@ -235,21 +261,36 @@ buildAndRegisterUnpackedPackage delegate $ PBTestPhase $ annotateFailure mlogFile TestsFailed $ - setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs + setup + testCommand + Cabal.testCommonFlags + (return . testFlags) + testArgs + (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI) -- Bench phase whenBench $ delegate $ PBBenchPhase $ annotateFailure mlogFile BenchFailed $ - setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs + setup + benchCommand + Cabal.benchmarkCommonFlags + (return . benchFlags) + benchArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) -- Repl phase whenRepl $ delegate $ PBReplPhase $ annotateFailure mlogFile ReplFailed $ - setupInteractive replCommand Cabal.replCommonFlags replFlags replArgs + setupInteractive + replCommand + Cabal.replCommonFlags + (return . replFlags) + replArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI) return () where @@ -276,7 +317,8 @@ buildAndRegisterUnpackedPackage | otherwise = return () mbWorkDir = useWorkingDir scriptOptions - commonFlags = setupHsCommonFlags verbosity mbWorkDir builddir buildSettingKeepTempFiles + commonFlags targets = + setupHsCommonFlags verbosity mbWorkDir builddir targets buildSettingKeepTempFiles configureCommand = Cabal.configureCommand defaultProgramDb configureFlags v = @@ -286,7 +328,7 @@ buildAndRegisterUnpackedPackage plan rpkg pkgshared - commonFlags + (commonFlags $ configureArgs v) configureArgs _ = setupHsConfigureArgs pkg buildCommand = Cabal.buildCommand defaultProgramDb @@ -296,7 +338,7 @@ buildAndRegisterUnpackedPackage comp_par_strat pkg pkgshared - commonFlags + (commonFlags $ buildArgs v) buildArgs _ = setupHsBuildArgs pkg copyFlags destdir v = @@ -304,7 +346,7 @@ buildAndRegisterUnpackedPackage setupHsCopyFlags pkg pkgshared - commonFlags + (commonFlags $ buildArgs v) destdir -- In theory, we could want to copy less things than those that were -- built, but instead, we simply copy the targets that were built. @@ -315,7 +357,7 @@ buildAndRegisterUnpackedPackage flip filterTestFlags v $ setupHsTestFlags pkg - commonFlags + (commonFlags $ testArgs v) testArgs _ = setupHsTestArgs pkg benchCommand = Cabal.benchmarkCommand @@ -324,7 +366,7 @@ buildAndRegisterUnpackedPackage setupHsBenchFlags pkg pkgshared - commonFlags + (commonFlags $ benchArgs v) benchArgs _ = setupHsBenchArgs pkg replCommand = Cabal.replCommand defaultProgramDb @@ -333,7 +375,7 @@ buildAndRegisterUnpackedPackage setupHsReplFlags pkg pkgshared - commonFlags + (commonFlags $ replArgs v) replArgs _ = setupHsReplArgs pkg haddockCommand = Cabal.haddockCommand @@ -343,7 +385,7 @@ buildAndRegisterUnpackedPackage pkg pkgshared buildTimeSettings - commonFlags + (commonFlags $ haddockArgs v) haddockArgs v = flip filterHaddockArgs v $ setupHsHaddockArgs pkg @@ -356,17 +398,18 @@ buildAndRegisterUnpackedPackage distDirLayout srcdir builddir - (isParallelBuild buildSettingNumJobs) cacheLock setup - :: CommandUI flags + :: (HasCallStack, RightFlagsForPhase flags setupSpec) + => CommandUI flags -> (flags -> CommonSetupFlags) -> (Version -> IO flags) -> (Version -> [String]) - -> IO () - setup cmd getCommonFlags flags args = - withLogging $ \mLogFileHandle -> do + -> SetupRunnerArgs setupSpec + -> IO (SetupRunnerRes setupSpec) + setup cmd getCommonFlags flags args wrapperArgs = + withLogging $ \mLogFileHandle -> setupWrapper (setVerbosityHandles mLogFileHandle verbosity) scriptOptions @@ -381,25 +424,24 @@ buildAndRegisterUnpackedPackage getCommonFlags flags args + wrapperArgs setupInteractive - :: CommandUI flags + :: RightFlagsForPhase flags setupSpec + => CommandUI flags -> (flags -> CommonSetupFlags) - -> (Version -> flags) + -> (Version -> IO 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 - (\v -> return (flags v)) - args - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = + generateInstalledPackageInfo :: InLibraryLBI -> IO InstalledPackageInfo + generateInstalledPackageInfo mbLBI = withTempInstalledPackageInfoFile verbosity distTempDirectory @@ -409,9 +451,14 @@ buildAndRegisterUnpackedPackage setupHsRegisterFlags pkg pkgshared - commonFlags + (commonFlags []) pkgConfDest - setup (Cabal.registerCommand) Cabal.registerCommonFlags (\v -> return (registerFlags v)) (const []) + setup + (Cabal.registerCommand) + Cabal.registerCommonFlags + (return . registerFlags) + (const []) + (InLibraryArgs $ InLibraryPostConfigureArgs SRegisterPhase mbLBI) withLogging :: (Maybe Handle -> IO r) -> IO r withLogging action = @@ -465,12 +512,6 @@ buildInplaceUnpackedPackage True (distPackageCacheDirectory dparams) - let docsResult = DocsNotTried - testsResult = TestsNotTried - - buildResult :: BuildResultMisc - buildResult = (docsResult, testsResult) - buildAndRegisterUnpackedPackage verbosity distDirLayout @@ -485,65 +526,18 @@ 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 - PBBuildPhase{runBuild} -> do - whenRebuild $ do - timestamp <- beginUpdateFileMonitor - runBuild - -- Be sure to invalidate the cache if building throws an exception! - -- If not, we'll abort execution with a stale recompilation cache. - -- See ghc#24926 for an example of how this can go wrong. - `onException` invalidatePackageRegFileMonitor packageFileMonitor - - let listSimple = - execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg) - listSdist = - fmap (map monitorFileHashed) $ - allPackageSourceFiles verbosity (getSymbolicPath srcdir) - ifNullThen m m' = do - xs <- m - if null xs then m' else return xs - monitors <- case PD.buildType (elabPkgDescription pkg) of - Simple -> 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 - -- cause unnecessary rebuilding (for example, if README - -- is edited, we will try to rebuild) but there isn't - -- a more accurate Custom interface we can use to get - -- this info. We prefer not to use listSimple here - -- as it can miss extra source files that are considered - -- by the Custom setup. - _ - | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> - -- However, sometimes sdist --list-sources will fail - -- and return an empty list. In that case, fall - -- back on the (inaccurate) simple tracking. - listSdist `ifNullThen` listSimple - | otherwise -> - listSimple - - let dep_monitors = - map monitorFileHashed $ - elabInplaceDependencyBuildCacheFiles - distDirLayout - pkgshared - plan - pkg - updatePackageBuildFileMonitor - packageFileMonitor - (getSymbolicPath srcdir) - timestamp - pkg - buildStatus - (monitors ++ dep_monitors) - buildResult + return mbLBI + PBBuildPhase{runBuild} -> + whenRebuild $ withFileMonitor runBuild + PBReplPhase{runRepl} -> + withFileMonitor runRepl PBHaddockPhase{runHaddock} -> do - runHaddock + withFileMonitor runHaddock let haddockTarget = elabHaddockForHackage pkg when (haddockTarget == Cabal.ForHackage) $ do let dest = distDirectory name <.> "tar.gz" @@ -586,7 +580,6 @@ buildInplaceUnpackedPackage updatePackageRegFileMonitor packageFileMonitor (getSymbolicPath srcdir) mipkg PBTestPhase{runTest} -> runTest PBBenchPhase{runBench} -> runBench - PBReplPhase{runRepl} -> runRepl return BuildResult @@ -595,14 +588,75 @@ buildInplaceUnpackedPackage , buildResultLogFile = Nothing } where + docsResult = DocsNotTried + testsResult = TestsNotTried + buildResult :: BuildResultMisc + buildResult = (docsResult, testsResult) + dparams = elabDistDirParams pkgshared pkg packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams - whenReConfigure action = case buildStatus of - BuildStatusConfigure _ -> action - _ -> return () - + withFileMonitor :: IO [MonitorFilePath] -> IO () + withFileMonitor runAction = do + timestamp <- beginUpdateFileMonitor + monitors' <- + runAction + -- Be sure to invalidate the cache if building throws an exception! + -- If not, we'll abort execution with a stale recompilation cache. + -- See ghc#24926 for an example of how this can go wrong. + `onException` invalidatePackageRegFileMonitor packageFileMonitor + let listSimple = + execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity (getSymbolicPath srcdir) + ifNullThen m m' = do + xs <- m + if null xs then m' else return xs + monitors <- case PD.buildType (elabPkgDescription pkg) of + Simple -> listSimple + Hooks -> listSdist `ifNullThen` listSimple + _ + | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> + listSdist `ifNullThen` listSimple + | otherwise -> + listSimple + + let dep_monitors = + map monitorFileHashed $ + elabInplaceDependencyBuildCacheFiles + distDirLayout + pkgshared + plan + pkg + updatePackageBuildFileMonitor + packageFileMonitor + (getSymbolicPath srcdir) + timestamp + pkg + buildStatus + (monitors ++ monitors' ++ dep_monitors) + buildResult + + 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! @@ -697,10 +751,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/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 3538ac71260..a857bf98d0b 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1189,6 +1189,7 @@ printPlan verbosity Nothing -- omit working directory (makeSymbolicPath "$builddir") + (setupHsConfigureArgs elab) buildSettingKeepTempFiles fullConfigureFlags = runIdentity diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index f6d97a8f8fa..3c649e226ce 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -127,6 +127,7 @@ import Distribution.Client.ProjectPlanOutput import Distribution.Client.ProjectPlanning.SetupPolicy ( NonSetupLibDepSolverPlanPackage (..) , mkDefaultSetupDeps + , mkHooksSetupImplicitDeps , packageSetupScriptSpecVersion , packageSetupScriptStyle ) @@ -1369,6 +1370,13 @@ planPackages . removeLowerBounds solverSettingAllowOlder . removeUpperBounds solverSettingAllowNewer . addDefaultSetupDependencies + extendSetupBuildInfoSetupDepends + ( mkHooksSetupImplicitDeps + . PD.packageDescription + . srcpkgDescription + ) + . addDefaultSetupDependencies + setImplicitSetupInfo ( mkDefaultSetupDeps comp platform . PD.packageDescription . srcpkgDescription @@ -1758,6 +1766,7 @@ elaborateInstallPlan -- new 'ElabSetup' type, and teach all of the code paths how to -- handle it. -- Once you've implemented this, swap it for the code below. + -- (See #9986 for more information about this task.) cuz_buildtype = case bt of PD.Configure -> [] @@ -1765,9 +1774,12 @@ elaborateInstallPlan -- main library in cabal. Other components will need to depend -- on the main library for configured data. 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 (task tracked at #9986). + PD.Hooks -> [CuzBuildType CuzHooksBuildType] + -- 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 @@ -2235,6 +2247,7 @@ elaborateInstallPlan gdesc of Right (desc, _) -> desc Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabGPkgDescription = gdesc elabFlagAssignment = flags elabFlagDefaults = PD.mkFlagAssignment @@ -2370,16 +2383,30 @@ elaborateInstallPlan ] <> perPkgOptionMapLast pkgid packageConfigProgramPaths elabProgramArgs = - Map.unionWith - (++) - ( Map.fromList - [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog - , not (null args) - ] - ) - (perPkgOptionMapMappend pkgid packageConfigProgramArgs) + -- Workaround for + -- + -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. + -- custom Setup.hs scripts calling out to GHC even when going via + -- @runProgram ghcProgram@, as e.g. happy does in its + -- + -- (see also ) + -- + -- So for now, let's pass the rather harmless and idempotent + -- `-hide-all-packages` flag to all invocations (which has + -- the benefit that every GHC invocation starts with a + -- consistently well-defined clean slate) until we find a + -- better way. + Map.insertWith (++) "ghc" ["-hide-all-packages"] $ + Map.unionWith + (++) + ( Map.fromList + [ (programId prog, args) + | prog <- configuredPrograms compilerprogdb + , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog + , not (null args) + ] + ) + (perPkgOptionMapMappend pkgid packageConfigProgramArgs) elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra elabConfiguredPrograms = configuredPrograms compilerprogdb elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs @@ -3877,11 +3904,10 @@ 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 --- be a separate component!!! +-- be a separate component!!! See #9986. setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) plan @@ -3889,7 +3915,6 @@ setupHsScriptOptions distdir srcdir builddir - isParallelBuild cacheLock = SetupScriptOptions { useCabalVersion = thisVersion elabSetupScriptCliVersion @@ -3922,7 +3947,6 @@ setupHsScriptOptions -- for build-tools-depends. useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan , useWin32CleanHack = False -- TODO: [required eventually] - , forceExternalSetupMethod = isParallelBuild , setupCacheLock = Just cacheLock , isInteractive = False , isMainLibOrExeComponent = case elabPkgOrComp of @@ -4063,7 +4087,7 @@ setupHsConfigureFlags , configDynExe , configFullyStaticExe , configGHCiLib - , -- , configProfExe -- overridden + , -- configProfExe -- overridden configProfLib , configProfShared , -- , configProf -- overridden @@ -4093,27 +4117,7 @@ setupHsConfigureFlags ElabComponent _ -> toFlag elabComponentId configProgramPaths = Map.toList elabProgramPaths - configProgramArgs - | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True = - -- workaround for - -- - -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. - -- custom Setup.hs scripts calling out to GHC even when going via - -- @runProgram ghcProgram@, as e.g. happy does in its - -- - -- (see also ) - -- - -- So for now, let's pass the rather harmless and idempotent - -- `-hide-all-packages` flag to all invocations (which has - -- the benefit that every GHC invocation starts with a - -- consistently well-defined clean slate) until we find a - -- better way. - Map.toList $ - Map.insertWith - (++) - "ghc" - ["-hide-all-packages"] - elabProgramArgs + configProgramArgs = Map.toList elabProgramArgs configProgramPathExtra = toNubList elabProgramPathExtra configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) configHcPath = mempty -- we use configProgramPaths instead @@ -4126,8 +4130,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 @@ -4211,15 +4215,16 @@ setupHsCommonFlags :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> SymbolicPath Pkg (Dir Dist) + -> [String] -> Bool -> Cabal.CommonSetupFlags -setupHsCommonFlags verbosity mbWorkDir builddir keepTempFiles = +setupHsCommonFlags verbosity mbWorkDir builddir targets keepTempFiles = Cabal.CommonSetupFlags { setupDistPref = toFlag builddir , setupVerbosity = toFlag $ verbosityFlags verbosity , setupCabalFilePath = mempty , setupWorkingDir = maybeToFlag mbWorkDir - , setupTargets = [] + , setupTargets = targets , setupKeepTempFiles = toFlag keepTempFiles } @@ -4259,11 +4264,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 } @@ -4365,18 +4370,18 @@ 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 , haddockIndex = maybe mempty toFlag elabHaddockIndex , haddockBaseUrl = maybe mempty toFlag elabHaddockBaseUrl , haddockResourcesDir = maybe mempty toFlag elabHaddockResourcesDir diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs index 0ef3b872286..3e97010084f 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs @@ -22,9 +22,16 @@ -- In cases 1 and 2 we obviously have to build an external Setup.hs script, -- while in case 4 we can use the internal library API. -- +-- Since @3.14.0.0@ we must also consider the @Setup.hs@ scripts constructed +-- from 'SetupHooks' values, because these generated @Setup.hs@ scripts depend +-- on the @hooks-exe@ package (which creates an executable from 'SetupHooks'). +-- Therefore, 'SetupPolicy' is also concerned with augmenting the setup +-- dependencies with @hooks-exe@ when @build-type: Hooks@. +-- -- @since 3.12.0.0 module Distribution.Client.ProjectPlanning.SetupPolicy ( mkDefaultSetupDeps + , mkHooksSetupImplicitDeps , packageSetupScriptStyle , packageSetupScriptSpecVersion , NonSetupLibDepSolverPlanPackage (..) @@ -157,6 +164,30 @@ mkDefaultSetupDeps compiler platform pkg = csvToVersion :: CabalSpecVersion -> Version csvToVersion = mkVersion . cabalSpecMinimumLibraryVersion +-- | Returns an implicit dependency on @hooks-exe@ needed to create a +-- @Setup.hs@ executable from a 'SetupHooks' value, if @build-type: Hooks@, +-- as well as a dependency on @Cabal@ if there isn't one already. +-- +-- @since 3.14.0.0 +mkHooksSetupImplicitDeps + :: PackageDescription + -> Maybe [Dependency] +mkHooksSetupImplicitDeps pkg + | Hooks <- buildType pkg = + Just $ + [Dependency hooksExePkgname anyVersion mainLibSet] + -- Add a dependency on Cabal if there isn't one, so that we can compile: + -- module Main where + -- import Distribution.Simple (defaultMainWithSetupHooks) + -- import SetupHooks (setupHooks) + -- main = defaultMainWithSetupHooks setupHooks + ++ [ Dependency cabalPkgname (orLaterVersion $ mkVersion [3, 13, 0]) mainLibSet + | setupBI <- maybeToList $ setupBuildInfo pkg + , not $ any ((== cabalPkgname) . depPkgName) $ setupDepends setupBI + ] + | otherwise = + Nothing + -- | A newtype for 'SolverPlanPackage' for which the -- dependency graph considers only dependencies on libraries which are -- NOT from setup dependencies. Used to compute the set @@ -214,8 +245,9 @@ packageSetupScriptSpecVersion _ pkg libDepGraph deps = setupLibDeps = maybe [] (map packageId) (Graph.closure libDepGraph (CD.setupDeps deps)) -cabalPkgname :: PackageName +cabalPkgname, hooksExePkgname :: PackageName cabalPkgname = mkPackageName "Cabal" +hooksExePkgname = mkPackageName "hooks-exe" legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] legacyCustomSetupPkgs compiler (Platform _ os) = diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 09400582074..a334708ec10 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -223,6 +223,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 acb8f031c3a..076cfbb6858 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {- FOURMOLU_DISABLE -} ----------------------------------------------------------------------------- @@ -26,9 +28,16 @@ module Distribution.Client.SetupWrapper ( getSetup , runSetup , runSetupCommand + , SetupRunnerArgs(..) + , SPostConfigurePhase(..) + , InLibraryArgs(..) + , SetupRunnerRes + , InLibraryLBI(..) + , RightFlagsForPhase , setupWrapper , SetupScriptOptions (..) , defaultSetupScriptOptions + , externalSetupMethod ) where import Distribution.Client.Compat.Prelude @@ -36,7 +45,6 @@ import Prelude () import qualified Distribution.Backpack as Backpack import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion) -import qualified Distribution.Make as Make import Distribution.Package ( ComponentId , PackageId @@ -59,13 +67,11 @@ import Distribution.Simple.Build.Macros ( generatePackageVersionMacros ) import Distribution.Simple.BuildPaths - ( defaultDistPref - , exeExtension + ( exeExtension ) import Distribution.Simple.Compiler import Distribution.Simple.Configure - ( configCompilerEx - ) + hiding ( getInstalledPackages ) import Distribution.Simple.PackageDescription ( readGenericPackageDescription ) @@ -74,19 +80,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 ) @@ -109,6 +103,8 @@ import Distribution.Version import Distribution.Client.Config ( defaultCacheDir ) +import Distribution.Client.FileMonitor + ( MonitorFilePath ) import Distribution.Client.IndexUtils ( getInstalledPackages ) @@ -125,9 +121,6 @@ import Distribution.Client.Utils #endif , moreRecentFile , tryCanonicalizePath - , withEnv - , withEnvOverrides - , withExtraPathEnv ) import Distribution.Utils.Path hiding ( (), (<.>) ) @@ -144,12 +137,6 @@ import Distribution.Simple.Program.GHC , GhcOptions (..) , renderGhcOptions ) -import Distribution.Simple.Setup - ( CommonSetupFlags (..) - , pattern Flag - , GlobalFlags (..) - , globalCommand - ) import Distribution.Simple.Utils ( cabalVersion , copyFileVerbose @@ -172,16 +159,28 @@ import Distribution.Utils.Generic import Distribution.Compat.Stack import Distribution.ReadE +import Distribution.Simple.Setup +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 Data.Kind (Type, Constraint) import qualified Data.Map.Lazy as Map import System.Environment (getExecutablePath) -import Distribution.Compat.Process (proc) +import Data.Type.Equality ( type (==) ) +import Data.Type.Bool ( If ) import System.Directory (doesFileExist) import System.FilePath ((<.>), ()) import System.IO (Handle, hPutStr) @@ -189,38 +188,101 @@ 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 ( withTempDirectory ) import Control.Exception ( bracket ) -import System.FilePath ( equalFilePath, takeDirectory ) import System.Directory ( doesDirectoryExist ) +import System.FilePath ( equalFilePath, takeDirectory, takeFileName ) 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 = [MonitorFilePath] + 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 + -- | Directly use Cabal library functions, bypassing the Setup + -- mechanism entirely. + LibraryMethod :: SetupMethod InLibrary + -- | 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 @@ -267,7 +329,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 @@ -343,7 +404,6 @@ defaultSetupScriptOptions = , useExtraPathEnv = [] , useExtraEnvOverrides = [] , useWin32CleanHack = False - , forceExternalSetupMethod = False , setupCacheLock = Nothing , isInteractive = False , isMainLibOrExeComponent = True @@ -358,12 +418,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 @@ -373,8 +434,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 @@ -391,16 +453,15 @@ getSetup verbosity options mpkg = do buildType' = case (buildType pkg, isMainLibOrExeComponent options) of (Configure, False) -> Simple (bt, _) -> bt - (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 = @@ -411,37 +472,60 @@ 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 || maybe False (cabalVersion /=) (useCabalSpecVersion options) - || not (cabalVersion `withinRange` useCabalVersion options) = - getExternalSetupMethod verbosity options pkg buildType' - | -- 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) -runSetupMethod InternalMethod = internalSetupMethod + || not (cabalVersion `withinRange` useCabalVersion options) + || allowInLibrary == Don'tAllowInLibrary = + withExternalSetupMethod + | otherwise + = do + abiOK <- + if buildType' == Hooks + then do + -- Compile the hooks executable + compileExternalExe verbosity options pkg buildType' WantHooks + externalHooksABI + <- externalSetupHooksABI verbosity + $ 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." + withExternalSetupMethod + where + withExternalSetupMethod = do + debug verbosity $ "Using external setup method with build-type " ++ show buildType' + debug verbosity $ + "Using explicit dependencies: " + ++ show (useDependenciesExclusive options) + with <$> compileExternalExe verbosity options pkg buildType' WantSetup + +runSetupMethod :: WithCallStack (SetupMethod GeneralSetup -> SetupRunner UseGeneralSetup) runSetupMethod (ExternalMethod path) = externalSetupMethod path -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 @@ -455,7 +539,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 @@ -494,7 +578,7 @@ verbosityHack ver args0 -- | Run a command through a configured 'Setup'. runSetupCommand :: Verbosity - -> Setup + -> Setup GeneralSetup -> CommandUI flags -- ^ command definition -> (flags -> CommonSetupFlags) @@ -502,20 +586,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 @@ -523,60 +610,136 @@ setupWrapper -> (Version -> IO 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 - extraArgs = getExtraArgs version flags <- getFlags version - runSetupCommand - verbosity - setup - cmd - getCommonFlags - flags - extraArgs + let + verbHandles = verbosityHandles verbosity + extraArgs = getExtraArgs version + 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 + -- See (1)(a) in Note [Constructing the ProgramDb] + baseProgDb <- + prependProgramSearchPath verbosity + (useExtraPathEnv options) + (useExtraEnvOverrides options) =<< + mkProgramDb verbHandles flags -- Passes user-supplied arguments to e.g. GHC + (restoreProgramDb builtinPrograms $ + useProgramDb options) -- Recall that 'useProgramDb' is set to 'pkgConfigCompilerProgs' + -- See (2) in Note [Constructing the ProgramDb] + setupProgDb <- + configCompilerProgDb + verbosity + (pkgConfigCompiler elabSharedConfig) + baseProgDb + Nothing -- we use configProgramPaths instead + lbi0 <- + InLibrary.configure + (InLibrary.libraryConfigureInputsFromElabPackage + verbHandles + (setupBuildType setup) + setupProgDb + elabSharedConfig + elabReadyPkg + extraArgs + ) + flags + let progs0 = LBI.withPrograms lbi0 + -- See (1)(b) in Note [Constructing the ProgramDb] + 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 verbHandles flags lbi extraArgs + SHaddockPhase -> InLibrary.haddock verbHandles flags lbi extraArgs + SReplPhase -> InLibrary.repl verbHandles flags lbi extraArgs + SCopyPhase -> InLibrary.copy verbHandles flags lbi extraArgs + STestPhase -> InLibrary.test verbHandles flags lbi extraArgs + SBenchPhase -> InLibrary.bench verbHandles flags lbi extraArgs + SRegisterPhase -> InLibrary.register flags lbi extraArgs + NotInLibrary -> + error "internal error: NotInLibrary argument but getSetup chose InLibrary" + ExternalMethod {} -> notInLibraryMethod + +{- Note [Constructing the ProgramDb] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When using the in-library method for configuring a package, we want to start off +with the information cabal-install already has in hand, such as the compiler. +Specifically, we skip 'Cabal.Distribution.Simple.preConfigurePackage', which +includes the call to 'configCompilerEx'. + +To obtain a program database with all the required information, we do a few +things: + + (1) + (a) When building a package with internal build tools, we must ensure that + these build tools are available in PATH, with appropriate environment + variable overrides for their data directory. To do this, we call + 'prependProgramSearchPath'. + + (b) Moreover, these programs must be available in the search paths for the + compiler itself, in case they are run at compile-time (e.g. with a Template + Haskell splice). We achieve this using 'updatePathProgDb'. + + (2) Given the compiler, we must compute the ProgramDb of programs that are + specified alongside the compiler, such as ghc-pkg, haddock, and toolchain + programs such as ar, ld. + + We do this using the function 'configCompilerProgDb'. +-} -- ------------------------------------------------------------ --- * Internal SetupMethod +-- * 'invoke' function -- ------------------------------------------------------------ --- | Run a Setup script by directly invoking the @Cabal@ library. -internalSetupMethod :: SetupRunner -internalSetupMethod verbosity options bt args = do - info verbosity $ - "Using internal setup method with build-type " - ++ show bt - ++ " and args:\n " - ++ show args - -- 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. - -- - -- 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 - -- setup method in concurrent contexts. - withEnv "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $ - withExtraPathEnv (useExtraPathEnv options) $ - withEnvOverrides (useExtraEnvOverrides options) $ - buildTypeAction (verbosityHandles verbosity) bt args - -buildTypeAction :: VerbosityHandles -> BuildType -> ([String] -> IO ()) -buildTypeAction verbHandles = \ case - Simple -> - Simple.defaultMainArgsWithHandles verbHandles - Configure -> - Simple.defaultMainWithSetupHooksArgs Simple.autoconfSetupHooks verbHandles - Make -> - Make.defaultMainArgsWithHandles verbHandles - Hooks -> - error "buildTypeAction Hooks" - Custom -> - error "buildTypeAction Custom" - invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () invoke verbosity path args options = do info verbosity $ unwords (path : args) @@ -609,34 +772,12 @@ invoke verbosity path args options = do -- ------------------------------------------------------------ --- * Self-Exec SetupMethod - --- ------------------------------------------------------------ - -selfExecSetupMethod :: SetupRunner -selfExecSetupMethod verbosity options bt args0 = do - let args = - [ "act-as-setup" - , "--build-type=" ++ prettyShow bt - , "--" - ] - ++ args0 - info verbosity $ - "Using self-exec internal setup method with build-type " - ++ show bt - ++ " and args:\n " - ++ show args - path <- getExecutablePath - invoke verbosity path args options - --- ------------------------------------------------------------ - -- * External SetupMethod -- ------------------------------------------------------------ -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 @@ -661,7 +802,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 @@ -674,29 +815,40 @@ externalSetupMethod path verbosity options _ args = #endif -getExternalSetupMethod +data ExternalExe = HooksExe | SetupExe +data WantedExternalExe (meth :: ExternalExe) where + WantHooks :: WantedExternalExe HooksExe + WantSetup :: WantedExternalExe SetupExe + +compileExternalExe :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType - -> IO (Version, SetupMethod, SetupScriptOptions) -getExternalSetupMethod verbosity options pkg bt = do - debug verbosity $ "Using external setup method with build-type " ++ show bt - debug verbosity $ - "Using explicit dependencies: " - ++ show (useDependenciesExclusive options) - createDirectoryIfMissingVerbose verbosity True $ i setupDir + -> WantedExternalExe exe + -> IO (If (exe == HooksExe) () (Version, SetupMethod GeneralSetup, SetupScriptOptions)) +compileExternalExe verbosity options pkg bt wantedMeth = do + createDirectoryIfMissingVerbose verbosity True $ i (setupDir options) (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion - path <- + exePath <- if useCachedSetupExecutable then getCachedSetupExecutable + verbosity + platform + (package pkg) + bt options' cabalLibVersion mCabalLibInstalledPkgId else - compileSetupExecutable + compileExe + verbosity + platform + (package pkg) + bt + wantedMeth options' cabalLibVersion mCabalLibInstalledPkgId @@ -706,52 +858,34 @@ getExternalSetupMethod verbosity options pkg bt = do -- be turned into an absolute path. On some systems, runProcess' will take -- path as relative to the new working directory instead of the current -- working directory. - path' <- tryCanonicalizePath path + exePath' <- tryCanonicalizePath exePath -- See 'Note: win32 clean hack' above. #ifdef mingw32_HOST_OS -- setupProgFile may not exist if we're using a cached program - setupProgFile' <- canonicalizePathNoThrow $ i setupProgFile + setupProgFile' <- canonicalizePathNoThrow $ i (setupProgFile options) let win32CleanHackNeeded = (useWin32CleanHack options) -- Skip when a cached setup script is used. - && setupProgFile' `equalFilePath` path' + && setupProgFile' `equalFilePath` exePath' #else let win32CleanHackNeeded = False #endif let options'' = options'{useWin32CleanHack = win32CleanHackNeeded} - return (cabalLibVersion, ExternalMethod path', options'') + case wantedMeth of + WantHooks -> return () + WantSetup -> return (cabalLibVersion, ExternalMethod exePath', options'') 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) - platform = fromMaybe buildPlatform (usePlatform options) useCachedSetupExecutable = bt == Simple || bt == Configure || bt == Make - maybeGetInstalledPackages - :: SetupScriptOptions - -> Compiler - -> ProgramDb - -> IO InstalledPackageIndex - maybeGetInstalledPackages options' comp progdb = - case usePackageIndex options' of - Just index -> return index - Nothing -> - getInstalledPackages - verbosity - comp - (usePackageDB options') - progdb - -- Choose the version of Cabal to use if the setup script has a dependency on -- Cabal, and possibly update the setup script options. The version also -- determines how to filter the flags to Setup. @@ -762,7 +896,7 @@ getExternalSetupMethod verbosity options pkg bt = do -- checking 'useCabalSpecVersion', then the saved version, and finally the -- versions available in the index. -- - -- The version chosen here must match the one used in 'compileSetupExecutable' + -- The version chosen here must match the one used in 'compileExe' -- (See issue #3433). cabalLibVersionToUse :: IO @@ -798,23 +932,28 @@ getExternalSetupMethod verbosity options pkg bt = do _ -> installedVersion where -- This check duplicates the checks in 'getCachedSetupExecutable' / - -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice + -- 'compileExe'. Unfortunately, we have to perform it twice -- because the selected Cabal version may change as a result of this -- check. canUseExistingSetup :: Version -> IO Bool canUseExistingSetup version = if useCachedSetupExecutable then do - (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version + (_, cachedSetupProgFile) <- cachedSetupDirAndProg platform bt options version doesFileExist cachedSetupProgFile - else - (&&) - <$> i setupProgFile `existsAndIsMoreRecentThan` i setupHs - <*> i setupProgFile `existsAndIsMoreRecentThan` i setupVersionFile + else case wantedMeth of + WantSetup -> + (&&) + <$> i (setupProgFile options) `existsAndIsMoreRecentThan` i (setupHs options) + <*> i (setupProgFile options) `existsAndIsMoreRecentThan` i (setupVersionFile options) + WantHooks -> + (&&) + <$> i (hooksProgFile options) `existsAndIsMoreRecentThan` i (setupHooks options) + <*> i (hooksProgFile options) `existsAndIsMoreRecentThan` i (setupVersionFile options) writeSetupVersionFile :: Version -> IO () writeSetupVersionFile version = - writeFile (i setupVersionFile) (show version ++ "\n") + writeFile (i (setupVersionFile options)) (show version ++ "\n") installedVersion :: IO @@ -823,9 +962,12 @@ getExternalSetupMethod verbosity options pkg bt = do , SetupScriptOptions ) installedVersion = do - (comp, progdb, options') <- configureCompiler options + (comp, progdb, options') <- configureCompiler verbosity options (version, mipkgid, options'') <- installedCabalVersion + verbosity + pkg + bt options' comp progdb @@ -835,7 +977,7 @@ getExternalSetupMethod verbosity options pkg bt = do savedVersion :: IO (Maybe Version) savedVersion = do - versionString <- readFile (i setupVersionFile) `catchIO` \_ -> return "" + versionString <- readFile (i (setupVersionFile options)) `catchIO` \_ -> return "" case reads versionString of [(version, s)] | all isSpace s -> return (Just version) _ -> return Nothing @@ -848,323 +990,442 @@ getExternalSetupMethod verbosity options pkg bt = do unless (useHs || useLhs) $ dieWithException verbosity UpdateSetupScript let src = (if useHs then customSetupHs else customSetupLhs) - srcNewer <- src `moreRecentFile` i setupHs + srcNewer <- src `moreRecentFile` i (setupHs options) when srcNewer $ if useHs - then copyFileVerbose verbosity src (i setupHs) - else runSimplePreProcessor ppUnlit src (i setupHs) verbosity + then copyFileVerbose verbosity src (i (setupHs options)) + else runSimplePreProcessor ppUnlit src (i (setupHs options)) verbosity where customSetupHs = workingDir options "Setup.hs" customSetupLhs = workingDir options "Setup.lhs" updateSetupScript cabalLibVersion Hooks = do - let customSetupHooks = workingDir options "SetupHooks.hs" useHs <- doesFileExist customSetupHooks - unless (useHs) $ + unless useHs $ die' verbosity "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 - updateSetupScript cabalLibVersion _ = - rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) - - buildTypeScript :: Version -> BS.ByteString - buildTypeScript cabalLibVersion = "{-# LANGUAGE NoImplicitPrelude #-}\n" <> case bt of - Simple -> "import Distribution.Simple; main = defaultMain\n" - Configure - | cabalLibVersion >= mkVersion [3, 13, 0] - -> "import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n" - | cabalLibVersion >= mkVersion [1, 3, 10] - -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n" - | otherwise - -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n" - Make -> "import Distribution.Make; main = defaultMain\n" - Hooks - | cabalLibVersion >= mkVersion [3, 13, 0] - -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n" - | otherwise - -> error "buildTypeScript Hooks with Cabal < 3.13" - Custom -> error "buildTypeScript Custom" - - installedCabalVersion - :: SetupScriptOptions - -> Compiler - -> ProgramDb - -> IO - ( Version - , Maybe InstalledPackageId - , SetupScriptOptions - ) - installedCabalVersion options' _ _ - | packageName pkg == mkPackageName "Cabal" - && bt == Custom = - return (packageVersion pkg, Nothing, options') - installedCabalVersion options' compiler progdb = do - index <- maybeGetInstalledPackages options' compiler progdb - let cabalDepName = mkPackageName "Cabal" - cabalDepVersion = useCabalVersion options' - options'' = options'{usePackageIndex = Just index} - case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of - [] -> - dieWithException verbosity $ InstalledCabalVersion (packageName pkg) (useCabalVersion options) - pkgs -> - let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs - err = error "Distribution.Client.installedCabalVersion: empty version list" - in return - ( packageVersion ipkginfo - , Just . IPI.installedComponentId $ ipkginfo - , options'' - ) - - bestVersion :: (a -> Version) -> [a] -> a - bestVersion f = firstMaximumBy (comparing (preference . f)) + copyFileVerbose verbosity customSetupHooks (i (setupHooks options)) + rewriteFileLBS verbosity (i (setupHs options)) (buildTypeScript Hooks cabalLibVersion) + rewriteFileLBS verbosity (i (hooksHs options)) hooksExeScript + updateSetupScript cabalLibVersion bt' = + rewriteFileLBS verbosity (i (setupHs options)) (buildTypeScript bt' cabalLibVersion) + +-- | The source code for a non-Custom 'Setup' executable. +buildTypeScript :: BuildType -> Version -> BS.ByteString +buildTypeScript bt cabalLibVersion = "{-# LANGUAGE NoImplicitPrelude #-}\n" <> case bt of + Simple -> "import Distribution.Simple; main = defaultMain\n" + Configure + | cabalLibVersion >= mkVersion [3, 13, 0] + -> "import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n" + | cabalLibVersion >= mkVersion [1, 3, 10] + -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n" + | otherwise + -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n" + Make -> "import Distribution.Make; main = defaultMain\n" + Hooks + | cabalLibVersion >= mkVersion [3, 13, 0] + -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n" + | otherwise + -> error "buildTypeScript Hooks with Cabal < 3.13" + Custom -> error "buildTypeScript Custom" + +-- | The source code for an external hooks executable, using the 'hooks-exe' library. +hooksExeScript :: BS.ByteString +hooksExeScript = + "{-# LANGUAGE NoImplicitPrelude #-}\nimport Distribution.Client.SetupHooks.HooksExe (hooksMain); import SetupHooks; main = hooksMain setupHooks\n" + +installedCabalVersion + :: Verbosity + -> PackageDescription + -> BuildType + -> SetupScriptOptions + -> Compiler + -> ProgramDb + -> IO + ( Version + , Maybe InstalledPackageId + , SetupScriptOptions + ) +installedCabalVersion _verbosity pkg bt options' _ _ + | packageName pkg == mkPackageName "Cabal" + && bt == Custom = + return (packageVersion pkg, Nothing, options') +installedCabalVersion verbosity pkg _bt options' compiler progdb = do + index <- maybeGetInstalledPackages verbosity options' compiler progdb + let cabalDepName = mkPackageName "Cabal" + cabalDepVersion = useCabalVersion options' + options'' = options'{usePackageIndex = Just index} + case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of + [] -> + dieWithException verbosity $ InstalledCabalVersion (packageName pkg) (useCabalVersion options') + pkgs -> + let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs + err = error "Distribution.Client.installedCabalVersion: empty version list" + in return + ( packageVersion ipkginfo + , Just . IPI.installedComponentId $ ipkginfo + , options'' + ) + +bestVersion :: (a -> Version) -> [a] -> a +bestVersion f = firstMaximumBy (comparing (preference . f)) + where + -- Like maximumBy, but picks the first maximum element instead of the + -- last. In general, we expect the preferred version to go first in the + -- list. For the default case, this has the effect of choosing the version + -- installed in the user package DB instead of the global one. See #1463. + -- + -- Note: firstMaximumBy could be written as just + -- `maximumBy cmp . reverse`, but the problem is that the behaviour of + -- maximumBy is not fully specified in the case when there is not a single + -- greatest element. + firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a + firstMaximumBy _ [] = + error "Distribution.Client.firstMaximumBy: empty list" + firstMaximumBy cmp xs = foldl1' maxBy xs where - -- Like maximumBy, but picks the first maximum element instead of the - -- last. In general, we expect the preferred version to go first in the - -- list. For the default case, this has the effect of choosing the version - -- installed in the user package DB instead of the global one. See #1463. - -- - -- Note: firstMaximumBy could be written as just - -- `maximumBy cmp . reverse`, but the problem is that the behaviour of - -- maximumBy is not fully specified in the case when there is not a single - -- greatest element. - firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a - firstMaximumBy _ [] = - error "Distribution.Client.firstMaximumBy: empty list" - firstMaximumBy cmp xs = foldl1' maxBy xs - where - maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y - - preference version = - ( sameVersion - , sameMajorVersion - , stableVersion - , latestVersion - ) - where - sameVersion = version == cabalVersion - sameMajorVersion = majorVersion version == majorVersion cabalVersion - majorVersion = take 2 . versionNumbers - stableVersion = case versionNumbers version of - (_ : x : _) -> even x - _ -> False - latestVersion = version - - configureCompiler - :: SetupScriptOptions - -> IO (Compiler, ProgramDb, SetupScriptOptions) - configureCompiler options' = do - (comp, progdb) <- case useCompiler options' of - Just comp -> return (comp, useProgramDb options') - Nothing -> do - (comp, _, progdb) <- - configCompilerEx - (Just GHC) - Nothing - Nothing - (useProgramDb options') - verbosity - return (comp, progdb) - -- Whenever we need to call configureCompiler, we also need to access the - -- package index, so let's cache it in SetupScriptOptions. - index <- maybeGetInstalledPackages options' comp progdb - return - ( comp - , progdb - , options' - { useCompiler = Just comp - , usePackageIndex = Just index - , useProgramDb = progdb - } - ) - - -- \| Path to the setup exe cache directory and path to the cached setup - -- executable. - cachedSetupDirAndProg - :: SetupScriptOptions - -> Version - -> IO (FilePath, FilePath) - cachedSetupDirAndProg options' cabalLibVersion = do - cacheDir <- defaultCacheDir - let setupCacheDir = cacheDir "setup-exe-cache" - cachedSetupProgFile = - setupCacheDir - ( "setup-" - ++ buildTypeString - ++ "-" - ++ cabalVersionString - ++ "-" - ++ platformString - ++ "-" - ++ compilerVersionString - ) - <.> exeExtension buildPlatform - return (setupCacheDir, cachedSetupProgFile) + maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y + + preference version = + ( sameVersion + , sameMajorVersion + , stableVersion + , latestVersion + ) where - buildTypeString = show bt - cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion - compilerVersionString = - prettyShow $ - maybe buildCompilerId compilerId $ - useCompiler options' - platformString = prettyShow platform - - -- \| Look up the setup executable in the cache; update the cache if the setup - -- executable is not found. - getCachedSetupExecutable - :: SetupScriptOptions - -> Version - -> Maybe InstalledPackageId - -> IO FilePath - getCachedSetupExecutable - options' - cabalLibVersion - maybeCabalLibInstalledPkgId = do - (setupCacheDir, cachedSetupProgFile) <- - cachedSetupDirAndProg options' cabalLibVersion - cachedSetupExists <- doesFileExist cachedSetupProgFile - if cachedSetupExists + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionNumbers + stableVersion = case versionNumbers version of + (_ : x : _) -> even x + _ -> False + latestVersion = version + +configureCompiler + :: Verbosity + -> SetupScriptOptions + -> IO (Compiler, ProgramDb, SetupScriptOptions) +configureCompiler verbosity options' = do + (comp, progdb) <- case useCompiler options' of + Just comp -> return (comp, useProgramDb options') + Nothing -> do + (comp, _, progdb) <- + configCompilerEx + (Just GHC) + Nothing + Nothing + (useProgramDb options') + verbosity + return (comp, progdb) + -- Whenever we need to call configureCompiler, we also need to access the + -- package index, so let's cache it in SetupScriptOptions. + index <- maybeGetInstalledPackages verbosity options' comp progdb + return + ( comp + , progdb + , options' + { useCompiler = Just comp + , usePackageIndex = Just index + , useProgramDb = progdb + } + ) + +maybeGetInstalledPackages + :: Verbosity + -> SetupScriptOptions + -> Compiler + -> ProgramDb + -> IO InstalledPackageIndex +maybeGetInstalledPackages verbosity options' comp progdb = + case usePackageIndex options' of + Just index -> return index + Nothing -> + getInstalledPackages + verbosity + comp + (usePackageDB options') + progdb + +-- | Path to the setup exe cache directory and path to the cached setup +-- executable. +cachedSetupDirAndProg + :: Platform + -> BuildType + -> SetupScriptOptions + -> Version + -> IO (FilePath, FilePath) +cachedSetupDirAndProg platform bt options' cabalLibVersion = do + cacheDir <- defaultCacheDir + let setupCacheDir = cacheDir "setup-exe-cache" + cachedSetupProgFile = + setupCacheDir + ( "setup-" + ++ buildTypeString + ++ "-" + ++ cabalVersionString + ++ "-" + ++ platformString + ++ "-" + ++ compilerVersionString + ) + <.> exeExtension buildPlatform + return (setupCacheDir, cachedSetupProgFile) + where + buildTypeString = show bt + cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion + compilerVersionString = + prettyShow $ + maybe buildCompilerId compilerId $ + useCompiler options' + platformString = prettyShow platform + +-- | Look up the executable in the cache; update the cache if the executable +-- is not found. +getCachedSetupExecutable + :: Verbosity + -> Platform + -> PackageIdentifier + -> BuildType + -> SetupScriptOptions + -> Version + -> Maybe InstalledPackageId + -> IO FilePath +getCachedSetupExecutable + verbosity + platform + pkgId + bt + options' + cabalLibVersion + maybeCabalLibInstalledPkgId = do + (setupCacheDir, cachedSetupProgFile) <- + cachedSetupDirAndProg platform bt options' cabalLibVersion + cachedSetupExists <- doesFileExist cachedSetupProgFile + if cachedSetupExists + then + debug verbosity $ + "Found cached setup executable: " ++ cachedSetupProgFile + else criticalSection' $ do + -- The cache may have been populated while we were waiting. + cachedSetupExists' <- doesFileExist cachedSetupProgFile + if cachedSetupExists' then debug verbosity $ "Found cached setup executable: " ++ cachedSetupProgFile - else criticalSection' $ do - -- The cache may have been populated while we were waiting. - cachedSetupExists' <- doesFileExist cachedSetupProgFile - if cachedSetupExists' - then - debug verbosity $ - "Found cached setup executable: " ++ cachedSetupProgFile - else do - debug verbosity "Setup executable not found in the cache." - src <- - compileSetupExecutable - options' - cabalLibVersion - maybeCabalLibInstalledPkgId - True - createDirectoryIfMissingVerbose verbosity True setupCacheDir - installExecutableFile verbosity src cachedSetupProgFile - -- Do not strip if we're using GHCJS, since the result may be a script - when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do - -- Add the relevant PATH overrides for the package to the - -- program database. - setupProgDb - <- prependProgramSearchPath verbosity - (useExtraPathEnv options) - (useExtraEnvOverrides options) - (useProgramDb options') - >>= configureAllKnownPrograms verbosity - Strip.stripExe - verbosity - platform - setupProgDb - cachedSetupProgFile - return cachedSetupProgFile - where - criticalSection' = maybe id criticalSection $ setupCacheLock options' - - -- \| 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 - :: SetupScriptOptions - -> Version - -> Maybe ComponentId - -> Bool - -> IO FilePath - compileSetupExecutable - options' - cabalLibVersion - maybeCabalLibInstalledPkgId - forceCompile = do - setupHsNewer <- i setupHs `moreRecentFile` i setupProgFile - cabalVersionNewer <- i setupVersionFile `moreRecentFile` i setupProgFile - let outOfDate = setupHsNewer || cabalVersionNewer - when (outOfDate || forceCompile) $ do - debug verbosity "Setup executable needs to be updated, compiling..." - (compiler, progdb, options'') <- configureCompiler options' - pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options'')) - let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion - (program, extraOpts) = - case compilerFlavor compiler of - GHCJS -> (ghcjsProgram, ["-build-runner"]) - _ -> (ghcProgram, ["-threaded"]) - cabalDep = - maybe - [] - (\ipkgid -> [(ipkgid, cabalPkgid)]) - maybeCabalLibInstalledPkgId - - -- With 'useDependenciesExclusive' and Custom build type, - -- we enforce the deps specified, so only the given ones can be used. - -- Otherwise we add on a dep on the Cabal library - -- (unless 'useDependencies' already contains one). - selectedDeps - | (useDependenciesExclusive options' && (bt /= Hooks)) - -- NB: to compile build-type: Hooks packages, we need Cabal - -- in order to compile @main = defaultMainWithSetupHooks setupHooks@. - || any (isCabalPkgId . snd) (useDependencies options') - = useDependencies options' - | otherwise = - useDependencies options' ++ cabalDep - addRenaming (ipid, _) = - -- Assert 'DefUnitId' invariant - ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) - , defaultRenaming - ) - cppMacrosFile = setupDir Cabal.Path. makeRelativePathEx "setup_macros.h" - ghcOptions = - mempty - { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use - -- --ghc-option=-v instead! - ghcOptVerbosity = Flag (min (verbosityLevel verbosity) Normal) - , ghcOptMode = Flag GhcModeMake - , ghcOptInputFiles = toNubListR [setupHs] - , ghcOptOutputFile = Flag setupProgFile - , ghcOptObjDir = Flag setupDir - , ghcOptHiDir = Flag setupDir - , ghcOptSourcePathClear = Flag True - , ghcOptSourcePath = case bt of - Custom -> toNubListR [sameDirectory] - Hooks -> toNubListR [sameDirectory] - _ -> mempty - , ghcOptPackageDBs = pkgDbs - , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') - , ghcOptCabal = Flag (useDependenciesExclusive options') - , ghcOptPackages = toNubListR $ map addRenaming selectedDeps - -- With 'useVersionMacros', use a version CPP macros .h file. - , ghcOptCppIncludes = - toNubListR - [ cppMacrosFile - | useVersionMacros options' - ] - , ghcOptExtra = extraOpts - , ghcOptExtensions = toNubListR $ - [Simple.DisableExtension Simple.ImplicitPrelude | not (bt == Custom || any (isBasePkgId . snd) selectedDeps)] - -- Pass -WNoImplicitPrelude to avoid depending on base - -- when compiling a Simple Setup.hs file. - , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler - } - let ghcCmdLine = renderGhcOptions compiler platform ghcOptions - when (useVersionMacros options') $ - rewriteFileEx verbosity (i cppMacrosFile) $ - generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) - case useLoggingHandle options of - Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine - -- If build logging is enabled, redirect compiler output to - -- the log file. - Just logHandle -> do - output <- - getDbProgramOutputCwd - verbosity - mbWorkDir - program - progdb - ghcCmdLine - hPutStr logHandle output - return $ i setupProgFile + else do + debug verbosity "Setup executable not found in the cache." + src <- + compileExe + verbosity + platform + pkgId + bt + WantSetup + options' + cabalLibVersion + maybeCabalLibInstalledPkgId + True + createDirectoryIfMissingVerbose verbosity True setupCacheDir + installExecutableFile verbosity src cachedSetupProgFile + -- Do not strip if we're using GHCJS, since the result may be a script + when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do + -- Add the relevant PATH overrides for the package to the + -- program database. + setupProgDb + <- prependProgramSearchPath verbosity + (useExtraPathEnv options') + (useExtraEnvOverrides options') + (useProgramDb options') + >>= configureAllKnownPrograms verbosity + Strip.stripExe + verbosity + platform + setupProgDb + cachedSetupProgFile + return cachedSetupProgFile + where + criticalSection' = maybe id criticalSection $ setupCacheLock options' + +-- | 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. +compileExe + :: Verbosity + -> Platform + -> PackageIdentifier + -> BuildType + -> WantedExternalExe exe + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath +compileExe verbosity platform pkgId bt wantedMeth opts ver mbCompId forceCompile = + case wantedMeth of + WantHooks -> + compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile + WantSetup -> + compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile + +compileSetupScript + :: Verbosity + -> Platform + -> PackageIdentifier + -> BuildType + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath +compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile = + compileSetupX "Setup" + [setupHs opts] (setupProgFile opts) + verbosity platform pkgId bt opts ver mbCompId forceCompile + +compileHooksScript + :: Verbosity + -> Platform + -> PackageIdentifier + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath +compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile = + compileSetupX "SetupHooks" + [setupHooks opts, hooksHs opts] (hooksProgFile opts) + verbosity platform pkgId Hooks opts ver mbCompId forceCompile + +setupDir :: SetupScriptOptions -> SymbolicPath Pkg (Dir setup) +setupDir opts = useDistPref opts Cabal.Path. makeRelativePathEx "setup" +setupVersionFile :: SetupScriptOptions -> SymbolicPath Pkg File +setupVersionFile opts = setupDir opts Cabal.Path. makeRelativePathEx ( "setup" <.> "version" ) +setupHs, hooksHs, setupHooks, setupProgFile, hooksProgFile :: SetupScriptOptions -> SymbolicPath Pkg File +setupHs opts = setupDir opts Cabal.Path. makeRelativePathEx ( "setup" <.> "hs" ) +hooksHs opts = setupDir opts Cabal.Path. makeRelativePathEx ( "hooks" <.> "hs" ) +setupHooks opts = setupDir opts Cabal.Path. makeRelativePathEx ( "SetupHooks" <.> "hs" ) +setupProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ( "setup" <.> exeExtension buildPlatform ) +hooksProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ( "hooks" <.> exeExtension buildPlatform ) + +compileSetupX + :: String + -> [SymbolicPath Pkg File] -- input files + -> SymbolicPath Pkg File -- output file + -> Verbosity + -> Platform + -> PackageIdentifier + -> BuildType + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath +compileSetupX + what + inPaths outPath + verbosity + platform + pkgId + bt + options' + cabalLibVersion + maybeCabalLibInstalledPkgId + forceCompile = do + setupXHsNewer <- + or <$> for inPaths (\ inPath -> i inPath `moreRecentFile` i outPath) + cabalVersionNewer <- i (setupVersionFile options') `moreRecentFile` i outPath + let outOfDate = setupXHsNewer || cabalVersionNewer + when (outOfDate || forceCompile) $ do + debug verbosity $ what ++ " executable needs to be updated, compiling..." + (compiler, progdb, options'') <- configureCompiler verbosity options' + pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options'')) + let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion + (program, extraOpts) = + case compilerFlavor compiler of + GHCJS -> (ghcjsProgram, ["-build-runner"]) + _ -> (ghcProgram, ["-threaded"]) + cabalDep = + maybe + [] + (\ipkgid -> [(ipkgid, cabalPkgid)]) + maybeCabalLibInstalledPkgId + + -- With 'useDependenciesExclusive' and Custom build type, + -- we enforce the deps specified, so only the given ones can be used. + -- Otherwise we add on a dep on the Cabal library + -- (unless 'useDependencies' already contains one). + selectedDeps + | (useDependenciesExclusive options' && (bt /= Hooks)) + -- NB: to compile build-type: Hooks packages, we need Cabal + -- in order to compile @main = defaultMainWithSetupHooks setupHooks@. + || any (isCabalPkgId . snd) (useDependencies options') + = useDependencies options' + | otherwise = + useDependencies options' ++ cabalDep + addRenaming (ipid, _) = + -- Assert 'DefUnitId' invariant + ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) + , defaultRenaming + ) + cppMacrosFile = setupDir options' Cabal.Path. makeRelativePathEx "setup_macros.h" + ghcOptions = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use + -- --ghc-option=-v instead! + ghcOptVerbosity = Flag $ min (verbosityLevel verbosity) Normal + , ghcOptMode = Flag GhcModeMake + , ghcOptInputFiles = toNubListR inPaths + , ghcOptOutputFile = Flag outPath + , ghcOptObjDir = Flag (setupDir options') + , ghcOptHiDir = Flag (setupDir options') + , ghcOptSourcePathClear = Flag True + , ghcOptSourcePath = case bt of + Custom -> toNubListR [sameDirectory] + Hooks -> toNubListR [sameDirectory] + _ -> mempty + , ghcOptPackageDBs = pkgDbs + , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') + , ghcOptCabal = Flag (useDependenciesExclusive options') + , ghcOptPackages = toNubListR $ map addRenaming selectedDeps + -- With 'useVersionMacros', use a version CPP macros .h file. + , ghcOptCppIncludes = + toNubListR + [ cppMacrosFile + | useVersionMacros options' + ] + , ghcOptExtra = extraOpts + , ghcOptExtensions = toNubListR $ + [ Simple.DisableExtension Simple.ImplicitPrelude + | not $ bt == Custom || any (isBasePkgId . snd) selectedDeps + ] + -- Pass -WNoImplicitPrelude to avoid depending on base + -- when compiling a simple Setup.hs file. + , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler + } + let ghcCmdLine = renderGhcOptions compiler platform ghcOptions + when (useVersionMacros options') $ + rewriteFileEx verbosity (i cppMacrosFile) $ + generatePackageVersionMacros (pkgVersion pkgId) (map snd selectedDeps) + case useLoggingHandle options' of + Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine + -- If build logging is enabled, redirect compiler output to + -- the log file. + Just logHandle -> do + output <- + getDbProgramOutputCwd + verbosity + mbWorkDir + program + progdb + ghcCmdLine + hPutStr logHandle output + return $ i outPath + where + mbWorkDir = useWorkingDir options' + -- See Note [Symbolic paths] in Distribution.Utils.Path + i :: SymbolicPathX allowAbs Pkg to -> FilePath + i = interpretSymbolicPath mbWorkDir isCabalPkgId, isBasePkgId :: 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 9e57595bb95..a324356d9cb 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-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index c35faec5efa..7c332e7e9f6 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -2130,9 +2130,21 @@ getProgArgs :: [ElaboratedConfiguredPackage] -> String -> Maybe [String] getProgArgs [] _ = Nothing getProgArgs (elab : pkgs) name | pkgName (elabPkgSourceId elab) == mkPackageName name = - Map.lookup "ghc" (elabProgramArgs elab) + removeHideAllPackages $ Map.lookup "ghc" (elabProgramArgs elab) | otherwise = getProgArgs pkgs name + where + removeHideAllPackages mbArgs = + -- Filter out "-hide-all-packages", as we pass that by default + -- to GHC invocations in order to avoid it picking up environment files. + -- See https://github.com/haskell/cabal/issues/4010 + case filter (/= "-hide-all-packages") <$> mbArgs of + Just args' + | null args' -> + Nothing + | otherwise -> + Just args' + Nothing -> Nothing --------------------------------- -- Test utils to plan and build diff --git a/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.out b/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.out deleted file mode 100644 index 512a50e37ee..00000000000 --- a/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.out +++ /dev/null @@ -1,10 +0,0 @@ -# cabal v2-build -Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following will be built: - - pkg-0 (lib) (first run) -Configuring library for pkg-0... -Error: [Cabal-5559] -[autogen-guard] To use the autogenerated module PackageInfo_* you need to specify `cabal-version: 3.12` or higher. -Error: [Cabal-7125] -Failed to build pkg-0-inplace. The failure occurred during the configure step. diff --git a/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.test.hs b/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.test.hs index 0711dcccfe1..5bdb7ead190 100644 --- a/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.test.hs +++ b/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.test.hs @@ -4,5 +4,6 @@ import Test.Cabal.Prelude -- build failure. main = cabalTest $ do withProjectFile "cabal.project" $ do - fails $ cabal "v2-build" ["pkg"] + res <- recordMode DoNotRecord $ fails $ cabal' "v2-build" ["pkg"] + assertOutputContains "[autogen-guard]" res diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out deleted file mode 100644 index c8c27376397..00000000000 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out +++ /dev/null @@ -1,8 +0,0 @@ -# cabal v2-run -Warning: The package description file ./script.cabal has warnings: script.cabal:0:0: A package using 'cabal-version: >=1.10' must use section syntax. See the Cabal user guide for details. -Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following will be built: - - fake-package-0 (exe:script-script.lhs) (first run) -Configuring executable 'script-script.lhs' for fake-package-0... -Building executable 'script-script.lhs' for fake-package-0... diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs index 64c858e8d0d..e7ae8bfc4c6 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs @@ -1,5 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ do +main = cabalTest $ recordMode DoNotRecord $ do res <- cabal' "v2-run" ["script.lhs"] assertOutputContains "Hello World" res diff --git a/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.out b/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.out deleted file mode 100644 index 53ccefe2347..00000000000 --- a/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.out +++ /dev/null @@ -1,12 +0,0 @@ -# cabal build -Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following will be built: - - aa-0.1.0.0 (exe:a) (first run) -Configuring executable 'a' for aa-0.1.0.0... -Warning: Executables will use dynamic linking, but a shared library is not -being built. Linking will fail if any executables depend on the library. -Error: [Cabal-3339] -Operating system: windows, does not support shared executables -Error: [Cabal-7125] -Failed to build aa-0.1.0.0-inplace-a. The failure occurred during the configure step. diff --git a/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.test.hs b/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.test.hs index aa0c8e83b7b..792f043165e 100644 --- a/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.test.hs @@ -2,4 +2,7 @@ import Test.Cabal.Prelude main = do skipUnlessWindows - cabalTest $ fails $ cabal "build" ["--enable-executable-dynamic", "--disable-shared"] + cabalTest $ recordMode DoNotRecord $ fails $ do + res <- cabal' "build" ["--enable-executable-dynamic", "--disable-shared"] + assertOutputContains "does not support shared executables" res + diff --git a/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.out b/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.out deleted file mode 100644 index f59d29e6b17..00000000000 --- a/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.out +++ /dev/null @@ -1,10 +0,0 @@ -# cabal build -Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following will be built: - - aa-0.1.0.0 (exe:a) (first run) -Configuring executable 'a' for aa-0.1.0.0... -Error: [Cabal-3339] -Operating system: windows, does not support relocatable builds -Error: [Cabal-7125] -Failed to build aa-0.1.0.0-inplace-a. The failure occurred during the configure step. diff --git a/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.test.hs b/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.test.hs index 448fc6fc22a..dc50d7b2ada 100644 --- a/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.test.hs @@ -2,4 +2,6 @@ import Test.Cabal.Prelude main = do skipUnlessWindows - cabalTest $ fails $ cabal "build" ["--enable-relocatable"] + cabalTest $ recordMode DoNotRecord $ fails $ do + res <- cabal' "build" ["--enable-relocatable"] + assertOutputContains "windows, does not support relocatable builds" res diff --git a/cabal-testsuite/PackageTests/Project/CoverageProject/cabal.out b/cabal-testsuite/PackageTests/Project/CoverageProject/cabal.out index 1278857b31d..f6afdb5e560 100644 --- a/cabal-testsuite/PackageTests/Project/CoverageProject/cabal.out +++ b/cabal-testsuite/PackageTests/Project/CoverageProject/cabal.out @@ -5,11 +5,9 @@ In order, the following will be built: - pkg-a-0.1 (lib) (first run) - pkg-a-0.1 (test:testing) (first run) Configuring library for pkg-a-0.1... -Warning: [no-default-language] Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. Preprocessing library for pkg-a-0.1... Building library for pkg-a-0.1... Configuring test suite 'testing' for pkg-a-0.1... -Warning: [no-default-language] Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. Preprocessing test suite 'testing' for pkg-a-0.1... Building test suite 'testing' for pkg-a-0.1... Running 1 test suites... diff --git a/cabal-testsuite/PackageTests/Project/CoverageProject/pkg-a/pkg-a.cabal b/cabal-testsuite/PackageTests/Project/CoverageProject/pkg-a/pkg-a.cabal index 4a064d3389c..c6c44432201 100644 --- a/cabal-testsuite/PackageTests/Project/CoverageProject/pkg-a/pkg-a.cabal +++ b/cabal-testsuite/PackageTests/Project/CoverageProject/pkg-a/pkg-a.cabal @@ -18,6 +18,7 @@ library test-suite testing type: exitcode-stdio-1.0 build-depends: base, pkg-a + default-language: Haskell2010 main-is: Main.hs hs-source-dirs: test diff --git a/cabal-testsuite/PackageTests/Regression/T5318/install.out b/cabal-testsuite/PackageTests/Regression/T5318/install.out index 9c47fdc6b50..e69de29bb2d 100644 --- a/cabal-testsuite/PackageTests/Regression/T5318/install.out +++ b/cabal-testsuite/PackageTests/Regression/T5318/install.out @@ -1,8 +0,0 @@ -# cabal v1-install -Resolving dependencies... -Configuring empty-data-dir-0... -Preprocessing executable 'foo' for empty-data-dir-0... -Building executable 'foo' for empty-data-dir-0... -Installing executable foo in -Warning: The directory /install.dist/home/.cabal/bin is not in the system search path. -Completed empty-data-dir-0 diff --git a/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs b/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs index 6fd409c2704..3efaca5c05a 100644 --- a/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs +++ b/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs @@ -1,3 +1,3 @@ import Test.Cabal.Prelude -main = cabalTest $ +main = cabalTest $ recordMode DoNotRecord $ cabal "v1-install" [] diff --git a/cabal-testsuite/PackageTests/Regression/T6440/cabal.out b/cabal-testsuite/PackageTests/Regression/T6440/cabal.out index 5c24cecf81f..23cfe47a187 100644 --- a/cabal-testsuite/PackageTests/Regression/T6440/cabal.out +++ b/cabal-testsuite/PackageTests/Regression/T6440/cabal.out @@ -6,15 +6,12 @@ In order, the following will be built: - cabal6440-0.1 (lib) (first run) - cabal6440-0.1 (test:tests) (first run) Configuring library 'intern6440' for cabal6440-0.1... -Warning: [no-default-language] Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. Preprocessing library 'intern6440' for cabal6440-0.1... Building library 'intern6440' for cabal6440-0.1... Configuring library for cabal6440-0.1... -Warning: [no-default-language] Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. Preprocessing library for cabal6440-0.1... Building library for cabal6440-0.1... Configuring test suite 'tests' for cabal6440-0.1... -Warning: [no-default-language] Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. Preprocessing test suite 'tests' for cabal6440-0.1... Building test suite 'tests' for cabal6440-0.1... Running 1 test suites... diff --git a/cabal-testsuite/PackageTests/Regression/T6440/cabal6440.cabal b/cabal-testsuite/PackageTests/Regression/T6440/cabal6440.cabal index 42192a71672..1af78b1545b 100644 --- a/cabal-testsuite/PackageTests/Regression/T6440/cabal6440.cabal +++ b/cabal-testsuite/PackageTests/Regression/T6440/cabal6440.cabal @@ -13,7 +13,7 @@ library intern6440 exposed-modules: Inn build-depends: base hs-source-dirs: srcint - + default-language: Haskell2010 test-suite tests main-is: Main.hs diff --git a/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out b/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out index ebfae34dde9..49589c6e29d 100644 --- a/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out +++ b/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out @@ -4,7 +4,6 @@ Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: - issue7234-0 (lib) (first run) -Warning: issue7234.cabal:14:3: The field "other-extensions" is available only since the Cabal specification version 1.10. Configuring library for issue7234-0... Preprocessing library for issue7234-0... Building library for issue7234-0... diff --git a/cabal-testsuite/PackageTests/Regression/T9640/cabal.out b/cabal-testsuite/PackageTests/Regression/T9640/cabal.out index a3d4d2935a4..c55ad4c9da4 100644 --- a/cabal-testsuite/PackageTests/Regression/T9640/cabal.out +++ b/cabal-testsuite/PackageTests/Regression/T9640/cabal.out @@ -11,7 +11,6 @@ Configuring one-custom-0.1.0.0... Preprocessing library for one-custom-0.1.0.0... Building library for one-custom-0.1.0.0... Installing library in -Warning: depend-on-custom-with-exe.cabal:16:1: Ignoring trailing fields after sections: "ghc-options" Configuring library for depend-on-custom-with-exe-0.1.0.0... Preprocessing library for depend-on-custom-with-exe-0.1.0.0... Building library for depend-on-custom-with-exe-0.1.0.0... 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/PackageTests/WithRepl/SimpleTests/cabal.test.hs b/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.test.hs index 71c584120f5..38fd325f126 100644 --- a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.test.hs +++ b/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.test.hs @@ -4,7 +4,7 @@ import System.FilePath (()) main = do -- Test that --with-repl works with a valid GHC path - cabalTest' "with-repl-valid-path" $ do + cabalTest' "with-repl-valid-path" $ recordMode DoNotRecord $ do cabal' "clean" [] -- Get the path to the system GHC ghc_prog <- requireProgramM ghcProgram @@ -13,7 +13,7 @@ main = do assertOutputContains "GHCi, version" res -- Test that --with-repl fails with an invalid path - cabalTest' "with-repl-invalid-path" $ do + cabalTest' "with-repl-invalid-path" $ recordMode DoNotRecord $ do cabal' "clean" [] res <- fails $ cabalWithStdin "v2-repl" ["--with-repl=/nonexistent/path/to/ghc"] "" assertOutputContains "does not exist" res diff --git a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-invalid-path.out b/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-invalid-path.out deleted file mode 100644 index b59b62a074a..00000000000 --- a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-invalid-path.out +++ /dev/null @@ -1,10 +0,0 @@ -# cabal clean -# cabal v2-repl -Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following will be built: - - cabal-with-repl-0.1.0.0 (interactive) (lib) (first run) -Configuring library for cabal-with-repl-0.1.0.0... -Preprocessing library for cabal-with-repl-0.1.0.0... -Error: [Cabal-7125] -repl failed for cabal-with-repl-0.1.0.0-inplace. diff --git a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-valid-path.out b/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-valid-path.out deleted file mode 100644 index f1ca1ffc808..00000000000 --- a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-valid-path.out +++ /dev/null @@ -1,8 +0,0 @@ -# cabal clean -# cabal v2-repl -Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following will be built: - - cabal-with-repl-0.1.0.0 (interactive) (lib) (first run) -Configuring library for cabal-with-repl-0.1.0.0... -Preprocessing library for cabal-with-repl-0.1.0.0... diff --git a/cabal-testsuite/main/cabal-tests.hs b/cabal-testsuite/main/cabal-tests.hs index 49b2c80c6bf..6f90145c575 100644 --- a/cabal-testsuite/main/cabal-tests.hs +++ b/cabal-testsuite/main/cabal-tests.hs @@ -159,7 +159,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 @@ -192,7 +192,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 5aa329f9ae5..7f7efa4fa32 100644 --- a/cabal.bootstrap.project +++ b/cabal.bootstrap.project @@ -6,6 +6,7 @@ packages: , Cabal-hooks , cabal-install , cabal-install-solver + , hooks-exe -- Don't include tests or benchmarks for bootstrapping tests: False diff --git a/hooks-exe/Setup.hs b/hooks-exe/Setup.hs new file mode 100644 index 00000000000..021805cb81a --- /dev/null +++ b/hooks-exe/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Simple + +main :: IO () +main = defaultMain 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..e4d27c30479 --- /dev/null +++ b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- 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 Distribution.Verbosity + ( Verbosity, VerbosityHandles, mkVerbosity ) + +-- 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 + => Verbosity + -> FilePath -- ^ path to hooks executable + -> String -- ^ name of the hook to run + -> inputs -- ^ argument to the hook + -> IO outputs +callHooksExe verb 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 verb $ + HookFailed hookName $ + HookException exitCode + ExitSuccess -> do + let mbOutput = Binary.decodeOrFail output + case mbOutput of + Left (_, offset, err) -> do + dieWithException verb $ + 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 :: Verbosity -> FilePath -> SetupHooks +externalSetupHooks verb 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 verb 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 :: Verbosity -> FilePath -> IO HooksVersion +externalSetupHooksABI verb hooksExe = + callHooksExe verb 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 + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> BuildType + -> SetupHooks +buildTypeSetupHooks verb mbWorkDir distPref = \case + Hooks -> externalSetupHooks verb $ 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 + :: VerbosityHandles + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> BuildType + -> ( PreBuildComponentInputs -> IO [MonitorFilePath] ) +buildTypePreBuildHooks verbHandles mbWorkDir distPref = \ case + Hooks -> runExternalPreBuildRules verbHandles + $ 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 + :: VerbosityHandles + -> FilePath + -> PreBuildComponentInputs + -> IO [MonitorFilePath] +runExternalPreBuildRules verbHandles hooksExe + pbci@PreBuildComponentInputs + { buildingWhat = what + , localBuildInfo = lbi + , targetInfo = tgt } = do + let verbFlags = buildingWhatVerbosity what + verbosity = mkVerbosity verbHandles verbFlags + hook :: HookIO inputs outputs => String -> inputs -> IO outputs + hook = callHooksExe verbosity hooksExe + -- 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 + +-- | 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..cc62f977bcf --- /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..1360c029e38 --- /dev/null +++ b/hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe.hs @@ -0,0 +1,201 @@ +{-# 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 + +-- hooks-exe +import Distribution.Client.SetupHooks.HooksExe.Errors + ( SetupHooksExeException(..) + , BadHooksExecutableArgs(..) + , hooksExeVerbosity + ) +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 hooksExeVerbosity $ + NoHandle (Just $ "hook input communication handle '" ++ inputFdRef ++ "'") + Just hRead -> + case hWriteMb of + Nothing -> + dieWithException hooksExeVerbosity $ + 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 hooksExeVerbosity $ + BadHooksExeArgs hookName $ + UnknownHookType + { knownHookTypes = map fst allHookHandlers + } + _ -> dieWithException hooksExeVerbosity NoHookType + _ -> dieWithException hooksExeVerbosity $ + 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 hooksExeVerbosity $ + 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 hooksExeVerbosity 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 hooksExeVerbosity $ 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..bfb3ff93d99 --- /dev/null +++ b/hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe/Errors.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE InstanceSigs #-} + +module Distribution.Client.SetupHooks.HooksExe.Errors + ( SetupHooksExeException (..) + , BadHooksExecutableArgs (..) + , setupHooksExeExceptionCode + , setupHooksExeExceptionMessage + , hooksExeVerbosity + ) where + +-- Cabal +import Distribution.Simple.SetupHooks.Rule + ( RuleId (..) ) +import Distribution.Simple.Utils +import Distribution.Verbosity + ( Verbosity, mkVerbosity, defaultVerbosityHandles ) +import qualified Distribution.Verbosity as Verbosity + ( normal ) + +-- base +import GHC.Exception +import GHC.Int + ( Int64 ) + +-- bytestring +import Data.ByteString.Lazy + ( ByteString ) + +-------------------------------------------------------------------------------- + +hooksExeVerbosity :: Verbosity +hooksExeVerbosity = mkVerbosity defaultVerbosityHandles Verbosity.normal + -- NB: the hooks executable is always invoked as a separate process, never as + -- a library function, so we can use stdout/stderr for verbosity and redirect + -- them using the System.Process API. + +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..8871e2cbf12 --- /dev/null +++ b/hooks-exe/hooks-exe.cabal @@ -0,0 +1,70 @@ +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 + -fno-warn-unticked-promoted-constructors + 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 + +-- NB: we are not using named sub-libraries, as the cabal-install bootstrap +-- script does not currently support them. +library + import: warnings + hs-source-dirs: + -- Component that defines a hooks version, to ensure compatibility between the + -- hooks executable and the executable it communicates with. + version, + -- Component imported by cabal-install to interface with an external + -- hooks executable. + cli, + -- Component used to create an external hooks executable + -- from a SetupHooks.hs module. + exe + + build-depends: + base + >= 4.10 && < 4.22, + bytestring + >= 0.10.6.0 && < 0.13, + containers + >= 0.5.6.2 && < 0.8 , + filepath + >= 1.4.0.0 && < 1.6 , + process + >= 1.6.20.0 && < 1.8 , + Cabal-syntax, Cabal + + exposed-modules: + Distribution.Client.SetupHooks.CallHooksExe + Distribution.Client.SetupHooks.HooksExe + Distribution.Client.SetupHooks.Version + other-modules: + Distribution.Client.SetupHooks.CallHooksExe.Errors + 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