From 84e8f16d38c2f45cc417acfc55c3da757a829e6b Mon Sep 17 00:00:00 2001
From: Laurent Rene de Cotret <l.rdc@socivolta.com>
Date: Sun, 25 Aug 2024 15:06:56 -0400
Subject: [PATCH] Address warnings related to non-canonical definition for
 mappend

---
 beam-migrate/Database/Beam/Haskell/Syntax.hs  | 46 ++++++++-----------
 beam-migrate/Database/Beam/Migrate/Actions.hs | 26 +++++------
 beam-migrate/Database/Beam/Migrate/Backend.hs |  5 +-
 .../Database/Beam/Migrate/SQL/Builder.hs      |  9 ++--
 .../Database/Beam/Migrate/Serialization.hs    | 12 ++---
 beam-migrate/Database/Beam/Migrate/Types.hs   |  8 ++--
 .../Database/Beam/Postgres/Syntax.hs          |  5 +-
 beam-sqlite/Database/Beam/Sqlite/Syntax.hs    |  5 +-
 8 files changed, 50 insertions(+), 66 deletions(-)

diff --git a/beam-migrate/Database/Beam/Haskell/Syntax.hs b/beam-migrate/Database/Beam/Haskell/Syntax.hs
index 1615d7fee..d83f8f45d 100644
--- a/beam-migrate/Database/Beam/Haskell/Syntax.hs
+++ b/beam-migrate/Database/Beam/Haskell/Syntax.hs
@@ -54,13 +54,12 @@ data HsImport = HsImportAll | HsImportSome (S.Set (Hs.ImportSpec ()))
   deriving (Show, Eq, Generic)
 instance Hashable HsImport
 instance Semigroup HsImport where
-  (<>) = mappend
+  HsImportAll <> _ = HsImportAll
+  _ <> HsImportAll = HsImportAll
+  (HsImportSome a) <> (HsImportSome b) =
+    HsImportSome (a <> b)
 instance Monoid HsImport where
   mempty = HsImportSome mempty
-  mappend HsImportAll _ = HsImportAll
-  mappend _ HsImportAll = HsImportAll
-  mappend (HsImportSome a) (HsImportSome b) =
-    HsImportSome (a <> b)
 
 importSome :: T.Text -> [ Hs.ImportSpec () ] -> HsImports
 importSome modNm names = HsImports (M.singleton (Hs.ModuleName () (T.unpack modNm))
@@ -77,11 +76,10 @@ newtype HsImports = HsImports (M.Map (Hs.ModuleName ()) HsImport)
 instance Hashable HsImports where
   hashWithSalt s (HsImports a) = hashWithSalt s (M.assocs a)
 instance Semigroup HsImports where
-  (<>) = mappend
+  (HsImports a) <> (HsImports b) =
+      HsImports (M.unionWith mappend a b)
 instance Monoid HsImports where
   mempty = HsImports mempty
-  mappend (HsImports a) (HsImports b) =
-    HsImports (M.unionWith mappend a b)
 
 data HsDataType
   = HsDataType
@@ -140,11 +138,10 @@ data HsAction
   }
 
 instance Semigroup HsAction where
-  (<>) = mappend
+  (<>) (HsAction ma ea) (HsAction mb eb) =
+    HsAction (ma <> mb) (ea <> eb)
 instance Monoid HsAction where
   mempty = HsAction [] []
-  mappend (HsAction ma ea) (HsAction mb eb) =
-    HsAction (ma <> mb) (ea <> eb)
 
 newtype HsBackendConstraint = HsBackendConstraint { buildHsBackendConstraint :: Hs.Type () -> Hs.Asst () }
 
@@ -154,18 +151,17 @@ data HsBeamBackend f
   | HsBeamBackendNone
 
 instance Semigroup (HsBeamBackend f) where
-  (<>) = mappend
+  (<>) (HsBeamBackendSingle aTy aExp) (HsBeamBackendSingle bTy _)
+      | aTy == bTy = HsBeamBackendSingle aTy aExp
+      | otherwise = HsBeamBackendNone
+  (<>) a@HsBeamBackendSingle {} _ = a
+  (<>) _ b@HsBeamBackendSingle {} = b
+  (<>) HsBeamBackendNone _ = HsBeamBackendNone
+  (<>) _ HsBeamBackendNone = HsBeamBackendNone
+  (<>) (HsBeamBackendConstrained a) (HsBeamBackendConstrained b) =
+    HsBeamBackendConstrained (a <> b)
 instance Monoid (HsBeamBackend f) where
   mempty = HsBeamBackendConstrained []
-  mappend (HsBeamBackendSingle aTy aExp) (HsBeamBackendSingle bTy _)
-    | aTy == bTy = HsBeamBackendSingle aTy aExp
-    | otherwise = HsBeamBackendNone
-  mappend a@HsBeamBackendSingle {} _ = a
-  mappend _ b@HsBeamBackendSingle {} = b
-  mappend HsBeamBackendNone _ = HsBeamBackendNone
-  mappend _ HsBeamBackendNone = HsBeamBackendNone
-  mappend (HsBeamBackendConstrained a) (HsBeamBackendConstrained b) =
-    HsBeamBackendConstrained (a <> b)
 
 data HsEntity
     = HsEntity
@@ -189,12 +185,11 @@ data HsTableConstraintDecls
     }
 
 instance Semigroup HsTableConstraintDecls where
-  (<>) = mappend
+  (<>) (HsTableConstraintDecls ai ad) (HsTableConstraintDecls bi bd) =
+    HsTableConstraintDecls (ai <> bi) (ad <> bd)
 
 instance Monoid HsTableConstraintDecls where
   mempty = HsTableConstraintDecls [] []
-  mappend (HsTableConstraintDecls ai ad) (HsTableConstraintDecls bi bd) =
-    HsTableConstraintDecls (ai <> bi) (ad <> bd)
 
 data HsModule
   = HsModule
@@ -415,10 +410,9 @@ data HsNone = HsNone deriving (Show, Eq, Ord, Generic)
 instance Hashable HsNone
 
 instance Semigroup HsNone where
-  (<>) = mappend
+  (<>) _ _ = HsNone
 instance Monoid HsNone where
   mempty = HsNone
-  mappend _ _ = HsNone
 
 data HsMigrateBackend = HsMigrateBackend
 
diff --git a/beam-migrate/Database/Beam/Migrate/Actions.hs b/beam-migrate/Database/Beam/Migrate/Actions.hs
index 13d900279..c5d31f3dc 100644
--- a/beam-migrate/Database/Beam/Migrate/Actions.hs
+++ b/beam-migrate/Database/Beam/Migrate/Actions.hs
@@ -194,7 +194,14 @@ data PotentialAction be
   }
 
 instance Semigroup (PotentialAction be) where
-  (<>) = mappend
+  a <> b =
+      PotentialAction (actionPreConditions a <> actionPreConditions b)
+                      (actionPostConditions a <> actionPostConditions b)
+                      (actionCommands a <> actionCommands b)
+                      (if T.null (actionEnglish a) then actionEnglish b
+                        else if T.null (actionEnglish b) then actionEnglish a
+                            else actionEnglish a <> "; " <> actionEnglish b)
+                      (actionScore a + actionScore b)
 
 -- | 'PotentialAction's can represent edges or paths. Monadically combining two
 -- 'PotentialAction's results in the path between the source of the first and
@@ -202,14 +209,6 @@ instance Semigroup (PotentialAction be) where
 -- nothing (i.e., the edge going back to the same database state)
 instance Monoid (PotentialAction be) where
   mempty = PotentialAction mempty mempty mempty  "" 0
-  mappend a b =
-    PotentialAction (actionPreConditions a <> actionPreConditions b)
-                    (actionPostConditions a <> actionPostConditions b)
-                    (actionCommands a <> actionCommands b)
-                    (if T.null (actionEnglish a) then actionEnglish b
-                      else if T.null (actionEnglish b) then actionEnglish a
-                           else actionEnglish a <> "; " <> actionEnglish b)
-                    (actionScore a + actionScore b)
 
 -- | See 'ActionProvider'
 type ActionProviderFn be =
@@ -254,11 +253,7 @@ newtype ActionProvider be
   = ActionProvider { getPotentialActions :: ActionProviderFn be }
 
 instance Semigroup (ActionProvider be) where
-  (<>) = mappend
-
-instance Monoid (ActionProvider be) where
-  mempty = ActionProvider (\_ _ -> [])
-  mappend (ActionProvider a) (ActionProvider b) =
+  (<>) (ActionProvider a) (ActionProvider b) =
     ActionProvider $ \pre post ->
     let aRes = a pre post
         bRes = b pre post
@@ -267,6 +262,9 @@ instance Monoid (ActionProvider be) where
        withStrategy (rparWith (parList rseq)) bRes `seq`
        aRes ++ bRes
 
+instance Monoid (ActionProvider be) where
+  mempty = ActionProvider (\_ _ -> [])
+
 createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int
 createTableWeight = 500
 dropTableWeight = 100
diff --git a/beam-migrate/Database/Beam/Migrate/Backend.hs b/beam-migrate/Database/Beam/Migrate/Backend.hs
index 64696a733..0cb8086b8 100644
--- a/beam-migrate/Database/Beam/Migrate/Backend.hs
+++ b/beam-migrate/Database/Beam/Migrate/Backend.hs
@@ -113,13 +113,12 @@ newtype HaskellPredicateConverter
   = HaskellPredicateConverter (SomeDatabasePredicate -> Maybe SomeDatabasePredicate)
 
 instance Semigroup HaskellPredicateConverter where
-  (<>) = mappend
+  (HaskellPredicateConverter a) <> (HaskellPredicateConverter b) =
+    HaskellPredicateConverter $ \r -> a r <|> b r
 
 -- | 'HaskellPredicateConverter's can be combined monoidally.
 instance Monoid HaskellPredicateConverter where
   mempty = HaskellPredicateConverter $ \_ -> Nothing
-  mappend (HaskellPredicateConverter a) (HaskellPredicateConverter b) =
-    HaskellPredicateConverter $ \r -> a r <|> b r
 
 -- | Converters for the 'TableExistsPredicate', 'TableHasPrimaryKey', and
 -- 'TableHasColumn' (when supplied with a function to convert a backend data
diff --git a/beam-migrate/Database/Beam/Migrate/SQL/Builder.hs b/beam-migrate/Database/Beam/Migrate/SQL/Builder.hs
index ec9ebe982..12bcf2c65 100644
--- a/beam-migrate/Database/Beam/Migrate/SQL/Builder.hs
+++ b/beam-migrate/Database/Beam/Migrate/SQL/Builder.hs
@@ -123,15 +123,14 @@ data SqlConstraintAttributesBuilder
   deriving (Show, Eq)
 
 instance Semigroup SqlConstraintAttributesBuilder where
-  (<>) = mappend
-
-instance Monoid SqlConstraintAttributesBuilder where
-  mempty = SqlConstraintAttributesBuilder Nothing Nothing
-  mappend a b =
+  a <> b =
     SqlConstraintAttributesBuilder
       (_sqlConstraintAttributeTiming b <|> _sqlConstraintAttributeTiming a)
       (_sqlConstraintAttributeDeferrable b <|> _sqlConstraintAttributeDeferrable a)
 
+instance Monoid SqlConstraintAttributesBuilder where
+  mempty = SqlConstraintAttributesBuilder Nothing Nothing
+
 -- | Convert a 'SqlConstraintAttributesBuilder' to its @SQL92@ representation in
 -- the returned 'ByteString' 'Builder'.
 fromSqlConstraintAttributes :: SqlConstraintAttributesBuilder -> Builder
diff --git a/beam-migrate/Database/Beam/Migrate/Serialization.hs b/beam-migrate/Database/Beam/Migrate/Serialization.hs
index e40829100..54ef3843d 100644
--- a/beam-migrate/Database/Beam/Migrate/Serialization.hs
+++ b/beam-migrate/Database/Beam/Migrate/Serialization.hs
@@ -246,21 +246,19 @@ newtype BeamDeserializers be
   }
 
 instance Semigroup (BeamDeserializer be) where
-  (<>) = mappend
+  (BeamDeserializer a) <> (BeamDeserializer b) =
+    BeamDeserializer $ \d o ->
+    a d o <|> b d o
 
 instance Monoid (BeamDeserializer be) where
   mempty = BeamDeserializer (const (const mzero))
-  mappend (BeamDeserializer a) (BeamDeserializer b) =
-    BeamDeserializer $ \d o ->
-    a d o <|> b d o
 
 instance Semigroup (BeamDeserializers be) where
-  (<>) = mappend
+  (BeamDeserializers a) <> (BeamDeserializers b) =
+    BeamDeserializers (D.unionWithKey (const mappend) a b)
 
 instance Monoid (BeamDeserializers be) where
   mempty = BeamDeserializers mempty
-  mappend (BeamDeserializers a) (BeamDeserializers b) =
-    BeamDeserializers (D.unionWithKey (const mappend) a b)
 
 -- | Helper function to deserialize data from a 'Maybe' 'Value'.
 --
diff --git a/beam-migrate/Database/Beam/Migrate/Types.hs b/beam-migrate/Database/Beam/Migrate/Types.hs
index c68c4ac98..a307998c4 100644
--- a/beam-migrate/Database/Beam/Migrate/Types.hs
+++ b/beam-migrate/Database/Beam/Migrate/Types.hs
@@ -98,13 +98,13 @@ data MigrationDataLoss
   deriving Show
 
 instance Semigroup MigrationDataLoss where
-    (<>) = mappend
+    MigrationLosesData <> _ = MigrationLosesData
+    _ <> MigrationLosesData = MigrationLosesData
+    MigrationKeepsData <> MigrationKeepsData = MigrationKeepsData
 
 instance Monoid MigrationDataLoss where
     mempty = MigrationKeepsData
-    mappend MigrationLosesData _ = MigrationLosesData
-    mappend _ MigrationLosesData = MigrationLosesData
-    mappend MigrationKeepsData MigrationKeepsData = MigrationKeepsData
+
 
 -- | A migration command along with metadata on whether the command can lose data
 data MigrationCommand be
diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs
index 17de650b5..bc42da551 100644
--- a/beam-postgres/Database/Beam/Postgres/Syntax.hs
+++ b/beam-postgres/Database/Beam/Postgres/Syntax.hs
@@ -677,13 +677,10 @@ mkNumericPrec (Just (whole, dec)) = Just $ (fromIntegral whole `shiftL` 16) .|.
 instance IsCustomSqlSyntax PgExpressionSyntax where
   newtype CustomSqlSyntax PgExpressionSyntax =
     PgCustomExpressionSyntax { fromPgCustomExpression :: PgSyntax }
-    deriving Monoid
+    deriving (Semigroup, Monoid)
   customExprSyntax = PgExpressionSyntax . fromPgCustomExpression
   renderSyntax = PgCustomExpressionSyntax . pgParens . fromPgExpression
 
-instance Semigroup (CustomSqlSyntax PgExpressionSyntax) where
-  (<>) = mappend
-
 instance IsString (CustomSqlSyntax PgExpressionSyntax) where
   fromString = PgCustomExpressionSyntax . emit . fromString
 
diff --git a/beam-sqlite/Database/Beam/Sqlite/Syntax.hs b/beam-sqlite/Database/Beam/Sqlite/Syntax.hs
index 4eba08902..e4135d726 100644
--- a/beam-sqlite/Database/Beam/Sqlite/Syntax.hs
+++ b/beam-sqlite/Database/Beam/Sqlite/Syntax.hs
@@ -105,12 +105,11 @@ instance Sql92DisplaySyntax SqliteSyntax where
   displaySyntax = BL.unpack . sqliteRenderSyntaxScript
 
 instance Semigroup SqliteSyntax where
-  (<>) = mappend
+  (<>) (SqliteSyntax ab av) (SqliteSyntax bb bv) =
+    SqliteSyntax (\v -> ab v <> bb v) (av <> bv)
 
 instance Monoid SqliteSyntax where
   mempty = SqliteSyntax (\_ -> mempty) mempty
-  mappend (SqliteSyntax ab av) (SqliteSyntax bb bv) =
-    SqliteSyntax (\v -> ab v <> bb v) (av <> bv)
 
 instance Eq SqliteSyntax where
   SqliteSyntax ab av == SqliteSyntax bb bv =