Merge pull request #10292 from MercuryTechnologies/rebeccat/keep-temp-files

Expand and unify `--keep-temp-files`

Author: mergify[bot]

Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -34,4 +34,4 @@ md5CheckGenericPackageDescription proxy = md5Check proxy
 
 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
 md5CheckLocalBuildInfo proxy = md5Check proxy
-    0x93b7e8ebb5b9f879fa5fe49b1708b43b
+    0x8fa7b2c8cc611407bfdcb734ecb460a2

Cabal/src/Distribution/Simple/Haddock.hs

@@ -67,12 +67,9 @@ import Distribution.Simple.Program.GHC
 import qualified Distribution.Simple.Program.HcPkg as HcPkg
 import Distribution.Simple.Program.ResponseFile
 import Distribution.Simple.Register
-import Distribution.Simple.Setup.Common
-import Distribution.Simple.Setup.Haddock
-import Distribution.Simple.Setup.Hscolour
+import Distribution.Simple.Setup
 import Distribution.Simple.SetupHooks.Internal
   ( BuildHooks (..)
-  , BuildingWhat (..)
   , noBuildHooks
   )
 import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks
@@ -265,6 +262,7 @@ haddock_setupHooks
         mbWorkDir = flagToMaybe $ haddockWorkingDir flags
         comp = compiler lbi
         platform = hostPlatform lbi
+        config = configFlags lbi
 
         quickJmpFlag = haddockQuickJump flags'
         flags = case haddockTarget of
@@ -282,9 +280,7 @@ haddock_setupHooks
         flag f = fromFlag $ f flags
 
         tmpFileOpts =
-          defaultTempFileOptions
-            { optKeepTempFiles = flag haddockKeepTempFiles
-            }
+          commonSetupTempFileOptions $ configCommonFlags config
         htmlTemplate =
           fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $
             flags
@@ -553,9 +549,11 @@ createHaddockIndex
   -> IO ()
 createHaddockIndex verbosity programDb comp platform mbWorkDir flags = do
   let args = fromHaddockProjectFlags flags
+      tmpFileOpts =
+        commonSetupTempFileOptions $ haddockProjectCommonFlags $ flags
   (haddockProg, _version) <-
     getHaddockProg verbosity programDb comp args (Flag True)
-  runHaddock verbosity mbWorkDir defaultTempFileOptions comp platform haddockProg False args
+  runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg False args
 
 -- ------------------------------------------------------------------------------
 -- Contributions to HaddockArgs (see also Doctest.hs for very similar code).

Cabal/src/Distribution/Simple/Setup.hs

@@ -41,6 +41,7 @@ module Distribution.Simple.Setup
   , globalCommand
   , CommonSetupFlags (..)
   , defaultCommonSetupFlags
+  , commonSetupTempFileOptions
   , ConfigFlags (..)
   , emptyConfigFlags
   , defaultConfigFlags

Cabal/src/Distribution/Simple/Setup/Common.hs

@@ -23,6 +23,7 @@ module Distribution.Simple.Setup.Common
   ( CommonSetupFlags (..)
   , defaultCommonSetupFlags
   , withCommonSetupOptions
+  , commonSetupTempFileOptions
   , CopyDest (..)
   , configureCCompiler
   , configureLinker
@@ -85,6 +86,13 @@ data CommonSetupFlags = CommonSetupFlags
   --
   -- TODO: this one should not be here, it's just that the silly
   -- UserHooks stop us from passing extra info in other ways
+  , setupKeepTempFiles :: Flag Bool
+  -- ^ When this flag is set, temporary files will be kept after building.
+  --
+  -- Note: Keeping temporary files is important functionality for HLS, which
+  -- runs @cabal repl@ with a fake GHC to get CLI arguments. It will need the
+  -- temporary files (including multi unit repl response files) to stay, even
+  -- after the @cabal repl@ command exits.
   }
   deriving (Eq, Show, Read, Generic)
 
@@ -106,6 +114,15 @@ defaultCommonSetupFlags =
     , setupDistPref = NoFlag
     , setupCabalFilePath = NoFlag
     , setupTargets = []
+    , setupKeepTempFiles = NoFlag
+    }
+
+-- | Get `TempFileOptions` that respect the `setupKeepTempFiles` flag.
+commonSetupTempFileOptions :: CommonSetupFlags -> TempFileOptions
+commonSetupTempFileOptions options =
+  TempFileOptions
+    { optKeepTempFiles =
+        fromFlagOrDefault False (setupKeepTempFiles options)
     }
 
 commonSetupOptions :: ShowOrParseArgs -> [OptionField CommonSetupFlags]
@@ -124,6 +141,14 @@ commonSetupOptions showOrParseArgs =
       setupCabalFilePath
       (\v flags -> flags{setupCabalFilePath = v})
       (reqSymbolicPathArgFlag "PATH")
+  , option
+      ""
+      ["keep-temp-files"]
+      ( "Keep temporary files."
+      )
+      setupKeepTempFiles
+      (\keepTempFiles flags -> flags{setupKeepTempFiles = keepTempFiles})
+      trueArg
       -- NB: no --working-dir flag, as that value is populated using the
       -- global flag (see Distribution.Simple.Setup.Global.globalCommand).
   ]

Cabal/src/Distribution/Simple/Setup/Haddock.hs

@@ -111,7 +111,6 @@ data HaddockFlags = HaddockFlags
   , haddockHscolourCss :: Flag FilePath
   , haddockContents :: Flag PathTemplate
   , haddockIndex :: Flag PathTemplate
-  , haddockKeepTempFiles :: Flag Bool
   , haddockBaseUrl :: Flag String
   , haddockResourcesDir :: Flag String
   , haddockOutputDir :: Flag FilePath
@@ -166,7 +165,6 @@ defaultHaddockFlags =
     , haddockQuickJump = Flag False
     , haddockHscolourCss = NoFlag
     , haddockContents = NoFlag
-    , haddockKeepTempFiles = Flag False
     , haddockIndex = NoFlag
     , haddockBaseUrl = NoFlag
     , haddockResourcesDir = NoFlag
@@ -219,13 +217,6 @@ haddockOptions showOrParseArgs =
     (\c f -> f{haddockCommonFlags = c})
     showOrParseArgs
     [ option
-        ""
-        ["keep-temp-files"]
-        "Keep temporary files"
-        haddockKeepTempFiles
-        (\b flags -> flags{haddockKeepTempFiles = b})
-        trueArg
-    , option
         ""
         ["hoogle"]
         "Generate a hoogle database"
@@ -447,9 +438,7 @@ data HaddockProjectFlags = HaddockProjectFlags
   , -- haddockContent is not supported, a fixed value is provided
     -- haddockIndex is not supported, a fixed value is provided
     -- haddockDistPerf is not supported, note: it changes location of the haddocks
-    haddockProjectKeepTempFiles :: Flag Bool
-  , haddockProjectVerbosity :: Flag Verbosity
-  , -- haddockBaseUrl is not supported, a fixed value is provided
+    -- haddockBaseUrl is not supported, a fixed value is provided
     haddockProjectResourcesDir :: Flag String
   , haddockProjectUseUnicode :: Flag Bool
   }
@@ -473,8 +462,6 @@ defaultHaddockProjectFlags =
     , haddockProjectInternal = Flag False
     , haddockProjectCss = NoFlag
     , haddockProjectHscolourCss = NoFlag
-    , haddockProjectKeepTempFiles = Flag False
-    , haddockProjectVerbosity = Flag normal
     , haddockProjectResourcesDir = NoFlag
     , haddockProjectInterfaces = NoFlag
     , haddockProjectUseUnicode = NoFlag
@@ -632,13 +619,6 @@ haddockProjectOptions showOrParseArgs =
         haddockProjectHscolourCss
         (\v flags -> flags{haddockProjectHscolourCss = v})
         (reqArgFlag "PATH")
-    , option
-        ""
-        ["keep-temp-files"]
-        "Keep temporary files"
-        haddockProjectKeepTempFiles
-        (\b flags -> flags{haddockProjectKeepTempFiles = b})
-        trueArg
     , option
         ""
         ["resources-dir"]

cabal-install/src/Distribution/Client/CmdHaddockProject.hs

@@ -391,7 +391,6 @@ haddockProjectAction flags _extraArgs globalFlags = do
             if localStyle
               then Flag (toPathTemplate "../doc-index.html")
               else NoFlag
-        , haddockKeepTempFiles = haddockProjectKeepTempFiles flags
         , haddockResourcesDir = haddockProjectResourcesDir flags
         , haddockUseUnicode = haddockProjectUseUnicode flags
         -- NOTE: we don't pass `haddockOutputDir`. If we do, we'll need to

cabal-install/src/Distribution/Client/CmdRepl.hs

@@ -103,11 +103,11 @@ import Distribution.Simple.Compiler
   )
 import Distribution.Simple.Setup
   ( ReplOptions (..)
+  , commonSetupTempFileOptions
   , setupVerbosity
   )
 import Distribution.Simple.Utils
-  ( TempFileOptions (..)
-  , debugNoWrap
+  ( debugNoWrap
   , dieWithException
   , withTempDirectoryEx
   , wrapText
@@ -411,7 +411,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
     -- Multi Repl implemention see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for
     -- a high-level overview about how everything fits together.
     if Set.size (distinctTargetComponents targets) > 1
-      then withTempDirectoryEx verbosity (TempFileOptions keepTempFiles) distDir "multi-out" $ \dir' -> do
+      then withTempDirectoryEx verbosity tempFileOptions distDir "multi-out" $ \dir' -> do
         -- multi target repl
         dir <- makeAbsolute dir'
         -- Modify the replOptions so that the ./Setup repl command will write options
@@ -507,7 +507,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
         go m _ = m
 
     verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags)
-    keepTempFiles = fromFlagOrDefault False replKeepTempFiles
+    tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags
 
     validatedTargets ctx compiler elaboratedPlan targetSelectors = do
       let multi_repl_enabled = multiReplDecision ctx compiler r

cabal-install/src/Distribution/Client/Config.hs

@@ -470,6 +470,7 @@ instance Semigroup SavedConfig where
           , setupCabalFilePath = combine setupCabalFilePath
           , setupVerbosity = combine setupVerbosity
           , setupTargets = lastNonEmpty setupTargets
+          , setupKeepTempFiles = combine setupKeepTempFiles
           }
         where
           lastNonEmpty = lastNonEmpty' which
@@ -630,7 +631,6 @@ instance Semigroup SavedConfig where
           , haddockQuickJump = combine haddockQuickJump
           , haddockHscolourCss = combine haddockHscolourCss
           , haddockContents = combine haddockContents
-          , haddockKeepTempFiles = combine haddockKeepTempFiles
           , haddockIndex = combine haddockIndex
           , haddockBaseUrl = combine haddockBaseUrl
           , haddockResourcesDir = combine haddockResourcesDir

cabal-install/src/Distribution/Client/ParseUtils.hs

@@ -17,6 +17,8 @@ module Distribution.Client.ParseUtils
     FieldDescr (..)
   , liftField
   , liftFields
+  , addFields
+  , aliasField
   , filterFields
   , mapFieldNames
   , commandOptionToField
@@ -103,9 +105,15 @@ liftFields get set = map (liftField get set)
 
 -- | Given a collection of field descriptions, keep only a given list of them,
 -- identified by name.
+--
+-- TODO: This makes it easy to footgun by providing a non-existent field name.
 filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]
 filterFields includeFields = filter ((`elem` includeFields) . fieldName)
 
+-- | Given a collection of field descriptions, get a field with a given name.
+getField :: String -> [FieldDescr a] -> Maybe (FieldDescr a)
+getField name = find ((== name) . fieldName)
+
 -- | Apply a name mangling function to the field names of all the field
 -- descriptions. The typical use case is to apply some prefix.
 mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]
@@ -120,6 +128,30 @@ commandOptionToField = viewAsFieldDescr
 commandOptionsToFields :: [OptionField a] -> [FieldDescr a]
 commandOptionsToFields = map viewAsFieldDescr
 
+-- | Add fields to a field list.
+addFields
+  :: [FieldDescr a]
+  -> ([FieldDescr a] -> [FieldDescr a])
+addFields = (++)
+
+-- | Add a new field which is identical to an existing field but with a
+-- different name.
+aliasField
+  :: String
+  -- ^ The existing field name.
+  -> String
+  -- ^ The new field name.
+  -> [FieldDescr a]
+  -> [FieldDescr a]
+aliasField oldName newName fields =
+  let fieldToRename = getField oldName fields
+   in case fieldToRename of
+        -- TODO: Should this throw?
+        Nothing -> fields
+        Just fieldToRename' ->
+          let newField = fieldToRename'{fieldName = newName}
+           in newField : fields
+
 ------------------------------------------
 -- SectionDescr definition and utilities
 --

cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs

@@ -173,7 +173,7 @@ buildAndRegisterUnpackedPackage
   verbosity
   distDirLayout@DistDirLayout{distTempDirectory}
   maybe_semaphore
-  buildTimeSettings@BuildTimeSettings{buildSettingNumJobs}
+  buildTimeSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingKeepTempFiles}
   registerLock
   cacheLock
   pkgshared@ElaboratedSharedConfig
@@ -276,7 +276,7 @@ buildAndRegisterUnpackedPackage
         | otherwise = return ()
 
       mbWorkDir = useWorkingDir scriptOptions
-      commonFlags = setupHsCommonFlags verbosity mbWorkDir builddir
+      commonFlags = setupHsCommonFlags verbosity mbWorkDir builddir buildSettingKeepTempFiles
 
       configureCommand = Cabal.configureCommand defaultProgramDb
       configureFlags v =