diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,12 @@ +0.19.1 [2019.08.27] +------------------- +* Add `GenericSemigroupMonoid`, an adapter newtype suitable for `DerivingVia`, + to `Data.Semigroup.Generic`. +* Work around a bug related to the backported `Generic(1)` instances in this + package (that could only be triggered on GHC 7.2 or 7.4) in which the + hand-written `Datatype`, `Constructor`, and `Selector` instances for internal + data types could overlap with GHC-generated instances. + 0.19 [2019.05.10] ----------------- * The `(<>)` method of the backported `Semigroup` class no longer has a default diff --git a/semigroups.cabal b/semigroups.cabal --- a/semigroups.cabal +++ b/semigroups.cabal @@ -1,6 +1,6 @@ name: semigroups category: Algebra, Data, Data Structures, Math -version: 0.19 +version: 0.19.1 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE diff --git a/src-ghc7/Data/List/NonEmpty.hs b/src-ghc7/Data/List/NonEmpty.hs --- a/src-ghc7/Data/List/NonEmpty.hs +++ b/src-ghc7/Data/List/NonEmpty.hs @@ -204,23 +204,23 @@ #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 instance Generic1 NonEmpty where type Rep1 NonEmpty - = D1 D1NonEmpty - (C1 C1_0NonEmpty + = D1 D1'NonEmpty + (C1 C1'_0NonEmpty (S1 NoSelector Par1 :*: S1 NoSelector (Rec1 []))) from1 (h :| t) = M1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))) to1 (M1 (M1 (M1 h :*: M1 t))) = unPar1 h :| unRec1 t -instance Datatype D1NonEmpty where +instance Datatype D1'NonEmpty where datatypeName _ = "NonEmpty" moduleName _ = "Data.List.NonEmpty" -instance Constructor C1_0NonEmpty where +instance Constructor C1'_0NonEmpty where conName _ = ":|" conFixity _ = Infix RightAssociative 5 -data D1NonEmpty -data C1_0NonEmpty +data D1'NonEmpty +data C1'_0NonEmpty #endif #ifdef MIN_VERSION_deepseq diff --git a/src-ghc7/Data/Semigroup.hs b/src-ghc7/Data/Semigroup.hs --- a/src-ghc7/Data/Semigroup.hs +++ b/src-ghc7/Data/Semigroup.hs @@ -524,24 +524,24 @@ #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 instance Generic1 Min where - type Rep1 Min = D1 D1Min (C1 C1_0Min (S1 S1_0_0Min Par1)) + type Rep1 Min = D1 D1'Min (C1 C1'_0Min (S1 S1'_0_0Min Par1)) from1 (Min x) = M1 (M1 (M1 (Par1 x))) to1 (M1 (M1 (M1 x))) = Min (unPar1 x) -instance Datatype D1Min where +instance Datatype D1'Min where datatypeName _ = "Min" moduleName _ = "Data.Semigroup" -instance Constructor C1_0Min where +instance Constructor C1'_0Min where conName _ = "Min" conIsRecord _ = True -instance Selector S1_0_0Min where +instance Selector S1'_0_0Min where selName _ = "getMin" -data D1Min -data C1_0Min -data S1_0_0Min +data D1'Min +data C1'_0Min +data S1'_0_0Min #endif newtype Max a = Max { getMax :: a } deriving @@ -627,24 +627,24 @@ #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 instance Generic1 Max where - type Rep1 Max = D1 D1Max (C1 C1_0Max (S1 S1_0_0Max Par1)) + type Rep1 Max = D1 D1'Max (C1 C1'_0Max (S1 S1'_0_0Max Par1)) from1 (Max x) = M1 (M1 (M1 (Par1 x))) to1 (M1 (M1 (M1 x))) = Max (unPar1 x) -instance Datatype D1Max where +instance Datatype D1'Max where datatypeName _ = "Max" moduleName _ = "Data.Semigroup" -instance Constructor C1_0Max where +instance Constructor C1'_0Max where conName _ = "Max" conIsRecord _ = True -instance Selector S1_0_0Max where +instance Selector S1'_0_0Max where selName _ = "getMax" -data D1Max -data C1_0Max -data S1_0_0Max +data D1'Max +data C1'_0Max +data S1'_0_0Max #endif -- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be placed inside 'Min' and 'Max' @@ -711,22 +711,22 @@ #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 instance Generic1 (Arg a) where type Rep1 (Arg a) - = D1 D1Arg - (C1 C1_0Arg + = D1 D1'Arg + (C1 C1'_0Arg (S1 NoSelector (Rec0 a) :*: S1 NoSelector Par1)) from1 (Arg a b) = M1 (M1 (M1 (K1 a) :*: M1 (Par1 b))) to1 (M1 (M1 (M1 a :*: M1 b))) = Arg (unK1 a) (unPar1 b) -instance Datatype D1Arg where +instance Datatype D1'Arg where datatypeName _ = "Arg" moduleName _ = "Data.Semigroup" -instance Constructor C1_0Arg where +instance Constructor C1'_0Arg where conName _ = "Arg" -data D1Arg -data C1_0Arg +data D1'Arg +data C1'_0Arg #endif -- | Use @'Option' ('First' a)@ to get the behavior of 'Data.Monoid.First' from @Data.Monoid@. @@ -797,24 +797,24 @@ #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 instance Generic1 First where - type Rep1 First = D1 D1First (C1 C1_0First (S1 S1_0_0First Par1)) + type Rep1 First = D1 D1'First (C1 C1'_0First (S1 S1'_0_0First Par1)) from1 (First x) = M1 (M1 (M1 (Par1 x))) to1 (M1 (M1 (M1 x))) = First (unPar1 x) -instance Datatype D1First where +instance Datatype D1'First where datatypeName _ = "First" moduleName _ = "Data.Semigroup" -instance Constructor C1_0First where +instance Constructor C1'_0First where conName _ = "First" conIsRecord _ = True -instance Selector S1_0_0First where +instance Selector S1'_0_0First where selName _ = "getFirst" -data D1First -data C1_0First -data S1_0_0First +data D1'First +data C1'_0First +data S1'_0_0First #endif -- | Use @'Option' ('Last' a)@ to get the behavior of 'Data.Monoid.Last' from @Data.Monoid@ @@ -885,24 +885,24 @@ #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 instance Generic1 Last where - type Rep1 Last = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last Par1)) + type Rep1 Last = D1 D1'Last (C1 C1'_0Last (S1 S1'_0_0Last Par1)) from1 (Last x) = M1 (M1 (M1 (Par1 x))) to1 (M1 (M1 (M1 x))) = Last (unPar1 x) -instance Datatype D1Last where +instance Datatype D1'Last where datatypeName _ = "Last" moduleName _ = "Data.Semigroup" -instance Constructor C1_0Last where +instance Constructor C1'_0Last where conName _ = "Last" conIsRecord _ = True -instance Selector S1_0_0Last where +instance Selector S1'_0_0Last where selName _ = "getLast" -data D1Last -data C1_0Last -data S1_0_0Last +data D1'Last +data C1'_0Last +data S1'_0_0Last #endif -- (==)/XNOR on Bool forms a 'Semigroup', but has no good name @@ -1007,24 +1007,24 @@ #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 instance Generic1 WrappedMonoid where - type Rep1 WrappedMonoid = D1 D1WrappedMonoid (C1 C1_0WrappedMonoid (S1 S1_0_0WrappedMonoid Par1)) + type Rep1 WrappedMonoid = D1 D1'WrappedMonoid (C1 C1'_0WrappedMonoid (S1 S1'_0_0WrappedMonoid Par1)) from1 (WrapMonoid x) = M1 (M1 (M1 (Par1 x))) to1 (M1 (M1 (M1 x))) = WrapMonoid (unPar1 x) -instance Datatype D1WrappedMonoid where +instance Datatype D1'WrappedMonoid where datatypeName _ = "WrappedMonoid" moduleName _ = "Data.Semigroup" -instance Constructor C1_0WrappedMonoid where +instance Constructor C1'_0WrappedMonoid where conName _ = "WrapMonoid" conIsRecord _ = True -instance Selector S1_0_0WrappedMonoid where +instance Selector S1'_0_0WrappedMonoid where selName _ = "unwrapMonoid" -data D1WrappedMonoid -data C1_0WrappedMonoid -data S1_0_0WrappedMonoid +data D1'WrappedMonoid +data C1'_0WrappedMonoid +data S1'_0_0WrappedMonoid #endif -- | Repeat a value @n@ times. @@ -1127,24 +1127,24 @@ #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 instance Generic1 Option where - type Rep1 Option = D1 D1Option (C1 C1_0Option (S1 S1_0_0Option (Rec1 Maybe))) + type Rep1 Option = D1 D1'Option (C1 C1'_0Option (S1 S1'_0_0Option (Rec1 Maybe))) from1 (Option x) = M1 (M1 (M1 (Rec1 x))) to1 (M1 (M1 (M1 x))) = Option (unRec1 x) -instance Datatype D1Option where +instance Datatype D1'Option where datatypeName _ = "Option" moduleName _ = "Data.Semigroup" -instance Constructor C1_0Option where +instance Constructor C1'_0Option where conName _ = "Option" conIsRecord _ = True -instance Selector S1_0_0Option where +instance Selector S1'_0_0Option where selName _ = "getOption" -data D1Option -data C1_0Option -data S1_0_0Option +data D1'Option +data C1'_0Option +data S1'_0_0Option #endif -- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. diff --git a/src/Data/Semigroup/Generic.hs b/src/Data/Semigroup/Generic.hs --- a/src/Data/Semigroup/Generic.hs +++ b/src/Data/Semigroup/Generic.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #else @@ -21,14 +22,21 @@ -- ---------------------------------------------------------------------------- module Data.Semigroup.Generic - ( GSemigroup - , gmappend - , GMonoid - , gmempty + ( -- * Generic method implementations + gmappend, gmempty + + -- * Adapter newtype + , GenericSemigroupMonoid(..) + + -- * Internal classes + , GSemigroup, GMonoid ) where +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (Monoid(..)) +#endif #if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup +import Data.Semigroup (Semigroup(..)) #endif import GHC.Generics @@ -87,3 +95,26 @@ instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where gmempty' = gmempty' :*: gmempty' + +-- | An adapter newtype, suitable for @DerivingVia@. Its 'Semigroup' and +-- 'Monoid' instances leverage the 'Generic'-based defaults defined by +-- 'gmappend' and 'gmempty'. Here is an example of how to use it: +-- +-- @ +-- {-# LANGUAGE DerivingVia #-} +-- import "Data.Semigroup.Generic" +-- +-- data Pair a = MkPair a a +-- deriving ('Semigroup', 'Monoid') via ('GenericSemigroupMonoid' (Pair a)) +-- @ +newtype GenericSemigroupMonoid a = + GenericSemigroupMonoid { getGenericSemigroupMonoid :: a } + +instance (Generic a, GSemigroup (Rep a)) => Semigroup (GenericSemigroupMonoid a) where + GenericSemigroupMonoid x <> GenericSemigroupMonoid y = + GenericSemigroupMonoid (gmappend x y) +instance (Generic a, GMonoid (Rep a)) => Monoid (GenericSemigroupMonoid a) where + mempty = GenericSemigroupMonoid gmempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif