Merge branch 'janus/fix-dependency-branching'

Author: ysangkok

src/Distribution/Server/Features/UserNotify.hs

@@ -494,7 +494,14 @@ dependencyReleaseEmails userSetIdForPackage index (ReverseIndex revs nodemap dep
           (userId, Just NotifyPref{..}) <- zip ids mPrefs
           guard $ not notifyOptOut
           guard notifyDependencyForMaintained
-          Just depList <- [mDepList]
+
+          Just depListWithCollisions <- [mDepList]
+          -- Remove collisions on the same PackageName, amassed e.g. across
+          -- multiple conditional branches. The branches could be from either
+          -- side of an 'if' block conditioned on a flag. If either of them
+          -- permits the newly released version, avoid sending the notification.
+          let depList = unionSamePackageName depListWithCollisions
+
           case notifyDependencyTriggerBounds of
             NewIncompatibility -> do
               let allNewUploadPkgInfos = PackageIndex.lookupPackageName index (pkgName pkgId)
@@ -532,6 +539,23 @@ dependencyReleaseEmails userSetIdForPackage index (ReverseIndex revs nodemap dep
           | otherwise = True
         newestVersion = pkgVersion pkgId
 
+-- | Boolean OR on ranges across dependencies on the same PackageName
+unionSamePackageName :: [Dependency] -> [Dependency]
+unionSamePackageName collisions =
+  let
+    maps = [Map.singleton depName dep | dep@(Dependency depName _ _) <- collisions]
+    disjunct :: Dependency -> Dependency -> Dependency
+    disjunct
+      (Dependency fName fRange fLibraries)
+      (Dependency _     gRange gLibraries) =
+        mkDependency
+          fName
+          (unionVersionRanges fRange gRange)
+          (fLibraries <> gLibraries)
+    disjunctions = Map.unionsWith disjunct maps
+  in
+    Map.elems disjunctions
+
 pkgInfoToPkgId :: PkgInfo -> PackageIdentifier
 pkgInfoToPkgId pkgInfo =
   PackageIdentifier (packageName pkgInfo) (packageVersion pkgInfo)

tests/RevDepCommon.hs

@@ -31,6 +31,13 @@ packToPkgInfo Package {pName, pVersion, pDeps} =
 
 mkPackage :: PackageName -> [Int] -> [BSL.ByteString] -> PkgInfo
 mkPackage name intVersion depends =
+  mkPackageWithCabalFileSuffix name intVersion $
+    if depends /= []
+      then "library\n  build-depends: " <> BSL.intercalate "," depends
+      else ""
+
+mkPackageWithCabalFileSuffix :: PackageName -> [Int] -> BSL.ByteString -> PkgInfo
+mkPackageWithCabalFileSuffix name intVersion cabalFileSuffix =
   let
     version = mkVersion intVersion
     -- e.g. "2.3" for [2,3]
@@ -41,7 +48,7 @@ mkPackage name intVersion depends =
 \name: " <> BSL.fromStrict (Char8.pack $ unPackageName name) <> "\n\
 \version: " <> dotVersion <> "\n"
     cabalFile :: CabalFileText
-    cabalFile = CabalFileText $ cabalFilePrefix <> if depends /= [] then "library\n  build-depends: " <> BSL.intercalate "," depends else ""
+    cabalFile = CabalFileText $ cabalFilePrefix <> cabalFileSuffix
   in
   PkgInfo
   (PackageIdentifier name version)

tests/ReverseDependenciesTest.hs

@@ -31,7 +31,7 @@ import qualified Hedgehog.Range as Range
 import qualified Hedgehog.Gen as Gen
 import           Hedgehog ((===), Group(Group), MonadGen, Property, PropertyT, checkSequential, forAll, property)
 
-import RevDepCommon (Package(..), TestPackage(..), mkPackage, packToPkgInfo)
+import RevDepCommon (Package(..), TestPackage(..), mkPackage, mkPackageWithCabalFileSuffix, packToPkgInfo)
 
 mtlBeelineLens :: [PkgInfo]
 mtlBeelineLens =
@@ -214,6 +214,22 @@ allTests = testGroup "ReverseDependenciesTest"
         "dependencyReleaseEmails(trigger=BoundsOutOfRange) shouldn't generate a notification when the new package is for an old release series"
         mempty
         (runWithPref (pref BoundsOutOfRange) (PackageIndex.fromList newVersionOfOldBase) base4_14_1)
+      assertEqual
+        "dependencyReleaseEmails(trigger=BoundsOutOfRange) should only generate a notification when the new version is forbidden across all branches"
+        mempty -- The two branches below should get OR'd and therefore the dependency is not out of bounds
+        (runWithPref
+          (pref BoundsOutOfRange)
+          (PackageIndex.fromList
+            [ mkPackage "base" [4,14] []
+            , mkPackage "base" [4,15] []
+            , mkPackageWithCabalFileSuffix "mtl" [2,3]
+                "library\n\
+                \  if arch(arm)\n\
+                \    build-depends: base >= 4.14 && < 4.15\n\
+                \  else\n\
+                \    build-depends: base >= 4.15 && < 4.16"
+            ])
+          base4_15)
   , testCase "hedgehogTests" $ do
       res <- hedgehogTests
       assertEqual "hedgehog test pass" True res