Skip to content

Commit aeeeb6f

Browse files
mpilgremmpilgrem
authored
Merge pull request #6545 from commercialhaskell/re6542-SetupHooks
Re #6542 Add Well-Typed's patch to the repository, so it is to hand
2 parents 4975d5b + 9e4624d commit aeeeb6f

File tree

2 files changed

+132
-20
lines changed

2 files changed

+132
-20
lines changed

‎Setup.hs

+29-20
Original file line numberDiff line numberDiff line change
@@ -4,24 +4,24 @@ module Main
44

55
import Data.List ( nub, sortOn )
66
import Distribution.InstalledPackageInfo
7-
( sourcePackageId, installedUnitId )
8-
import Distribution.Package ( UnitId, packageVersion, packageName )
7+
( installedUnitId, sourcePackageId )
8+
import Distribution.Package ( UnitId, packageName, packageVersion )
99
import Distribution.PackageDescription
10-
( PackageDescription (), Executable (..) )
10+
( Executable (..), PackageDescription )
1111
import Distribution.Pretty ( prettyShow )
1212
import Distribution.Simple
13-
( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
13+
( UserHooks(..), defaultMainWithHooks, simpleUserHooks )
1414
import Distribution.Simple.BuildPaths ( autogenPackageModulesDir )
1515
import Distribution.Simple.LocalBuildInfo
16-
( installedPkgs, withLibLBI, withExeLBI, LocalBuildInfo ()
17-
, ComponentLocalBuildInfo (componentPackageDeps)
16+
( ComponentLocalBuildInfo (..), LocalBuildInfo, installedPkgs
17+
, withExeLBI, withLibLBI
1818
)
1919
import Distribution.Simple.PackageIndex
2020
( allPackages, dependencyClosure )
2121
import Distribution.Simple.Setup
2222
( BuildFlags (..), ReplFlags (..), fromFlag )
2323
import Distribution.Simple.Utils
24-
( rewriteFileEx, createDirectoryIfMissingVerbose )
24+
( createDirectoryIfMissingVerbose, rewriteFileEx )
2525
import Distribution.Types.PackageName ( unPackageName )
2626
import Distribution.Types.UnqualComponentName
2727
( unUnqualComponentName )
@@ -41,7 +41,11 @@ main = defaultMainWithHooks simpleUserHooks
4141
replHook simpleUserHooks pkg lbi hooks flags args
4242
}
4343

44-
generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
44+
generateBuildModule ::
45+
Verbosity
46+
-> PackageDescription
47+
-> LocalBuildInfo
48+
-> IO ()
4549
generateBuildModule verbosity pkg lbi = do
4650
let dir = autogenPackageModulesDir lbi
4751
createDirectoryIfMissingVerbose verbosity True dir
@@ -60,17 +64,22 @@ generateBuildModule verbosity pkg lbi = do
6064
formatdeps = map formatone . sortOn unPackageName'
6165
formatone p = unPackageName' p ++ "-" ++ prettyShow (packageVersion p)
6266
unPackageName' = unPackageName . packageName
63-
transDeps xs ys =
64-
either (map sourcePackageId . allPackages) handleDepClosureFailure $ dependencyClosure allInstPkgsIdx availInstPkgIds
65-
where
66-
allInstPkgsIdx = installedPkgs lbi
67-
allInstPkgIds = map installedUnitId $ allPackages allInstPkgsIdx
68-
-- instPkgIds includes `stack-X.X.X`, which is not a dependency hence is missing from allInstPkgsIdx. Filter that out.
69-
availInstPkgIds = filter (`elem` allInstPkgIds) $ testDeps xs ys
70-
handleDepClosureFailure unsatisfied =
71-
error $
72-
"Computation of transitive dependencies failed." ++
73-
if null unsatisfied then "" else " Unresolved dependencies: " ++ show unsatisfied
67+
transDeps xs ys = either
68+
(map sourcePackageId . allPackages)
69+
handleDepClosureFailure $ dependencyClosure allInstPkgsIdx availInstPkgIds
70+
where
71+
allInstPkgsIdx = installedPkgs lbi
72+
allInstPkgIds = map installedUnitId $ allPackages allInstPkgsIdx
73+
-- instPkgIds includes `stack-X.X.X`, which is not a dependency hence is
74+
-- missing from allInstPkgsIdx. Filter that out.
75+
availInstPkgIds = filter (`elem` allInstPkgIds) $ testDeps xs ys
76+
handleDepClosureFailure unsatisfied =
77+
error $
78+
"Computation of transitive dependencies failed."
79+
++ if null unsatisfied
80+
then ""
81+
else " Unresolved dependencies: " ++ show unsatisfied
7482

7583
testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [UnitId]
76-
testDeps xs ys = map fst $ nub $ componentPackageDeps xs ++ componentPackageDeps ys
84+
testDeps xs ys =
85+
map fst $ nub $ componentPackageDeps xs ++ componentPackageDeps ys

‎SetupHooks.hs

+103
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,103 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
3+
-- | See https://github.com/well-typed/hooks-build-type. As part of their work,
4+
-- Well-Typed reviewed stack-2.13.1 and identified that it used a pre-build hook
5+
-- to generate, for the stack main library component, a module that lists all
6+
-- the dependencies of stack (both library and executable), which is used in
7+
-- `Stack.BuildInfo` to be listed. They also wrote an experimental patch, the
8+
-- source code of which is below (with some reformatting).
9+
--
10+
-- This would be used if Stack's build type was 'Hooks' rather than 'Custom'.
11+
12+
module SetupHooks
13+
( setupHooks
14+
) where
15+
16+
import Data.List ( nub, sortBy )
17+
import Data.Ord ( comparing )
18+
import Distribution.InstalledPackageInfo
19+
( installedUnitId, sourcePackageId )
20+
import Distribution.Package
21+
( PackageId, UnitId, packageName, packageVersion )
22+
import Distribution.PackageDescription
23+
( PackageDescription (..), Executable (..), componentNameRaw
24+
)
25+
import Distribution.Pretty ( prettyShow )
26+
import Distribution.Simple
27+
( UserHooks(..), defaultMainWithHooks, simpleUserHooks )
28+
import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )
29+
import Distribution.Simple.LocalBuildInfo
30+
import Distribution.Simple.PackageIndex
31+
( allPackages, dependencyClosure )
32+
import Distribution.Simple.Setup ( BuildFlags (..), fromFlag )
33+
import Distribution.Simple.SetupHooks
34+
import Distribution.Simple.Utils
35+
( createDirectoryIfMissingVerbose, rewriteFileEx )
36+
import Distribution.Types.PackageName ( PackageName, unPackageName )
37+
import Distribution.Types.UnqualComponentName
38+
( unUnqualComponentName )
39+
import Distribution.Verbosity ( Verbosity, normal )
40+
import System.FilePath ( (</>) )
41+
42+
setupHooks :: SetupHooks
43+
setupHooks =
44+
noSetupHooks
45+
{ buildHooks =
46+
noBuildHooks
47+
{ preBuildComponentHook = Just preBuildHook }
48+
}
49+
50+
preBuildHook :: BuildingWhat -> LocalBuildInfo -> TargetInfo -> IO ()
51+
preBuildHook flags lbi tgt
52+
| CLibName LMainLibName <- componentName $ targetComponent tgt =
53+
generateBuildModule (buildingWhatVerbosity flags) (localPkgDescr lbi)
54+
lbi tgt
55+
| otherwise = pure ()
56+
57+
generateBuildModule ::
58+
Verbosity
59+
-> PackageDescription
60+
-> LocalBuildInfo
61+
-> TargetInfo
62+
-> IO ()
63+
generateBuildModule verbosity pkg lbi mainLibTargetInfo = do
64+
-- Generate a module in the stack library component that lists all the
65+
-- dependencies of stack (both the library and the executable).
66+
createDirectoryIfMissingVerbose verbosity True autogenDir
67+
withExeLBI pkg lbi $ \ _ exeCLBI -> do
68+
rewriteFileEx normal buildModulePath $ unlines
69+
[ "module Build_" ++ pkgNm
70+
, " ( deps"
71+
, " ) where"
72+
, ""
73+
, "deps :: [String]"
74+
, "deps = " ++ (show $ formatdeps (transDeps mainLibCLBI exeCLBI))
75+
]
76+
where
77+
mainLibCLBI = targetCLBI mainLibTargetInfo
78+
autogenDir = autogenComponentModulesDir lbi mainLibCLBI
79+
pkgNm :: String
80+
pkgNm = unPackageName' $ package pkg
81+
buildModulePath = autogenDir </> "Build_" ++ pkgNm ++ ".hs"
82+
formatdeps = map formatone . sortBy (comparing unPackageName')
83+
formatone p = unPackageName' p ++ "-" ++ prettyShow (packageVersion p)
84+
unPackageName' = unPackageName . packageName
85+
transDeps xs ys = either
86+
(map sourcePackageId . allPackages)
87+
handleDepClosureFailure $ dependencyClosure allInstPkgsIdx availInstPkgIds
88+
where
89+
allInstPkgsIdx = installedPkgs lbi
90+
allInstPkgIds = map installedUnitId $ allPackages allInstPkgsIdx
91+
-- instPkgIds includes `stack-X.X.X`, which is not a dependency hence is
92+
-- missing from allInstPkgsIdx. Filter that out.
93+
availInstPkgIds = filter (`elem` allInstPkgIds) $ testDeps xs ys
94+
handleDepClosureFailure unsatisfied =
95+
error $
96+
"Computation of transitive dependencies failed."
97+
++ if null unsatisfied
98+
then ""
99+
else " Unresolved dependencies: " ++ show unsatisfied
100+
101+
testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [UnitId]
102+
testDeps xs ys =
103+
map fst $ nub $ componentPackageDeps xs ++ componentPackageDeps ys

0 commit comments

Comments
 (0)