diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 71ea82c5bfc..6342eda1df6 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -111,7 +111,6 @@ import Distribution.Simple.SetupHooks.Internal ) import Distribution.Simple.Test import Distribution.Simple.Utils -import Distribution.Types.LocalBuildInfo (buildDirPBD) import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Utils.Path import Distribution.Verbosity @@ -171,7 +170,7 @@ defaultMainWithSetupHooksArgs setupHooks = -> BuildFlags -> IO () setup_buildHook pkg_descr lbi hooks flags = - build_setupHooks + void $ build_setupHooks (SetupHooks.buildHooks setupHooks) pkg_descr lbi @@ -224,7 +223,7 @@ defaultMainWithSetupHooksArgs setupHooks = -> HaddockFlags -> IO () setup_haddockHook pkg_descr lbi hooks flags = - haddock_setupHooks + void $ haddock_setupHooks (SetupHooks.buildHooks setupHooks) pkg_descr lbi diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 36b4b7411f0..423e8fb4a34 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 @@ -86,6 +89,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 @@ -101,9 +105,11 @@ import Distribution.Simple.Setup.Repl import Distribution.Simple.SetupHooks.Internal ( BuildHooks (..) , BuildingWhat (..) + , buildingWhatVerbosity , noBuildHooks ) import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks import Distribution.Simple.ShowBuildInfo import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils @@ -120,7 +126,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) @@ -137,7 +142,8 @@ build -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> IO () -build = build_setupHooks noBuildHooks +build pkg lbi flags suffixHandlers = + void $ build_setupHooks noBuildHooks pkg lbi flags suffixHandlers build_setupHooks :: BuildHooks @@ -149,13 +155,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}) 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) @@ -180,7 +188,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 @@ -191,18 +199,13 @@ 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 -> - SetupHooks.executeRules verbosity lbi2 tgt pbcRules inputs - preBuildComponent runPreBuildHooks verbosity lbi' target - + runPreBuildHooksNormal :: IO [SetupHooks.MonitorFilePath] + runPreBuildHooksNormal = + case mbPbcRules of + Nothing -> return [] + Just pbcRules -> + runPreBuildHooks (BuildNormal flags) lbi target pbcRules + mons <- preBuildComponent runPreBuildHooksNormal verbosity lbi target let numJobs = buildNumJobs flags par_strat <- toFlag <$> case buildUseSemaphore flags of @@ -231,12 +234,41 @@ build_setupHooks , SetupHooks.targetInfo = target } for_ mbPostBuild ($ postBuildInputs) - return (maybe index (Index.insert `flip` index) mb_ipi) + return (monsAcc ++ mons, maybe index (Index.insert `flip` index) mb_ipi) + return mons - return () - where - distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) +runPreBuildHooks + :: BuildingWhat + -> LocalBuildInfo + -> TargetInfo + -> SetupHooks.Rules SetupHooks.PreBuildComponentInputs + -> IO [SetupHooks.MonitorFilePath] +runPreBuildHooks what lbi tgt pbRules = do + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = what + , SetupHooks.localBuildInfo = lbi + , SetupHooks.targetInfo = tgt + } + verbosity = buildingWhatVerbosity what + (rules, monitors) <- SetupHooks.computeRules verbosity inputs pbRules + SetupHooks.executeRules verbosity lbi tgt rules + return monitors + +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 @@ -378,16 +410,10 @@ 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 -> - SetupHooks.executeRules verbosity lbi2 tgt pbcRules inputs + runPreBuildHooksRepl :: TargetInfo -> IO () + runPreBuildHooksRepl tgt = + for_ mbPbcRules $ + void . runPreBuildHooks (BuildRepl flags) lbi tgt -- build any dependent components sequence_ @@ -395,7 +421,7 @@ repl_setupHooks let clbi = targetCLBI subtarget comp = targetComponent subtarget lbi' = lbiForComponent comp lbi - preBuildComponent runPreBuildHooks verbosity lbi' subtarget + preBuildComponent (runPreBuildHooksRepl subtarget) verbosity lbi subtarget buildComponent (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}}) NoFlag @@ -412,7 +438,7 @@ repl_setupHooks let clbi = targetCLBI target comp = targetComponent target lbi' = lbiForComponent comp lbi - preBuildComponent runPreBuildHooks verbosity lbi' target + preBuildComponent (runPreBuildHooksRepl target) verbosity lbi target replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref -- | Start an interpreter without loading any package files. @@ -1029,19 +1055,19 @@ replFLib flags pkg_descr lbi exe clbi = -- | 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 createDirectoryIfMissingVerbose verbosity True (interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi) 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 3dfe0b7e0be..eb49c5c8c40 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -33,6 +33,16 @@ module Distribution.Simple.Configure ( configure , configure_setupHooks + , runPreConfPackageHook + , runPostConfPackageHook + , runPreConfComponentHook + , configurePackage + , PackageInfo (..) + , finalCheckPackage + , configureComponents + , configureDependencies + , mkPromisedDepsSet + , combinedConstraints , writePersistBuildConfig , getConfigStateFile , getPersistBuildConfig @@ -467,81 +477,112 @@ 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 + 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 +850,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 +879,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 @@ -1041,7 +1088,6 @@ finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do enabled comp platform - programDb0 packageDbs return (lbc, pbd, pkg_info) @@ -1111,7 +1157,7 @@ finalCheckPackage } ) hookedBuildInfo - (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) = + pkg_info = do let common = configCommonFlags cfg verbosity = fromFlag $ setupVerbosity common @@ -1185,17 +1231,16 @@ finalCheckPackage configureDependencies verbosity use_external_internal_deps - internalPackageSet - promisedDepsSet - installedPackageSet - requiredDepsMap + pkg_info 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 e71c20d47bc..6cf8cf3c284 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 cbc2213e0cc..a41ade6bf1e 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Haddock.hs @@ -56,6 +56,8 @@ 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 @@ -75,7 +77,6 @@ import Distribution.Simple.SetupHooks.Internal , BuildingWhat (..) , noBuildHooks ) -import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentLocalBuildInfo @@ -93,7 +94,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) @@ -227,7 +227,8 @@ haddock -> [PPSuffixHandler] -> HaddockFlags -> IO () -haddock = haddock_setupHooks noBuildHooks +haddock pkg lbi suffixHandlers flags = + void $ haddock_setupHooks noBuildHooks pkg lbi suffixHandlers flags haddock_setupHooks :: BuildHooks @@ -235,7 +236,7 @@ haddock_setupHooks -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags - -> IO () + -> IO [MonitorFilePath] haddock_setupHooks _ pkg_descr @@ -246,11 +247,12 @@ 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}) pkg_descr @@ -331,22 +333,18 @@ 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 - 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 -> - SetupHooks.executeRules verbosity lbi2 tgt pbcRules inputs - preBuildComponent runPreBuildHooks verbosity lbi target + runPreBuildHooksHaddock :: IO [MonitorFilePath] + runPreBuildHooksHaddock = + case mbPbcRules of + Nothing -> return [] + Just pbcRules -> + runPreBuildHooks (BuildHaddock flags) lbi target pbcRules + mons <- preBuildComponent runPreBuildHooksHaddock verbosity lbi target let lbi' = @@ -465,13 +463,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 @@ -1236,18 +1236,13 @@ 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 -> - SetupHooks.executeRules verbosity lbi2 target pbcRules inputs - preBuildComponent runPreBuildHooks verbosity lbi tgt + let + target = TargetInfo clbi comp + runPreBuildHooksHscolour :: IO () + runPreBuildHooksHscolour = + for_ mbPbcRules $ + void . runPreBuildHooks (BuildHscolour flags) lbi target + preBuildComponent runPreBuildHooksHscolour 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/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/Internal.hs b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs index 74eaa8246da..9a2c4a2ccdf 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs @@ -108,7 +108,8 @@ 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 @@ -119,6 +120,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 GHC.Exts (Any) import Unsafe.Coerce @@ -789,8 +791,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 @@ -826,8 +828,7 @@ applyComponentDiff verbosity comp (ComponentDiff diff) -------------------------------------------------------------------------------- -- Running pre-processors and code generators --- | Run all preprocessors and code generators specified in --- 'SetupHooks'. +-- | Run all pre-build rules. -- -- This function should only be called internally within @Cabal@, as it is used -- to implement the (legacy) Setup.hs interface. The build tool @@ -838,12 +839,9 @@ executeRules :: Verbosity -> LocalBuildInfo -> TargetInfo - -> Rules inputs - -> inputs + -> Map RuleId Rule -> IO () -executeRules verbosity lbi tgtInfo rulesFromInputs inputs = do - -- Get all the rules. - (allRules, _monitors) <- computeRules verbosity inputs rulesFromInputs +executeRules verbosity lbi tgtInfo allRules = do -- Compute all extra dynamic dependency edges. dynDepsEdges <- flip Map.traverseMaybeWithKey allRules $ \_rId (Rule{ruleCommands = cmds}) -> diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index a5626d110b7..665a1b03f9b 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.11.0.0 @@ -147,6 +147,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 @@ -218,6 +219,7 @@ library Distribution.Client.Win32SelfUpgrade build-depends: + hooks-exe:hooks-cli, async >= 2.0 && < 2.3, array >= 0.4 && < 0.6, base16-bytestring >= 0.1.1 && < 1.1.0.0, @@ -235,7 +237,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..bba7bacd26b 100644 --- a/cabal-install/src/Distribution/Client/CmdLegacy.hs +++ b/cabal-install/src/Distribution/Client/CmdLegacy.hs @@ -17,6 +17,7 @@ import qualified Distribution.Client.Setup as Client import Distribution.Client.SetupWrapper ( SetupScriptOptions (..) , defaultSetupScriptOptions + , SetupRunnerArgs(NotInLibrary) , setupWrapper ) import Distribution.Simple.Command @@ -80,6 +81,7 @@ wrapperAction command getCommonFlags = getCommonFlags (const flags) (const extraArgs) + NotInLibrary -- diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index fc7ea49fe31..0b0d6588a62 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -49,6 +49,7 @@ import Distribution.Client.Setup import Distribution.Client.SetupWrapper ( SetupScriptOptions (..) , defaultSetupScriptOptions + , SetupRunnerArgs(NotInLibrary) , setupWrapper ) import Distribution.Client.SolverInstallPlan (SolverInstallPlan) @@ -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 @@ -507,6 +509,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..f38595dacc8 --- /dev/null +++ b/cabal-install/src/Distribution/Client/InLibrary.hs @@ -0,0 +1,307 @@ +{-# 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.Client.ProjectPlanning.Types +import Distribution.Client.RebuildMonad +import qualified Distribution.Client.SetupHooks.CallHooksExe as ExternalHooksExe + ( buildTypeSetupHooks ) +import Distribution.Client.Types + +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Build (build_setupHooks, repl_setupHooks) +import qualified Distribution.Simple.Configure as Cabal +import Distribution.Simple.LocalBuildInfo + ( Component + , componentName, mbWorkDirLBI + ) +import qualified Distribution.Simple.PreProcess as Cabal +import qualified Distribution.Simple.Register as Cabal +import qualified Distribution.Simple.Test as Cabal +import qualified Distribution.Simple.Bench as Cabal +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Haddock (haddock_setupHooks) +import Distribution.Simple.Install (install_setupHooks) +import Distribution.Simple.SetupHooks.Internal +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.Simple ( Compiler, PackageDBStack ) + +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 + , flagAssignment :: PD.FlagAssignment + } + +libraryConfigureInputsFromElabPackage + :: ElaboratedSharedConfig + -> ElaboratedReadyPackage + -> LibraryConfigureInputs +libraryConfigureInputsFromElabPackage + ElaboratedSharedConfig + { pkgConfigPlatform = platform + , pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb } + (ReadyPackage pkg) + = 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 = [] + , LBC.withPrograms = progdb + , LBC.withBuildOptions = elabBuildOptions pkg + } + , packageDBStack = elabBuildPackageDBStack pkg + , packageDescription = pkgDescr + , flagAssignment = elabFlagAssignment pkg + } + where + pkgDescr = elabPkgDescription pkg + +configure + :: LibraryConfigureInputs + -> Cabal.ConfigFlags + -> IO LocalBuildInfo +configure + LibraryConfigureInputs + { platform, compiler + , buildType = bt + , compRequested = mbComp + , localBuildConfig = lbc0 + , packageDBStack = packageDBs + , packageDescription = pkgDesc + , flagAssignment + } + cfg = + -- 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 + + -- 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} + + -- SetupHooks TODO: not calling "finalCheckPackage" from Cabal, + -- as that works with a generic package description. + -- Is this OK? + + -- SetupHooks TODO: the following is a huge 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 + lbi <- Cabal.configureComponents lbc2 pbd3 installedPkgs promisedDeps externalPkgDeps + -- 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'. + Cabal.writePersistBuildConfig mbWorkDir distPref lbi + return lbi + +wantComponent :: ComponentRequestedSpec -> Component -> Bool +wantComponent compReq comp = case compReq of + ComponentRequestedSpec {} -> True + OneComponentRequestedSpec reqComp -> + componentName comp == reqComp + -- NB: this might match multiple components, + -- due to Backpack instantiations. + +-------------------------------------------------------------------------------- +-- Build + +build + :: Cabal.BuildFlags + -> LocalBuildInfo + -> IO [MonitorFilePath] +build flags lbi = + build_setupHooks hooks pkgDescr lbi flags Cabal.knownSuffixHandlers + where + hooks = buildHooks $ ExternalHooksExe.buildTypeSetupHooks mbWorkDir distPref bt + pkgDescr = localPkgDescr lbi + bt = PD.buildType pkgDescr + mbWorkDir = mbWorkDirLBI lbi + distPref = Cabal.fromFlag $ Cabal.buildDistPref flags + +-------------------------------------------------------------------------------- +-- Haddock + +haddock + :: Cabal.HaddockFlags + -> LocalBuildInfo + -> IO [MonitorFilePath] +haddock flags lbi = + haddock_setupHooks hooks pkgDescr lbi Cabal.knownSuffixHandlers flags + where + hooks = buildHooks $ ExternalHooksExe.buildTypeSetupHooks mbWorkDir distPref bt + pkgDescr = localPkgDescr lbi + bt = PD.buildType pkgDescr + mbWorkDir = mbWorkDirLBI lbi + distPref = Cabal.fromFlag $ Cabal.haddockDistPref flags + +-------------------------------------------------------------------------------- +-- Repl + +repl + :: Cabal.ReplFlags + -> LocalBuildInfo + -> IO () +repl flags lbi = + repl_setupHooks hooks pkgDescr lbi flags Cabal.knownSuffixHandlers [] + where + hooks = buildHooks $ ExternalHooksExe.buildTypeSetupHooks mbWorkDir distPref bt + pkgDescr = localPkgDescr lbi + bt = PD.buildType pkgDescr + mbWorkDir = mbWorkDirLBI lbi + distPref = Cabal.fromFlag $ Cabal.replDistPref flags + +-------------------------------------------------------------------------------- +-- Copy + +copy + :: Cabal.CopyFlags + -> LocalBuildInfo + -> IO () +copy flags lbi = + 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 + -> IO () +test flags lbi = + Cabal.test [] pkgDescr lbi flags + -- SetupHooksTODO: is args = [] OK here? + where + pkgDescr = localPkgDescr lbi + +bench + :: Cabal.BenchmarkFlags + -> LocalBuildInfo + -> IO () +bench flags lbi = + Cabal.bench [] pkgDescr lbi flags + -- SetupHooksTODO: is args = [] OK here? + where + pkgDescr = localPkgDescr lbi + +register + :: Cabal.RegisterFlags + -> LocalBuildInfo + -> IO () +register flags lbi = 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..5b56ce100ad 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -119,6 +119,7 @@ import Distribution.Client.Setup import Distribution.Client.SetupWrapper ( SetupScriptOptions (..) , defaultSetupScriptOptions + , SetupRunnerArgs(NotInLibrary) , setupWrapper ) import Distribution.Client.SolverInstallPlan (SolverInstallPlan) @@ -2088,6 +2089,7 @@ installUnpackedPackage getCommonFlags flags (const []) + NotInLibrary ) -- helper diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 59b2f76da34..4582a552eb0 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -121,6 +121,7 @@ import qualified Distribution.Client.List as List import Distribution.Client.SetupWrapper ( SetupScriptOptions (..) , defaultSetupScriptOptions + , SetupRunnerArgs(NotInLibrary) , setupWrapper ) import Distribution.Client.Targets @@ -539,6 +540,7 @@ wrapperAction command getCommonFlags = getCommonFlags (const flags) (const extraArgs) + NotInLibrary configureAction :: (ConfigFlags, ConfigExFlags) @@ -648,6 +650,7 @@ build verbosity config distPref buildFlags extraArgs = buildCommonFlags mkBuildFlags (const extraArgs) + NotInLibrary where progDb = defaultProgramDb setupOptions = defaultSetupScriptOptions{useDistPref = distPref} @@ -741,6 +744,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). @@ -788,6 +792,7 @@ installAction (configFlags, _, installFlags, _, _, _) _ globalFlags (const common) (const (mempty, mempty, mempty, mempty, mempty, mempty)) (const []) + NotInLibrary installAction ( configFlags , configExFlags @@ -955,6 +960,7 @@ testAction (buildFlags, testFlags) extraArgs globalFlags = do Cabal.testCommonFlags (const testFlags') (const extraArgs') + NotInLibrary data ComponentNames = ComponentNamesUnknown @@ -1076,6 +1082,7 @@ benchmarkAction Cabal.benchmarkCommonFlags (const benchmarkFlags') (const extraArgs') + NotInLibrary haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do @@ -1116,6 +1123,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" @@ -1151,6 +1159,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 065334d5c6e..27a2305ee1e 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. -- @@ -71,6 +75,7 @@ import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package import qualified Distribution.PackageDescription as PD import Distribution.Simple.BuildPaths (haddockDirName) +import qualified Distribution.Simple.Configure as Cabal import Distribution.Simple.Command (CommandUI) import Distribution.Simple.Compiler ( PackageDBStack @@ -80,12 +85,15 @@ 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 @@ -106,11 +116,7 @@ import System.IO (Handle, IOMode (AppendMode), withFile) import System.Semaphore (SemaphoreName (..)) import Web.Browser (openBrowser) - -import Distribution.Client.Errors -import Distribution.Compat.Directory (listDirectory) - -import Distribution.Client.ProjectBuilding.PackageFileMonitor +import GHC.Stack -- | Each unpacked package is processed in the following phases: -- @@ -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,7 +169,7 @@ 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 @@ -181,24 +188,28 @@ buildAndRegisterUnpackedPackage builddir mlogFile delegate = do + -- Configure phase - delegate $ + mbLBI <- delegate $ PBConfigurePhase $ annotateFailure mlogFile ConfigureFailed $ setup configureCommand Cabal.configCommonFlags configureFlags configureArgs + (InLibraryArgs $ InLibraryConfigureArgs pkgshared rpkg) -- Build phase delegate $ PBBuildPhase $ - annotateFailure mlogFile BuildFailed $ do + annotateFailure mlogFile BuildFailed $ setup buildCommand Cabal.buildCommonFlags buildFlags buildArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBuildPhase mbLBI) -- Haddock phase whenHaddock $ delegate $ PBHaddockPhase $ - annotateFailure mlogFile HaddocksFailed $ do + annotateFailure mlogFile HaddocksFailed $ setup haddockCommand Cabal.haddockCommonFlags haddockFlags haddockArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SHaddockPhase mbLBI) -- Install phase delegate $ @@ -206,12 +217,13 @@ buildAndRegisterUnpackedPackage { runCopy = \destdir -> annotateFailure mlogFile InstallFailed $ 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 @@ -231,6 +243,7 @@ buildAndRegisterUnpackedPackage PBTestPhase $ annotateFailure mlogFile TestsFailed $ setup testCommand Cabal.testCommonFlags testFlags testArgs + (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI) -- Bench phase whenBench $ @@ -238,6 +251,7 @@ buildAndRegisterUnpackedPackage PBBenchPhase $ annotateFailure mlogFile BenchFailed $ setup benchCommand Cabal.benchmarkCommonFlags benchFlags benchArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) -- Repl phase whenRepl $ @@ -245,6 +259,7 @@ buildAndRegisterUnpackedPackage PBReplPhase $ annotateFailure mlogFile ReplFailed $ setupInteractive replCommand Cabal.replCommonFlags replFlags replArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI) return () where @@ -346,12 +361,14 @@ buildAndRegisterUnpackedPackage 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 @@ -367,25 +384,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,6 +413,7 @@ buildAndRegisterUnpackedPackage (commonFlags v) pkgConfDest setup (Cabal.registerCommand) Cabal.registerCommonFlags registerFlags (const []) + (InLibraryArgs $ InLibraryPostConfigureArgs SRegisterPhase mbLBI) withLogging :: (Maybe Handle -> IO r) -> IO r withLogging action = @@ -470,15 +487,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) @@ -490,6 +508,7 @@ buildInplaceUnpackedPackage if null xs then m' else return xs monitors <- case PD.buildType (elabPkgDescription pkg) of Simple -> listSimple + Hooks -> 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 @@ -521,10 +540,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" @@ -580,10 +599,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 + -- SetupHooks 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! @@ -678,10 +711,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/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index b6ca3aa6130..6c94c18ee2d 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1653,9 +1653,14 @@ elaborateInstallPlan case bt of PD.Configure -> [CuzBuildType CuzConfigureBuildType] PD.Custom -> [CuzBuildType CuzCustomBuildType] - PD.Hooks -> [CuzBuildType CuzHooksBuildType] PD.Make -> [CuzBuildType CuzMakeBuildType] PD.Simple -> [] + + -- SetupHooks TODO: we should be able to remove the following + -- once we make Setup a proper separate component, instead of + -- having to fetch it from the whole package. + PD.Hooks -> [CuzBuildType CuzHooksBuildType] + -- cabal-format versions prior to 1.8 have different build-depends semantics -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 -- see, https://github.com/haskell/cabal/issues/4121 @@ -3832,9 +3837,9 @@ setupHsConfigureFlags , configDynExe , configFullyStaticExe , configGHCiLib - , -- , configProfExe -- overridden + , -- configProfExe -- overridden configProfLib - , -- , configProf -- overridden + , -- configProf -- overridden configProfDetail , configProfLibDetail , configCoverage @@ -3894,8 +3899,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 @@ -3942,7 +3947,7 @@ setupHsConfigureFlags configExactConfiguration = toFlag True configFlagError = mempty -- TODO: [research required] appears not to be implemented configScratchDir = mempty -- never use - configUserInstall = mempty -- don't rely on defaults + configUserInstall = toFlag False -- SetupHooks TODO mempty -- don't rely on defaults configPrograms_ = mempty -- never use, shouldn't exist configUseResponseFiles = mempty configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler @@ -4019,11 +4024,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 } @@ -4120,23 +4125,23 @@ setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) (ElaboratedSharedConfig{.. , 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 = mempty -- TODO: from build settings - , 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/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 56d76817692..62434c19fd1 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -1,8 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{- FOURMOLU_DISABLE -} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -24,9 +29,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 +73,7 @@ import Distribution.Simple.Build.Macros ( generatePackageVersionMacros ) import Distribution.Simple.BuildPaths - ( defaultDistPref - , exeExtension + ( exeExtension ) import Distribution.Simple.Compiler ( Compiler (compilerId) @@ -114,6 +125,8 @@ import Distribution.Version import Distribution.Client.Config ( defaultCacheDir ) +import Distribution.Client.FileMonitor + ( MonitorFilePath ) import Distribution.Client.IndexUtils ( getInstalledPackages ) @@ -148,9 +161,6 @@ import Distribution.Simple.Program.GHC , GhcOptions (..) , renderGhcOptions ) -import Distribution.Simple.Setup - ( Flag (..), CommonSetupFlags (..), GlobalFlags (..) - ) import Distribution.Simple.Utils ( cabalVersion , copyFileVerbose @@ -173,24 +183,28 @@ 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 Distribution.Verbosity +import Distribution.Client.Errors +import qualified Distribution.Client.InLibrary as InLibrary +import Distribution.Client.ProjectPlanning.Types import Data.List (foldl1') -import Distribution.Simple.Setup (globalCommand) -import Distribution.Client.Compat.ExecutablePath (getExecutablePath) -import Distribution.Compat.Process (proc) +import Data.Kind ( Type, Constraint ) import System.Directory (doesFileExist) -import System.FilePath ((<.>), ()) +import System.FilePath ((<.>), (), takeFileName) 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 @@ -202,26 +216,95 @@ import System.Directory ( doesDirectoryExist ) import qualified System.Win32 as Win32 #endif +data AllowInLibrary + = AllowInLibrary + | Don'tAllowInLibrary + +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 + 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 @@ -352,12 +435,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 @@ -367,8 +451,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 @@ -378,16 +463,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 = @@ -398,26 +482,36 @@ getSetup verbosity options mpkg = do -- | Decide if we're going to be able to do a direct internal call to the -- entry point in the Cabal library or if we're going to have to compile -- and execute an external Setup.hs script. -getSetupMethod +withSetupMethod :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType - -> IO (Version, SetupMethod, SetupScriptOptions) -getSetupMethod verbosity options pkg buildType' + -> AllowInLibrary + -> ( forall kind. (Version, SetupMethod kind, SetupScriptOptions ) -> r ) + -> IO r +withSetupMethod verbosity options pkg buildType' allowInLibrary with | buildType' == Custom - || buildType' == Hooks || maybe False (cabalVersion /=) (useCabalSpecVersion options) || not (cabalVersion `withinRange` useCabalVersion options) = - getExternalSetupMethod verbosity options pkg buildType' + with <$> getExternalSetupMethod verbosity options pkg buildType' + -- SetupHooks TODO: the following guard should be lower, but I want to test + -- the InLibrary method. + | AllowInLibrary <- allowInLibrary + = do + -- SetupHooks TODO: getExternalSetupMethod compiles the hooks executable. + -- That functionality should be moved here. + when (buildType' == Hooks) $ + void $ getExternalSetupMethod verbosity options pkg Hooks + return $ with (cabalVersion, LibraryMethod, options) | 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) + return $ with (cabalVersion, SelfExecMethod, options) + | otherwise = return $ with (cabalVersion, InternalMethod, options) -runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner) +runSetupMethod :: WithCallStack (SetupMethod GeneralSetup -> SetupRunner UseGeneralSetup) runSetupMethod InternalMethod = internalSetupMethod runSetupMethod (ExternalMethod path) = externalSetupMethod path runSetupMethod SelfExecMethod = selfExecSetupMethod @@ -425,11 +519,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 @@ -443,7 +538,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 @@ -482,7 +577,7 @@ verbosityHack ver args0 -- | Run a command through a configured 'Setup'. runSetupCommand :: Verbosity - -> Setup + -> Setup GeneralSetup -> CommandUI flags -- ^ command definition -> (flags -> CommonSetupFlags) @@ -490,20 +585,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 @@ -511,19 +609,66 @@ 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 + lbi <- + InLibrary.configure + (InLibrary.libraryConfigureInputsFromElabPackage elabSharedConfig elabReadyPkg) + flags + 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 + SHaddockPhase -> InLibrary.haddock flags lbi + SReplPhase -> InLibrary.repl flags lbi + SCopyPhase -> InLibrary.copy flags lbi + STestPhase -> InLibrary.test flags lbi + SBenchPhase -> InLibrary.bench flags lbi + SRegisterPhase -> InLibrary.register flags lbi + NotInLibrary -> + error "internal error: NotInLibrary argument but getSetup chose InLibrary" + InternalMethod -> notInLibraryMethod + ExternalMethod {} -> notInLibraryMethod + SelfExecMethod -> notInLibraryMethod -- ------------------------------------------------------------ @@ -532,8 +677,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 @@ -542,7 +687,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 @@ -599,8 +744,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 @@ -621,8 +766,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 @@ -647,7 +792,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 @@ -665,7 +810,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 $ @@ -711,13 +856,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 = @@ -852,7 +999,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) @@ -865,6 +1012,11 @@ getExternalSetupMethod verbosity options pkg bt = do Make -> "import Distribution.Make; main = defaultMain\n" Hooks -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n" 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 @@ -1037,22 +1189,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) = @@ -1077,6 +1250,9 @@ getExternalSetupMethod verbosity options pkg bt = do = useDependencies options' | otherwise = useDependencies options' ++ cabalDep + -- SetupHooks TODO: when compiling the external hooksHs, + -- we need to add a dependency on the hooks-exe library. + -- However, we might not have installed that library yet... hmm... addRenaming (ipid, _) = -- Assert 'DefUnitId' invariant ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) @@ -1090,10 +1266,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] @@ -1128,7 +1304,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/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..46441dd31ff --- /dev/null +++ b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Client.SetupHooks.CallHooksExe + ( callHooksExe + , externalSetupHooks + , buildTypeSetupHooks + ) where + +-- base +import GHC.Stack + +-- bytestring +import Data.ByteString.Lazy as LBS + ( hGetContents + , hPut + , null + ) + +-- mtl +import qualified Control.Monad.State as MTL +import qualified Control.Monad.Writer.CPS as MTL + +-- 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 + +-------------------------------------------------------------------------------- + +type HookIO inputs outputs = + ( HasCallStack + , Show inputs, Show outputs + , 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 -> + let i = Binary.encode input + in unless (LBS.null i) $ hPut hWeWrite i ) + case ex of + ExitFailure exitCode -> + dieWithException Verbosity.normal $ + HookFailed hookName (HookInput input) $ + HookException exitCode + ExitSuccess -> do + let mbOutput = Binary.decodeOrFail output + case mbOutput of + Left (_, offset, err) -> do + dieWithException Verbosity.normal $ + HookFailed hookName (HookInput input) $ + 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 + { preBuildComponentRules = Just $ Rules externalPreBuildRules + , postBuildComponentHook = Just $ hook "postBuildComponent" + } + , installHooks = + InstallHooks + { installComponentHook = Just $ hook "installComponent" + } + } + where + hook :: HookIO inputs outputs => String -> inputs -> IO outputs + hook = callHooksExe hooksExe + externalPreBuildRules :: PreBuildComponentInputs -> RulesM () + externalPreBuildRules pbci = + -- Bypass the pre-build rules API, directly returning the pre-build + -- rules obtained by querying the external hooks executable. + -- + -- This is OK because we are not going to combine these pre-build rules + -- with any other pre-build rules at this point; we have the entire + -- collection of pre-build rules used by the package in hand now. + RulesT $ do + (rulesMap, monitors) <- MTL.liftIO $ hook "preBuildRules" pbci + MTL.put rulesMap + MTL.tell monitors + +buildTypeSetupHooks + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> BuildType + -> SetupHooks +buildTypeSetupHooks mbWorkDir distPref = \case + Hooks -> externalSetupHooks hooksProgFile + Configure -> autoconfSetupHooks + _ -> noSetupHooks + -- SetupHooks TODO: if any built-in functionality is implemented using SetupHooks, + -- we would also need to include those (for example, pre-processors such as hsc2hs). + + where + -- SetupHooks TODO: don't duplicate the following path. + hooksProgFile = + 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..494c6f602f2 --- /dev/null +++ b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe/Errors.hs @@ -0,0 +1,94 @@ +{-# 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 + HookInput + -- ^ inputs that were passed to the hook + 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 (HookInput input) reason -> + setupHooksCallExeFailedMessage hookName input reason + +setupHooksCallExeFailedMessage :: (Binary input, Typeable input, Show input) => String -> input -> HookFailedReason -> String +setupHooksCallExeFailedMessage hookName _input = \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 ++ ".\ + \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..406a7867985 --- /dev/null +++ b/hooks-exe/exe/Distribution/Client/SetupHooks/HooksExe.hs @@ -0,0 +1,184 @@ +{-# 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 + ) + +-- containers +import qualified Data.Map as Map + +-- process +import System.Process.CommunicationHandle + ( useCommunicationHandle + ) + +-- 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 + +-------------------------------------------------------------------------------- + +-- | Create a hooks executable given 'SetupHooks': +-- +-- - the first two argument are references to input & output communciation +-- 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 useCommunicationHandle $ readMaybe inputFdRef + hWriteMb <- traverse useCommunicationHandle $ 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 + LBS.hPutStr hWrite $ Binary.encode output + hFlush hWrite + hClose hWrite + +data HookHandler = HookHandler + { hookName :: !String + , hookHandler :: (Handle, Handle) -> SetupHooks -> IO () + } + +hookHandlers :: [HookHandler] +hookHandlers = + [ 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" + in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) -> + -- Run the package-wide post-configure hook. + for_ postConfPackageHook $ runHookHandle h hookName + , 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" + in HookHandler hookName $ \h (SetupHooks{buildHooks = BuildHooks{..}}) -> + -- Run the per-component post-build hook. + for_ postBuildComponentHook $ runHookHandle h hookName + , let hookName = "installComponent" + in HookHandler hookName $ \h (SetupHooks{installHooks = InstallHooks{..}}) -> + -- Run the per-component copy/install hook. + for_ installComponentHook $ runHookHandle h hookName + ] 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..1a5a4aa535b --- /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 ++ ".\ + \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..49546530e27 --- /dev/null +++ b/hooks-exe/hooks-exe.cabal @@ -0,0 +1,56 @@ +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 imported by cabal-install to interface with an external +-- hooks executable. +library hooks-cli + import: warnings + build-depends: base >= 4.10 && < 4.20, + bytestring >= 0.10.6.0 && < 0.13, + filepath >= 1.4.0.0 && < 1.6 , + mtl >= 2.0 && < 2.4 , + process >= 1.6.19.0 && < 1.8 , + Cabal-syntax, Cabal + default-language: Haskell2010 + hs-source-dirs: cli + exposed-modules: Distribution.Client.SetupHooks.CallHooksExe + other-modules: Distribution.Client.SetupHooks.CallHooksExe.Errors + visibility: public + +-- Library used to create an external hooks executable +-- from a SetupHooks.hs module. +library + import: warnings + build-depends: base >= 4.10 && < 4.20, + bytestring >= 0.10.6.0 && < 0.13, + containers >= 0.5.6.2 && < 0.8 , + process >= 1.6.19.0 && < 1.8 , + Cabal-syntax, Cabal + default-language: Haskell2010 + hs-source-dirs: exe + exposed-modules: Distribution.Client.SetupHooks.HooksExe + other-modules: Distribution.Client.SetupHooks.HooksExe.Errors 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/project-cabal/pkgs/cabal.config b/project-cabal/pkgs/cabal.config index 3c1d897705d..39a19e5493e 100644 --- a/project-cabal/pkgs/cabal.config +++ b/project-cabal/pkgs/cabal.config @@ -3,3 +3,4 @@ packages: , Cabal-described , Cabal-syntax , Cabal-hooks + , hooks-exe