From 78d89a91570b4c08146de3b787010e5f6d46daa4 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Fri, 22 Dec 2023 14:13:04 +0100
Subject: [PATCH] Fix Monoid instances for ForeignLib & Executable

The Semigroup and Monoid instances for ForeignLib were completely
broken: for the `foreignLibVersionInfo` and `foreignLibVersionInfo`,
we essentially had the following:

  mempty :: Maybe XYZ
  mempty = Nothing

  (<>) :: Maybe XYZ -> Maybe XYZ -> Maybe XYZ
  _ <> b = b

which is obviously not a valid Monoid, as `Just x <> Nothing = Nothing`,
violating the identity law.

The Semigroup instance for Executable was also deeply suspicious, as
it combined the module paths, which makes no sense. Now we instead error
if the two module paths are different (and both nonempty).
---
 .../src/Distribution/Types/Executable.hs      |  2 +-
 .../src/Distribution/Types/ForeignLib.hs      |  8 ++++---
 .../Distribution/Types/UnqualComponentName.hs | 22 +++++++++----------
 3 files changed, 17 insertions(+), 15 deletions(-)

diff --git a/Cabal-syntax/src/Distribution/Types/Executable.hs b/Cabal-syntax/src/Distribution/Types/Executable.hs
index 5362d7122b0..bf70702f41c 100644
--- a/Cabal-syntax/src/Distribution/Types/Executable.hs
+++ b/Cabal-syntax/src/Distribution/Types/Executable.hs
@@ -41,7 +41,7 @@ instance Semigroup Executable where
   a <> b =
     Executable
       { exeName = combineNames a b exeName "executable"
-      , modulePath = combine modulePath
+      , modulePath = combineNames a b modulePath "modulePath"
       , exeScope = combine exeScope
       , buildInfo = combine buildInfo
       }
diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs
index 7e31a6cc7c0..19336af203d 100644
--- a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs
+++ b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs
@@ -28,6 +28,7 @@ import Distribution.Types.ForeignLibType
 import Distribution.Types.UnqualComponentName
 import Distribution.Version
 
+import Data.Monoid
 import qualified Distribution.Compat.CharParsing as P
 import qualified Text.PrettyPrint as Disp
 import qualified Text.Read as Read
@@ -144,13 +145,14 @@ instance Semigroup ForeignLib where
       , foreignLibType = combine foreignLibType
       , foreignLibOptions = combine foreignLibOptions
       , foreignLibBuildInfo = combine foreignLibBuildInfo
-      , foreignLibVersionInfo = combine'' foreignLibVersionInfo
-      , foreignLibVersionLinux = combine'' foreignLibVersionLinux
+      , foreignLibVersionInfo = chooseLast foreignLibVersionInfo
+      , foreignLibVersionLinux = chooseLast foreignLibVersionLinux
       , foreignLibModDefFile = combine foreignLibModDefFile
       }
     where
       combine field = field a `mappend` field b
-      combine'' field = field b
+      -- chooseLast: the second field overrides the first, unless it is Nothing
+      chooseLast field = getLast (Last (field a) <> Last (field b))
 
 instance Monoid ForeignLib where
   mempty =
diff --git a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs
index 93feff2fbbe..3879cdd2169 100644
--- a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs
+++ b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs
@@ -14,7 +14,6 @@ module Distribution.Types.UnqualComponentName
 
 import Distribution.Compat.Prelude
 import Distribution.Utils.ShortText
-import Prelude as P (null)
 
 import Distribution.Parsec
 import Distribution.Pretty
@@ -111,28 +110,29 @@ unqualComponentNameToPackageName = mkPackageNameST . unUnqualComponentNameST
 -- (partial function).
 -- Useful in 'Semigroup' and similar instances.
 combineNames
-  :: a
+  :: (Monoid b, Eq b, Show b)
+  => a
   -> a
-  -> (a -> UnqualComponentName)
+  -> (a -> b)
   -> String
-  -> UnqualComponentName
+  -> b
 combineNames a b tacc tt
   -- One empty or the same.
-  | P.null unb
-      || una == unb =
+  | nb == mempty
+      || na == nb =
       na
-  | P.null una = nb
+  | na == mempty =
+      nb
   -- Both non-empty, different.
   | otherwise =
       error $
         "Ambiguous values for "
           ++ tt
           ++ " field: '"
-          ++ una
+          ++ show na
           ++ "' and '"
-          ++ unb
+          ++ show nb
           ++ "'"
   where
     (na, nb) = (tacc a, tacc b)
-    una = unUnqualComponentName na
-    unb = unUnqualComponentName nb
+{-# INLINEABLE combineNames #-}