Merge pull request #6444 from commercialhaskell/ambiguity

Eliminate ambiguity; make use of GHC2021's NamedFieldPuns

Author: mpilgrem

.stan.toml

@@ -10,11 +10,11 @@
 # Partial: base/head
 # Usage of partial function 'head' for lists
 [[ignore]]
-  id = "OBS-STAN-0001-0pmobG-86:1"
+  id = "OBS-STAN-0001-0pmobG-87:1"
 # ✦ Category:      #Partial #List
 # ✦ File:          src\Stack\Storage\User.hs
 #
-#   86 ┃ share [ mkPersist sqlSettings
+#   87 ┃ share [ mkPersist sqlSettings
 
 # Partial: base/last
 # On Windows
@@ -72,14 +72,14 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-erw24B-1022:3"
+  id = "OBS-STAN-0203-erw24B-1029:3"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\ExecuteEnv.hs
 #
-#  1021 ┃
-#  1022 ┃   S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q"
-#  1023 ┃   ^^^^^^^
+#  1028 ┃
+#  1029 ┃   S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q"
+#  1030 ┃   ^^^^^^^
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]

src/Stack/Build.hs

@@ -328,21 +328,21 @@ splitObjsWarning =
 -- | Get the @BaseConfigOpts@ necessary for constructing configure options
 mkBaseConfigOpts :: (HasEnvConfig env)
                  => BuildOptsCLI -> RIO env BaseConfigOpts
-mkBaseConfigOpts boptsCli = do
-  bopts <- view buildOptsL
-  snapDBPath <- packageDatabaseDeps
-  localDBPath <- packageDatabaseLocal
+mkBaseConfigOpts buildOptsCLI = do
+  buildOpts <- view buildOptsL
+  snapDB <- packageDatabaseDeps
+  localDB <- packageDatabaseLocal
   snapInstallRoot <- installationRootDeps
   localInstallRoot <- installationRootLocal
-  packageExtraDBs <- packageDatabaseExtra
+  extraDBs <- packageDatabaseExtra
   pure BaseConfigOpts
-    { snapDB = snapDBPath
-    , localDB = localDBPath
-    , snapInstallRoot = snapInstallRoot
-    , localInstallRoot = localInstallRoot
-    , buildOpts = bopts
-    , buildOptsCLI = boptsCli
-    , extraDBs = packageExtraDBs
+    { snapDB
+    , localDB
+    , snapInstallRoot
+    , localInstallRoot
+    , buildOpts
+    , buildOptsCLI
+    , extraDBs
     }
 
 -- | Provide a function for loading package information from the package index
@@ -354,16 +354,16 @@ loadPackage ::
   -> [Text] -- ^ Cabal configure options
   -> RIO env Package
 loadPackage loc flags ghcOptions cabalConfigOpts = do
-  compiler <- view actualCompilerVersionL
+  compilerVersion <- view actualCompilerVersionL
   platform <- view platformL
   let pkgConfig = PackageConfig
         { enableTests = False
         , enableBenchmarks = False
-        , flags = flags
-        , ghcOptions = ghcOptions
-        , cabalConfigOpts = cabalConfigOpts
-        , compilerVersion = compiler
-        , platform = platform
+        , flags
+        , ghcOptions
+        , cabalConfigOpts
+        , compilerVersion
+        , platform
         }
   resolvePackage pkgConfig <$> loadCabalFileImmutable loc
 

src/Stack/Build/ExecuteEnv.hs

@@ -261,90 +261,97 @@ withExecuteEnv ::
   -> Maybe Int -- ^ largest package name, for nicer interleaved output
   -> (ExecuteEnv -> RIO env a)
   -> RIO env a
-withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages mlargestPackageName inner =
-  createTempDirFunction stackProgName $ \tmpdir -> do
-    installLock <- liftIO $ newMVar ()
-    idMap <- liftIO $ newTVarIO Map.empty
-    config <- view configL
-
-    customBuiltRef <- newIORef Set.empty
-
-    -- Create files for simple setup and setup shim, if necessary
-    let setupSrcDir =
-            view stackRootL config </>
-            relDirSetupExeSrc
-    ensureDir setupSrcDir
-    let setupStub = "setup-" ++ simpleSetupHash
-    setupFileName <- parseRelFile (setupStub ++ ".hs")
-    setupHiName <- parseRelFile (setupStub ++ ".hi")
-    setupOName <- parseRelFile (setupStub ++ ".o")
-    let setupHs = setupSrcDir </> setupFileName
-        setupHi = setupSrcDir </> setupHiName
-        setupO =  setupSrcDir </> setupOName
-    setupHsExists <- doesFileExist setupHs
-    unless setupHsExists $ writeBinaryFileAtomic setupHs simpleSetupCode
-    -- See https://github.com/commercialhaskell/stack/issues/6267. Remove any
-    -- historical *.hi or *.o files. This can be dropped when Stack drops
-    -- support for the problematic versions of GHC.
-    ignoringAbsence (removeFile setupHi)
-    ignoringAbsence (removeFile setupO)
-    let setupShimStub = "setup-shim-" ++ simpleSetupHash
-    setupShimFileName <- parseRelFile (setupShimStub ++ ".hs")
-    setupShimHiName <- parseRelFile (setupShimStub ++ ".hi")
-    setupShimOName <- parseRelFile (setupShimStub ++ ".o")
-    let setupShimHs = setupSrcDir </> setupShimFileName
-        setupShimHi = setupSrcDir </> setupShimHiName
-        setupShimO = setupSrcDir </> setupShimOName
-    setupShimHsExists <- doesFileExist setupShimHs
-    unless setupShimHsExists $
-      writeBinaryFileAtomic setupShimHs setupGhciShimCode
-    -- See https://github.com/commercialhaskell/stack/issues/6267. Remove any
-    -- historical *.hi or *.o files. This can be dropped when Stack drops
-    -- support for the problematic versions of GHC.
-    ignoringAbsence (removeFile setupShimHi)
-    ignoringAbsence (removeFile setupShimO)
-    setupExe <- getSetupExe setupHs setupShimHs tmpdir
-
-    cabalPkgVer <- view cabalVersionL
-    globalDB <- view $ compilerPathsL . to (.globalDB)
-    snapshotPackagesTVar <-
-      liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)
-    localPackagesTVar <-
-      liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages)
-    logFilesTChan <- liftIO $ atomically newTChan
-    let totalWanted = length $ filter (.wanted) locals
-    pathEnvVar <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"
-    inner ExecuteEnv
-      { buildOpts = bopts
-      , buildOptsCLI = boptsCli
-        -- Uncertain as to why we cannot run configures in parallel. This
-        -- appears to be a Cabal library bug. Original issue:
-        -- https://github.com/commercialhaskell/stack/issues/84. Ideally
-        -- we'd be able to remove this.
-      , installLock = installLock
-      , baseConfigOpts = baseConfigOpts
-      , ghcPkgIds = idMap
-      , tempDir = tmpdir
-      , setupHs = setupHs
-      , setupShimHs = setupShimHs
-      , setupExe = setupExe
-      , cabalPkgVer = cabalPkgVer
-      , totalWanted = totalWanted
-      , locals = locals
-      , globalDB = globalDB
-      , globalDumpPkgs = toDumpPackagesByGhcPkgId globalPackages
-      , snapshotDumpPkgs = snapshotPackagesTVar
-      , localDumpPkgs = localPackagesTVar
-      , logFiles = logFilesTChan
-      , customBuilt = customBuiltRef
-      , largestPackageName = mlargestPackageName
-      , pathEnvVar = pathEnvVar
-      } `finally` dumpLogs logFilesTChan totalWanted
+withExecuteEnv
+    buildOpts
+    buildOptsCLI
+    baseConfigOpts
+    locals
+    globalPackages
+    snapshotPackages
+    localPackages
+    largestPackageName
+    inner
+  = createTempDirFunction stackProgName $ \tempDir -> do
+      installLock <- liftIO $ newMVar ()
+      ghcPkgIds <- liftIO $ newTVarIO Map.empty
+      config <- view configL
+      customBuilt <- newIORef Set.empty
+      -- Create files for simple setup and setup shim, if necessary
+      let setupSrcDir =
+              view stackRootL config </>
+              relDirSetupExeSrc
+      ensureDir setupSrcDir
+      let setupStub = "setup-" ++ simpleSetupHash
+      setupFileName <- parseRelFile (setupStub ++ ".hs")
+      setupHiName <- parseRelFile (setupStub ++ ".hi")
+      setupOName <- parseRelFile (setupStub ++ ".o")
+      let setupHs = setupSrcDir </> setupFileName
+          setupHi = setupSrcDir </> setupHiName
+          setupO =  setupSrcDir </> setupOName
+      setupHsExists <- doesFileExist setupHs
+      unless setupHsExists $ writeBinaryFileAtomic setupHs simpleSetupCode
+      -- See https://github.com/commercialhaskell/stack/issues/6267. Remove any
+      -- historical *.hi or *.o files. This can be dropped when Stack drops
+      -- support for the problematic versions of GHC.
+      ignoringAbsence (removeFile setupHi)
+      ignoringAbsence (removeFile setupO)
+      let setupShimStub = "setup-shim-" ++ simpleSetupHash
+      setupShimFileName <- parseRelFile (setupShimStub ++ ".hs")
+      setupShimHiName <- parseRelFile (setupShimStub ++ ".hi")
+      setupShimOName <- parseRelFile (setupShimStub ++ ".o")
+      let setupShimHs = setupSrcDir </> setupShimFileName
+          setupShimHi = setupSrcDir </> setupShimHiName
+          setupShimO = setupSrcDir </> setupShimOName
+      setupShimHsExists <- doesFileExist setupShimHs
+      unless setupShimHsExists $
+        writeBinaryFileAtomic setupShimHs setupGhciShimCode
+      -- See https://github.com/commercialhaskell/stack/issues/6267. Remove any
+      -- historical *.hi or *.o files. This can be dropped when Stack drops
+      -- support for the problematic versions of GHC.
+      ignoringAbsence (removeFile setupShimHi)
+      ignoringAbsence (removeFile setupShimO)
+      setupExe <- getSetupExe setupHs setupShimHs tempDir
+      cabalPkgVer <- view cabalVersionL
+      globalDB <- view $ compilerPathsL . to (.globalDB)
+      let globalDumpPkgs = toDumpPackagesByGhcPkgId globalPackages
+      snapshotDumpPkgs <-
+        liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)
+      localDumpPkgs <-
+        liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages)
+      logFiles <- liftIO $ atomically newTChan
+      let totalWanted = length $ filter (.wanted) locals
+      pathEnvVar <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"
+      inner ExecuteEnv
+        { buildOpts
+        , buildOptsCLI
+          -- Uncertain as to why we cannot run configures in parallel. This
+          -- appears to be a Cabal library bug. Original issue:
+          -- https://github.com/commercialhaskell/stack/issues/84. Ideally
+          -- we'd be able to remove this.
+        , installLock
+        , baseConfigOpts
+        , ghcPkgIds
+        , tempDir
+        , setupHs
+        , setupShimHs
+        , setupExe
+        , cabalPkgVer
+        , totalWanted
+        , locals
+        , globalDB
+        , globalDumpPkgs
+        , snapshotDumpPkgs
+        , localDumpPkgs
+        , logFiles
+        , customBuilt
+        , largestPackageName
+        , pathEnvVar
+        } `finally` dumpLogs logFiles totalWanted
  where
   toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dp.ghcPkgId, dp))
 
   createTempDirFunction
-    | bopts.keepTmpFiles = withKeepSystemTempDir
+    | buildOpts.keepTmpFiles = withKeepSystemTempDir
     | otherwise = withSystemTempDir
 
   dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()

src/Stack/Build/Source.hs

@@ -415,11 +415,11 @@ loadLocalPackage pp = do
   pure LocalPackage
     { package = pkg
     , testBench = btpkg
-    , componentFiles = componentFiles
+    , componentFiles
     , buildHaddocks = pp.common.haddocks
     , forceDirty = bopts.forceDirty
-    , dirtyFiles = dirtyFiles
-    , newBuildCaches = newBuildCaches
+    , dirtyFiles
+    , newBuildCaches
     , cabalFile = pp.cabalFP
     , wanted = isWanted
     , components = nonLibComponents

src/Stack/BuildPlan.hs

@@ -166,7 +166,7 @@ gpdPackageDeps ::
   -> Platform
   -> Map FlagName Bool
   -> Map PackageName VersionRange
-gpdPackageDeps gpd ac platform flags =
+gpdPackageDeps gpd compilerVersion platform flags =
   Map.filterWithKey (const . not . isLocalLibrary) (packageDependencies pkgDesc)
  where
   isLocalLibrary name' = name' == name || name' `Set.member` subs
@@ -182,11 +182,11 @@ gpdPackageDeps gpd ac platform flags =
   pkgConfig = PackageConfig
     { enableTests = True
     , enableBenchmarks = True
-    , flags = flags
+    , flags
     , ghcOptions = []
     , cabalConfigOpts = []
-    , compilerVersion = ac
-    , platform = platform
+    , compilerVersion
+    , platform
     }
 
 -- Remove any src package flags having default values

src/Stack/Config.hs

@@ -727,7 +727,7 @@ withBuildConfig inner = do
     logDebug ("Using resolver: " <> display aresolver <> " specified on command line")
     makeConcreteResolver aresolver
 
-  (project', stackYamlFP) <- case config.project of
+  (project', stackYaml) <- case config.project of
     PCProject (project, fp) -> do
       forM_ project.userMsg prettyWarnS
       pure (project, fp)
@@ -794,22 +794,22 @@ withBuildConfig inner = do
         }
   extraPackageDBs <- mapM resolveDir' project.extraPackageDBs
 
-  wanted <- lockCachedWanted stackYamlFP project.resolver $
-    fillProjectWanted stackYamlFP config project
+  smWanted <- lockCachedWanted stackYaml project.resolver $
+    fillProjectWanted stackYaml config project
 
   -- Unfortunately redoes getProjectWorkDir, since we don't have a BuildConfig
   -- yet
   workDir <- view workDirL
-  let projectStorageFile = parent stackYamlFP </> workDir </> relFileStorage
+  let projectStorageFile = parent stackYaml </> workDir </> relFileStorage
 
   initProjectStorage projectStorageFile $ \projectStorage -> do
     let bc = BuildConfig
-          { config = config
-          , smWanted = wanted
-          , extraPackageDBs = extraPackageDBs
-          , stackYaml = stackYamlFP
+          { config
+          , smWanted
+          , extraPackageDBs
+          , stackYaml
           , curator = project.curator
-          , projectStorage = projectStorage
+          , projectStorage
           }
     runRIO bc inner
  where
@@ -836,8 +836,7 @@ withBuildConfig inner = do
     pure Project
       { userMsg = Nothing
       , packages = []
-      , dependencies =
-          map (RPLImmutable . flip RPLIHackage Nothing) extraDeps
+      , dependencies = map (RPLImmutable . flip RPLIHackage Nothing) extraDeps
       , flags = mempty
       , resolver = r
       , compiler = Nothing