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