diff --git a/Setup.hs b/Setup.hs index 3b3f6cfcab..3812223d2d 100644 --- a/Setup.hs +++ b/Setup.hs @@ -4,24 +4,24 @@ module Main import Data.List ( nub, sortOn ) import Distribution.InstalledPackageInfo - ( sourcePackageId, installedUnitId ) -import Distribution.Package ( UnitId, packageVersion, packageName ) + ( installedUnitId, sourcePackageId ) +import Distribution.Package ( UnitId, packageName, packageVersion ) import Distribution.PackageDescription - ( PackageDescription (), Executable (..) ) + ( Executable (..), PackageDescription ) import Distribution.Pretty ( prettyShow ) import Distribution.Simple - ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) + ( UserHooks(..), defaultMainWithHooks, simpleUserHooks ) import Distribution.Simple.BuildPaths ( autogenPackageModulesDir ) import Distribution.Simple.LocalBuildInfo - ( installedPkgs, withLibLBI, withExeLBI, LocalBuildInfo () - , ComponentLocalBuildInfo (componentPackageDeps) + ( ComponentLocalBuildInfo (..), LocalBuildInfo, installedPkgs + , withExeLBI, withLibLBI ) import Distribution.Simple.PackageIndex ( allPackages, dependencyClosure ) import Distribution.Simple.Setup ( BuildFlags (..), ReplFlags (..), fromFlag ) import Distribution.Simple.Utils - ( rewriteFileEx, createDirectoryIfMissingVerbose ) + ( createDirectoryIfMissingVerbose, rewriteFileEx ) import Distribution.Types.PackageName ( unPackageName ) import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) @@ -41,7 +41,11 @@ main = defaultMainWithHooks simpleUserHooks replHook simpleUserHooks pkg lbi hooks flags args } -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule :: + Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () generateBuildModule verbosity pkg lbi = do let dir = autogenPackageModulesDir lbi createDirectoryIfMissingVerbose verbosity True dir @@ -60,17 +64,22 @@ generateBuildModule verbosity pkg lbi = do formatdeps = map formatone . sortOn unPackageName' formatone p = unPackageName' p ++ "-" ++ prettyShow (packageVersion p) unPackageName' = unPackageName . packageName - transDeps xs ys = - either (map sourcePackageId . allPackages) handleDepClosureFailure $ dependencyClosure allInstPkgsIdx availInstPkgIds - where - allInstPkgsIdx = installedPkgs lbi - allInstPkgIds = map installedUnitId $ allPackages allInstPkgsIdx - -- instPkgIds includes `stack-X.X.X`, which is not a dependency hence is missing from allInstPkgsIdx. Filter that out. - availInstPkgIds = filter (`elem` allInstPkgIds) $ testDeps xs ys - handleDepClosureFailure unsatisfied = - error $ - "Computation of transitive dependencies failed." ++ - if null unsatisfied then "" else " Unresolved dependencies: " ++ show unsatisfied + transDeps xs ys = either + (map sourcePackageId . allPackages) + handleDepClosureFailure $ dependencyClosure allInstPkgsIdx availInstPkgIds + where + allInstPkgsIdx = installedPkgs lbi + allInstPkgIds = map installedUnitId $ allPackages allInstPkgsIdx + -- instPkgIds includes `stack-X.X.X`, which is not a dependency hence is + -- missing from allInstPkgsIdx. Filter that out. + availInstPkgIds = filter (`elem` allInstPkgIds) $ testDeps xs ys + handleDepClosureFailure unsatisfied = + error $ + "Computation of transitive dependencies failed." + ++ if null unsatisfied + then "" + else " Unresolved dependencies: " ++ show unsatisfied testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [UnitId] -testDeps xs ys = map fst $ nub $ componentPackageDeps xs ++ componentPackageDeps ys +testDeps xs ys = + map fst $ nub $ componentPackageDeps xs ++ componentPackageDeps ys diff --git a/SetupHooks.hs b/SetupHooks.hs new file mode 100644 index 0000000000..d9b152deaa --- /dev/null +++ b/SetupHooks.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | See https://github.com/well-typed/hooks-build-type. As part of their work, +-- Well-Typed reviewed stack-2.13.1 and identified that it used a pre-build hook +-- to generate, for the stack main library component, a module that lists all +-- the dependencies of stack (both library and executable), which is used in +-- `Stack.BuildInfo` to be listed. They also wrote an experimental patch, the +-- source code of which is below (with some reformatting). +-- +-- This would be used if Stack's build type was 'Hooks' rather than 'Custom'. + +module SetupHooks + ( setupHooks + ) where + +import Data.List ( nub, sortBy ) +import Data.Ord ( comparing ) +import Distribution.InstalledPackageInfo + ( installedUnitId, sourcePackageId ) +import Distribution.Package + ( PackageId, UnitId, packageName, packageVersion ) +import Distribution.PackageDescription + ( PackageDescription (..), Executable (..), componentNameRaw + ) +import Distribution.Pretty ( prettyShow ) +import Distribution.Simple + ( UserHooks(..), defaultMainWithHooks, simpleUserHooks ) +import Distribution.Simple.BuildPaths ( autogenComponentModulesDir ) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex + ( allPackages, dependencyClosure ) +import Distribution.Simple.Setup ( BuildFlags (..), fromFlag ) +import Distribution.Simple.SetupHooks +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, rewriteFileEx ) +import Distribution.Types.PackageName ( PackageName, unPackageName ) +import Distribution.Types.UnqualComponentName + ( unUnqualComponentName ) +import Distribution.Verbosity ( Verbosity, normal ) +import System.FilePath ( () ) + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentHook = Just preBuildHook } + } + +preBuildHook :: BuildingWhat -> LocalBuildInfo -> TargetInfo -> IO () +preBuildHook flags lbi tgt + | CLibName LMainLibName <- componentName $ targetComponent tgt = + generateBuildModule (buildingWhatVerbosity flags) (localPkgDescr lbi) + lbi tgt + | otherwise = pure () + +generateBuildModule :: + Verbosity + -> PackageDescription + -> LocalBuildInfo + -> TargetInfo + -> IO () +generateBuildModule verbosity pkg lbi mainLibTargetInfo = do + -- Generate a module in the stack library component that lists all the + -- dependencies of stack (both the library and the executable). + createDirectoryIfMissingVerbose verbosity True autogenDir + withExeLBI pkg lbi $ \ _ exeCLBI -> do + rewriteFileEx normal buildModulePath $ unlines + [ "module Build_" ++ pkgNm + , " ( deps" + , " ) where" + , "" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (transDeps mainLibCLBI exeCLBI)) + ] + where + mainLibCLBI = targetCLBI mainLibTargetInfo + autogenDir = autogenComponentModulesDir lbi mainLibCLBI + pkgNm :: String + pkgNm = unPackageName' $ package pkg + buildModulePath = autogenDir "Build_" ++ pkgNm ++ ".hs" + formatdeps = map formatone . sortBy (comparing unPackageName') + formatone p = unPackageName' p ++ "-" ++ prettyShow (packageVersion p) + unPackageName' = unPackageName . packageName + transDeps xs ys = either + (map sourcePackageId . allPackages) + handleDepClosureFailure $ dependencyClosure allInstPkgsIdx availInstPkgIds + where + allInstPkgsIdx = installedPkgs lbi + allInstPkgIds = map installedUnitId $ allPackages allInstPkgsIdx + -- instPkgIds includes `stack-X.X.X`, which is not a dependency hence is + -- missing from allInstPkgsIdx. Filter that out. + availInstPkgIds = filter (`elem` allInstPkgIds) $ testDeps xs ys + handleDepClosureFailure unsatisfied = + error $ + "Computation of transitive dependencies failed." + ++ if null unsatisfied + then "" + else " Unresolved dependencies: " ++ show unsatisfied + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [UnitId] +testDeps xs ys = + map fst $ nub $ componentPackageDeps xs ++ componentPackageDeps ys