generic-monoid (empty) → 0.1.0.0

raw patch · 7 files changed

+216/−0 lines, 7 filesdep +basesetup-changed

Dependencies added: base

Files

ChangeLog.md +5/−0
LICENSE +30/−0
README.md +27/−0
Setup.hs +2/−0
generic-monoid.cabal +23/−0
src/Data/Monoid/Generic.hs +69/−0
src/Data/Semigroup/Generic.hs +60/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for generic-monoid++## 0.1.0.0  -- 2018-12-12++* Initial release.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2018, Luke Clifton++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Luke Clifton nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,27 @@+# Generic Monoid (and Semigroup)++This library provides a method of deriving `Semigroup` and `Monoid` instances+for your large product types. It does this using GHC generics, and can provides+a mechanism for using the `DerivingVia` extension to reduce boilerplate.++It only works if each field of your product type is itself a `Semigroup`/`Monoid`.++```haskell+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia        #-}+{-# LANGUAGE DeriveGeneric      #-}++import GHC.Generics+import Data.Monoid.Generic++data BigProduct = BigProduct+    { theList   :: [Int]+    , theSum    :: Sum Double+    , theString :: String+    } deriving (Generic, Eq)+    deriving Semigroup via GenericSemigroup BigProduct+    deriving Monoid    via GenericMonoid BigProduct++useIt :: Bool+useIt = (mempty <> mempty) == BigProduct [] 0 ""+```

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ generic-monoid.cabal view

@@ -0,0 +1,23 @@+name:                generic-monoid+version:             0.1.0.0+synopsis:            Derive monoid instances for product types.+description:         Using GHC's generics, allow for deriving `Monoid` and `Semigroup` instances for your product types.+license:             BSD3+license-file:        LICENSE+author:              Luke Clifton+maintainer:          lukec@themk.net+copyright:           2018 Luke Clifton+category:            Data+build-type:          Simple+extra-source-files:  ChangeLog.md README.md+cabal-version:       >=1.10++source-repository head+  type: git+  location: https://github.com/luke-clifton/generic-monoid++library+  exposed-modules:     Data.Semigroup.Generic, Data.Monoid.Generic+  build-depends:       base >=4.12 && <4.13+  hs-source-dirs:      src+  default-language:    Haskell2010

+ src/Data/Monoid/Generic.hs view

@@ -0,0 +1,69 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Data.Monoid.Generic+    ( genericMappend+    , genericMempty+    , GenericSemigroup(..)+    , GenericMonoid(..)+    ) where++import GHC.TypeLits+import Data.Semigroup.Generic+import GHC.Generics++-- | A newtype which allows you to using the @DerivingVia@ extension+-- to reduce boilerplate.+--+-- @+-- data X = X [Int] String+--   deriving (Generic, Show)+--   deriving Semigroup via GenericSemigroup X+--   deriving Monoid    via GenericMonoid X+-- @+--+-- Note: Do NOT attempt to @derive Semigroup via GenericMonoid@. That will lead+-- to infinite recursion.+newtype GenericMonoid a = GenericMonoid a+    deriving Show+    deriving Semigroup via a++instance+    (Semigroup a, Generic a, MemptyProduct (Rep a))+    => Monoid (GenericMonoid a) where+    mempty = GenericMonoid genericMempty++-- | A generic @`mempty`@ function which works for product types where each+-- contained type is itself a @`Monoid`@. It simply calls @`mempty`@ for+-- each field.+--+-- If you don't want to use the @deriving via@ mechanism, use this function+-- to implement the `Monoid` type class.+genericMempty :: (Generic a, MemptyProduct (Rep a)) => a+genericMempty = to genericMempty'++class MemptyProduct f where+    genericMempty' :: f k++instance MemptyProduct c => MemptyProduct (D1 md c) where+    genericMempty' = M1 genericMempty'++instance MemptyProduct s => MemptyProduct (C1 md s) where+    genericMempty' = M1 genericMempty'++instance+    (TypeError (Text "You can't use `genericMempty` for sum types"))+    => MemptyProduct (a :+: b) where+    genericMempty' = undefined++instance (MemptyProduct a, MemptyProduct b) => MemptyProduct (a :*: b) where+    genericMempty' = genericMempty' :*: genericMempty'++instance Monoid t => MemptyProduct (S1 m (Rec0 t)) where+    genericMempty' = M1 (K1 mempty)

+ src/Data/Semigroup/Generic.hs view

@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Data.Semigroup.Generic+    ( genericMappend+    , GenericSemigroup(..)+    ) where++import GHC.TypeLits+import Data.Semigroup+import GHC.Generics++-- | A newtype which allows you to using the @DerivingVia@ extension+-- to reduce boilerplate.+--+-- @+-- data X = X [Int] String+--   deriving (Generic, Show)+--   deriving Semigroup via GenericSemigroup X+-- @+newtype GenericSemigroup a = GenericSemigroup a++instance+    (Generic a, MappendProduct (Rep a))+    => Semigroup (GenericSemigroup a) where+    (GenericSemigroup a) <> (GenericSemigroup b)+        = GenericSemigroup $ genericMappend a b++-- | A generic @`<>`@ function which works for product types where each+-- contained type is itself a @`Semigroup`@. It simply calls @`<>`@ for+-- each field.+--+-- If you don't want to use the @deriving via@ mechanism, use this function+-- to implement the `Semigroup` type class.+genericMappend :: (Generic a, MappendProduct (Rep a)) => a -> a -> a+genericMappend a b = to $ from a `genericMappend'` from b++class MappendProduct f where+    genericMappend' :: f k -> f k -> f k++instance+    (TypeError (Text "You can't use `genericMappend` for sum types"))+    => MappendProduct (a :+: b) where+    genericMappend' = undefined++instance MappendProduct c => MappendProduct (D1 md c) where+    genericMappend' (M1 a) (M1 b) = M1 (genericMappend' a b)++instance MappendProduct s => MappendProduct (C1 mc s) where+    genericMappend' (M1 a) (M1 b) = M1 (genericMappend' a b)++instance (MappendProduct a, MappendProduct b) => MappendProduct (a :*: b) where+    genericMappend' (a :*: b) (a' :*: b')+        = genericMappend' a a' :*: genericMappend' b b'++instance Semigroup t => MappendProduct (S1 m (Rec0 t)) where+    genericMappend' (M1 (K1 a)) (M1 (K1 b)) = M1 (K1 (a <> b))