Skip to content

Commit 094adf4

Browse files
mpilgremmpilgrem
authored
Merge pull request commercialhaskell#6571 from commercialhaskell/fix6564
Fix commercialhaskell#6570 Apply `--flag *:[-]<flag_name` only to relevant packages
2 parents 92ab62c + ff30482 commit 094adf4

File tree

8 files changed

+173
-125
lines changed

8 files changed

+173
-125
lines changed

‎ChangeLog.md

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,8 @@ Behaviour changes:
3939
* The `list` command, with a specified snapshot and package, also reports the
4040
version of the package included indirectly in the snapshot (as a boot package
4141
of the compiler specified by the snapshot).
42+
* `stack build --flag *:[-]<flag_name>` now only applies the flag setting to
43+
packages for which the Cabal flag is defined, as opposed to all packages.
4244

4345
Other enhancements:
4446

‎doc/build_command.md

Lines changed: 11 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -257,15 +257,21 @@ This overrides:
257257
* any use of `--flag *` (see below).
258258

259259
`stack build --flag *:[-]<flag_name>` sets (or unsets) the specified Cabal flag
260-
for all packages (project packages and dependencies) (whether or not a flag of
261-
that name is a flag of the package).
260+
for all packages (project packages and dependencies) for which the flag is
261+
defined.
262262

263263
This overrides:
264264

265-
* any Cabal flag specifications for packages in the snapshot; and
265+
* any Cabal flag specifications for the relevant packages in the snapshot; and
266266

267-
* any Cabal flag specifications for packages in Stack's project-level
268-
configuration file (`stack.yaml`).
267+
* any Cabal flag specifications for the relevant packages in Stack's
268+
project-level configuration file (`stack.yaml`).
269+
270+
!!! info
271+
272+
`flag *:[-]<flag_name> inspects the Cabal file of each package in the
273+
snapshot. Consequently, its use will add a few seconds to the duration of
274+
a build.
269275

270276
!!! note
271277

‎doc/maintainers/stack_errors.md

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@
55
In connection with considering Stack's support of the
66
[Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks
77
to take stock of the errors that Stack itself can raise, by reference to the
8-
`master` branch of the Stack repository. Last updated: 2024-03-29.
8+
`master` branch of the Stack repository. Last updated: 2024-05-05.
99

1010
* `Stack.main`: catches exceptions from action `commandLineHandler`.
1111

@@ -381,7 +381,7 @@ to take stock of the errors that Stack itself can raise, by reference to the
381381
[S-6374] | SetupHsBuildFailure ExitCode (Maybe PackageIdentifier) (Path Abs File) [String] (Maybe (Path Abs File)) [Text]
382382
[S-8506] | TargetParseException [StyleDoc]
383383
[S-7086] | SomeTargetsNotBuildable [(PackageName, NamedComponent)]
384-
[S-8664] | InvalidFlagSpecification (Set UnusedFlags)
384+
[S-8664] | InvalidFlagSpecification [UnusedFlags]
385385
[S-8100] | GHCProfOptionInvalid
386386
[S-1727] | NotOnlyLocal [PackageName] [Text]
387387
[S-6362] | CompilerVersionMismatch (Maybe (ActualCompiler, Arch)) (WantedCompiler, Arch) GHCVariant CompilerBuild VersionCheck (Maybe (Path Abs File)) Text

‎src/Stack/Build/Source.hs

Lines changed: 104 additions & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,6 @@ module Stack.Build.Source
1010
, loadCommonPackage
1111
, loadLocalPackage
1212
, loadSourceMap
13-
, getLocalFlags
1413
, addUnlistedToBuildCache
1514
, hashSourceMapData
1615
) where
@@ -32,12 +31,12 @@ import Stack.Package
3231
import Stack.PackageFile ( getPackageFile )
3332
import Stack.Prelude
3433
import Stack.SourceMap
35-
( DumpedGlobalPackage, checkFlagsUsedThrowing
36-
, getCompilerInfo, immutableLocSha, mkProjectPackage
37-
, pruneGlobals
34+
( DumpedGlobalPackage, getCompilerInfo, immutableLocSha
35+
, mkProjectPackage, pruneGlobals
3836
)
3937
import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
4038
import Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) )
39+
import Stack.Types.Build.Exception ( BuildPrettyException (..) )
4140
import Stack.Types.BuildConfig
4241
( BuildConfig (..), HasBuildConfig (..) )
4342
import Stack.Types.BuildOpts ( BuildOpts (..), TestOpts (..) )
@@ -69,7 +68,7 @@ import Stack.Types.SourceMap
6968
, SMActual (..), SMTargets (..), SourceMap (..)
7069
, SourceMapHash (..), Target (..), ppGPD, ppRoot
7170
)
72-
import Stack.Types.UnusedFlags ( FlagSource (..) )
71+
import Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) )
7372
import System.FilePath ( takeFileName )
7473
import System.IO.Error ( isDoesNotExistError )
7574

@@ -93,51 +92,25 @@ localDependencies = do
9392

9493
-- | Given the parsed targets and build command line options constructs a source
9594
-- map
96-
loadSourceMap :: HasBuildConfig env
97-
=> SMTargets
98-
-> BuildOptsCLI
99-
-> SMActual DumpedGlobalPackage
100-
-> RIO env SourceMap
95+
loadSourceMap ::
96+
forall env. HasBuildConfig env
97+
=> SMTargets
98+
-> BuildOptsCLI
99+
-> SMActual DumpedGlobalPackage
100+
-> RIO env SourceMap
101101
loadSourceMap targets boptsCli sma = do
102-
bconfig <- view buildConfigL
102+
logDebug "Applying and checking flags"
103+
let errsPackages = mapMaybe checkPackage packagesWithCliFlags
104+
eProject <- mapM applyOptsFlagsPP (M.toList sma.project)
105+
eDeps <- mapM applyOptsFlagsDep (M.toList targetsAndSmaDeps)
106+
let (errsProject, project') = partitionEithers eProject
107+
(errsDeps, deps') = partitionEithers eDeps
108+
errs = errsPackages <> errsProject <> errsDeps
109+
unless (null errs) $ prettyThrowM $ InvalidFlagSpecification errs
103110
let compiler = sma.compiler
104-
project = M.map applyOptsFlagsPP sma.project
105-
bopts = bconfig.config.build
106-
applyOptsFlagsPP p@ProjectPackage{ projectCommon = c } = p
107-
{ projectCommon = applyOptsFlags (M.member c.name targets.targets) True c }
108-
deps0 = targets.deps <> sma.deps
109-
deps = M.map applyOptsFlagsDep deps0
110-
applyOptsFlagsDep d@DepPackage{ depCommon = c } = d
111-
{ depCommon = applyOptsFlags (M.member c.name targets.deps) False c }
112-
applyOptsFlags isTarget isProjectPackage common =
113-
let name = common.name
114-
flags = getLocalFlags boptsCli name
115-
ghcOptions =
116-
generalGhcOptions bconfig boptsCli isTarget isProjectPackage
117-
cabalConfigOpts =
118-
generalCabalConfigOpts bconfig boptsCli common.name isTarget isProjectPackage
119-
in common
120-
{ flags =
121-
if M.null flags
122-
then common.flags
123-
else flags
124-
, ghcOptions =
125-
ghcOptions ++ common.ghcOptions
126-
, cabalConfigOpts =
127-
cabalConfigOpts ++ common.cabalConfigOpts
128-
, buildHaddocks =
129-
if isTarget
130-
then bopts.buildHaddocks
131-
else shouldHaddockDeps bopts
132-
}
133-
packageCliFlags = Map.fromList $
134-
mapMaybe maybeProjectFlags $
135-
Map.toList boptsCli.flags
136-
maybeProjectFlags (ACFByName name, fs) = Just (name, fs)
137-
maybeProjectFlags _ = Nothing
111+
project = M.fromList project'
112+
deps = M.fromList deps'
138113
globalPkgs = pruneGlobals sma.globals (Map.keysSet deps)
139-
logDebug "Checking flags"
140-
checkFlagsUsedThrowing packageCliFlags FSCommandLine project deps
141114
logDebug "SourceMap constructed"
142115
pure SourceMap
143116
{ targets
@@ -146,6 +119,90 @@ loadSourceMap targets boptsCli sma = do
146119
, deps
147120
, globalPkgs
148121
}
122+
where
123+
cliFlags = boptsCli.flags
124+
targetsAndSmaDeps = targets.deps <> sma.deps
125+
packagesWithCliFlags = mapMaybe maybeProjectWithCliFlags $ Map.toList cliFlags
126+
where
127+
maybeProjectWithCliFlags (ACFByName name, _) = Just name
128+
maybeProjectWithCliFlags _ = Nothing
129+
checkPackage :: PackageName -> Maybe UnusedFlags
130+
checkPackage name =
131+
let maybeCommon =
132+
fmap (.projectCommon) (Map.lookup name sma.project)
133+
<|> fmap (.depCommon) (Map.lookup name targetsAndSmaDeps)
134+
in maybe
135+
(Just $ UFNoPackage FSCommandLine name)
136+
(const Nothing)
137+
maybeCommon
138+
applyOptsFlagsPP ::
139+
(a, ProjectPackage)
140+
-> RIO env (Either UnusedFlags (a, ProjectPackage))
141+
applyOptsFlagsPP (name, p@ProjectPackage{ projectCommon = common }) = do
142+
let isTarget = M.member common.name targets.targets
143+
eCommon <- applyOptsFlags isTarget True common
144+
pure $ (\common' -> (name, p { projectCommon = common' })) <$> eCommon
145+
applyOptsFlagsDep ::
146+
(a, DepPackage)
147+
-> RIO env (Either UnusedFlags (a, DepPackage))
148+
applyOptsFlagsDep (name, d@DepPackage{ depCommon = common }) = do
149+
let isTarget = M.member common.name targets.deps
150+
eCommon <- applyOptsFlags isTarget False common
151+
pure $ (\common' -> (name, d { depCommon = common' })) <$> eCommon
152+
applyOptsFlags ::
153+
Bool
154+
-> Bool
155+
-> CommonPackage
156+
-> RIO env (Either UnusedFlags CommonPackage)
157+
applyOptsFlags isTarget isProjectPackage common = do
158+
let name = common.name
159+
cliFlagsByName = Map.findWithDefault Map.empty (ACFByName name) cliFlags
160+
cliFlagsAll =
161+
Map.findWithDefault Map.empty ACFAllProjectPackages cliFlags
162+
noOptsToApply = Map.null cliFlagsByName && Map.null cliFlagsAll
163+
(flags, unusedByName, pkgFlags) <- if noOptsToApply
164+
then
165+
pure (Map.empty, Set.empty, Set.empty)
166+
else do
167+
gpd <-
168+
-- This action is expensive. We want to avoid it if we can.
169+
liftIO common.gpd
170+
let pkgFlags = Set.fromList $ map C.flagName $ C.genPackageFlags gpd
171+
unusedByName = Map.keysSet $ Map.withoutKeys cliFlagsByName pkgFlags
172+
cliFlagsAllRelevant =
173+
Map.filterWithKey (\k _ -> k `Set.member` pkgFlags) cliFlagsAll
174+
flags = cliFlagsByName <> cliFlagsAllRelevant
175+
pure (flags, unusedByName, pkgFlags)
176+
if Set.null unusedByName
177+
-- All flags are defined, nothing to do
178+
then do
179+
bconfig <- view buildConfigL
180+
let bopts = bconfig.config.build
181+
ghcOptions =
182+
generalGhcOptions bconfig boptsCli isTarget isProjectPackage
183+
cabalConfigOpts = generalCabalConfigOpts
184+
bconfig
185+
boptsCli
186+
name
187+
isTarget
188+
isProjectPackage
189+
pure $ Right common
190+
{ flags =
191+
if M.null flags
192+
then common.flags
193+
else flags
194+
, ghcOptions =
195+
ghcOptions ++ common.ghcOptions
196+
, cabalConfigOpts =
197+
cabalConfigOpts ++ common.cabalConfigOpts
198+
, buildHaddocks =
199+
if isTarget
200+
then bopts.buildHaddocks
201+
else shouldHaddockDeps bopts
202+
}
203+
-- Error about the undefined flags
204+
else
205+
pure $ Left $ UFFlagsNotDefined FSCommandLine name pkgFlags unusedByName
149206

150207
-- | Get a 'SourceMapHash' for a given 'SourceMap'
151208
--
@@ -207,18 +264,6 @@ depPackageHashableContent dp =
207264
<> getUtf8Builder (mconcat ghcOptions)
208265
<> getUtf8Builder (mconcat cabalConfigOpts)
209266

210-
-- | All flags for a project package.
211-
getLocalFlags ::
212-
BuildOptsCLI
213-
-> PackageName
214-
-> Map FlagName Bool
215-
getLocalFlags boptsCli name = Map.unions
216-
[ Map.findWithDefault Map.empty (ACFByName name) cliFlags
217-
, Map.findWithDefault Map.empty ACFAllProjectPackages cliFlags
218-
]
219-
where
220-
cliFlags = boptsCli.flags
221-
222267
-- | Get the options to pass to @./Setup.hs configure@
223268
generalCabalConfigOpts ::
224269
BuildConfig

‎src/Stack/Config.hs

Lines changed: 40 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -47,8 +47,10 @@ import qualified Data.Map as Map
4747
import qualified Data.Map.Merge.Strict as MS
4848
import qualified Data.Monoid
4949
import Data.Monoid.Map ( MonoidMap (..) )
50+
import qualified Data.Set as Set
5051
import qualified Data.Text as T
5152
import qualified Data.Yaml as Yaml
53+
import qualified Distribution.PackageDescription as PD
5254
import Distribution.System
5355
( Arch (..), OS (..), Platform (..), buildPlatform )
5456
import qualified Distribution.Text ( simpleParse )
@@ -97,17 +99,15 @@ import Stack.Constants
9799
import qualified Stack.Constants as Constants
98100
import Stack.Lock ( lockCachedWanted )
99101
import Stack.Prelude
100-
import Stack.SourceMap
101-
( additionalDepPackage, checkFlagsUsedThrowing
102-
, mkProjectPackage
103-
)
102+
import Stack.SourceMap ( additionalDepPackage, mkProjectPackage )
104103
import Stack.Storage.Project ( initProjectStorage )
105104
import Stack.Storage.User ( initUserStorage )
106105
import Stack.Storage.Util ( handleMigrationException )
107106
import Stack.Types.AllowNewerDeps ( AllowNewerDeps (..) )
108107
import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
109108
import Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) )
110-
import Stack.Types.Build.Exception ( BuildException (..) )
109+
import Stack.Types.Build.Exception
110+
( BuildException (..), BuildPrettyException (..) )
111111
import Stack.Types.BuildConfig ( BuildConfig (..) )
112112
import Stack.Types.BuildOpts ( BuildOpts (..) )
113113
import Stack.Types.ColorWhen ( ColorWhen (..) )
@@ -145,7 +145,7 @@ import Stack.Types.SourceMap
145145
, SMWanted (..)
146146
)
147147
import Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
148-
import Stack.Types.UnusedFlags ( FlagSource (..) )
148+
import Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) )
149149
import Stack.Types.Version
150150
( IntersectingVersionRange (..), VersionCheck (..)
151151
, stackVersion, withinRange
@@ -959,7 +959,7 @@ fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages
959959
deps2 = mergeApply deps1 pFlags $ \_ d flags ->
960960
d { depCommon = d.depCommon { flags = flags } }
961961

962-
checkFlagsUsedThrowing pFlags FSStackYaml packages1 deps1
962+
checkFlagsUsedThrowing pFlags packages1 deps1
963963

964964
let pkgGhcOptions = config.ghcOptionsByName
965965
deps = mergeApply deps2 pkgGhcOptions $ \_ d options ->
@@ -982,6 +982,39 @@ fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages
982982

983983
pure (wanted, catMaybes mcompleted)
984984

985+
-- | Check if a package is a project package or a dependency and, if it is,
986+
-- if all the specified flags are defined in the package's Cabal file.
987+
checkFlagsUsedThrowing ::
988+
forall m. (MonadIO m, MonadThrow m)
989+
=> Map PackageName (Map FlagName Bool)
990+
-> Map PackageName ProjectPackage
991+
-> Map PackageName DepPackage
992+
-> m ()
993+
checkFlagsUsedThrowing packageFlags projectPackages deps = do
994+
unusedFlags <- forMaybeM (Map.toList packageFlags) getUnusedPackageFlags
995+
unless (null unusedFlags) $
996+
prettyThrowM $ InvalidFlagSpecification unusedFlags
997+
where
998+
getUnusedPackageFlags ::
999+
(PackageName, Map FlagName Bool)
1000+
-> m (Maybe UnusedFlags)
1001+
getUnusedPackageFlags (name, userFlags) = case maybeCommon of
1002+
-- Package is not available as project or dependency
1003+
Nothing -> pure $ Just $ UFNoPackage FSStackYaml name
1004+
-- Package exists, let's check if the flags are defined
1005+
Just common -> do
1006+
gpd <- liftIO common.gpd
1007+
let pname = pkgName $ PD.package $ PD.packageDescription gpd
1008+
pkgFlags = Set.fromList $ map PD.flagName $ PD.genPackageFlags gpd
1009+
unused = Map.keysSet $ Map.withoutKeys userFlags pkgFlags
1010+
pure $ if Set.null unused
1011+
-- All flags are defined, nothing to do
1012+
then Nothing
1013+
-- Error about the undefined flags
1014+
else Just $ UFFlagsNotDefined FSStackYaml pname pkgFlags unused
1015+
where
1016+
maybeCommon = fmap (.projectCommon) (Map.lookup name projectPackages)
1017+
<|> fmap (.depCommon) (Map.lookup name deps)
9851018

9861019
-- | Check if there are any duplicate package names and, if so, throw an
9871020
-- exception.
@@ -994,7 +1027,6 @@ checkDuplicateNames locals =
9941027
hasMultiples (_, _:_:_) = True
9951028
hasMultiples _ = False
9961029

997-
9981030
-- | Get the Stack root, e.g. @~/.stack@, and determine whether the user owns it.
9991031
--
10001032
-- On Windows, the second value is always 'True'.

0 commit comments

Comments
 (0)