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

9 files changed, 287 insertions, 3 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