Merge pull request #6443 from commercialhaskell/cp-prefix

mpilgrem · web-flow · commit 05e3e6c7e444 · 2024-01-17T21:23:58.000Z
diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs
@@ -153,7 +153,7 @@ constructPlan
         <> line
 
     econfig <- view envConfigL
-    globalCabalVersion <- view $ compilerPathsL . to (.cpCabalVersion)
+    globalCabalVersion <- view $ compilerPathsL . to (.cabalVersion)
     sources <- getSources globalCabalVersion
     mcur <- view $ buildConfigL . to (.curator)
     pathEnvVar' <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"
diff --git a/src/Stack/Build/ExecuteEnv.hs b/src/Stack/Build/ExecuteEnv.hs
@@ -306,7 +306,7 @@ withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPacka
     setupExe <- getSetupExe setupHs setupShimHs tmpdir
 
     cabalPkgVer <- view cabalVersionL
-    globalDB <- view $ compilerPathsL . to (.cpGlobalDB)
+    globalDB <- view $ compilerPathsL . to (.globalDB)
     snapshotPackagesTVar <-
       liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)
     localPackagesTVar <-
@@ -879,7 +879,7 @@ withSingleContext
             then pure outputFile
             else do
               ensureDir setupDir
-              compilerPath <- view $ compilerPathsL . to (.cpCompiler)
+              compilerPath <- view $ compilerPathsL . to (.compiler)
               packageArgs <- getPackageArgs setupDir
               runExe compilerPath $
                 [ "--make"
diff --git a/src/Stack/Build/ExecutePackage.hs b/src/Stack/Build/ExecutePackage.hs
@@ -276,11 +276,11 @@ ensureConfig newConfigCache pkgDir buildOpts announce cabal cabalfp task = do
     deleteCaches pkgDir
     announce
     cp <- view compilerPathsL
-    let (GhcPkgExe pkgPath) = cp.cpPkg
+    let (GhcPkgExe pkgPath) = cp.pkg
     let programNames =
           case cpWhich cp of
             Ghc ->
-              [ ("ghc", toFilePath cp.cpCompiler)
+              [ ("ghc", toFilePath cp.compiler)
               , ("ghc-pkg", toFilePath pkgPath)
               ]
     exes <- forM programNames $ \(name, file) -> do
diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs
@@ -236,7 +236,7 @@ generateHaddockIndex descr bco dumpPackages docRelFP destDir = do
           <> line
           <> pretty destIndexFile
         liftIO (mapM_ copyPkgDocs interfaceOpts)
-        haddockExeName <- view $ compilerPathsL . to (toFilePath . (.cpHaddock))
+        haddockExeName <- view $ compilerPathsL . to (toFilePath . (.haddock))
         withWorkingDir (toFilePath destDir) $ readProcessNull
           haddockExeName
           ( map
diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs
@@ -160,12 +160,12 @@ execCmd opts =
 
   getGhcCmd pkgs args = do
     pkgopts <- getPkgOpts pkgs
-    compiler <- view $ compilerPathsL . to (.cpCompiler)
+    compiler <- view $ compilerPathsL . to (.compiler)
     pure (toFilePath compiler, pkgopts ++ args)
 
   getRunGhcCmd pkgs args = do
     pkgopts <- getPkgOpts pkgs
-    interpret <- view $ compilerPathsL . to (.cpInterpreter)
+    interpret <- view $ compilerPathsL . to (.interpreter)
     pure (toFilePath interpret, pkgopts ++ args)
 
   runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig ()
diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs
@@ -169,7 +169,7 @@ unregisterGhcPkgIds ::
   -> NonEmpty (Either PackageIdentifier GhcPkgId)
   -> RIO env ()
 unregisterGhcPkgIds isWarn pkgexe pkgDb epgids = do
-  globalDb <- view $ compilerPathsL . to (.cpGlobalDB)
+  globalDb <- view $ compilerPathsL . to (.globalDB)
   eres <- try $ do
     ghcPkgUnregisterForce globalDb pkgDb hasIpid pkgarg_strs
     -- ghcPkgUnregisterForce does not perform an effective
diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
@@ -573,7 +573,7 @@ runGhci
             (map (fromPackageName . (.ghciPkgName)) pkgs :: [StyleDoc])
         )
       compilerExeName <-
-        view $ compilerPathsL . to (.cpCompiler) . to toFilePath
+        view $ compilerPathsL . to (.compiler) . to toFilePath
       let execGhci extras = do
             menv <-
               liftIO $ config.processContextSettings defaultEnvSettings
diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs
@@ -104,7 +104,7 @@ fillPathInfo = do
   piSnapDb <- packageDatabaseDeps
   piLocalDb <- packageDatabaseLocal
   piExtraDbs <- packageDatabaseExtra
-  piGlobalDb <- view $ compilerPathsL . to (.cpGlobalDB)
+  piGlobalDb <- view $ compilerPathsL . to (.globalDB)
   piSnapRoot <- installationRootDeps
   piLocalRoot <- installationRootLocal
   piToolsDir <- bindirCompilerTools
diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs
@@ -245,7 +245,7 @@ scriptCmd opts = do
           -- to check which packages are installed already. If all needed
           -- packages are available, we can skip the (rather expensive) build
           -- call below.
-          GhcPkgExe pkg <- view $ compilerPathsL . to (.cpPkg)
+          GhcPkgExe pkg <- view $ compilerPathsL . to (.pkg)
           -- https://github.com/haskell/process/issues/251
           bss <- snd <$> sinkProcessStderrStdout (toFilePath pkg)
               ["list", "--simple-output"] CL.sinkNull CL.consume -- FIXME use the package info from envConfigPackages, or is that crazy?
@@ -284,7 +284,7 @@ scriptCmd opts = do
               ]
         case shouldCompile of
           SEInterpret -> do
-            interpret <- view $ compilerPathsL . to (.cpInterpreter)
+            interpret <- view $ compilerPathsL . to (.interpreter)
             exec (toFilePath interpret)
                 (ghcArgs ++ toFilePath file : opts.soArgs)
           _ -> do
@@ -295,7 +295,7 @@ scriptCmd opts = do
             -- to the user.
             liftIO $ Dir.createDirectoryIfMissing True (fromAbsDir (parent exe))
             compilerExeName <-
-              view $ compilerPathsL . to (.cpCompiler) . to toFilePath
+              view $ compilerPathsL . to (.compiler) . to toFilePath
             withWorkingDir (fromAbsDir (parent file)) $ proc
               compilerExeName
               (ghcArgs ++ [toFilePath file])
diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
@@ -667,7 +667,7 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do
         }
 
   (compilerPaths, ghcBin) <- ensureCompilerAndMsys sopts
-  let compilerVer = compilerPaths.cpCompilerVersion
+  let compilerVer = compilerPaths.compilerVersion
 
   -- Modify the initial environment to include the GHC path, if a local GHC
   -- is being used
@@ -712,12 +712,12 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do
     either throwM pure $ augmentPath (toFilePath <$> mkDirs True) mpath
 
   deps <- runRIO envConfig0 packageDatabaseDeps
-  runWithGHC menv compilerPaths $ createDatabase compilerPaths.cpPkg deps
+  runWithGHC menv compilerPaths $ createDatabase compilerPaths.pkg deps
   localdb <- runRIO envConfig0 packageDatabaseLocal
-  runWithGHC menv compilerPaths $ createDatabase compilerPaths.cpPkg localdb
+  runWithGHC menv compilerPaths $ createDatabase compilerPaths.pkg localdb
   extras <- runReaderT packageDatabaseExtra envConfig0
   let mkGPP locals =
-        mkGhcPackagePath locals localdb deps extras compilerPaths.cpGlobalDB
+        mkGhcPackagePath locals localdb deps extras compilerPaths.globalDB
 
   distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath
 
@@ -788,7 +788,7 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do
                 -- are ignored, since we're setting up our
                 -- own package databases. See
                 -- https://github.com/commercialhaskell/stack/issues/4706
-              $ (case compilerPaths.cpCompilerVersion of
+              $ (case compilerPaths.compilerVersion of
                   ACGhc version | version >= mkVersion [8, 4, 4] ->
                     Map.insert "GHC_ENVIRONMENT" "-"
                   _ -> id)
@@ -1052,8 +1052,8 @@ warnUnsupportedCompilerCabal ::
   -> RIO env ()
 warnUnsupportedCompilerCabal cp didWarn = do
   unless didWarn $
-    void $ warnUnsupportedCompiler $ getGhcVersion cp.cpCompilerVersion
-  let cabalVersion = cp.cpCabalVersion
+    void $ warnUnsupportedCompiler $ getGhcVersion cp.compilerVersion
+  let cabalVersion = cp.cabalVersion
   notifyIfCabalUntested <- view $ configL . to (.notifyIfCabalUntested)
   if
     | cabalVersion < mkVersion [1, 24, 0] -> do
@@ -1222,9 +1222,9 @@ ensureCompiler sopts getSetupInfo' = do
 
   let canUseCompiler cp
         | sopts.skipGhcCheck = pure cp
-        | not $ isWanted cp.cpCompilerVersion =
+        | not $ isWanted cp.compilerVersion =
             prettyThrowIO UnwantedCompilerVersion
-        | cp.cpArch /= expectedArch = prettyThrowIO UnwantedArchitecture
+        | cp.arch /= expectedArch = prettyThrowIO UnwantedArchitecture
         | otherwise = pure cp
       isWanted =
         isWantedCompiler sopts.compilerCheck sopts.wantedCompiler
@@ -1259,7 +1259,7 @@ ensureCompiler sopts getSetupInfo' = do
     Nothing -> ensureSandboxedCompiler sopts getSetupInfo'
     Just cp -> do
       let paths = ExtraDirs
-            { edBins = [parent cp.cpCompiler]
+            { edBins = [parent cp.compiler]
             , edInclude = [], edLib = []
             }
       pure (cp, paths)
@@ -1504,18 +1504,18 @@ pathsFromCompiler wc compilerBuild isSandboxed compiler =
         Just dp -> pure $ pkgVersion dp.packageIdent
 
     pure CompilerPaths
-      { cpBuild = compilerBuild
-      , cpArch = arch
-      , cpSandboxed = isSandboxed
-      , cpCompilerVersion = compilerVer
-      , cpCompiler = compiler
-      , cpPkg = pkg
-      , cpInterpreter = interpreter
-      , cpHaddock = haddock
-      , cpCabalVersion = cabalPkgVer
-      , cpGlobalDB = globaldb
-      , cpGhcInfo = infobs
-      , cpGlobalDump = globalDump
+      { build = compilerBuild
+      , arch = arch
+      , sandboxed = isSandboxed
+      , compilerVersion = compilerVer
+      , compiler = compiler
+      , pkg = pkg
+      , interpreter = interpreter
+      , haddock = haddock
+      , cabalVersion = cabalPkgVer
+      , globalDB = globaldb
+      , ghcInfo = infobs
+      , globalDump = globalDump
       }
  where
   onErr = throwIO . PrettyException . InvalidGhcAt compiler
diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs
@@ -65,7 +65,7 @@ setup ::
   -> RIO env ()
 setup sco wantedCompiler compilerCheck mstack = do
   config <- view configL
-  sandboxedGhc <- (.cpSandboxed) . fst <$> ensureCompilerAndMsys SetupOpts
+  sandboxedGhc <- (.sandboxed) . fst <$> ensureCompilerAndMsys SetupOpts
     { installIfMissing = True
     , useSystem = config.systemGHC && not sco.scoForceReinstall
     , wantedCompiler = wantedCompiler
diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs
@@ -179,7 +179,7 @@ actualFromGhc ::
   -> ActualCompiler
   -> RIO env (SMActual DumpedGlobalPackage)
 actualFromGhc smw ac = do
-  globals <- view $ compilerPathsL . to (.cpGlobalDump)
+  globals <- view $ compilerPathsL . to (.globalDump)
   pure
     SMActual
       { compiler = ac
@@ -267,7 +267,7 @@ pruneGlobals globals deps =
       Map.map ReplacedGlobalPackage prunedGlobals
 
 getCompilerInfo :: (HasConfig env, HasCompiler env) => RIO env Builder
-getCompilerInfo = view $ compilerPathsL . to (byteString . (.cpGhcInfo))
+getCompilerInfo = view $ compilerPathsL . to (byteString . (.ghcInfo))
 
 immutableLocSha :: PackageLocationImmutable -> Builder
 immutableLocSha = byteString . treeKeyToBs . locationTreeKey
diff --git a/src/Stack/Storage/User.hs b/src/Stack/Storage/User.hs
@@ -1,13 +1,14 @@
-{-# LANGUAGE NoImplicitPrelude    #-}
-{-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE DerivingStrategies   #-}
-{-# LANGUAGE GADTs                #-}
-{-# LANGUAGE OverloadedRecordDot  #-}
-{-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE QuasiQuotes          #-}
-{-# LANGUAGE TemplateHaskell      #-}
-{-# LANGUAGE TypeFamilies         #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE OverloadedRecordDot   #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-}
 
 -- | Work with SQLite database used for caches across an entire user account.
@@ -366,18 +367,18 @@ loadCompilerPaths compiler build sandboxed = do
         Just arch -> pure arch
 
     pure CompilerPaths
-      { cpCompiler = compiler
-      , cpCompilerVersion = compilerCache.compilerCacheActualVersion
-      , cpArch = arch
-      , cpBuild = build
-      , cpPkg = GhcPkgExe pkgexe
-      , cpInterpreter = runghc
-      , cpHaddock = haddock
-      , cpSandboxed = sandboxed
-      , cpCabalVersion = cabalVersion
-      , cpGlobalDB = globaldb
-      , cpGhcInfo = compilerCache.compilerCacheInfo
-      , cpGlobalDump = globalDump
+      { compiler = compiler
+      , compilerVersion = compilerCache.compilerCacheActualVersion
+      , arch = arch
+      , build = build
+      , pkg = GhcPkgExe pkgexe
+      , interpreter = runghc
+      , haddock = haddock
+      , sandboxed = sandboxed
+      , cabalVersion = cabalVersion
+      , globalDB = globaldb
+      , ghcInfo = compilerCache.compilerCacheInfo
+      , globalDump = globalDump
       }
 
 -- | Save compiler information. May throw exceptions!
@@ -386,27 +387,27 @@ saveCompilerPaths ::
   => CompilerPaths
   -> RIO env ()
 saveCompilerPaths cp = withUserStorage $ do
-  deleteBy $ UniqueCompilerInfo $ toFilePath cp.cpCompiler
-  compilerStatus <- liftIO $ getFileStatus $ toFilePath cp.cpCompiler
+  deleteBy $ UniqueCompilerInfo $ toFilePath cp.compiler
+  compilerStatus <- liftIO $ getFileStatus $ toFilePath cp.compiler
   globalDbStatus <- liftIO $
-    getFileStatus $ toFilePath $ cp.cpGlobalDB </> $(mkRelFile "package.cache")
-  let GhcPkgExe pkgexe = cp.cpPkg
+    getFileStatus $ toFilePath $ cp.globalDB </> $(mkRelFile "package.cache")
+  let GhcPkgExe pkgexe = cp.pkg
   insert_ CompilerCache
-    { compilerCacheActualVersion = cp.cpCompilerVersion
-    , compilerCacheGhcPath = toFilePath cp.cpCompiler
+    { compilerCacheActualVersion = cp.compilerVersion
+    , compilerCacheGhcPath = toFilePath cp.compiler
     , compilerCacheGhcSize = sizeToInt64 $ fileSize compilerStatus
     , compilerCacheGhcModified = timeToInt64 $ modificationTime compilerStatus
     , compilerCacheGhcPkgPath = toFilePath pkgexe
-    , compilerCacheRunghcPath = toFilePath cp.cpInterpreter
-    , compilerCacheHaddockPath = toFilePath cp.cpHaddock
-    , compilerCacheCabalVersion = T.pack $ versionString cp.cpCabalVersion
-    , compilerCacheGlobalDb = toFilePath cp.cpGlobalDB
+    , compilerCacheRunghcPath = toFilePath cp.interpreter
+    , compilerCacheHaddockPath = toFilePath cp.haddock
+    , compilerCacheCabalVersion = T.pack $ versionString cp.cabalVersion
+    , compilerCacheGlobalDb = toFilePath cp.globalDB
     , compilerCacheGlobalDbCacheSize = sizeToInt64 $ fileSize globalDbStatus
     , compilerCacheGlobalDbCacheModified =
         timeToInt64 $ modificationTime globalDbStatus
-    , compilerCacheInfo = cp.cpGhcInfo
-    , compilerCacheGlobalDump = tshow cp.cpGlobalDump
-    , compilerCacheArch = T.pack $ Distribution.Text.display cp.cpArch
+    , compilerCacheInfo = cp.ghcInfo
+    , compilerCacheGlobalDump = tshow cp.globalDump
+    , compilerCacheArch = T.pack $ Distribution.Text.display cp.arch
     }
 
 -- | How many upgrade checks have occurred since the given timestamp?
diff --git a/src/Stack/Types/CompilerPaths.hs b/src/Stack/Types/CompilerPaths.hs
diff --git a/src/Stack/Types/EnvConfig.hs b/src/Stack/Types/EnvConfig.hs

Original file line number	Diff line number	Diff line change
`@@ -573,7 +573,7 @@ runGhci`
`573`	`573`	`(map (fromPackageName . (.ghciPkgName)) pkgs :: [StyleDoc])`
`574`	`574`	`)`
`575`	`575`	`compilerExeName <-`
`576`		`- view $ compilerPathsL . to (.cpCompiler) . to toFilePath`
	`576`	`+ view $ compilerPathsL . to (.compiler) . to toFilePath`
`577`	`577`	`let execGhci extras = do`
`578`	`578`	`menv <-`
`579`	`579`	`liftIO $ config.processContextSettings defaultEnvSettings`