Allow use of Hpack's --force to be specified

ChangeLog.md

@@ -1,8 +1,12 @@
 # Changelog for pantry
 
-## v0.9.3.3
+## v0.10.0
 
 * Name of tar file of local cache of package index is not hard coded.
+* `withPantryConfig'` now requires the specification of whether or not Hpack's
+  `--force` flag is to be applied.
+* Expose `hpackForceL`, a lens to view or modify the `Force` (Hpack) of a
+  `PantryConfig`.
 
 ## v0.9.3.2
 

int/Pantry/HPack.hs

@@ -51,10 +51,13 @@ hpack pkgDir = do
   whenM (doesFileExist hpackFile) $ do
     logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile)
     he <- view $ pantryConfigL.to pcHpackExecutable
+    hpackForce <- view $ pantryConfigL.to pcHpackForce
     case he of
       HpackBundled -> do
         r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $
-          Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions
+          Hpack.setTarget
+            (toFilePath hpackFile)
+            Hpack.defaultOptions { Hpack.optionsForce = hpackForce }
         forM_ (Hpack.resultWarnings r) (logWarn . fromString)
         let cabalFile = fromString . Hpack.resultCabalFile $ r
         case Hpack.resultStatus r of
@@ -82,6 +85,8 @@ hpack pkgDir = do
             <> fromString (toFilePath (filename hpackFile))
             <> " file instead of the Cabal file,\n"
             <> "then please delete the Cabal file."
-      HpackCommand command ->
-        withWorkingDir (toFilePath pkgDir) $
-        proc command [] runProcess_
+      HpackCommand command -> do
+        let hpackArgs = case hpackForce of
+              Hpack.Force -> ["--force"]
+              Hpack.NoForce -> []
+        withWorkingDir (toFilePath pkgDir) $ proc command hpackArgs runProcess_

int/Pantry/Types.hs

@@ -171,6 +171,7 @@ import           Distribution.Types.PackageName
                    ( PackageName, mkPackageName, unPackageName )
 import           Distribution.Types.Version ( Version, mkVersion, nullVersion )
 import           Distribution.Types.VersionRange ( VersionRange )
+import qualified Hpack
 import qualified Hpack.Config as Hpack
 import           Network.HTTP.Client ( parseRequest )
 import           Network.HTTP.Types ( Status, statusCode )
@@ -285,6 +286,7 @@ data Storage = Storage
 data PantryConfig = PantryConfig
   { pcPackageIndex :: !PackageIndexConfig
   , pcHpackExecutable :: !HpackExecutable
+  , pcHpackForce :: !Hpack.Force
   , pcRootDir :: !(Path Abs Dir)
   , pcStorage :: !Storage
   , pcUpdateRef :: !(MVar Bool)

package.yaml

@@ -1,5 +1,5 @@
 name: pantry
-version: 0.9.3.3
+version: 0.10.0
 synopsis: Content addressable Haskell package management
 description: Please see the README on GitHub at <https://github.com/commercialhaskell/pantry#readme>
 category: Development

src/Pantry.hs

@@ -33,6 +33,7 @@ module Pantry
   , runPantryAppClean
   , runPantryAppWith
   , hpackExecutableL
+  , hpackForceL
 
     -- * Types
 
@@ -47,6 +48,9 @@ module Pantry
   , FlagName
   , PackageIdentifier (..)
 
+    -- ** Hpack types
+  , Hpack.Force (..)
+
     -- ** Files
   , FileSize (..)
   , RelFilePath (..)
@@ -324,7 +328,8 @@ formatYamlParseError file e =
   <> displayException e
 
 -- | Create a new 'PantryConfig' with the given settings. For a version where
--- the use of Casa (content-addressable storage archive) is optional, see
+-- Hpack's approach to overwriting Cabal files is configurable and the use of
+-- Casa (content-addressable storage archive) is optional, see
 -- 'withPantryConfig''.
 --
 -- For something easier to use in simple cases, see 'runPantryApp'.
@@ -353,7 +358,7 @@ withPantryConfig ::
      -- ^ What to do with the config
   -> RIO env a
 withPantryConfig root pic he count pullURL maxPerRequest =
-  withPantryConfig' root pic he count (Just (pullURL, maxPerRequest))
+  withPantryConfig' root pic he Hpack.NoForce count (Just (pullURL, maxPerRequest))
 
 -- | Create a new 'PantryConfig' with the given settings.
 --
@@ -363,25 +368,30 @@ withPantryConfig root pic he count pullURL maxPerRequest =
 withPantryConfig'
   :: HasLogFunc env
   => Path Abs Dir
-  -- ^ pantry root directory, where the SQLite database and Hackage
-  -- downloads are kept.
+     -- ^ pantry root directory, where the SQLite database and Hackage
+     -- downloads are kept.
   -> PackageIndexConfig
-  -- ^ Package index configuration. You probably want
-  -- 'defaultPackageIndexConfig'.
+     -- ^ Package index configuration. You probably want
+     -- 'defaultPackageIndexConfig'.
   -> HpackExecutable
-  -- ^ When converting an hpack @package.yaml@ file to a cabal file,
-  -- what version of hpack should we use?
+     -- ^ When converting an hpack @package.yaml@ file to a cabal file,
+     -- what version of hpack should we use?
+  -> Hpack.Force
+     -- ^ Should Hpack force the overwriting of a Cabal file that has been
+     -- modified manually?
+     --
+     -- @since 0.10.0
   -> Int
-  -- ^ Maximum connection count
+     -- ^ Maximum connection count
   -> Maybe (CasaRepoPrefix, Int)
-  -- ^ Optionally, the Casa pull URL e.g. @https://casa.fpcomplete.com@ and the
-  -- maximum number of Casa keys to pull per request.
+     -- ^ Optionally, the Casa pull URL e.g. @https://casa.fpcomplete.com@ and
+     -- the maximum number of Casa keys to pull per request.
   -> (SnapName -> RawSnapshotLocation)
-  -- ^ The location of snapshot synonyms
+     -- ^ The location of snapshot synonyms
   -> (PantryConfig -> RIO env a)
-  -- ^ What to do with the config
+     -- ^ What to do with the config
   -> RIO env a
-withPantryConfig' root pic he count mCasaConfig snapLoc inner = do
+withPantryConfig' root pic he hpackForce count mCasaConfig snapLoc inner = do
   env <- ask
   pantryRelFile <- parseRelFile "pantry.sqlite3"
   -- Silence persistent's logging output, which is really noisy
@@ -392,6 +402,7 @@ withPantryConfig' root pic he count mCasaConfig snapLoc inner = do
     inner PantryConfig
       { pcPackageIndex = pic
       , pcHpackExecutable = he
+      , pcHpackForce = hpackForce
       , pcRootDir = root
       , pcStorage = storage
       , pcUpdateRef = ur
@@ -870,17 +881,19 @@ hpack progName pkgDir = do
   when exists $ do
     logDebug $ "Running Hpack on " <> fromString (toFilePath hpackFile)
     he <- view $ pantryConfigL.to pcHpackExecutable
+    hpackForce <- view $ pantryConfigL.to pcHpackForce
     case he of
       HpackBundled ->
-                  liftIO
-                     ( Hpack.hpackResultWithError
-                     $ mHpackProgName
-                     $ Hpack.setDecode decodeYaml
-                     $ Hpack.setFormatYamlParseError formatYamlParseError
-                     $ Hpack.setTarget
-                         (toFilePath hpackFile) Hpack.defaultOptions
-                     )
-                   >>= \ case
+        liftIO
+           ( Hpack.hpackResultWithError
+           $ mHpackProgName
+           $ Hpack.setDecode decodeYaml
+           $ Hpack.setFormatYamlParseError formatYamlParseError
+           $ Hpack.setTarget
+               (toFilePath hpackFile)
+               Hpack.defaultOptions { Hpack.optionsForce = hpackForce }
+           )
+         >>= \ case
         Left err -> throwIO (HpackLibraryException hpackFile $ formatHpackError (fromMaybe "hpack" progName) err)
         Right r -> do
           forM_ (Hpack.resultWarnings r) (logWarn . fromString)
@@ -909,11 +922,15 @@ hpack progName pkgDir = do
               <> fromString (toFilePath (filename hpackFile))
               <> " file instead of the Cabal file,\n"
               <> "then please delete the Cabal file."
-      HpackCommand command -> catchAny
-        ( withWorkingDir (toFilePath pkgDir) $
-          proc command [] runProcess_
-        )
-        ( throwIO . HpackExeException command pkgDir)
+      HpackCommand command -> do
+        let hpackArgs = case hpackForce of
+              Hpack.Force -> ["--force"]
+              Hpack.NoForce -> []
+        catchAny
+          ( withWorkingDir (toFilePath pkgDir) $
+            proc command hpackArgs runProcess_
+          )
+          ( throwIO . HpackExeException command pkgDir)
 
 -- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'.
 --
@@ -1871,13 +1888,22 @@ data PantryApp = PantryApp
 simpleAppL :: Lens' PantryApp SimpleApp
 simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y })
 
--- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig'
+-- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig'.
 --
 -- @since 0.1.0.0
 hpackExecutableL :: Lens' PantryConfig HpackExecutable
 hpackExecutableL k pconfig =
   fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig))
 
+-- | Lens to view or modify the 'Hpack.Force' of a 'PantryConfig'.
+--
+-- @since 0.10.0
+hpackForceL :: Lens' PantryConfig Hpack.Force
+hpackForceL k pconfig =
+  fmap
+    (\hpackForce -> pconfig { pcHpackForce = hpackForce })
+    (k (pcHpackForce pconfig))
+
 instance HasLogFunc PantryApp where
   logFuncL = simpleAppL.logFuncL
 
@@ -1922,6 +1948,7 @@ runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp
     root
     defaultPackageIndexConfig
     HpackBundled
+    Hpack.NoForce
     maxConnCount
     (Just (casaRepoPrefix, casaMaxPerRequest))
     defaultSnapshotLocation
@@ -1949,6 +1976,7 @@ runPantryAppClean f =
       root
       defaultPackageIndexConfig
       HpackBundled
+      Hpack.NoForce
       8
       (Just (defaultCasaRepoPrefix, defaultCasaMaxPerRequest))
       defaultSnapshotLocation