Merge pull request #6447 from commercialhaskell/ambiguity2

Different approach to avoiding some ambiguity with record updates

src/Stack/Build/ConstructPlan.hs

@@ -278,7 +278,7 @@ constructPlan
     pure plan
 
   prunedGlobalDeps :: Map PackageName [PackageName]
-  prunedGlobalDeps = flip Map.mapMaybe sourceMap.global $
+  prunedGlobalDeps = flip Map.mapMaybe sourceMap.globalPkgs $
     \case
       ReplacedGlobalPackage deps ->
         let pruned = filter (not . inSourceMap) deps
@@ -303,7 +303,7 @@ constructPlan
       case dp.location of
         PLImmutable loc ->
           pure $
-            PSRemote loc (getPLIVersion loc) dp.fromSnapshot dp.common
+            PSRemote loc (getPLIVersion loc) dp.fromSnapshot dp.depCommon
         PLMutable dir -> do
           pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts)
           lp <- loadLocalPackage' pp

src/Stack/Build/Haddock.hs

@@ -64,7 +64,7 @@ openHaddocksInBrowser ::
   -- ^ Build targets as determined by 'Stack.Build.Source.loadSourceMap'
   -> RIO env ()
 openHaddocksInBrowser bco pkgLocations buildTargets = do
-  let cliTargets = bco.buildOptsCLI.targets
+  let cliTargets = bco.buildOptsCLI.targetsCLI
       getDocIndex = do
         let localDocs = haddockIndexFile (localDepsDocDir bco)
         localExists <- doesFileExist localDocs

src/Stack/Build/Installed.hs

@@ -41,14 +41,14 @@ toInstallMap :: MonadIO m => SourceMap -> m InstallMap
 toInstallMap sourceMap = do
   projectInstalls <-
     for sourceMap.project $ \pp -> do
-      version <- loadVersion pp.common
+      version <- loadVersion pp.projectCommon
       pure (Local, version)
   depInstalls <-
     for sourceMap.deps $ \dp ->
       case dp.location of
         PLImmutable pli -> pure (Snap, getPLIVersion pli)
         PLMutable _ -> do
-          version <- loadVersion dp.common
+          version <- loadVersion dp.depCommon
           pure (Local, version)
   pure $ projectInstalls <> depInstalls
 

src/Stack/Build/Source.hs

@@ -69,8 +69,6 @@ import           Stack.Types.SourceMap
                    , SMActual (..), SMTargets (..), SourceMap (..)
                    , SourceMapHash (..), Target (..), ppGPD, ppRoot
                    )
-import qualified Stack.Types.SourceMap as DepPackage ( DepPackage (..) )
-import qualified Stack.Types.SourceMap as ProjectPackage ( ProjectPackage (..) )
 import           Stack.Types.UnusedFlags ( FlagSource (..) )
 import           System.FilePath ( takeFileName )
 import           System.IO.Error ( isDoesNotExistError )
@@ -100,21 +98,17 @@ loadSourceMap :: HasBuildConfig env
               -> BuildOptsCLI
               -> SMActual DumpedGlobalPackage
               -> RIO env SourceMap
-loadSourceMap smt boptsCli sma = do
+loadSourceMap targets boptsCli sma = do
   bconfig <- view buildConfigL
   let compiler = sma.compiler
       project = M.map applyOptsFlagsPP sma.project
       bopts = bconfig.config.build
-      applyOptsFlagsPP p@ProjectPackage{ common = c } = p
-        { ProjectPackage.common =
-            applyOptsFlags (M.member c.name smt.targets) True c
-        }
-      deps0 = smt.deps <> sma.deps
+      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{ common = c } = d
-        { DepPackage.common =
-            applyOptsFlags (M.member c.name smt.deps) False c
-        }
+      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
@@ -141,18 +135,17 @@ loadSourceMap smt boptsCli sma = do
         Map.toList boptsCli.flags
       maybeProjectFlags (ACFByName name, fs) = Just (name, fs)
       maybeProjectFlags _ = Nothing
-      globals = pruneGlobals sma.global (Map.keysSet deps)
+      globalPkgs = pruneGlobals sma.global (Map.keysSet deps)
   logDebug "Checking flags"
   checkFlagsUsedThrowing packageCliFlags FSCommandLine project deps
   logDebug "SourceMap constructed"
-  pure
-    SourceMap
-      { targets = smt
-      , compiler = compiler
-      , project = project
-      , deps = deps
-      , global = globals
-      }
+  pure SourceMap
+    { targets
+    , compiler
+    , project
+    , deps
+    , globalPkgs
+    }
 
 -- | Get a 'SourceMapHash' for a given 'SourceMap'
 --
@@ -204,10 +197,10 @@ depPackageHashableContent dp =
             if enabled
               then ""
               else "-" <> fromString (C.unFlagName f)
-          flags = map flagToBs $ Map.toList dp.common.flags
-          ghcOptions = map display dp.common.ghcOptions
-          cabalConfigOpts = map display dp.common.cabalConfigOpts
-          haddocks = if dp.common.haddocks then "haddocks" else ""
+          flags = map flagToBs $ Map.toList dp.depCommon.flags
+          ghcOptions = map display dp.depCommon.ghcOptions
+          cabalConfigOpts = map display dp.depCommon.cabalConfigOpts
+          haddocks = if dp.depCommon.haddocks then "haddocks" else ""
           hash = immutableLocSha pli
       pure
         $  hash
@@ -307,7 +300,7 @@ loadLocalPackage ::
   -> RIO env LocalPackage
 loadLocalPackage pp = do
   sm <- view sourceMapL
-  let common = pp.common
+  let common = pp.projectCommon
   bopts <- view buildOptsL
   mcurator <- view $ buildConfigL . to (.curator)
   config <- getPackageConfig
@@ -416,7 +409,7 @@ loadLocalPackage pp = do
     { package = pkg
     , testBench = btpkg
     , componentFiles
-    , buildHaddocks = pp.common.haddocks
+    , buildHaddocks = pp.projectCommon.haddocks
     , forceDirty = bopts.forceDirty
     , dirtyFiles
     , newBuildCaches

src/Stack/Build/Target.hs

@@ -108,7 +108,7 @@ getRawInput ::
   -> Map PackageName ProjectPackage
   -> ([Text], [RawInput])
 getRawInput boptscli locals =
-  let textTargets' = boptscli.targets
+  let textTargets' = boptscli.targetsCLI
       textTargets =
         -- Handle the no targets case, which means we pass in the names of all
         -- project packages

src/Stack/BuildPlan.hs

@@ -381,7 +381,7 @@ checkSnapBuildPlan ::
 checkSnapBuildPlan pkgDirs flags snapCandidate = do
   platform <- view platformL
   sma <- snapCandidate pkgDirs
-  gpds <- liftIO $ forM (Map.elems sma.project) (.common.gpd)
+  gpds <- liftIO $ forM (Map.elems sma.project) (.projectCommon.gpd)
 
   let compiler = sma.compiler
       globalVersion (GlobalPackageVersion v) = v

src/Stack/Config.hs

@@ -138,9 +138,6 @@ import           Stack.Types.SourceMap
                    ( CommonPackage (..), DepPackage (..), ProjectPackage (..)
                    , SMWanted (..)
                    )
-import qualified Stack.Types.SourceMap as DepPackage ( DepPackage (..) )
-import qualified Stack.Types.SourceMap as ProjectPackage ( ProjectPackage (..) )
-import qualified Stack.Types.SourceMap as CommonPackage ( CommonPackage (..) )
 import           Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
 import           Stack.Types.UnusedFlags ( FlagSource (..) )
 import           Stack.Types.Version
@@ -837,7 +834,7 @@ withBuildConfig inner = do
       { userMsg = Nothing
       , packages = []
       , dependencies = map (RPLImmutable . flip RPLIHackage Nothing) extraDeps
-      , flags = mempty
+      , flagsByPkg = mempty
       , resolver = r
       , compiler = Nothing
       , extraPackageDBs = []
@@ -861,7 +858,7 @@ fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages
     abs' <- resolveDir (parent stackYamlFP) (T.unpack t)
     let resolved = ResolvedPath fp abs'
     pp <- mkProjectPackage YesPrintWarnings resolved bopts.haddock
-    pure (pp.common.name, pp)
+    pure (pp.projectCommon.name, pp)
 
   -- prefetch git repos to avoid cloning per subdirectory
   -- see https://github.com/commercialhaskell/stack/issues/5411
@@ -891,7 +888,7 @@ fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages
        RPLMutable p ->
          pure (PLMutable p, Nothing)
     dp <- additionalDepPackage (shouldHaddockDeps bopts) pl
-    pure ((dp.common.name, dp), mCompleted)
+    pure ((dp.depCommon.name, dp), mCompleted)
 
   checkDuplicateNames $
     map (second (PLMutable . (.resolvedDir))) packages0 ++
@@ -909,19 +906,19 @@ fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages
 
   let mergeApply m1 m2 f =
         MS.merge MS.preserveMissing MS.dropMissing (MS.zipWithMatched f) m1 m2
-      pFlags = project.flags
+      pFlags = project.flagsByPkg
       packages2 = mergeApply packages1 pFlags $ \_ p flags ->
-        p { ProjectPackage.common = p.common { CommonPackage.flags = flags } }
+        p { projectCommon = p.projectCommon { flags = flags } }
       deps2 = mergeApply deps1 pFlags $ \_ d flags ->
-        d { DepPackage.common = d.common { CommonPackage.flags = flags } }
+        d { depCommon = d.depCommon { flags = flags } }
 
   checkFlagsUsedThrowing pFlags FSStackYaml packages1 deps1
 
   let pkgGhcOptions = config.ghcOptionsByName
       deps = mergeApply deps2 pkgGhcOptions $ \_ d options ->
-        d { DepPackage.common = d.common { ghcOptions = options } }
+        d { depCommon = d.depCommon { ghcOptions = options } }
       packages = mergeApply packages2 pkgGhcOptions $ \_ p options ->
-        p { ProjectPackage.common = p.common { ghcOptions = options } }
+        p { projectCommon = p.projectCommon { ghcOptions = options } }
       unusedPkgGhcOptions =
         pkgGhcOptions `Map.restrictKeys` Map.keysSet packages2
           `Map.restrictKeys` Map.keysSet deps2

src/Stack/Coverage.hs

@@ -49,8 +49,8 @@ import           Stack.Types.BuildConfig
                    ( BuildConfig (..), HasBuildConfig (..) )
 import           Stack.Types.Compiler ( getGhcVersion )
 import           Stack.Types.CompCollection ( getBuildableSetText )
-import           Stack.Types.BuildOptsCLI ( defaultBuildOptsCLI )
-import qualified Stack.Types.BuildOptsCLI as BuildOptsCLI ( BuildOptsCLI (..) )
+import           Stack.Types.BuildOptsCLI
+                   ( BuildOptsCLI (..), defaultBuildOptsCLI )
 import           Stack.Types.EnvConfig
                    ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
                    , hpcReportDir
@@ -115,7 +115,7 @@ hpcReportCmd hropts = do
   let (tixFiles, targetNames) =
         L.partition (".tix" `T.isSuffixOf`) hropts.hroptsInputs
       boptsCLI = defaultBuildOptsCLI
-        { BuildOptsCLI.targets = if hropts.hroptsAll then [] else targetNames }
+        { targetsCLI = if hropts.hroptsAll then [] else targetNames }
   withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $
     generateHpcReportForTargets hropts tixFiles targetNames
 

src/Stack/DependencyGraph.hs

@@ -57,7 +57,6 @@ import           Stack.Types.SourceMap
                    ( CommonPackage (..), DepPackage (..), ProjectPackage (..)
                    , SMActual (..), SMWanted (..), SourceMap (..)
                    )
-import qualified Stack.Types.SourceMap as SMActual ( SMActual (..) )
 
 -- | Type representing exceptions thrown by functions exported by the
 -- "Stack.DependencyGraph" module.
@@ -139,7 +138,7 @@ withDotConfig opts inner =
         actualPkgs =
           Map.keysSet smActual.deps <> Map.keysSet smActual.project
         prunedActual = smActual
-          { SMActual.global = pruneGlobals smActual.global actualPkgs }
+          { global = pruneGlobals smActual.global actualPkgs }
     targets <- parseTargets NeedTargets False boptsCLI prunedActual
     logDebug "Loading source map"
     sourceMap <- loadSourceMap targets boptsCLI smActual
@@ -164,7 +163,7 @@ withDotConfig opts inner =
     runRIO dc inner
 
   boptsCLI = defaultBuildOptsCLI
-    { targets = opts.dotTargets
+    { targetsCLI = opts.dotTargets
     , flags = opts.flags
     }
   modifyGO =
@@ -257,19 +256,19 @@ createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName =
   projectPackageDeps = loadDeps <$> Map.lookup pkgName sourceMap.project
    where
     loadDeps pp = do
-      pkg <- loadCommonPackage pp.common
+      pkg <- loadCommonPackage pp.projectCommon
       pure (setOfPackageDeps pkg, payloadFromLocal pkg Nothing)
 
   dependencyDeps =
     loadDeps <$> Map.lookup pkgName sourceMap.deps
    where
     loadDeps DepPackage{ location = PLMutable dir } = do
       pp <- mkProjectPackage YesPrintWarnings dir False
-      pkg <- loadCommonPackage pp.common
+      pkg <- loadCommonPackage pp.projectCommon
       pure (setOfPackageDeps pkg, payloadFromLocal pkg (Just $ PLMutable dir))
 
     loadDeps dp@DepPackage{ location = PLImmutable loc } = do
-      let common = dp.common
+      let common = dp.depCommon
       gpd <- liftIO common.gpd
       let PackageIdentifier name version = PD.package $ PD.packageDescription gpd
           flags = common.flags

src/Stack/Exec.hs

@@ -124,7 +124,7 @@ execCmd opts =
   eo = opts.eoExtra
 
   targets = concatMap words eo.eoPackages
-  boptsCLI = defaultBuildOptsCLI { targets = map T.pack targets }
+  boptsCLI = defaultBuildOptsCLI { targetsCLI = map T.pack targets }
 
   -- return the package-id of the first package in GHC_PACKAGE_PATH
   getPkgId name = do

src/Stack/Ghci.hs

@@ -61,7 +61,6 @@ import qualified Stack.Types.BuildOpts as BenchmarkOpts ( BenchmarkOpts (..) )
 import qualified Stack.Types.BuildOpts as TestOpts ( TestOpts (..) )
 import           Stack.Types.BuildOptsCLI
                    ( ApplyCLIFlag, BuildOptsCLI (..), defaultBuildOptsCLI )
-import qualified Stack.Types.BuildOptsCLI as BuildOptsCLI ( BuildOptsCLI (..) )
 import           Stack.Types.CompCollection ( getBuildableListText )
 import           Stack.Types.CompilerPaths
                    ( CompilerPaths (..), HasCompiler (..) )
@@ -203,7 +202,7 @@ ghciCmd :: GhciOpts -> RIO Runner ()
 ghciCmd ghciOpts =
   let boptsCLI = defaultBuildOptsCLI
         -- using only additional packages, targets then get overridden in `ghci`
-        { targets = map T.pack ghciOpts.ghciAdditionalPackages
+        { targetsCLI = map T.pack ghciOpts.ghciAdditionalPackages
         , initialBuildSteps = True
         , flags = ghciOpts.ghciFlags
         , ghcOptions = map T.pack ghciOpts.ghciGhcOptions
@@ -224,7 +223,7 @@ ghciCmd ghciOpts =
 ghci :: HasEnvConfig env => GhciOpts -> RIO env ()
 ghci opts = do
   let buildOptsCLI = defaultBuildOptsCLI
-        { targets = []
+        { targetsCLI = []
         , flags = opts.ghciFlags
         }
   sourceMap <- view $ envConfigL . to (.sourceMap)
@@ -238,7 +237,7 @@ ghci opts = do
         { compiler = sourceMap.compiler
         , project = sourceMap.project
         , deps = sourceMap.deps
-        , global = sourceMap.global
+        , global = sourceMap.globalPkgs
         }
   -- Parse --main-is argument.
   mainIsTargets <- parseMainIsTargets buildOptsCLI sma opts.ghciMainIs
@@ -323,7 +322,7 @@ preprocessTargets buildOptsCLI sma rawTargets = do
     else do
       -- Try parsing targets before checking if both file and
       -- module targets are specified (see issue#3342).
-      let boptsCLI = buildOptsCLI { BuildOptsCLI.targets = normalTargetsRaw }
+      let boptsCLI = buildOptsCLI { targetsCLI = normalTargetsRaw }
       normalTargets <- parseTargets AllowNoTargets False boptsCLI sma
         `catch` \pex@(PrettyException ex) ->
           case fromException $ toException ex of
@@ -340,7 +339,7 @@ parseMainIsTargets ::
   -> Maybe Text
   -> RIO env (Maybe (Map PackageName Target))
 parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do
-  let boptsCLI = buildOptsCLI { BuildOptsCLI.targets = [target] }
+  let boptsCLI = buildOptsCLI { targetsCLI = [target] }
   targets <- parseTargets AllowNoTargets False boptsCLI sma
   pure targets.targets
 
@@ -849,15 +848,15 @@ loadGhciPkgDesc buildOptsCLI name cabalfp target = do
       -- Currently this source map is being build with
       -- the default targets
       sourceMapGhcOptions = fromMaybe [] $
-        ((.common.ghcOptions) <$> M.lookup name sm.project)
+        ((.projectCommon.ghcOptions) <$> M.lookup name sm.project)
         <|>
-        ((.common.ghcOptions) <$> M.lookup name sm.deps)
+        ((.depCommon.ghcOptions) <$> M.lookup name sm.deps)
       sourceMapCabalConfigOpts = fromMaybe [] $
-        ( (.common.cabalConfigOpts) <$> M.lookup name sm.project)
+        ( (.projectCommon.cabalConfigOpts) <$> M.lookup name sm.project)
         <|>
-        ((.common.cabalConfigOpts) <$> M.lookup name sm.deps)
+        ((.depCommon.cabalConfigOpts) <$> M.lookup name sm.deps)
       sourceMapFlags =
-        maybe mempty (.common.flags) $ M.lookup name sm.project
+        maybe mempty (.projectCommon.flags) $ M.lookup name sm.project
       config = PackageConfig
         { enableTests = True
         , enableBenchmarks = True