summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/Check.hs45
-rw-r--r--compiler/iface/IfaceType.hs10
-rw-r--r--compiler/main/Packages.hs29
-rw-r--r--compiler/rename/RnEnv.hs26
-rw-r--r--compiler/typecheck/TcType.hs11
-rw-r--r--compiler/utils/FastString.hs6
-rw-r--r--compiler/utils/Pair.hs8
-rw-r--r--compiler/utils/PprColour.hs6
-rw-r--r--compiler/utils/UniqDFM.hs6
-rw-r--r--compiler/utils/UniqFM.hs7
10 files changed, 96 insertions, 58 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index ab2047fcf3..72c94f814c 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -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]
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index f623ca2997..cde9e02d83 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -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.
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 01d66cb740..088f58a675 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -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
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 298de54168..175cb6b518 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -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.
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index 3b97555158..6253bbf456 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -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
diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs
index 8653485e0c..ee6dd7a415 100644
--- a/compiler/utils/FastString.hs
+++ b/compiler/utils/FastString.hs
@@ -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
diff --git a/compiler/utils/Pair.hs b/compiler/utils/Pair.hs
index d816ad3f98..aeb8648b64 100644
--- a/compiler/utils/Pair.hs
+++ b/compiler/utils/Pair.hs
@@ -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
diff --git a/compiler/utils/PprColour.hs b/compiler/utils/PprColour.hs
index ba7435d5c2..f8ea28faa9 100644
--- a/compiler/utils/PprColour.hs
+++ b/compiler/utils/PprColour.hs
@@ -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)
diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs
index 17f2747f83..cb3dd7b7bd 100644
--- a/compiler/utils/UniqDFM.hs
+++ b/compiler/utils/UniqDFM.hs
@@ -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
diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs
index 8ea8ba4537..076479f984 100644
--- a/compiler/utils/UniqFM.hs
+++ b/compiler/utils/UniqFM.hs
@@ -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
View Lorry Controller Status