Cabal 3.4: copy D.S.Util.CabalRevisions from hackage-cli (#1016)

The module Distribution.Server.Util.CabalRevisions is shared between
hackage-server and hackage-cli and has been updated at the latter first.

Author: andreasabel

src/Distribution/Server/Util/CabalRevisions.hs

@@ -9,7 +9,7 @@
 -- |
 -- Module      :  Distribution.Server.Util.CabalRevisions
 -- Copyright   :  Duncan Coutts et al.
--- License     :  BSD3
+-- SPDX-License-Identifier: BSD-3-Clause
 --
 -- Maintainer  :  [email protected]
 -- Stability   :  provisional
@@ -18,12 +18,13 @@
 -- Validation and helpers for Cabal revision handling
 module Distribution.Server.Util.CabalRevisions
     ( diffCabalRevisions
+    , diffCabalRevisions'
     , Change(..)
     , insertRevisionField
     ) where
 
 -- NB: This module avoids to import any hackage-server modules
-import Distribution.CabalSpecVersion (cabalSpecLatest)
+import Distribution.CabalSpecVersion (CabalSpecVersion(..), cabalSpecLatest, showCabalSpecVersion)
 import Distribution.Types.Dependency
 import Distribution.Types.ExeDependency
 import Distribution.Types.PkgconfigDependency
@@ -43,7 +44,6 @@ import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, r
 import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar)
 import Distribution.PackageDescription.Check
 import Distribution.Parsec (showPWarning, showPError, PWarning (..))
-import Distribution.Simple.LocalBuildInfo (showComponentName)
 import Distribution.Utils.ShortText
 import Text.PrettyPrint as Doc
          ((<+>), colon, text, Doc, hsep, punctuate)
@@ -54,6 +54,7 @@ import Control.Monad.Except  (ExceptT, runExceptT, throwError)
 import Control.Monad.Writer (MonadWriter(..), Writer, runWriter)
 import Data.Foldable (for_)
 import Data.List
+         ((\\), deleteBy, intercalate)
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS8
@@ -72,8 +73,16 @@ import qualified Control.Monad.Fail as Fail
 -- 'String' and performs validations. Returns either a validation
 -- error or a list of detected changes.
 diffCabalRevisions :: BS.ByteString -> BS.ByteString -> Either String [Change]
-diffCabalRevisions oldVersion newRevision = runCheck $
-    checkCabalFileRevision oldVersion newRevision
+diffCabalRevisions = diffCabalRevisions' True
+
+-- | Like 'diffCabalRevisions' but only optionally check @x-revision@ field modifications.
+diffCabalRevisions'
+    :: Bool                    -- ^ check @x-revision@
+    -> BS.ByteString           -- ^ old revision
+    -> BS.ByteString           -- ^ new revision
+    -> Either String [Change]
+diffCabalRevisions' checkXRevision oldVersion newRevision = runCheck $
+    checkCabalFileRevision checkXRevision oldVersion newRevision
 
 newtype CheckM a = CheckM { unCheckM :: ExceptT String (Writer [Change]) a }
     deriving (Functor, Applicative)
@@ -127,15 +136,15 @@ logChange change = CheckM (tell [change])
 
 type Check a = a -> a -> CheckM ()
 
-checkCabalFileRevision :: Check BS.ByteString
-checkCabalFileRevision old new = do
+checkCabalFileRevision :: Bool -> Check BS.ByteString
+checkCabalFileRevision checkXRevision old new = do
     (pkg,  warns)  <- parseCabalFile old
     (pkg', warns') <- parseCabalFile new
 
     let pkgid    = packageId pkg
         filename = prettyShow pkgid ++ ".cabal"
 
-    checkGenericPackageDescription pkg pkg'
+    checkGenericPackageDescription checkXRevision pkg pkg'
     checkParserWarnings filename warns warns'
     checkPackageChecks  pkg   pkg'
 
@@ -170,12 +179,12 @@ checkCabalFileRevision old new = do
             []        -> return ()
             newchecks -> fail $ unlines (map explanation newchecks)
 
-checkGenericPackageDescription :: Check GenericPackageDescription
-checkGenericPackageDescription
-    (GenericPackageDescription descrA flagsA libsA sublibsA flibsA exesA testsA benchsA)
-    (GenericPackageDescription descrB flagsB libsB sublibsB flibsB exesB testsB benchsB) = do
+checkGenericPackageDescription :: Bool -> Check GenericPackageDescription
+checkGenericPackageDescription checkXRevision
+    (GenericPackageDescription descrA _versionA flagsA libsA sublibsA flibsA exesA testsA benchsA)
+    (GenericPackageDescription descrB _versionB flagsB libsB sublibsB flibsB exesB testsB benchsB) = do
 
-    checkPackageDescriptions descrA descrB
+    checkPackageDescriptions checkXRevision descrA descrB
 
     checkList "Cannot add or remove flags" checkFlag flagsA flagsB
 
@@ -213,7 +222,7 @@ checkGenericPackageDescription
     withComponentName' f        condTree  = (f,             condTree)
 
 
-checkFlag :: Check Flag
+checkFlag :: Check PackageFlag
 checkFlag flagOld flagNew = do
     -- This check is applied via 'checkList' and for simplicity we
     -- disallow renaming/reordering flags (even though reordering
@@ -248,10 +257,10 @@ checkFlag flagOld flagNew = do
     changesOk ("description of flag '" ++ fname ++ "'") id
               (flagDescription flagOld) (flagDescription flagNew)
 
-checkPackageDescriptions :: Check PackageDescription
-checkPackageDescriptions
+checkPackageDescriptions :: Bool -> Check PackageDescription
+checkPackageDescriptions checkXRevision
   pdA@(PackageDescription
-     { specVersionRaw  = _specVersionRawA
+     { specVersion     = _specVersionA
      , package         = packageIdA
      , licenseRaw      = licenseRawA
      , licenseFiles    = licenseFilesA
@@ -283,7 +292,7 @@ checkPackageDescriptions
      , extraDocFiles   = extraDocFilesA
      })
   pdB@(PackageDescription
-     { specVersionRaw  = _specVersionRawB
+     { specVersion     = _specVersionB
      , package         = packageIdB
      , licenseRaw      = licenseRawB
      , licenseFiles    = licenseFilesB
@@ -354,14 +363,14 @@ checkPackageDescriptions
   checkSpecVersionRaw pdA pdB
   checkSetupBuildInfo setupBuildInfoA setupBuildInfoB
 
-  checkRevision customFieldsPDA customFieldsPDB
+  when checkXRevision $ checkRevision customFieldsPDA customFieldsPDB
   checkCuration customFieldsPDA customFieldsPDB
 
 checkSpecVersionRaw :: Check PackageDescription
 checkSpecVersionRaw pdA pdB
-  | specVersionA `withinRange` range110To120
-  , specVersionB `withinRange` range110To120
-  = changesOk "cabal-version" prettyShow specVersionA specVersionB
+  | range110To120 specVersionA
+  , range110To120 specVersionB
+  = changesOk "cabal-version" showCabalSpecVersion specVersionA specVersionB
 
   | otherwise
   = checkSame "Cannot change the Cabal spec version"
@@ -372,8 +381,7 @@ checkSpecVersionRaw pdA pdB
 
     -- nothing interesting changed within the  Cabal >=1.10 && <1.21 range
     -- therefore we allow to change the spec version within this interval
-    range110To120 = (orLaterVersion (mkVersion [1,10])) `intersectVersionRanges`
-                    (earlierVersion (mkVersion [1,21]))
+    range110To120 v = CabalSpecV1_10 >= v && v <= CabalSpecV1_20
 
 checkRevision :: Check [(String, String)]
 checkRevision customFieldsA customFieldsB =
@@ -467,7 +475,7 @@ instance IsDependency VersionRange Dependency where
     depKey (Dependency pkgname _ _) = pkgname
     depKeyShow Proxy              = prettyShow''
     depVerRg (Dependency _ vr _)  = vr
-    reconstructDep                = \n vr -> Dependency n vr Set.empty
+    reconstructDep                = \n vr -> Dependency n vr mainLibSet
 
     depInAddWhitelist (Dependency pn _ _) = pn `elem`
     -- Special case: there are some pretty weird broken packages out there, see