Skip to content

Commit

Permalink
Address warnings related to non-canonical definition for mappend
Browse files Browse the repository at this point in the history
  • Loading branch information
LaurentRDC committed Aug 25, 2024
1 parent 715db73 commit 84e8f16
Show file tree
Hide file tree
Showing 8 changed files with 50 additions and 66 deletions.
46 changes: 20 additions & 26 deletions beam-migrate/Database/Beam/Haskell/Syntax.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand All @@ -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
Expand Down Expand Up @@ -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 () }

Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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

Expand Down
26 changes: 12 additions & 14 deletions beam-migrate/Database/Beam/Migrate/Actions.hs
Original file line number Diff line number Diff line change
Expand Up @@ -194,22 +194,21 @@ 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
-- the destination of the second. 'mempty' here returns the action that does
-- 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 =
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
5 changes: 2 additions & 3 deletions beam-migrate/Database/Beam/Migrate/Backend.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
9 changes: 4 additions & 5 deletions beam-migrate/Database/Beam/Migrate/SQL/Builder.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
12 changes: 5 additions & 7 deletions beam-migrate/Database/Beam/Migrate/Serialization.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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'.
--
Expand Down
8 changes: 4 additions & 4 deletions beam-migrate/Database/Beam/Migrate/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
5 changes: 1 addition & 4 deletions beam-postgres/Database/Beam/Postgres/Syntax.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
5 changes: 2 additions & 3 deletions beam-sqlite/Database/Beam/Sqlite/Syntax.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down

0 comments on commit 84e8f16

Please sign in to comment.