Fix #6570 Apply --flag *:[-]<flag_name only to relevant packages

Previously, the Cabal flags specified at the command line were added and then an action checked the validity of the flags specified for specific packages (only) (in `checkFlagsUsedThrowing`). Now, the flags are 'checked' as they are added and `applyOptsFlag` yields a value of type `RIO env (Either UnusedFlags CommonPackage)`. Moves logic of `getLocalFiles` from module `Stack.Build.Source` to `Stack.Ghci.loadGhciPkgDescs`, as that is the only place where it is now used in the original form. Moves logic of `checkFlagsUsedThrowing` from module `Stack.SourceMap` to `Stack.Config.fillProjectWanted`, as that is the only place where it is now used in the original form. To avoid `Set.toList . Set.fromList`, changes error data constructor to be `InvalidFlagSpecification [UnusedFlags]`.
commercialhaskell · May 5, 2024 · ff30482 · ff30482
1 parent 92ab62c
commit ff30482
Show file tree

Hide file tree

Showing 8 changed files with 173 additions and 125 deletions.
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -39,6 +39,8 @@ Behaviour changes:
 * The `list` command, with a specified snapshot and package, also reports the
   version of the package included indirectly in the snapshot (as a boot package
   of the compiler specified by the snapshot).
+* `stack build --flag *:[-]<flag_name>` now only applies the flag setting to
+  packages for which the Cabal flag is defined, as opposed to all packages.
 
 Other enhancements:
 

diff --git a/doc/build_command.md b/doc/build_command.md
@@ -257,15 +257,21 @@ This overrides:
 * any use of `--flag *` (see below).
 
 `stack build --flag *:[-]<flag_name>` sets (or unsets) the specified Cabal flag
-for all packages (project packages and dependencies) (whether or not a flag of
-that name is a flag of the package).
+for all packages (project packages and dependencies) for which the flag is
+defined.
 
 This overrides:
 
-* any Cabal flag specifications for packages in the snapshot; and
+* any Cabal flag specifications for the relevant packages in the snapshot; and
 
-* any Cabal flag specifications for packages in Stack's project-level
-  configuration file (`stack.yaml`).
+* any Cabal flag specifications for the relevant packages in Stack's
+  project-level configuration file (`stack.yaml`).
+
+!!! info
+
+    `flag *:[-]<flag_name> inspects the Cabal file of each package in the
+    snapshot. Consequently, its use will add a few seconds to the duration of
+    a build.
 
 !!! note
 

diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md
@@ -5,7 +5,7 @@
 In connection with considering Stack's support of the
 [Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks
 to take stock of the errors that Stack itself can raise, by reference to the
-`master` branch of the Stack repository. Last updated: 2024-03-29.
+`master` branch of the Stack repository. Last updated: 2024-05-05.
 
 *   `Stack.main`: catches exceptions from action `commandLineHandler`.
 
@@ -381,7 +381,7 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-6374] | SetupHsBuildFailure ExitCode (Maybe PackageIdentifier) (Path Abs File) [String] (Maybe (Path Abs File)) [Text]
         [S-8506] | TargetParseException [StyleDoc]
         [S-7086] | SomeTargetsNotBuildable [(PackageName, NamedComponent)]
-        [S-8664] | InvalidFlagSpecification (Set UnusedFlags)
+        [S-8664] | InvalidFlagSpecification [UnusedFlags]
         [S-8100] | GHCProfOptionInvalid
         [S-1727] | NotOnlyLocal [PackageName] [Text]
         [S-6362] | CompilerVersionMismatch (Maybe (ActualCompiler, Arch)) (WantedCompiler, Arch) GHCVariant CompilerBuild VersionCheck (Maybe (Path Abs File)) Text

diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs
@@ -10,7 +10,6 @@ module Stack.Build.Source
   , loadCommonPackage
   , loadLocalPackage
   , loadSourceMap
-  , getLocalFlags
   , addUnlistedToBuildCache
   , hashSourceMapData
   ) where
@@ -32,12 +31,12 @@ import           Stack.Package
 import           Stack.PackageFile ( getPackageFile )
 import           Stack.Prelude
 import           Stack.SourceMap
-                   ( DumpedGlobalPackage, checkFlagsUsedThrowing
-                   , getCompilerInfo, immutableLocSha, mkProjectPackage
-                   , pruneGlobals
+                   ( DumpedGlobalPackage, getCompilerInfo, immutableLocSha
+                   , mkProjectPackage, pruneGlobals
                    )
 import           Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
 import           Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) )
+import           Stack.Types.Build.Exception ( BuildPrettyException (..) )
 import           Stack.Types.BuildConfig
                    ( BuildConfig (..), HasBuildConfig (..) )
 import           Stack.Types.BuildOpts ( BuildOpts (..), TestOpts (..) )
@@ -69,7 +68,7 @@ import           Stack.Types.SourceMap
                    , SMActual (..), SMTargets (..), SourceMap (..)
                    , SourceMapHash (..), Target (..), ppGPD, ppRoot
                    )
-import           Stack.Types.UnusedFlags ( FlagSource (..) )
+import           Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) )
 import           System.FilePath ( takeFileName )
 import           System.IO.Error ( isDoesNotExistError )
 
@@ -93,51 +92,25 @@ localDependencies = do
 
 -- | Given the parsed targets and build command line options constructs a source
 -- map
-loadSourceMap :: HasBuildConfig env
-              => SMTargets
-              -> BuildOptsCLI
-              -> SMActual DumpedGlobalPackage
-              -> RIO env SourceMap
+loadSourceMap ::
+     forall env. HasBuildConfig env
+  => SMTargets
+  -> BuildOptsCLI
+  -> SMActual DumpedGlobalPackage
+  -> RIO env SourceMap
 loadSourceMap targets boptsCli sma = do
-  bconfig <- view buildConfigL
+  logDebug "Applying and checking flags"
+  let errsPackages = mapMaybe checkPackage packagesWithCliFlags
+  eProject <- mapM applyOptsFlagsPP (M.toList sma.project)
+  eDeps <- mapM applyOptsFlagsDep (M.toList targetsAndSmaDeps)
+  let (errsProject, project') = partitionEithers eProject
+      (errsDeps, deps') = partitionEithers eDeps
+      errs = errsPackages <> errsProject <> errsDeps
+  unless (null errs) $ prettyThrowM $ InvalidFlagSpecification errs
   let compiler = sma.compiler
-      project = M.map applyOptsFlagsPP sma.project
-      bopts = bconfig.config.build
-      applyOptsFlagsPP p@ProjectPackage{ projectCommon = c } = p
-        { projectCommon = applyOptsFlags (M.member c.name targets.targets) True c }
-      deps0 = targets.deps <> sma.deps
-      deps = M.map applyOptsFlagsDep deps0
-      applyOptsFlagsDep d@DepPackage{ depCommon = c } = d
-        { depCommon = applyOptsFlags (M.member c.name targets.deps) False c }
-      applyOptsFlags isTarget isProjectPackage common =
-        let name = common.name
-            flags = getLocalFlags boptsCli name
-            ghcOptions =
-              generalGhcOptions bconfig boptsCli isTarget isProjectPackage
-            cabalConfigOpts =
-              generalCabalConfigOpts bconfig boptsCli common.name isTarget isProjectPackage
-        in  common
-              { flags =
-                  if M.null flags
-                    then common.flags
-                    else flags
-              , ghcOptions =
-                  ghcOptions ++ common.ghcOptions
-              , cabalConfigOpts =
-                  cabalConfigOpts ++ common.cabalConfigOpts
-              , buildHaddocks =
-                  if isTarget
-                    then bopts.buildHaddocks
-                    else shouldHaddockDeps bopts
-              }
-      packageCliFlags = Map.fromList $
-        mapMaybe maybeProjectFlags $
-        Map.toList boptsCli.flags
-      maybeProjectFlags (ACFByName name, fs) = Just (name, fs)
-      maybeProjectFlags _ = Nothing
+      project = M.fromList project'
+      deps = M.fromList deps'
       globalPkgs = pruneGlobals sma.globals (Map.keysSet deps)
-  logDebug "Checking flags"
-  checkFlagsUsedThrowing packageCliFlags FSCommandLine project deps
   logDebug "SourceMap constructed"
   pure SourceMap
     { targets
@@ -146,6 +119,90 @@ loadSourceMap targets boptsCli sma = do
     , deps
     , globalPkgs
     }
+ where
+  cliFlags = boptsCli.flags
+  targetsAndSmaDeps = targets.deps <> sma.deps
+  packagesWithCliFlags = mapMaybe maybeProjectWithCliFlags $ Map.toList cliFlags
+   where
+    maybeProjectWithCliFlags (ACFByName name, _) = Just name
+    maybeProjectWithCliFlags _ = Nothing
+  checkPackage :: PackageName -> Maybe UnusedFlags
+  checkPackage name =
+    let maybeCommon =
+              fmap (.projectCommon) (Map.lookup name sma.project)
+          <|> fmap (.depCommon) (Map.lookup name targetsAndSmaDeps)
+    in  maybe
+          (Just $ UFNoPackage FSCommandLine name)
+          (const Nothing)
+           maybeCommon
+  applyOptsFlagsPP ::
+       (a, ProjectPackage)
+    -> RIO env (Either UnusedFlags (a, ProjectPackage))
+  applyOptsFlagsPP (name, p@ProjectPackage{ projectCommon = common }) = do
+    let isTarget = M.member common.name targets.targets
+    eCommon <- applyOptsFlags isTarget True common
+    pure $ (\common' -> (name, p { projectCommon = common' })) <$> eCommon
+  applyOptsFlagsDep ::
+       (a, DepPackage)
+    -> RIO env (Either UnusedFlags (a, DepPackage))
+  applyOptsFlagsDep (name, d@DepPackage{ depCommon = common }) = do
+    let isTarget = M.member common.name targets.deps
+    eCommon <- applyOptsFlags isTarget False common
+    pure $ (\common' -> (name, d { depCommon = common' })) <$> eCommon
+  applyOptsFlags ::
+       Bool
+    -> Bool
+    -> CommonPackage
+    -> RIO env (Either UnusedFlags CommonPackage)
+  applyOptsFlags isTarget isProjectPackage common = do
+    let name = common.name
+        cliFlagsByName = Map.findWithDefault Map.empty (ACFByName name) cliFlags
+        cliFlagsAll =
+          Map.findWithDefault Map.empty ACFAllProjectPackages cliFlags
+        noOptsToApply = Map.null cliFlagsByName && Map.null cliFlagsAll
+    (flags, unusedByName, pkgFlags) <- if noOptsToApply
+      then
+        pure (Map.empty, Set.empty, Set.empty)
+      else do
+        gpd <-
+          -- This action is expensive. We want to avoid it if we can.
+          liftIO common.gpd
+        let pkgFlags = Set.fromList $ map C.flagName $ C.genPackageFlags gpd
+            unusedByName = Map.keysSet $ Map.withoutKeys cliFlagsByName pkgFlags
+            cliFlagsAllRelevant =
+              Map.filterWithKey (\k _ -> k `Set.member` pkgFlags) cliFlagsAll
+            flags = cliFlagsByName <> cliFlagsAllRelevant
+        pure (flags, unusedByName, pkgFlags)
+    if Set.null unusedByName
+      -- All flags are defined, nothing to do
+      then do
+        bconfig <- view buildConfigL
+        let bopts = bconfig.config.build
+            ghcOptions =
+              generalGhcOptions bconfig boptsCli isTarget isProjectPackage
+            cabalConfigOpts = generalCabalConfigOpts
+              bconfig
+              boptsCli
+              name
+              isTarget
+              isProjectPackage
+        pure $ Right common
+          { flags =
+              if M.null flags
+                then common.flags
+                else flags
+          , ghcOptions =
+              ghcOptions ++ common.ghcOptions
+          , cabalConfigOpts =
+              cabalConfigOpts ++ common.cabalConfigOpts
+          , buildHaddocks =
+              if isTarget
+                then bopts.buildHaddocks
+                else shouldHaddockDeps bopts
+          }
+      -- Error about the undefined flags
+      else
+        pure $ Left $ UFFlagsNotDefined FSCommandLine name pkgFlags unusedByName
 
 -- | Get a 'SourceMapHash' for a given 'SourceMap'
 --
@@ -207,18 +264,6 @@ depPackageHashableContent dp =
         <> getUtf8Builder (mconcat ghcOptions)
         <> getUtf8Builder (mconcat cabalConfigOpts)
 
--- | All flags for a project package.
-getLocalFlags ::
-     BuildOptsCLI
-  -> PackageName
-  -> Map FlagName Bool
-getLocalFlags boptsCli name = Map.unions
-  [ Map.findWithDefault Map.empty (ACFByName name) cliFlags
-  , Map.findWithDefault Map.empty ACFAllProjectPackages cliFlags
-  ]
- where
-  cliFlags = boptsCli.flags
-
 -- | Get the options to pass to @./Setup.hs configure@
 generalCabalConfigOpts ::
      BuildConfig

diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -47,8 +47,10 @@ import qualified Data.Map as Map
 import qualified Data.Map.Merge.Strict as MS
 import qualified Data.Monoid
 import           Data.Monoid.Map ( MonoidMap (..) )
+import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Yaml as Yaml
+import qualified Distribution.PackageDescription as PD
 import           Distribution.System
                    ( Arch (..), OS (..), Platform (..), buildPlatform )
 import qualified Distribution.Text ( simpleParse )
@@ -97,17 +99,15 @@ import           Stack.Constants
 import qualified Stack.Constants as Constants
 import           Stack.Lock ( lockCachedWanted )
 import           Stack.Prelude
-import           Stack.SourceMap
-                   ( additionalDepPackage, checkFlagsUsedThrowing
-                   , mkProjectPackage
-                   )
+import           Stack.SourceMap ( additionalDepPackage, mkProjectPackage )
 import           Stack.Storage.Project ( initProjectStorage )
 import           Stack.Storage.User ( initUserStorage )
 import           Stack.Storage.Util ( handleMigrationException )
 import           Stack.Types.AllowNewerDeps ( AllowNewerDeps (..) )
 import           Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
 import           Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) )
-import           Stack.Types.Build.Exception ( BuildException (..) )
+import           Stack.Types.Build.Exception
+                   ( BuildException (..), BuildPrettyException (..) )
 import           Stack.Types.BuildConfig ( BuildConfig (..) )
 import           Stack.Types.BuildOpts ( BuildOpts (..) )
 import           Stack.Types.ColorWhen ( ColorWhen (..) )
@@ -145,7 +145,7 @@ import           Stack.Types.SourceMap
                    , SMWanted (..)
                    )
 import           Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
-import           Stack.Types.UnusedFlags ( FlagSource (..) )
+import           Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) )
 import           Stack.Types.Version
                    ( IntersectingVersionRange (..), VersionCheck (..)
                    , stackVersion, withinRange
@@ -959,7 +959,7 @@ fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages
       deps2 = mergeApply deps1 pFlags $ \_ d flags ->
         d { depCommon = d.depCommon { flags = flags } }
 
-  checkFlagsUsedThrowing pFlags FSStackYaml packages1 deps1
+  checkFlagsUsedThrowing pFlags packages1 deps1
 
   let pkgGhcOptions = config.ghcOptionsByName
       deps = mergeApply deps2 pkgGhcOptions $ \_ d options ->
@@ -982,6 +982,39 @@ fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages
 
   pure (wanted, catMaybes mcompleted)
 
+-- | Check if a package is a project package or a dependency and, if it is,
+-- if all the specified flags are defined in the package's Cabal file.
+checkFlagsUsedThrowing ::
+     forall m. (MonadIO m, MonadThrow m)
+  => Map PackageName (Map FlagName Bool)
+  -> Map PackageName ProjectPackage
+  -> Map PackageName DepPackage
+  -> m ()
+checkFlagsUsedThrowing packageFlags projectPackages deps = do
+  unusedFlags <- forMaybeM (Map.toList packageFlags) getUnusedPackageFlags
+  unless (null unusedFlags) $
+    prettyThrowM $ InvalidFlagSpecification unusedFlags
+ where
+  getUnusedPackageFlags ::
+       (PackageName, Map FlagName Bool)
+    -> m (Maybe UnusedFlags)
+  getUnusedPackageFlags (name, userFlags) = case maybeCommon of
+    -- Package is not available as project or dependency
+    Nothing -> pure $ Just $ UFNoPackage FSStackYaml name
+    -- Package exists, let's check if the flags are defined
+    Just common -> do
+      gpd <- liftIO common.gpd
+      let pname = pkgName $ PD.package $ PD.packageDescription gpd
+          pkgFlags = Set.fromList $ map PD.flagName $ PD.genPackageFlags gpd
+          unused = Map.keysSet $ Map.withoutKeys userFlags pkgFlags
+      pure $ if Set.null unused
+        -- All flags are defined, nothing to do
+        then Nothing
+        -- Error about the undefined flags
+        else Just $ UFFlagsNotDefined FSStackYaml pname pkgFlags unused
+   where
+    maybeCommon =     fmap (.projectCommon) (Map.lookup name projectPackages)
+                  <|> fmap (.depCommon) (Map.lookup name deps)
 
 -- | Check if there are any duplicate package names and, if so, throw an
 -- exception.
@@ -994,7 +1027,6 @@ checkDuplicateNames locals =
   hasMultiples (_, _:_:_) = True
   hasMultiples _ = False
 
-
 -- | Get the Stack root, e.g. @~/.stack@, and determine whether the user owns it.
 --
 -- On Windows, the second value is always 'True'.