Implement warnings for Semigroups as parent of Monoid

This patch is similar to the AMP patch (#8004), which offered two
functions:

  1. Warn when an instance of a class has been given, but the type does
     not have a certain superclass instance
  2. Warn when top-level definitions conflict with future Prelude names

These warnings are issued as part of the new `-Wcompat` warning group.

Reviewers: hvr, ekmett, austin, bgamari

Reviewed By: hvr, ekmett, bgamari

Subscribers: ekmett, thomie

Differential Revision: https://phabricator.haskell.org/D1539

GHC Trac Issues: #11139

22 files changed, 402 insertions, 31 deletions

diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 3fea3968dd..eda643c43c 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -89,6 +89,10 @@ import Data.Maybe ( fromMaybe )
 #if __GLASGOW_HASKELL__ < 709
 import Data.Monoid hiding ((<>))
 #endif
+#if __GLASGOW_HASKELL__ > 710
+import Data.Semigroup   ( Semigroup )
+import qualified Data.Semigroup as Semigroup
+#endif
 
 {-
 ************************************************************************
@@ -175,6 +179,12 @@ emptyHsQTvs =  HsQTvs { hsq_kvs = [], hsq_tvs = [] }
 hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
 hsQTvBndrs = hsq_tvs
 
+#if __GLASGOW_HASKELL__ > 710
+instance Semigroup (LHsTyVarBndrs name) where
+  HsQTvs kvs1 tvs1 <> HsQTvs kvs2 tvs2
+    = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2)
+#endif
+
 instance Monoid (LHsTyVarBndrs name) where
   mempty = emptyHsQTvs
   mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2)
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index fb79a9d973..539e2220b7 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -38,6 +38,10 @@ import Control.Monad.Trans.Writer
 #else
 import Data.Monoid ( Monoid, mappend, mempty )
 #endif
+#if __GLASGOW_HASKELL__ > 710
+import Data.Semigroup   ( Semigroup )
+import qualified Data.Semigroup as Semigroup
+#endif
 import Data.List ( nub )
 import Data.Maybe ( catMaybes )
 
@@ -1840,6 +1844,12 @@ getTBAARegMeta = getTBAAMeta . getTBAA
 -- | A more convenient way of accumulating LLVM statements and declarations.
 data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
 
+#if __GLASGOW_HASKELL__ > 710
+instance Semigroup LlvmAccum where
+  LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =
+        LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)
+#endif
+
 instance Monoid LlvmAccum where
     mempty = LlvmAccum nilOL []
     LlvmAccum stmtsA declsA `mappend` LlvmAccum stmtsB declsB =
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ac27243aa3..98c61e7659 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -502,7 +502,8 @@ data WarningFlag =
    | Opt_WarnWarningsDeprecations
    | Opt_WarnDeprecatedFlags
    | Opt_WarnAMP -- Introduced in GHC 7.8, obsolete since 7.10
-   | Opt_WarnMissingMonadFailInstance
+   | Opt_WarnMissingMonadFailInstance -- since 8.0
+   | Opt_WarnSemigroup -- since 8.0
    | Opt_WarnDodgyExports
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans
@@ -2904,6 +2905,7 @@ fWarningFlags = [
   flagSpec "warn-missing-local-sigs"          Opt_WarnMissingLocalSigs,
   flagSpec "warn-missing-methods"             Opt_WarnMissingMethods,
   flagSpec "warn-missing-monadfail-instance"  Opt_WarnMissingMonadFailInstance,
+  flagSpec "warn-semigroup"                   Opt_WarnSemigroup,
   flagSpec "warn-missing-signatures"          Opt_WarnMissingSigs,
   flagSpec "warn-missing-exported-sigs"       Opt_WarnMissingExportedSigs,
   flagSpec "warn-monomorphism-restriction"    Opt_WarnMonomorphism,
@@ -3485,6 +3487,7 @@ minusWallOpts
 minusWcompatOpts :: [WarningFlag]
 minusWcompatOpts
     = [ Opt_WarnMissingMonadFailInstance
+      , Opt_WarnSemigroup
       ]
 
 enableUnusedBinds :: DynP ()
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index fdf96708fb..ac4fae2449 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -79,6 +79,10 @@ import Data.Set (Set)
 #if __GLASGOW_HASKELL__ < 709
 import Data.Monoid hiding ((<>))
 #endif
+#if __GLASGOW_HASKELL__ > 710
+import Data.Semigroup   ( Semigroup )
+import qualified Data.Semigroup as Semigroup
+#endif
 import qualified Data.Map as Map
 import qualified FiniteMap as Map
 import qualified Data.Set as Set
@@ -191,6 +195,18 @@ fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
 fromFlag :: ModuleOrigin
 fromFlag = ModOrigin Nothing [] [] True
 
+#if __GLASGOW_HASKELL__ > 710
+instance Semigroup ModuleOrigin where
+    ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =
+        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
+      where g (Just b) (Just b')
+                | b == b'   = Just b
+                | otherwise = panic "ModOrigin: package both exposed/hidden"
+            g Nothing x = x
+            g x Nothing = x
+    _x <> _y = panic "ModOrigin: hidden module redefined"
+#endif
+
 instance Monoid ModuleOrigin where
     mempty = ModOrigin Nothing [] [] False
     mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') =
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index cdf3df60b3..27194a203c 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -197,6 +197,8 @@ basicKnownKeyNames
         alternativeClassName,
         foldableClassName,
         traversableClassName,
+        semigroupClassName, sappendName,
+        monoidClassName, memptyName, mappendName, mconcatName,
 
         -- The IO type
         -- See Note [TyConRepNames for non-wired-in TyCons]
@@ -403,7 +405,8 @@ pRELUDE         = mkBaseModule_ pRELUDE_NAME
 gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
     gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
-    gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
+    gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
+    dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, dATA_SEMIGROUP,
     gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
     gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
@@ -432,6 +435,7 @@ dATA_EITHER     = mkBaseModule (fsLit "Data.Either")
 dATA_STRING     = mkBaseModule (fsLit "Data.String")
 dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")
 dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
+dATA_SEMIGROUP  = mkBaseModule (fsLit "Data.Semigroup")
 dATA_MONOID     = mkBaseModule (fsLit "Data.Monoid")
 gHC_CONC        = mkBaseModule (fsLit "GHC.Conc")
 gHC_IO          = mkBaseModule (fsLit "GHC.IO")
@@ -938,6 +942,16 @@ foldableClassName, traversableClassName :: Name
 foldableClassName     = clsQual  dATA_FOLDABLE       (fsLit "Foldable")    foldableClassKey
 traversableClassName  = clsQual  dATA_TRAVERSABLE    (fsLit "Traversable") traversableClassKey
 
+-- Classes (Semigroup, Monoid)
+semigroupClassName, sappendName :: Name
+semigroupClassName = clsQual dATA_SEMIGROUP (fsLit "Semigroup") semigroupClassKey
+sappendName        = varQual dATA_SEMIGROUP (fsLit "<>")        sappendClassOpKey
+monoidClassName, memptyName, mappendName, mconcatName :: Name
+monoidClassName    = clsQual gHC_BASE       (fsLit "Monoid")    monoidClassKey
+memptyName         = varQual gHC_BASE       (fsLit "mempty")    memptyClassOpKey
+mappendName        = varQual gHC_BASE       (fsLit "mappend")   mappendClassOpKey
+mconcatName        = varQual gHC_BASE       (fsLit "mconcat")   mconcatClassOpKey
+
 
 
 -- AMP additions
@@ -1438,6 +1452,10 @@ ghciIoClassKey = mkPreludeClassUnique 44
 isLabelClassNameKey :: Unique
 isLabelClassNameKey = mkPreludeClassUnique 45
 
+semigroupClassKey, monoidClassKey :: Unique
+semigroupClassKey = mkPreludeClassUnique 46
+monoidClassKey    = mkPreludeClassUnique 47
+
 ---------------- Template Haskell -------------------
 --      THNames.hs: USES ClassUniques 200-299
 -----------------------------------------------------
@@ -2072,6 +2090,14 @@ toDynIdKey            = mkPreludeMiscIdUnique 509
 bitIntegerIdKey :: Unique
 bitIntegerIdKey       = mkPreludeMiscIdUnique 510
 
+sappendClassOpKey :: Unique
+sappendClassOpKey = mkPreludeMiscIdUnique 511
+
+memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique
+memptyClassOpKey  = mkPreludeMiscIdUnique 512
+mappendClassOpKey = mkPreludeMiscIdUnique 513
+mconcatClassOpKey = mkPreludeMiscIdUnique 514
+
 
 {-
 ************************************************************************
@@ -2108,6 +2134,7 @@ standardClassKeys = derivableClassKeys ++ numericClassKeys
                   ++ [randomClassKey, randomGenClassKey,
                       functorClassKey,
                       monadClassKey, monadPlusClassKey, monadFailClassKey,
+                      semigroupClassKey, monoidClassKey,
                       isStringClassKey,
                       applicativeClassKey, foldableClassKey,
                       traversableClassKey, alternativeClassKey
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index c733d21705..14885e74eb 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -52,6 +52,10 @@ import Data.List        ( partition, mapAccumL, nub, sortBy )
 #if __GLASGOW_HASKELL__ < 709
 import Data.Monoid      ( Monoid, mempty, mappend, mconcat )
 #endif
+#if __GLASGOW_HASKELL__ > 710
+import Data.Semigroup   ( Semigroup )
+import qualified Data.Semigroup as Semigroup
+#endif
 
 
 {-
@@ -204,6 +208,11 @@ Unfortunately, unlike the context, the relevant bindings are added in
 multiple places so they have to be in the Report.
 -}
 
+#if __GLASGOW_HASKELL__ > 710
+instance Semigroup Report where
+    Report a1 b1 <> Report a2 b2 = Report (a1 ++ a2) (b1 ++ b2)
+#endif
+
 instance Monoid Report where
     mempty = Report [] []
     mappend (Report a1 b1) (Report a2 b2) = Report (a1 ++ a2) (b1 ++ b2)
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 3c68dcf462..2e86d322b3 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -7,7 +7,9 @@
 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker
 -}
 
-{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
 
 module TcRnDriver (
 #ifdef GHCI
@@ -103,6 +105,7 @@ import FastString
 import Maybes
 import Util
 import Bag
+import Inst (tcGetInsts)
 
 import Control.Monad
 
@@ -1153,6 +1156,10 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                 -- Generate Applicative/Monad proposal (AMP) warnings
         traceTc "Tc3b" empty ;
 
+                -- Generate Semigroup/Monoid warnings
+        traceTc "Tc3c" empty ;
+        tcSemigroupWarnings ;
+
                 -- Foreign import declarations next.
         traceTc "Tc4" empty ;
         (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
@@ -1223,6 +1230,190 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
         return (tcg_env', tcl_env)
     }}}}}}
 
+
+tcSemigroupWarnings :: TcM ()
+tcSemigroupWarnings = do
+    traceTc "tcSemigroupWarnings" empty
+    let warnFlag = Opt_WarnSemigroup
+    tcPreludeClashWarn warnFlag sappendName
+    tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName
+
+
+-- | Warn on local definitions of names that would clash with future Prelude
+-- elements.
+--
+--   A name clashes if the following criteria are met:
+--       1. It would is imported (unqualified) from Prelude
+--       2. It is locally defined in the current module
+--       3. It has the same literal name as the reference function
+--       4. It is not identical to the reference function
+tcPreludeClashWarn :: WarningFlag
+                   -> Name
+                   -> TcM ()
+tcPreludeClashWarn warnFlag name = do
+    { warn <- woptM warnFlag
+    ; when warn $ do
+    { traceTc "tcPreludeClashWarn/wouldBeImported" empty
+    -- Is the name imported (unqualified) from Prelude? (Point 4 above)
+    ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv
+    -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude
+    -- will not appear in rnImports automatically if it is set.)
+
+    -- Continue only the name is imported from Prelude
+    ; when (importedViaPrelude name rnImports) $ do
+      -- Handle 2.-4.
+    { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv
+
+    ; let clashes :: GlobalRdrElt -> Bool
+          clashes x = isLocalDef && nameClashes && isNotInProperModule
+            where
+              isLocalDef = gre_lcl x == True
+              -- Names are identical ...
+              nameClashes = nameOccName (gre_name x) == nameOccName name
+              -- ... but not the actual definitions, because we don't want to
+              -- warn about a bad definition of e.g. <> in Data.Semigroup, which
+              -- is the (only) proper place where this should be defined
+              isNotInProperModule = gre_name x /= name
+
+          -- List of all offending definitions
+          clashingElts :: [GlobalRdrElt]
+          clashingElts = filter clashes rdrElts
+
+    ; traceTc "tcPreludeClashWarn/prelude_functions"
+                (hang (ppr name) 4 (sep [ppr clashingElts]))
+
+    ; let warn_msg x = addWarnAt (nameSrcSpan (gre_name x)) (hsep
+              [ text "Local definition of"
+              , (quotes . ppr . nameOccName . gre_name) x
+              , text "clashes with a future Prelude name." ]
+              $$
+              text "This will become an error in a future release." )
+    ; mapM_ warn_msg clashingElts
+    }}}
+
+  where
+
+    -- Is the given name imported via Prelude?
+    --
+    -- Possible scenarios:
+    --   a) Prelude is imported implicitly, issue warnings.
+    --   b) Prelude is imported explicitly, but without mentioning the name in
+    --      question. Issue no warnings.
+    --   c) Prelude is imported hiding the name in question. Issue no warnings.
+    --   d) Qualified import of Prelude, no warnings.
+    importedViaPrelude :: Name
+                       -> [ImportDecl Name]
+                       -> Bool
+    importedViaPrelude name = any importViaPrelude
+      where
+        isPrelude :: ImportDecl Name -> Bool
+        isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME
+
+        -- Implicit (Prelude) import?
+        isImplicit :: ImportDecl Name -> Bool
+        isImplicit = ideclImplicit
+
+        -- Unqualified import?
+        isUnqualified :: ImportDecl Name -> Bool
+        isUnqualified = not . ideclQualified
+
+        -- List of explicitly imported (or hidden) Names from a single import.
+        --   Nothing -> No explicit imports
+        --   Just (False, <names>) -> Explicit import list of <names>
+        --   Just (True , <names>) -> Explicit hiding of <names>
+        importListOf :: ImportDecl Name -> Maybe (Bool, [Name])
+        importListOf = fmap toImportList . ideclHiding
+          where
+            toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc))
+
+        isExplicit :: ImportDecl Name -> Bool
+        isExplicit x = case importListOf x of
+            Nothing -> False
+            Just (False, explicit)
+                -> nameOccName name `elem`    map nameOccName explicit
+            Just (True, hidden)
+                -> nameOccName name `notElem` map nameOccName hidden
+
+        -- Check whether the given name would be imported (unqualified) from
+        -- an import declaration.
+        importViaPrelude :: ImportDecl Name -> Bool
+        importViaPrelude x = isPrelude x
+                          && isUnqualified x
+                          && (isImplicit x || isExplicit x)
+
+
+-- Notation: is* is for classes the type is an instance of, should* for those
+--           that it should also be an instance of based on the corresponding
+--           is*.
+tcMissingParentClassWarn :: WarningFlag
+                         -> Name -- ^ Instances of this ...
+                         -> Name -- ^ should also be instances of this
+                         -> TcM ()
+tcMissingParentClassWarn warnFlag isName shouldName
+  = do { warn <- woptM warnFlag
+       ; when warn $ do
+       { traceTc "tcMissingParentClassWarn" empty
+       ; isClass'     <- tcLookupClass_maybe isName
+       ; shouldClass' <- tcLookupClass_maybe shouldName
+       ; case (isClass', shouldClass') of
+              (Just isClass, Just shouldClass) -> do
+                  { localInstances <- tcGetInsts
+                  ; let isInstance m = is_cls m == isClass
+                        isInsts = filter isInstance localInstances
+                  ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts)
+                  ; forM_ isInsts (checkShouldInst isClass shouldClass)
+                  }
+              (is',should') ->
+                  traceTc "tcMissingParentClassWarn/notIsShould"
+                          (hang (ppr isName <> text "/" <> ppr shouldName) 2 (
+                            (hsep [ quotes (text "Is"), text "lookup for"
+                                  , ppr isName
+                                  , text "resulted in", ppr is' ])
+                            $$
+                            (hsep [ quotes (text "Should"), text "lookup for"
+                                  , ppr shouldName
+                                  , text "resulted in", ppr should' ])))
+       }}
+  where
+    -- Check whether the desired superclass exists in a given environment.
+    checkShouldInst :: Class   -- ^ Class of existing instance
+                    -> Class   -- ^ Class there should be an instance of
+                    -> ClsInst -- ^ Existing instance
+                    -> TcM ()
+    checkShouldInst isClass shouldClass isInst
+      = do { instEnv <- tcGetInstEnvs
+           ; let (instanceMatches, shouldInsts, _)
+                    = lookupInstEnv False instEnv shouldClass (is_tys isInst)
+
+           ; traceTc "tcMissingParentClassWarn/checkShouldInst"
+                     (hang (ppr isInst) 4
+                         (sep [ppr instanceMatches, ppr shouldInsts]))
+
+           -- "<location>: Warning: <type> is an instance of <is> but not
+           -- <should>" e.g. "Foo is an instance of Monad but not Applicative"
+           ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
+                 warnMsg (Just name:_) =
+                      addWarnAt instLoc $
+                           hsep [ (quotes . ppr . nameOccName) name
+                                , text "is an instance of"
+                                , (ppr . nameOccName . className) isClass
+                                , text "but not"
+                                , (ppr . nameOccName . className) shouldClass ]
+                                <> text "."
+                           $$
+                           hsep [ text "This will become an error in"
+                                , text "a future release." ]
+                 warnMsg _ = pure ()
+           ; when (null shouldInsts && null instanceMatches) $
+                  warnMsg (is_tcs isInst)
+           }
+
+    tcLookupClass_maybe :: Name -> TcM (Maybe Class)
+    tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case
+        Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls
+        _else -> pure Nothing
+
+
 ---------------------------
 tcTyClsInstDecls :: [TyClGroup Name]
                  -> [LInstDecl Name]
diff --git a/compiler/utils/OrdList.hs b/compiler/utils/OrdList.hs
index 4591b55978..f5362bb27f 100644
--- a/compiler/utils/OrdList.hs
+++ b/compiler/utils/OrdList.hs
@@ -21,6 +21,10 @@ import Outputable
 #if __GLASGOW_HASKELL__ < 709
 import Data.Monoid ( Monoid(..) )
 #endif
+#if __GLASGOW_HASKELL__ > 710
+import Data.Semigroup   ( Semigroup )
+import qualified Data.Semigroup as Semigroup
+#endif
 
 infixl 5  `appOL`
 infixl 5  `snocOL`
@@ -38,6 +42,11 @@ data OrdList a
 instance Outputable a => Outputable (OrdList a) where
   ppr ol = ppr (fromOL ol)  -- Convert to list and print that
 
+#if __GLASGOW_HASKELL__ > 710
+instance Semigroup (OrdList a) where
+  (<>) = appOL
+#endif
+
 instance Monoid (OrdList a) where
   mempty = nilOL
   mappend = appOL
diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs
index db578c37d0..fa556fb2b1 100644
--- a/compiler/utils/UniqFM.hs
+++ b/compiler/utils/UniqFM.hs
@@ -84,6 +84,10 @@ import Data.Data
 #if __GLASGOW_HASKELL__ < 709
 import Data.Monoid
 #endif
+#if __GLASGOW_HASKELL__ > 710
+import Data.Semigroup   ( Semigroup )
+import qualified Data.Semigroup as Semigroup
+#endif
 
 {-
 ************************************************************************
@@ -202,6 +206,11 @@ ufmToList       :: UniqFM elt -> [(Unique, elt)]
 ************************************************************************
 -}
 
+#if __GLASGOW_HASKELL__ > 710
+instance Semigroup (UniqFM a) where
+  (<>) = plusUFM
+#endif
+
 instance Monoid (UniqFM a) where
     mempty = emptyUFM
     mappend = plusUFM
diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst
index dfc5bb361b..2e0ae6f18c 100644
--- a/docs/users_guide/7.12.1-notes.rst
+++ b/docs/users_guide/7.12.1-notes.rst
@@ -164,6 +164,12 @@ Compiler
    `MonadFail Proposal (MFP)
    <https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail>`__.
 
+-  Added the ``-fwarn-semigroup`` flag. When enabled, this
+   will issue a warning if a type is an instance of ``Monoid`` but not
+   ``Semigroup``, and when a custom definition ``(<>)`` is made. Fixing these
+   warnings makes sure the definition of ``Semigroup`` as a superclass of
+   ``Monoid`` does not break any code.
+
 GHCi
 ~~~~
 
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 4c2bc88710..deb0e5459d 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -54,7 +54,8 @@ standard “packages” of warnings:
     eager to make their code future compatible to adapt to new features before
     they even generate warnings.
 
-    This currently enables only ``-fwarn-missing-monadfail-instance``.
+    This currently enables ``-fwarn-missing-monadfail-instance`` and
+    ``-fwarn-semigroup``.
 
 ``-Wno-compat``
     .. index::
@@ -245,6 +246,21 @@ command line.
     the `MonadFail Proposal (MFP)
     <https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail>`__.
 
+``-fwarn-semigroup``
+    .. index::
+       single: -fwarn-semigroup
+       single: semigroup
+
+    Warn when definitions are in conflict with the future inclusion of
+    ``Semigroup`` into the standard typeclasses.
+
+        1. Instances of ``Monoid`` should also be instances of ``Semigroup``
+        2. The ``Semigroup`` operator ``(<>)`` will be in ``Prelude``, which
+           clashes with custom local definitions of such an operator
+
+    Being part of the ``-Wcompat`` option group, this warning is off by
+    default, but will be switched on in a future GHC release.
+
 ``-fwarn-deprecated-flags``
     .. index::
        single: -fwarn-deprecated-flags
diff --git a/testsuite/tests/semigroup/Makefile b/testsuite/tests/semigroup/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/semigroup/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/semigroup/SemigroupWarnings.hs b/testsuite/tests/semigroup/SemigroupWarnings.hs
new file mode 100644
index 0000000000..83ae2cf180
--- /dev/null
+++ b/testsuite/tests/semigroup/SemigroupWarnings.hs
@@ -0,0 +1,34 @@
+-- Test purpose:
+-- Ensure that missing semigroup warnings are issued
+-- correctly if the warning flag is enabled
+
+{-# OPTIONS_GHC -fwarn-semigroup #-}
+
+module SemigroupWarnings where
+
+
+
+import Data.Semigroup
+
+
+
+-- Bad instance, should complain about missing Semigroup parent
+data LacksSemigroup
+instance Monoid LacksSemigroup where
+    mempty = undefined
+    mappend = undefined
+
+
+
+-- Correct instance, should not warn
+data HasSemigroup
+instance Semigroup HasSemigroup where
+    (<>) = undefined
+instance Monoid HasSemigroup where
+    mempty = undefined
+    mappend = undefined
+
+
+
+-- Should issue a Prelude clash warning
+(<>) = undefined
diff --git a/testsuite/tests/semigroup/SemigroupWarnings.stderr b/testsuite/tests/semigroup/SemigroupWarnings.stderr
new file mode 100644
index 0000000000..2c75819cf8
--- /dev/null
+++ b/testsuite/tests/semigroup/SemigroupWarnings.stderr
@@ -0,0 +1,8 @@
+
+SemigroupWarnings.hs:17:10: warning:
+    ‘LacksSemigroup’ is an instance of Monoid but not Semigroup.
+    This will become an error in a future release.
+
+SemigroupWarnings.hs:34:1: warning:
+    Local definition of ‘<>’ clashes with a future Prelude name.
+    This will become an error in a future release.
diff --git a/testsuite/tests/semigroup/all.T b/testsuite/tests/semigroup/all.T
new file mode 100644
index 0000000000..0b1c3b9878
--- /dev/null
+++ b/testsuite/tests/semigroup/all.T
@@ -0,0 +1 @@
+test('SemigroupWarnings', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr b/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr
index 2fd9036b01..02ae25931a 100644
--- a/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr
+++ b/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr
@@ -1,10 +1,10 @@
 
 CustomTypeErrors02.hs:17:1: error:
-    The type 'a_aER -> a_aER' cannot be represented as an integer.
-    When checking that ‘err’ has the inferred type
-      err :: (TypeError ...)
+    • The type 'a_aEN -> a_aEN' cannot be represented as an integer.
+    • When checking that ‘err’ has the inferred type
+        err :: (TypeError ...)
 
 CustomTypeErrors02.hs:17:7: error:
-    The type 'a0 -> a0' cannot be represented as an integer.
-    In the expression: convert id
-    In an equation for ‘err’: err = convert id
+    • The type 'a0 -> a0' cannot be represented as an integer.
+    • In the expression: convert id
+      In an equation for ‘err’: err = convert id
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs
index 2f86d46bc2..24cab851c9 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs
@@ -10,3 +10,5 @@ monadFail :: Monad m => m a
 monadFail = do
     Just _ <- undefined
     undefined
+
+(<>) = undefined -- Semigroup warnings
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs
index 727a4e7600..4c53a1e4ea 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs
@@ -10,3 +10,5 @@ monadFail :: Monad m => m a
 monadFail = do
     Just _ <- undefined
     undefined
+
+(<>) = undefined -- Semigroup warnings
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs
index 29fcc9eeb3..3b2586aff8 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs
@@ -10,3 +10,5 @@ monadFail :: Monad m => m a
 monadFail = do
     Just _ <- undefined
     undefined
+
+(<>) = undefined -- Semigroup warnings
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
index 03fc4e26c1..23d1a2892b 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
@@ -1,21 +1,25 @@
 
 WCompatWarningsOn.hs:11:5: warning:
-    Could not deduce (MonadFail m)
-      arising from the failable pattern ‘Just _’
-      (this will become an error a future GHC release)
-    from the context: Monad m
-      bound by the type signature for:
-                 monadFail :: Monad m => m a
-      at WCompatWarningsOn.hs:9:14-27
-    Possible fix:
-      add (MonadFail m) to the context of
-        the type signature for:
-          monadFail :: Monad m => m a
-    In a stmt of a 'do' block: Just _ <- undefined
-    In the expression:
-      do { Just _ <- undefined;
-           undefined }
-    In an equation for ‘monadFail’:
-        monadFail
-          = do { Just _ <- undefined;
-                 undefined }
+    • Could not deduce (MonadFail m)
+        arising from the failable pattern ‘Just _’
+        (this will become an error a future GHC release)
+      from the context: Monad m
+        bound by the type signature for:
+                   monadFail :: Monad m => m a
+        at WCompatWarningsOn.hs:9:14-27
+      Possible fix:
+        add (MonadFail m) to the context of
+          the type signature for:
+            monadFail :: Monad m => m a
+    • In a stmt of a 'do' block: Just _ <- undefined
+      In the expression:
+        do { Just _ <- undefined;
+             undefined }
+      In an equation for ‘monadFail’:
+          monadFail
+            = do { Just _ <- undefined;
+                   undefined }
+
+WCompatWarningsOn.hs:14:1: warning:
+    Local definition of ‘<>’ clashes with a future Prelude name.
+    This will become an error in a future release.
diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs
index 26d3973702..2f4aedff23 100644
--- a/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs
+++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs
@@ -10,3 +10,5 @@ monadFail :: Monad m => m a
 monadFail = do
     Just _ <- undefined
     undefined
+
+(<>) = undefined -- Semigroup warnings
diff --git a/utils/mkUserGuidePart/Options/Warnings.hs b/utils/mkUserGuidePart/Options/Warnings.hs
index 563ce94ab1..ba93f6ca83 100644
--- a/utils/mkUserGuidePart/Options/Warnings.hs
+++ b/utils/mkUserGuidePart/Options/Warnings.hs
@@ -154,11 +154,18 @@ warningsOptions =
          }
   , flag { flagName = "-fwarn-missing-monadfail-instance"
          , flagDescription =
-           "warn when a failable pattern is used in a do-block that does not  "++
-           "have a ``MonadFail`` instance."
+           "warn when a failable pattern is used in a do-block that does " ++
+           "not have a ``MonadFail`` instance."
          , flagType = DynamicFlag
          , flagReverse = "-fno-warn-missing-monadfail-instance"
          }
+  , flag { flagName = "-fwarn-semigroup"
+         , flagDescription =
+           "warn when a ``Monoid`` is not ``Semigroup``, and on non-" ++
+           "``Semigroup`` definitions of ``(<>)``?"
+         , flagType = DynamicFlag
+         , flagReverse = "-fno-warn-semigroup"
+         }
   , flag { flagName = "-fwarn-missed-specialisations"
          , flagDescription =
            "warn when specialisation of an imported, overloaded function fails."