difference-monoid (empty) → 0.1.0.0
raw patch · 11 files changed
+757/−0 lines, 11 filesdep +QuickCheckdep +adjunctionsdep +basesetup-changed
Dependencies added: QuickCheck, adjunctions, base, comonad, containers, deepseq, difference-monoid, distributive, doctest, groups, hedgehog, hedgehog-checkers, semigroupoids
Files
- ChangeLog.md +3/−0
- LICENSE +21/−0
- README.md +63/−0
- Setup.hs +2/−0
- difference-monoid.cabal +96/−0
- doctest/doctests.hs +6/−0
- src/Control/Monad/Parity.hs +13/−0
- src/Data/Monoid/Diff.hs +85/−0
- src/Data/Monoid/Diff/Internal.hs +323/−0
- src/Data/Monoid/Odd.hs +49/−0
- test/Spec.hs +96/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for difference-monoid++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018 Donnacha Oisín Kidney++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,63 @@+# difference-monoid++This package provides the Difference Monoid, which adds subtraction to+arbitrary monoids.++This has a number of uses:++* `Diff (Product a)` will give you a type similar to+Data.Ratio. Here, the "subtraction" operation is division. For+example:++ ```haskell+ >>> (1 :-: 2) <> (3 :-: 4) :: Diff (Product Int)+ Product {getProduct = 3} :-: Product {getProduct = 8}+ ```++* In a similar vein, `Diff (Sum a)` will add subtraction+to a numeric type:++ ```haskell+ >>> runDiff (-) (diff 2 <> diff 3 <> invert (diff 4)) :: Sum Natural+ Sum {getSum = 1}+ ```++ This will let you work with nonnegative types, where you need some+ form of subtraction (for, e.g., differences, hence the name), and+ you only want to check for underflow once.++* Using the above example, in particular, we get a monoid for averages:++ ```haskell+ >>> import Data.Function (on)+ >>> let avg = runDiff ((%) `on` getProduct.getSum) . foldMap (fmap Sum . diff . Product)+ >>> avg [1,4,3,2,5]+ 3 % 1+ ```++The Monoid and Semigroup laws hold in a pretty+straightforward way, provided the underlying type also follows those+laws.++For the Group laws, the underlying type must be a+cancellative semigroup.++A cancellative semigroup is one where++* `a <> b = a <> c` implies `b = c`+* `b <> a = c <> a` implies `b = c`++If this does not hold, than the equivalence only holds modulo the+the addition of some constant++Most common semigroups are cancellative, however notable+exceptions include the cross product of vectors, matrix+multiplication, and sets:++```haskell+fromList [1] <> fromList [1,2] = fromList [1] <> fromList [2]`+```++This type is known formally as the [Grothendieck group](https://en.wikipedia.org/wiki/Grothendieck_group).++The package also provides the `Parity` monad and comonad, which is left-adjunct to the difference monoid.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ difference-monoid.cabal view
@@ -0,0 +1,96 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 814f702b7822bc24e311185abb8d0d8d6e5a451789b132b18ae03b0bee6a103a++name: difference-monoid+version: 0.1.0.0+description: A Difference Monoid, to add subtraction to arbitrary monoids. Please see the README on Github at <https://github.com/oisdk/difference-monoid#readme>+homepage: https://github.com/oisdk/difference-monoid#readme+bug-reports: https://github.com/oisdk/difference-monoid/issues+author: Donnacha Oisín Kidney+maintainer: mail@doisinkidney.com+copyright: 2018 Donnacha Oisín Kidney+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/oisdk/difference-monoid++library+ hs-source-dirs:+ src+ ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns+ build-depends:+ adjunctions+ , base >=4.7 && <5+ , comonad+ , deepseq+ , distributive+ , groups+ , semigroupoids+ if impl(ghc >= 8.0)+ ghc-options: -fwarn-redundant-constraints -Wcompat+ exposed-modules:+ Control.Monad.Parity+ Data.Monoid.Diff+ Data.Monoid.Diff.Internal+ Data.Monoid.Odd+ other-modules:+ Paths_difference_monoid+ default-language: Haskell2010++test-suite difference-monoid-doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ hs-source-dirs:+ doctest+ ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns -threaded+ build-depends:+ QuickCheck+ , adjunctions+ , base >=4.7 && <5+ , comonad+ , deepseq+ , difference-monoid+ , distributive+ , doctest+ , groups+ , semigroupoids+ if impl(ghc >= 8.0)+ ghc-options: -fwarn-redundant-constraints -Wcompat+ other-modules:+ Paths_difference_monoid+ default-language: Haskell2010++test-suite difference-monoid-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ adjunctions+ , base >=4.7 && <5+ , comonad+ , containers+ , deepseq+ , difference-monoid+ , distributive+ , groups+ , hedgehog+ , hedgehog-checkers+ , semigroupoids+ if impl(ghc >= 8.0)+ ghc-options: -fwarn-redundant-constraints -Wcompat+ other-modules:+ Paths_difference_monoid+ default-language: Haskell2010
+ doctest/doctests.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Test.DocTest++main :: IO ()+main = doctest ["-isrc", "src/"]
+ src/Control/Monad/Parity.hs view
@@ -0,0 +1,13 @@+{-|+Module : Control.Monad.Parity+Description : The 'Parity' 'Monad' and 'Comonad'.+Copyright : (c) Donnacha Oisín Kidney, 2018+License : MIT+Maintainer : mail@doisinkidney.com+Stability : experimental+Portability : GHC+-}++module Control.Monad.Parity (Parity(..)) where++import Data.Monoid.Diff.Internal
+ src/Data/Monoid/Diff.hs view
@@ -0,0 +1,85 @@+{-|+Module : Data.Monoid.Diff+Description : The Difference Monoid, to add subtraction to arbitrary monoids.+Copyright : (c) Donnacha Oisín Kidney, 2018+License : MIT+Maintainer : mail@doisinkidney.com+Stability : experimental+Portability : GHC++This module provides the Difference Monoid, which adds subtraction to+arbitrary monoids.++This has a number of uses:++* @'Diff' ('Data.Monoid.Product' a)@ will give you a type similar to+'Data.Ratio'. Here, the "subtraction" operation is division. For+example:++ >>> (1 :-: 2) <> (3 :-: 4) :: Diff (Product Int)+ Product {getProduct = 3} :-: Product {getProduct = 8}++* In a similar vein, @'Diff' ('Data.Monoid.Sum' a)@ will add subtraction+to a numeric type:++ >>> runDiff (-) (diff 2 <> diff 3 <> invert (diff 4)) :: Sum Natural+ Sum {getSum = 1}++ This will let you work with nonnegative types, where you need some+ form of subtraction (for, e.g., differences, hence the name), and+ you only want to check for underflow once.++* Using the above example, in particular, we get a monoid for averages:++ >>> import Data.Function (on)+ >>> let avg = runDiff ((%) `on` getProduct.getSum) . foldMap (fmap Sum . diff . Product)+ >>> avg [1,4,3,2,5]+ 3 % 1++The 'Monoid' and 'Data.Semigroup.Semigroup' laws hold in a pretty+straightforward way, provided the underlying type also follows those+laws.++For the 'Data.Group.Group' laws, the underlying type must be a+cancellative semigroup.++A cancellative semigroup is one where++* @a 'Data.Semigroup.<>' b = a 'Data.Semigroup.<>' c@ implies @b = c@+* @b 'Data.Semigroup.<>' a = c 'Data.Semigroup.<>' a@ implies @b = c@++If this does not hold, than the equivalence only holds modulo the+the addition of some constant++Most common semigroups are cancellative, however notable+exceptions include the cross product of vectors, matrix+multiplication, and sets:++@'Data.Set.fromList' [1] 'Data.Semigroup.<>' 'Data.Set.fromList' [1,2] = 'Data.Set.fromList' [1] 'Data.Semigroup.<>' 'Data.Set.fromList' [2]@++This type is known formally as the <https://en.wikipedia.org/wiki/Grothendieck_group Grothendieck group>.+-}+module Data.Monoid.Diff+ (+ -- * The Diff Type+ Diff(..)+ ,+ -- * Functions for working with 'Diff'+ diff+ ,retract+ ,foldDiff+ ,runDiff+ ,normalize+ -- * Re-Exports from Group+ ,Group(..)+ )+ where++import Data.Monoid.Diff.Internal+import Data.Group (Group(..))++-- $setup+-- >>> import Data.Monoid+-- >>> import Numeric.Natural+-- >>> import Data.Group+-- >>> import Data.Ratio
+ src/Data/Monoid/Diff/Internal.hs view
@@ -0,0 +1,323 @@+{-# options_ghc -fno-warn-noncanonical-monoid-instances #-}++{-# OPTIONS_HADDOCK not-home #-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Monoid.Diff.Internal where++import Data.Group (Group (..))+import Data.Monoid.Odd+import Data.Semigroup (Semigroup (..))++import Control.DeepSeq (NFData (rnf))+import Data.Data (Data, Typeable)+import Data.Functor.Classes (Read1 (liftReadPrec),+ Show1 (liftShowsPrec))+import Data.Ix (Ix)+import GHC.Generics (Generic, Generic1)+import Text.Read (Lexeme (Symbol), lift, parens,+ prec, step)+import Text.Read.Lex (expect)++import Control.Applicative (liftA2)+import Control.Monad.Fix (MonadFix (..))+import Control.Monad.Zip (MonadZip (..))++import Data.Distributive (Distributive (..))+import Data.Functor.Adjunction+import Data.Functor.Rep (Representable (..))++import Data.Functor.Apply (Apply (..))+import Data.Functor.Bind (Bind (..))+import Data.Functor.Extend (Extend (..))+import Data.List.NonEmpty (NonEmpty (..))+import Data.Semigroup.Foldable (Foldable1 (..))+import Data.Semigroup.Traversable (Traversable1 (..))++import Control.Comonad (Comonad (..), ComonadApply (..))+import Control.Comonad.Env.Class (ComonadEnv)++import Data.Bool (bool)+import Data.Foldable (Foldable (..))++-- | The Difference Monoid.+data Diff a =+ !a :-: !a+ deriving (Show,Read,Data,Typeable,Generic,Generic1)++infixl 6 :-:+instance Functor Diff where+ fmap f (x :-: y) = f x :-: f y+ {-# INLINE fmap #-}+ x <$ _ = x :-: x+ {-# INLINE (<$) #-}++instance Foldable Diff where+ fold (x :-: y) = x `mappend` y+ {-# INLINE fold #-}+ foldMap f (x :-: y) = f x `mappend` f y+ {-# INLINE foldMap #-}+ foldr f b (x :-: y) = f x (f y b)+ {-# INLINE foldr #-}+ foldr' f !b (x :-: y) = case f y b of+ !b' -> f x b'+ {-# INLINE foldr' #-}+ foldl f b (x :-: y) = f (f b x) y+ {-# INLINE foldl #-}+ foldl' f !b (x :-: y) = case f b x of+ !b' -> f b' y+ minimum (x :-: y) = min x y+ {-# INLINE minimum #-}+ maximum (x :-: y) = max x y+ {-# INLINE maximum #-}+ foldr1 f (x :-: y) = f x y+ {-# INLINE foldr1 #-}+ foldl1 f (x :-: y) = f x y+ {-# INLINE foldl1 #-}+ toList (x :-: y) = [x,y]+ {-# INLINE toList #-}+ null _ = False+ {-# INLINE null #-}+ length _ = 2+ {-# INLINE length #-}+ elem x (y :-: z) = x == y || x == z+ {-# INLINE elem #-}+ sum (x :-: y) = x + y+ {-# INLINE sum #-}+ product (x :-: y) = x * y+ {-# INLINE product #-}++instance Traversable Diff where+ traverse f (x :-: y) = liftA2 (:-:) (f x) (f y)+ {-# INLINE traverse #-}+ sequenceA (x :-: y) = liftA2 (:-:) x y+ {-# INLINE sequenceA #-}++instance Applicative Diff where+ pure x = x :-: x+ {-# INLINE pure #-}+ (fx :-: fy) <*> (xx :-: xy) = fx xx :-: fy xy+ {-# INLINE (<*>) #-}+ liftA2 f (xx :-: xy) (yx :-: yy) = f xx yx :-: f xy yy+ {-# INLINE liftA2 #-}+ _ *> ys = ys+ {-# INLINE (*>) #-}+ xs <* _ = xs+ {-# INLINE (<*) #-}++instance Monad Diff where+ return = pure+ {-# INLINE return #-}+ (xx :-: xy) >>= f = x :-: y+ where+ x :-: _ = f xx+ _ :-: y = f xy+ {-# INLINE (>>=) #-}++instance Bind Diff where+ (xx :-: xy) >>- f = x :-: y+ where+ x :-: _ = f xx+ _ :-: y = f xy+ {-# INLINE (>>-) #-}++instance Semigroup a =>+ Semigroup (Diff a) where+ (xp :-: xn) <> (yp :-: yn) = (xp <> yp) :-: (xn <> yn)+ {-# INLINE (<>) #-}+ stimes n (x :-: y) = stimes n x :-: stimes n y+ {-# INLINE stimes #-}++instance (Monoid a) =>+ Monoid (Diff a) where+ mappend (xp :-: xn) (yp :-: yn) = (xp `mappend` yp) :-: (xn `mappend` yn)+ {-# INLINE mappend #-}+ mempty = mempty :-: mempty+ {-# INLINE mempty #-}++instance Monoid a => Group (Diff a) where+ invert (x :-: y) = y :-: x+ {-# INLINE invert #-}++instance (Eq a, Semigroup a) =>+ Eq (Diff a) where+ (xp :-: xn) == (yp :-: yn) = xn <> yp == xp <> yn+ {-# INLINE (==) #-}++instance (Ord a, Semigroup a) =>+ Ord (Diff a) where+ compare (xp :-: xn) (yp :-: yn) = compare (xp <> yn) (xn <> yp)+ {-# INLINE compare #-}++-- | Lift a monoid into the difference monoid.+--+-- >>> diff (Sum 1)+-- Sum {getSum = 1} :-: Sum {getSum = 0}+diff :: Monoid a => a -> Diff a+diff x = x :-: mempty+{-# INLINE diff #-}++-- | The inverse of 'diff'.+--+-- @'retract' '.' 'diff' = 'id'@+retract :: Group a => Diff a -> a+retract (x :-: y) = x `mappend` invert y+{-# INLINE retract #-}++-- | A group homomorphism given a monoid homomorphism.+foldDiff :: Group b => (a -> b) -> Diff a -> b+foldDiff f (x :-: y) = f x `mappend` invert (f y)+{-# INLINE foldDiff #-}++-- | Given a "normalizing" function, try simplify the representation.+--+-- For instance, one such normalizing function may be to take the+-- numeric difference of two types:+--+-- >>> let sumNorm x y = if x >= y then (x - y, 0) else (0, y - x)+-- >>> normalize sumNorm ((foldMap (diff.Sum) [1..10]) <> (invert (foldMap (diff.Sum) [1..5])))+-- Sum {getSum = 40} :-: Sum {getSum = 0}+normalize :: (a -> a -> (a, a)) -> Diff a -> Diff a+normalize f (x :-: y) = uncurry (:-:) (f x y)+{-# INLINE normalize #-}++-- | Interpret the difference using a subtraction function.+runDiff :: (a -> a -> b) -> Diff a -> b+runDiff f (x :-: y) = f x y+{-# INLINE runDiff #-}++instance MonadFix Diff where+ mfix f = (let n :-: _ = f n in n) :-: (let _ :-: d = f d in d)++instance MonadZip Diff where+ mzipWith = liftA2+ {-# INLINE mzipWith #-}+ munzip ((xx,xy) :-: (yx,yy)) = (xx :-: yx, xy :-: yy)+ {-# INLINE munzip #-}++instance NFData a => NFData (Diff a) where+ rnf (x :-: y) = rnf x `seq` rnf y++instance Distributive Diff where+ distribute f =+ fmap (\(x :-: _) -> x) f :-: fmap (\(_ :-: y) -> y) f+ {-# INLINE distribute #-}+ collect g f =+ fmap (\xs -> case g xs of (x :-: _) -> x) f :-:+ fmap (\ys -> case g ys of (_ :-: y) -> y) f+ {-# INLINE collect #-}++instance Representable Diff where+ type Rep Diff = Bool+ tabulate f = f False :-: f True+ {-# INLINE tabulate #-}+ index (x :-: y) = bool x y+ {-# INLINE index #-}++instance Foldable1 Diff where+ foldMap1 f (x :-: y) = f x <> f y+ {-# INLINE foldMap1 #-}+ fold1 (x :-: y) = x <> y+ {-# INLINE fold1 #-}+ toNonEmpty (x :-: y) = x :| [y]+ {-# INLINE toNonEmpty #-}++instance Traversable1 Diff where+ traverse1 f (x :-: y) = liftF2 (:-:) (f x) (f y)+ {-# INLINE traverse1 #-}+ sequence1 (x :-: y) = liftF2 (:-:) x y+ {-# INLINE sequence1 #-}++instance Apply Diff where+ (fx :-: fy) <.> (xx :-: xy) = fx xx :-: fy xy+ {-# INLINE (<.>) #-}+ liftF2 f (xx :-: xy) (yx :-: yy) = f xx yx :-: f xy yy+ {-# INLINE liftF2 #-}+ _ .> ys = ys+ {-# INLINE (.>) #-}+ xs <. _ = xs+ {-# INLINE (<.) #-}++instance Comonad Diff where+ extract (x :-: _) = x+ {-# INLINE extract #-}+ duplicate (x :-: y) = (x :-: y) :-: (y :-: x)+ {-# INLINE duplicate #-}+ extend f xy@(x :-: y) = f xy :-: f (y :-: x)+ {-# INLINE extend #-}++instance ComonadApply Diff where+ (fx :-: fy) <@> (xx :-: xy) = fx xx :-: fy xy+ {-# INLINE (<@>) #-}+ _ @> ys = ys+ {-# INLINE (@>) #-}+ xs <@ _ = xs+ {-# INLINE (<@) #-}++instance Bounded a => Bounded (Diff a) where+ minBound = minBound :-: maxBound+ {-# INLINE minBound #-}+ maxBound = maxBound :-: minBound+ {-# INLINE maxBound #-}++instance Show1 Diff where+ liftShowsPrec s _ d (xs :-: ys) =+ showParen (d > 6) $ s 7 xs . showString " :-: " . s 7 ys++instance Read1 Diff where+ liftReadPrec rp _ =+ parens $+ prec+ 6+ (liftA2 (:-:) (step rp) (lift (expect (Symbol ":-:")) *> step rp))++instance Extend Diff where+ duplicated (x :-: y) = (x :-: y) :-: (y :-: x)+ {-# INLINE duplicated #-}+ extended f xy@(x :-: y) = f xy :-: f (y :-: x)+ {-# INLINE extended #-}++-- | The 'Parity' 'Comonad'. It is left-adjunct to 'Data.Monoid.Diff'.+newtype Parity a = Parity+ { runParity :: (Odd, a)+ } deriving (Functor,Foldable,Traversable,Foldable1,Applicative+ ,Monad,Apply,Bind,Extend,Comonad,ComonadApply,Eq,Ord+ ,Show,Read,Bounded,Ix,Semigroup,Monoid,NFData+ ,ComonadEnv Odd)++instance Traversable1 Parity where+ traverse1 f (Parity (x, y)) = fmap (\y' -> Parity (x, y')) (f y)+ {-# INLINE traverse1 #-}+ sequence1 (Parity (x, y)) = fmap (\y' -> Parity (x, y')) y+ {-# INLINE sequence1 #-}++instance MonadFix Parity where+ mfix f = let (p,x) = runParity (f x) in Parity (p,x)++instance Adjunction Parity Diff where+ leftAdjunct f a = f (Parity (Odd False, a)) :-: f (Parity (Odd True, a))+ {-# INLINE leftAdjunct #-}+ unit a = Parity (Odd False, a) :-: Parity (Odd True, a)+ {-# INLINE unit #-}+ rightAdjunct f (Parity (Odd False,a)) =+ case f a of+ x :-: _ -> x+ rightAdjunct f (Parity (Odd True,a)) =+ case f a of+ _ :-: x -> x+ {-# INLINE rightAdjunct #-}+ counit (Parity (Odd False,x :-: _)) = x+ counit (Parity (Odd True,_ :-: x)) = x+ {-# INLINE counit #-}++-- $setup+-- >>> import Data.Monoid hiding (diff, (<>))
+ src/Data/Monoid/Odd.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|+Module : Data.Monoid.Odd+Description : The monoid of 'Bool' under xor.+Copyright : (c) Donnacha Oisín Kidney, 2018+License : MIT+Maintainer : mail@doisinkidney.com+Stability : experimental+Portability : GHC+-}++module Data.Monoid.Odd where++import Data.Coerce (coerce)++import Data.Group+import Data.Semigroup (Semigroup (stimes, (<>)))++import Control.DeepSeq (NFData)+import Data.Bits (Bits, FiniteBits)+import Data.Data (Data, Typeable)+import Data.Ix (Ix)+import Foreign.Storable (Storable)+import GHC.Generics (Generic)++-- | A monoid over XOR.+newtype Odd = Odd+ { getOdd :: Bool+ } deriving (Eq,Ord,Show,Bounded,Enum,Data,Read,Ix,Generic+ ,FiniteBits,Bits,Storable,NFData,Typeable)++instance Semigroup Odd where+ (<>) = (coerce :: (Bool -> Bool -> Bool) -> (Odd -> Odd -> Odd)) (/=)+ {-# INLINE (<>) #-}+ stimes n (Odd x) = Odd (x && n `mod` 2 == 1)+ {-# INLINE stimes #-}++instance Monoid Odd where+ mappend = (<>)+ {-# INLINE mappend #-}+ mempty = Odd False+ {-# INLINE mempty #-}++instance Group Odd where+ invert = id+ {-# INLINE invert #-}
+ test/Spec.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TemplateHaskell #-}++module Main (main) where++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Hedgehog.Checkers++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import Data.Function++import Data.Monoid.Diff+import Data.Monoid.Odd+import Data.Semigroup++newtype FreeAbelian a = FreeAbelian+ { getFreeAbelian :: Map a Int+ } deriving (Eq, Ord, Show)++instance Ord a => Semigroup (FreeAbelian a) where+ FreeAbelian xs <> FreeAbelian ys = FreeAbelian (Map.unionWith (+) xs ys)++instance Ord a => Monoid (FreeAbelian a) where+ mempty = FreeAbelian Map.empty+ mappend = (<>)++freeAbelian :: MonadGen m => m (FreeAbelian Int)+freeAbelian =+ FreeAbelian <$>+ Gen.map+ (Range.linear 0 10)+ ((,) <$> Gen.int (Range.linear 1 1000) <*> Gen.int (Range.linear 1 1000))++prop_AbelianMonoid :: Property+prop_AbelianMonoid = property $ monoid freeAbelian++intDiff :: MonadGen m => m (Diff (Sum Int))+intDiff = ((:-:) `on` Sum) <$> Gen.int (Range.linear 0 10) <*> Gen.int (Range.linear 0 10)++freeDiff :: MonadGen m => m (Diff (FreeAbelian Int))+freeDiff = (:-:) <$> freeAbelian <*> freeAbelian++oddGen :: MonadGen m => m Odd+oddGen = fmap Odd Gen.bool++prop_DiffMonoid :: Property+prop_DiffMonoid = property $ monoid intDiff++prop_DiffCommutative :: Property+prop_DiffCommutative = property $ commutativity (<>) intDiff++prop_OddMonoid :: Property+prop_OddMonoid = property $ monoid oddGen++prop_OddCommutative :: Property+prop_OddCommutative = property $ commutativity (<>) oddGen++prop_oddSTimes :: Property+prop_oddSTimes = property $ do+ x <- forAll oddGen+ n <- forAll $ Gen.int (Range.linear 0 100)+ stimesMonoid n x === stimes n x++prop_DiffInversion :: Property+prop_DiffInversion = property $ inversion (<>) mempty invert intDiff++prop_OddInversion :: Property+prop_OddInversion = property $ inversion (<>) mempty invert oddGen++prop_FreeDiffMonoid :: Property+prop_FreeDiffMonoid = property $ monoid freeDiff++prop_FreeDiffCommutative :: Property+prop_FreeDiffCommutative = property $ commutativity (<>) freeDiff++prop_FreeDiffInversion :: Property+prop_FreeDiffInversion = property $ inversion (<>) mempty invert freeDiff++prop_DiffOrd :: Property+prop_DiffOrd = property $ ord intDiff egte+ where+ egte (Sum x :-: Sum y) =+ ((:-:) `on` Sum) <$> Gen.int (Range.linear x 20) <*>+ Gen.int (Range.linear 0 y)++inversion :: (Show a, Eq a, Monad m) => (a -> a -> a) -> a -> (a -> a) -> Gen a -> PropertyT m ()+inversion (<+>) i inv gen = do+ xs <- forAll gen+ xs <+> inv xs === i+ inv xs <+> xs === i++main :: IO Bool+main = checkParallel $$discover