Commit c0feee90 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Add missing Semigroup instances to compiler

This is a pre-requisite for implementing the Semigroup/Monoid proposal.
The instances have been introduced in a way to minimise warnings.
parent 2c133b67
......@@ -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]
......
......@@ -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.
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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)
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment