Add missing Semigroup instances to compiler
authorHerbert Valerio Riedel <hvr@gnu.org>
Tue, 29 Aug 2017 23:29:55 +0000 (01:29 +0200)
committerHerbert Valerio Riedel <hvr@gnu.org>
Thu, 31 Aug 2017 07:45:11 +0000 (09:45 +0200)
This is a pre-requisite for implementing the Semigroup/Monoid proposal.
The instances have been introduced in a way to minimise warnings.

compiler/deSugar/Check.hs
compiler/iface/IfaceType.hs
compiler/main/Packages.hs
compiler/rename/RnEnv.hs
compiler/typecheck/TcType.hs
compiler/utils/FastString.hs
compiler/utils/Pair.hs
compiler/utils/PprColour.hs
compiler/utils/UniqDFM.hs
compiler/utils/UniqFM.hs

index ab2047f..72c94f8 100644 (file)
@@ -58,6 +58,7 @@ import Control.Monad (forM, when, forM_)
 import Coercion
 import TcEvidence
 import IOEnv
+import qualified Data.Semigroup as Semi
 
 import ListT (ListT(..), fold, select)
 
@@ -186,11 +187,14 @@ instance Outputable Covered where
 
 -- Like the or monoid for booleans
 -- Covered = True, Uncovered = False
+instance Semi.Semigroup Covered where
+  Covered <> _ = Covered
+  _ <> Covered = Covered
+  NotCovered <> NotCovered = NotCovered
+
 instance Monoid Covered where
   mempty = NotCovered
-  Covered `mappend` _ = Covered
-  _ `mappend` Covered = Covered
-  NotCovered `mappend` NotCovered = NotCovered
+  mappend = (Semi.<>)
 
 data Diverged = Diverged | NotDiverged
   deriving Show
@@ -199,11 +203,14 @@ instance Outputable Diverged where
   ppr Diverged = text "Diverged"
   ppr NotDiverged = text "NotDiverged"
 
+instance Semi.Semigroup Diverged where
+  Diverged <> _ = Diverged
+  _ <> Diverged = Diverged
+  NotDiverged <> NotDiverged = NotDiverged
+
 instance Monoid Diverged where
   mempty = NotDiverged
-  Diverged `mappend` _ = Diverged
-  _ `mappend` Diverged = Diverged
-  NotDiverged `mappend` NotDiverged = NotDiverged
+  mappend = (Semi.<>)
 
 -- | When we learned that a given match group is complete
 data Provenance =
@@ -215,11 +222,14 @@ data Provenance =
 instance Outputable Provenance where
   ppr  = text . show
 
+instance Semi.Semigroup Provenance where
+  FromComplete <> _ = FromComplete
+  _ <> FromComplete = FromComplete
+  _ <> _ = FromBuiltin
+
 instance Monoid Provenance where
   mempty = FromBuiltin
-  FromComplete `mappend` _ = FromComplete
-  _ `mappend` FromComplete = FromComplete
-  _ `mappend` _ = FromBuiltin
+  mappend = (Semi.<>)
 
 data PartialResult = PartialResult {
                         presultProvenence :: Provenance
@@ -235,14 +245,19 @@ instance Outputable PartialResult where
            = text "PartialResult" <+> ppr prov <+> ppr c
                                   <+> ppr d <+> ppr vsa
 
+
+instance Semi.Semigroup PartialResult where
+  (PartialResult prov1 cs1 vsa1 ds1)
+    <> (PartialResult prov2 cs2 vsa2 ds2)
+      = PartialResult (prov1 Semi.<> prov2)
+                      (cs1 Semi.<> cs2)
+                      (vsa1 Semi.<> vsa2)
+                      (ds1 Semi.<> ds2)
+
+
 instance Monoid PartialResult where
   mempty = PartialResult mempty mempty [] mempty
-  (PartialResult prov1 cs1 vsa1 ds1)
-    `mappend` (PartialResult prov2 cs2 vsa2 ds2)
-      = PartialResult (prov1 `mappend` prov2)
-                      (cs1 `mappend` cs2)
-                      (vsa1 `mappend` vsa2)
-                      (ds1 `mappend` ds2)
+  mappend = (Semi.<>)
 
 -- newtype ChoiceOf a = ChoiceOf [a]
 
index f623ca2..cde9e02 100644 (file)
@@ -66,6 +66,7 @@ import Util
 
 import Data.Maybe( isJust )
 import Data.List (foldl')
+import qualified Data.Semigroup as Semi
 
 {-
 ************************************************************************
@@ -149,11 +150,14 @@ data IfaceTcArgs
   | ITC_Invis IfaceKind IfaceTcArgs   -- "Invis" means don't show when pretty-printing
                                       --         except with -fprint-explicit-kinds
 
+instance Semi.Semigroup IfaceTcArgs where
+  ITC_Nil <> xs           = xs
+  ITC_Vis ty rest <> xs   = ITC_Vis ty (rest Semi.<> xs)
+  ITC_Invis ki rest <> xs = ITC_Invis ki (rest Semi.<> xs)
+
 instance Monoid IfaceTcArgs where
   mempty = ITC_Nil
-  ITC_Nil `mappend` xs           = xs
-  ITC_Vis ty rest `mappend` xs   = ITC_Vis ty (rest `mappend` xs)
-  ITC_Invis ki rest `mappend` xs = ITC_Invis ki (rest `mappend` xs)
+  mappend = (Semi.<>)
 
 -- Encodes type constructors, kind constructors,
 -- coercion constructors, the lot.
index 01d66cb..088f58a 100644 (file)
@@ -217,14 +217,7 @@ instance Semigroup ModuleOrigin where
 
 instance Monoid ModuleOrigin where
     mempty = ModOrigin Nothing [] [] False
-    mappend (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
-    mappend _ _ = panic "ModOrigin: hidden module redefined"
+    mappend = (Semigroup.<>)
 
 -- | Is the name from the import actually visible? (i.e. does it cause
 -- ambiguity, or is it only relevant when we're making suggestions?)
@@ -283,6 +276,17 @@ instance Outputable UnitVisibility where
         uv_requirements = reqs,
         uv_explicit = explicit
     }) = ppr (b, rns, mb_pn, reqs, explicit)
+
+instance Semigroup UnitVisibility where
+    uv1 <> uv2
+        = UnitVisibility
+          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
+          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
+          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
+          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
+          , uv_explicit = uv_explicit uv1 || uv_explicit uv2
+          }
+
 instance Monoid UnitVisibility where
     mempty = UnitVisibility
              { uv_expose_all = False
@@ -291,14 +295,7 @@ instance Monoid UnitVisibility where
              , uv_requirements = Map.empty
              , uv_explicit = False
              }
-    mappend uv1 uv2
-        = UnitVisibility
-          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
-          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
-          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
-          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
-          , uv_explicit = uv_explicit uv1 || uv_explicit uv2
-          }
+    mappend = (Semigroup.<>)
 
 type WiredUnitId = DefUnitId
 type PreloadUnitId = InstalledUnitId
index 298de54..175cb6b 100644 (file)
@@ -78,6 +78,7 @@ import RnUnbound
 import RnUtils
 import Data.Functor (($>))
 import Data.Maybe (isJust)
+import qualified Data.Semigroup as Semi
 
 {-
 *********************************************************
@@ -584,24 +585,27 @@ instance Outputable DisambigInfo where
   ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre
   ppr (AmbiguousOccurrence gres)    = text "Ambiguous:" <+> ppr gres
 
-instance Monoid DisambigInfo where
-  mempty = NoOccurrence
+instance Semi.Semigroup DisambigInfo where
   -- This is the key line: We prefer disambiguated occurrences to other
   -- names.
-  _ `mappend` DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
-  DisambiguatedOccurrence g' `mappend` _ = DisambiguatedOccurrence g'
+  _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
+  DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'
 
-
-  NoOccurrence `mappend` m = m
-  m `mappend` NoOccurrence = m
-  UniqueOccurrence g `mappend` UniqueOccurrence g'
+  NoOccurrence <> m = m
+  m <> NoOccurrence = m
+  UniqueOccurrence g <> UniqueOccurrence g'
     = AmbiguousOccurrence [g, g']
-  UniqueOccurrence g `mappend` AmbiguousOccurrence gs
+  UniqueOccurrence g <> AmbiguousOccurrence gs
     = AmbiguousOccurrence (g:gs)
-  AmbiguousOccurrence gs `mappend` UniqueOccurrence g'
+  AmbiguousOccurrence gs <> UniqueOccurrence g'
     = AmbiguousOccurrence (g':gs)
-  AmbiguousOccurrence gs `mappend` AmbiguousOccurrence gs'
+  AmbiguousOccurrence gs <> AmbiguousOccurrence gs'
     = AmbiguousOccurrence (gs ++ gs')
+
+instance Monoid DisambigInfo where
+  mempty = NoOccurrence
+  mappend = (Semi.<>)
+
 -- Lookup SubBndrOcc can never be ambiguous
 --
 -- Records the result of looking up a child.
index 3b97555..6253bbf 100644 (file)
@@ -233,6 +233,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Data.IORef
 import Data.Functor.Identity
+import qualified Data.Semigroup as Semi
 
 {-
 ************************************************************************
@@ -980,13 +981,15 @@ data CandidatesQTvs  -- See Note [Dependent type variables]
          -- See Note [Dependent type variables]
     }
 
-instance Monoid CandidatesQTvs where
-   mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet }
-   mappend (DV { dv_kvs = kv1, dv_tvs = tv1 })
-           (DV { dv_kvs = kv2, dv_tvs = tv2 })
+instance Semi.Semigroup CandidatesQTvs where
+   (DV { dv_kvs = kv1, dv_tvs = tv1 }) <> (DV { dv_kvs = kv2, dv_tvs = tv2 })
           = DV { dv_kvs = kv1 `unionDVarSet` kv2
                , dv_tvs = tv1 `unionDVarSet` tv2}
 
+instance Monoid CandidatesQTvs where
+   mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet }
+   mappend = (Semi.<>)
+
 instance Outputable CandidatesQTvs where
   ppr (DV {dv_kvs = kvs, dv_tvs = tvs })
     = text "DV" <+> braces (sep [ text "dv_kvs =" <+> ppr kvs
index 8653485..ee6dd7a 100644 (file)
@@ -118,6 +118,7 @@ import Data.IORef       ( IORef, newIORef, readIORef, atomicModifyIORef' )
 import Data.Maybe       ( isJust )
 import Data.Char
 import Data.List        ( elemIndex )
+import Data.Semigroup as Semi
 
 import GHC.IO           ( IO(..), unsafeDupablePerformIO )
 
@@ -202,9 +203,12 @@ instance Ord FastString where
 instance IsString FastString where
     fromString = fsLit
 
+instance Semi.Semigroup FastString where
+    (<>) = appendFS
+
 instance Monoid FastString where
     mempty = nilFS
-    mappend = appendFS
+    mappend = (Semi.<>)
     mconcat = concatFS
 
 instance Show FastString where
index d816ad3..aeb8648 100644 (file)
@@ -10,6 +10,7 @@ module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where
 #include "HsVersions.h"
 
 import Outputable
+import qualified Data.Semigroup as Semi
 
 data Pair a = Pair { pFst :: a, pSnd :: a }
 -- Note that Pair is a *unary* type constructor
@@ -31,9 +32,12 @@ instance Foldable Pair where
 instance Traversable Pair where
   traverse f (Pair x y) = Pair <$> f x <*> f y
 
-instance Monoid a => Monoid (Pair a) where
+instance Semi.Semigroup a => Semi.Semigroup (Pair a) where
+  Pair a1 b1 <> Pair a2 b2 =  Pair (a1 Semi.<> a2) (b1 Semi.<> b2)
+
+instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where
   mempty = Pair mempty mempty
-  Pair a1 b1 `mappend` Pair a2 b2 = Pair (a1 `mappend` a2) (b1 `mappend` b2)
+  mappend = (Semi.<>)
 
 instance Outputable a => Outputable (Pair a) where
   ppr (Pair a b) = ppr a <+> char '~' <+> ppr b
index ba7435d..f8ea28f 100644 (file)
@@ -1,15 +1,19 @@
 module PprColour where
 import Data.Maybe (fromMaybe)
 import Util (OverridingBool(..), split)
+import Data.Semigroup as Semi
 
 -- | A colour\/style for use with 'coloured'.
 newtype PprColour = PprColour { renderColour :: String }
 
+instance Semi.Semigroup PprColour where
+  PprColour s1 <> PprColour s2 = PprColour (s1 <> s2)
+
 -- | Allow colours to be combined (e.g. bold + red);
 --   In case of conflict, right side takes precedence.
 instance Monoid PprColour where
   mempty = PprColour mempty
-  PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2)
+  mappend = (<>)
 
 renderColourAfresh :: PprColour -> String
 renderColourAfresh c = renderColour (colReset `mappend` c)
index 17f2747..cb3dd7b 100644 (file)
@@ -66,6 +66,7 @@ import qualified Data.IntMap as M
 import Data.Data
 import Data.List (sortBy)
 import Data.Function (on)
+import qualified Data.Semigroup as Semi
 import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap)
 
 -- Note [Deterministic UniqFM]
@@ -371,9 +372,12 @@ anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m
 allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool
 allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m
 
+instance Semi.Semigroup (UniqDFM a) where
+  (<>) = plusUDFM
+
 instance Monoid (UniqDFM a) where
   mempty = emptyUDFM
-  mappend = plusUDFM
+  mappend = (Semi.<>)
 
 -- This should not be used in commited code, provided for convenience to
 -- make ad-hoc conversions when developing
index 8ea8ba4..076479f 100644 (file)
@@ -85,8 +85,7 @@ import qualified Data.Monoid as Mon
 import qualified Data.IntSet as S
 import Data.Typeable
 import Data.Data
-import Data.Semigroup   ( Semigroup )
-import qualified Data.Semigroup as Semigroup
+import qualified Data.Semigroup as Semi
 
 
 newtype UniqFM ele = UFM (M.IntMap ele)
@@ -356,12 +355,12 @@ equalKeysUFM (UFM m1) (UFM m2) = M.keys m1 == M.keys m2
 
 -- Instances
 
-instance Semigroup (UniqFM a) where
+instance Semi.Semigroup (UniqFM a) where
   (<>) = plusUFM
 
 instance Monoid (UniqFM a) where
     mempty = emptyUFM
-    mappend = plusUFM
+    mappend = (Semi.<>)
 
 -- Output-ery