├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── generic-monoid.cabal └── src └── Data ├── Monoid └── Generic.hs └── Semigroup └── Generic.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .*.sw[po] 4 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for generic-monoid 2 | 3 | ## 0.1.0.1 -- 2020-06-14 4 | 5 | * Support GHC 8.4 6 | 7 | ## 0.1.0.0 -- 2018-12-12 8 | 9 | * Initial release. 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Luke Clifton 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Luke Clifton nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Generic Monoid (and Semigroup) 2 | 3 | This library provides a method of deriving `Semigroup` and `Monoid` instances 4 | for your large product types. It does this using GHC generics, and can provides 5 | a mechanism for using the `DerivingVia` extension to reduce boilerplate. 6 | 7 | It only works if each field of your product type is itself a `Semigroup`/`Monoid`. 8 | 9 | ```haskell 10 | {-# LANGUAGE DerivingStrategies #-} 11 | {-# LANGUAGE DerivingVia #-} 12 | {-# LANGUAGE DeriveGeneric #-} 13 | 14 | import GHC.Generics 15 | import Data.Monoid.Generic 16 | 17 | data BigProduct = BigProduct 18 | { theList :: [Int] 19 | , theSum :: Sum Double 20 | , theString :: String 21 | } deriving (Generic, Eq) 22 | deriving Semigroup via GenericSemigroup BigProduct 23 | deriving Monoid via GenericMonoid BigProduct 24 | 25 | useIt :: Bool 26 | useIt = (mempty <> mempty) == BigProduct [] 0 "" 27 | ``` 28 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /generic-monoid.cabal: -------------------------------------------------------------------------------- 1 | name: generic-monoid 2 | version: 0.1.0.1 3 | synopsis: Derive monoid instances for product types. 4 | description: Using GHC's generics, allow for deriving `Monoid` and `Semigroup` instances for your product types. 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Luke Clifton 8 | maintainer: lukec@themk.net 9 | copyright: 2018 Luke Clifton 10 | category: Data 11 | build-type: Simple 12 | extra-source-files: ChangeLog.md 13 | cabal-version: >=1.10 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/luke-clifton/generic-monoid 18 | 19 | library 20 | exposed-modules: Data.Semigroup.Generic, Data.Monoid.Generic 21 | build-depends: base >=4.11 && <4.22 22 | hs-source-dirs: src 23 | default-language: Haskell2010 24 | -------------------------------------------------------------------------------- /src/Data/Monoid/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | module Data.Monoid.Generic 7 | ( genericMappend 8 | , genericMempty 9 | , GenericSemigroup(..) 10 | , GenericMonoid(..) 11 | ) where 12 | 13 | import Data.Semigroup.Generic 14 | import GHC.Generics 15 | import GHC.TypeLits 16 | 17 | -- | A newtype which allows you to using the @DerivingVia@ extension 18 | -- to reduce boilerplate. 19 | -- 20 | -- @ 21 | -- data X = X [Int] String 22 | -- deriving (Generic, Show) 23 | -- deriving Semigroup via GenericSemigroup X 24 | -- deriving Monoid via GenericMonoid X 25 | -- @ 26 | -- 27 | -- Note: Do NOT attempt to @derive Semigroup via GenericMonoid@. That will lead 28 | -- to infinite recursion. 29 | newtype GenericMonoid a = GenericMonoid a 30 | deriving Show 31 | 32 | instance Semigroup a => Semigroup (GenericMonoid a) where 33 | GenericMonoid a <> GenericMonoid b = GenericMonoid $ a <> b 34 | 35 | instance 36 | (Semigroup a, Generic a, MemptyProduct (Rep a)) 37 | => Monoid (GenericMonoid a) where 38 | mempty = GenericMonoid genericMempty 39 | 40 | -- | A generic @`mempty`@ function which works for product types where each 41 | -- contained type is itself a @`Monoid`@. It simply calls @`mempty`@ for 42 | -- each field. 43 | -- 44 | -- If you don't want to use the @deriving via@ mechanism, use this function 45 | -- to implement the `Monoid` type class. 46 | genericMempty :: (Generic a, MemptyProduct (Rep a)) => a 47 | genericMempty = to genericMempty' 48 | 49 | class MemptyProduct f where 50 | genericMempty' :: f k 51 | 52 | instance MemptyProduct c => MemptyProduct (D1 md c) where 53 | genericMempty' = M1 genericMempty' 54 | 55 | instance MemptyProduct s => MemptyProduct (C1 md s) where 56 | genericMempty' = M1 genericMempty' 57 | 58 | instance 59 | (TypeError (Text "You can't use `genericMempty` for sum types")) 60 | => MemptyProduct (a :+: b) where 61 | genericMempty' = undefined 62 | 63 | instance (MemptyProduct a, MemptyProduct b) => MemptyProduct (a :*: b) where 64 | genericMempty' = genericMempty' :*: genericMempty' 65 | 66 | instance Monoid t => MemptyProduct (S1 m (Rec0 t)) where 67 | genericMempty' = M1 (K1 mempty) 68 | -------------------------------------------------------------------------------- /src/Data/Semigroup/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | module Data.Semigroup.Generic 8 | ( genericMappend 9 | , GenericSemigroup(..) 10 | ) where 11 | 12 | import GHC.TypeLits 13 | import Data.Semigroup 14 | import GHC.Generics 15 | 16 | -- | A newtype which allows you to using the @DerivingVia@ extension 17 | -- to reduce boilerplate. 18 | -- 19 | -- @ 20 | -- data X = X [Int] String 21 | -- deriving (Generic, Show) 22 | -- deriving Semigroup via GenericSemigroup X 23 | -- @ 24 | newtype GenericSemigroup a = GenericSemigroup a 25 | 26 | instance 27 | (Generic a, MappendProduct (Rep a)) 28 | => Semigroup (GenericSemigroup a) where 29 | (GenericSemigroup a) <> (GenericSemigroup b) 30 | = GenericSemigroup $ genericMappend a b 31 | 32 | -- | A generic @`<>`@ function which works for product types where each 33 | -- contained type is itself a @`Semigroup`@. It simply calls @`<>`@ for 34 | -- each field. 35 | -- 36 | -- If you don't want to use the @deriving via@ mechanism, use this function 37 | -- to implement the `Semigroup` type class. 38 | genericMappend :: (Generic a, MappendProduct (Rep a)) => a -> a -> a 39 | genericMappend a b = to $ from a `genericMappend'` from b 40 | 41 | class MappendProduct f where 42 | genericMappend' :: f k -> f k -> f k 43 | 44 | instance 45 | (TypeError (Text "You can't use `genericMappend` for sum types")) 46 | => MappendProduct (a :+: b) where 47 | genericMappend' = undefined 48 | 49 | instance MappendProduct c => MappendProduct (D1 md c) where 50 | genericMappend' (M1 a) (M1 b) = M1 (genericMappend' a b) 51 | 52 | instance MappendProduct s => MappendProduct (C1 mc s) where 53 | genericMappend' (M1 a) (M1 b) = M1 (genericMappend' a b) 54 | 55 | instance (MappendProduct a, MappendProduct b) => MappendProduct (a :*: b) where 56 | genericMappend' (a :*: b) (a' :*: b') 57 | = genericMappend' a a' :*: genericMappend' b b' 58 | 59 | instance Semigroup t => MappendProduct (S1 m (Rec0 t)) where 60 | genericMappend' (M1 (K1 a)) (M1 (K1 b)) = M1 (K1 (a <> b)) 61 | --------------------------------------------------------------------------------