packages feed

semiring-num (empty) → 0.1.0.0

raw patch · 7 files changed

+741/−0 lines, 7 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, doctest, random, semiring-num

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright Donnacha Oisín Kidney (c) 2016++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ semiring-num.cabal view
@@ -0,0 +1,44 @@+name:                semiring-num+version:             0.1.0.0+synopsis:            Basic semiring class and instances+description:         Adds a basic semiring class+homepage:            https://github.com/oisdk/semiring-num+license:             MIT+license-file:        LICENSE+author:              Donnacha Oisín Kidney+maintainer:          mail@doisinkidney.com+copyright:           2016 Donnacha Oisín Kidney+category:            Data+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Data.Semiring+                     , Data.Semiring.Numeric+                     , Test.Semiring+  build-depends:       base >= 4.7 && < 5+                     , containers >= 0.5+                     , QuickCheck >= 2.8+                     , random >= 1.1+  default-language:    Haskell2010+  ghc-options:         -Wall++test-suite semiring-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , semiring-num+                     , QuickCheck >= 2.8+                     , doctest >= 0.11+                     , containers >= 0.5+  ghc-options:         -threaded+                       -rtsopts+                       -with-rtsopts=-N+                       -Wall+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/oisdk/semiring-num
+ src/Data/Semiring.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving         #-}++{-|+Module: Data.Semiring+Description: Haskell semirings+License: MIT+Maintainer: mail@doisinkidney.com+Stability: experimental+-}++module Data.Semiring+  ( Semiring(..)+  , Add(..)+  , Mul(..)+  ) where++import           Data.Coerce           (coerce)++import           Data.Functor.Const    (Const (..))+import           Data.Functor.Identity (Identity (..))++import           Data.Monoid+import           Data.Semigroup        (Max (..), Min (..))++import           Data.Complex          (Complex)+import           Data.Fixed            (Fixed, HasResolution)+import           Data.Ratio            (Ratio)+import           Numeric.Natural       (Natural)++import           Data.Set              (Set)+import qualified Data.Set              as Set++import           Data.Int              (Int16, Int32, Int64, Int8)+import           Data.Word             (Word16, Word32, Word64, Word8)+import           Foreign.C.Types       (CChar, CClock, CDouble, CFloat, CInt,+                                        CIntMax, CIntPtr, CLLong, CLong,+                                        CPtrdiff, CSChar, CSUSeconds, CShort,+                                        CSigAtomic, CSize, CTime, CUChar, CUInt,+                                        CUIntMax, CUIntPtr, CULLong, CULong,+                                        CUSeconds, CUShort, CWchar)++import           Foreign.Ptr           (IntPtr, WordPtr)+import           System.Posix.Types    (CCc, CDev, CGid, CIno, CMode, CNlink,+                                        COff, CPid, CRLim, CSpeed, CSsize,+                                        CTcflag, CUid, Fd)++import           GHC.Generics          (Generic, Generic1)++import           Test.QuickCheck       (Arbitrary)++-- | A <https://en.wikipedia.org/wiki/Semiring Semiring> is like the+-- the combination of two 'Data.Monoid.Monoid's. The first+-- is called '<+>'; it has the identity element 'zero', and it is+-- commutative. The second is called '<.>'; it has identity element 'one',+-- and it must distribute over '<+>'.+--+-- = Laws+-- == Normal 'Precursor.Algebra.Monoid.Monoid' laws+-- * @(a '<+>' b) '<+>' c = a '<+>' (b '<+>' c)@+-- * @'zero' '<+>' a = a '<+>' 'zero' = a@+-- * @(a '<.>' b) '<.>' c = a '<.>' (b '<.>' c)@+-- * @'one' '<.>' a = a '<.>' 'one' = a@+--+-- == Commutativity of '<+>'+-- * @a '<+>' b = b '<+>' a@+--+-- == Distribution of '<.>' over '<+>'+-- * @a '<.>' (b '<+>' c) = (a '<.>' b) '<+>' (a '<.>' c)@+-- * @(a '<+>' b) '<.>' c = (a '<.>' c) '<+>' (b '<.>' c)@+--+-- Another useful law, annihilation, may be deduced from the axioms+-- above:+--+-- * @'zero' '<.>' a = a '<.>' 'zero' = 'zero'@+class Semiring a where+  -- | The identity of '<+>'.+  zero :: a+  -- | The identity of '<.>'.+  one :: a+  -- | An associative binary operation, which distributes over '<+>'.+  infixl 7 <.>+  (<.>) :: a -> a -> a+  -- | An associative, commutative binary operation.+  infixl 6 <+>+  (<+>) :: a -> a -> a++  default zero :: Num a => a+  default one :: Num a => a+  default (<+>) :: Num a => a -> a -> a+  default (<.>) :: Num a => a -> a -> a++  zero = 0+  one = 1+  (<+>) = (+)+  (<.>) = (*)++------------------------------------------------------------------------+-- Instances+------------------------------------------------------------------------+instance Semiring Bool where+  one = True+  zero = False+  (<+>) = (||)+  (<.>) = (&&)++instance Semiring () where+  one = ()+  zero = ()+  _ <+> _ = ()+  _ <.> _ = ()++cartProd :: (Ord a, Monoid a) => Set a -> Set a -> Set a+cartProd xs ys =+  Set.foldl' (\a x ->+                Set.foldl' (flip (Set.insert . mappend x)) a ys)+  Set.empty xs++-- | The 'Set' 'Semiring' is 'Data.Set.union' for '<+>', and a Cartesian+-- product for '<.>'.+instance (Ord a, Monoid a) => Semiring (Set a) where+  (<.>) = cartProd+  (<+>) = Set.union+  zero = Set.empty+  one = Set.singleton mempty++------------------------------------------------------------------------+-- Addition and multiplication newtypes+------------------------------------------------------------------------++type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a++-- | Monoid under '<+>'. Analogous to 'Data.Monoid.Sum', but uses the+-- 'Semiring' constraint, rather than 'Num'.+newtype Add a = Add+  { getAdd :: a+  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num+             ,Arbitrary)++-- | Monoid under '<.>'. Analogous to 'Data.Monoid.Product', but uses the+-- 'Semiring' constraint, rather than 'Num'.+newtype Mul a = Mul+  { getMul :: a+  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num+             ,Arbitrary)++instance Functor Add where fmap = coerce++instance Functor Mul where fmap = coerce++instance Foldable Add where+  foldr   =+    (coerce :: ((a -> b -> c) -> (b -> a -> c))+            -> (a -> b -> c)+            -> (b -> Add a -> c)) flip+  foldl   = coerce+  foldMap = coerce+  length  = const 1++instance Foldable Mul where+  foldr   =+    (coerce :: ((a -> b -> c) -> (b -> a -> c))+            -> (a -> b -> c)+            -> (b -> Mul a -> c)) flip+  foldl   = coerce+  foldMap = coerce+  length  = const 1++instance Applicative Add where+  pure = coerce+  (<*>) =+    (coerce :: ((a -> b) -> a -> b)+            -> (Add (a -> b) -> Add a -> Add b)) ($)++instance Applicative Mul where+  pure = coerce+  (<*>) =+    (coerce :: ((a -> b) -> a -> b)+            -> (Mul (a -> b) -> Mul a -> Mul b)) ($)++instance Monad Add where+  (>>=) = flip coerce++instance Monad Mul where+  (>>=) = flip coerce++instance Semiring a => Monoid (Add a) where+  mempty = Add zero+  mappend = (coerce :: WrapBinary Add a) (<+>)++instance Semiring a => Monoid (Mul a) where+  mempty = Mul one+  mappend = (coerce :: WrapBinary Mul a) (<.>)++instance Semiring a => Semiring (Add a) where+  zero = Add zero+  one = Add one+  (<+>) = (coerce :: WrapBinary Add a) (<+>)+  (<.>) = (coerce :: WrapBinary Add a) (<.>)++instance Semiring a => Semiring (Mul a) where+  zero = Mul zero+  one = Mul one+  (<+>) = (coerce :: WrapBinary Mul a) (<+>)+  (<.>) = (coerce :: WrapBinary Mul a) (<.>)++------------------------------------------------------------------------+-- Ord wrappers+------------------------------------------------------------------------++-- | The 'Semiring' for 'Max' uses the 'max' operation for '<+>', and+-- normal '+' for '<.>'.+instance (Ord a, Bounded a, Semiring a) => Semiring (Max a) where+  (<+>) = mappend+  zero = mempty+  (<.>) = (coerce :: WrapBinary Max a) (<+>)+  one = Max zero++-- | The 'Semiring' for 'Min' uses the 'min' operation for '<+>', and+-- normal '+' for '<.>'.+instance (Ord a, Bounded a, Semiring a) => Semiring (Min a) where+  (<+>) = mappend+  zero = mempty+  (<.>) = (coerce :: WrapBinary Min a) (<+>)+  one = Min zero++------------------------------------------------------------------------+-- (->) instance+------------------------------------------------------------------------++-- | The @(->)@ instance is analogous to the one for 'Monoid'.+instance Semiring b => Semiring (a -> b) where+  zero = const zero+  one = const one+  (f <+> g) x = f x <+> g x+  (f <.> g) x = f x <.> g x++------------------------------------------------------------------------+-- Endo instance+------------------------------------------------------------------------++-- | The 'Endo' semiring uses function composition for '<.>', and+-- pointwise 'mappend' for '<+>'. The underlying 'Monoid' needs to be+-- commutative.+instance Monoid a => Semiring (Endo a) where+  (<.>) = mappend+  one = mempty+  Endo f <+> Endo g = Endo (\x -> f x `mappend` g x)+  zero = Endo (const mempty)++------------------------------------------------------------------------+-- Boring instances+------------------------------------------------------------------------++instance Semiring Int+instance Semiring Int8+instance Semiring Int16+instance Semiring Int32+instance Semiring Int64+instance Semiring Integer+instance Semiring Word+instance Semiring Word8+instance Semiring Word16+instance Semiring Word32+instance Semiring Word64+instance Semiring CUIntMax+instance Semiring CIntMax+instance Semiring CUIntPtr+instance Semiring CIntPtr+instance Semiring CSUSeconds+instance Semiring CUSeconds+instance Semiring CTime+instance Semiring CClock+instance Semiring CSigAtomic+instance Semiring CWchar+instance Semiring CSize+instance Semiring CPtrdiff+instance Semiring CDouble+instance Semiring CFloat+instance Semiring CULLong+instance Semiring CLLong+instance Semiring CULong+instance Semiring CLong+instance Semiring CUInt+instance Semiring CInt+instance Semiring CUShort+instance Semiring CShort+instance Semiring CUChar+instance Semiring CSChar+instance Semiring CChar+instance Semiring IntPtr+instance Semiring WordPtr+instance Semiring Fd+instance Semiring CRLim+instance Semiring CTcflag+instance Semiring CSpeed+instance Semiring CCc+instance Semiring CUid+instance Semiring CNlink+instance Semiring CGid+instance Semiring CSsize+instance Semiring CPid+instance Semiring COff+instance Semiring CMode+instance Semiring CIno+instance Semiring CDev+instance Semiring Natural+instance Integral a => Semiring (Ratio a)+deriving instance Semiring a => Semiring (Product a)+deriving instance Semiring a => Semiring (Sum a)+instance RealFloat a => Semiring (Complex a)+instance HasResolution a => Semiring (Fixed a)+deriving instance Semiring a => Semiring (Identity a)+deriving instance Semiring a => Semiring (Const a b)++------------------------------------------------------------------------+-- Very boring instances+------------------------------------------------------------------------+instance (Semiring a, Semiring b) => Semiring (a,b) where+        zero = (zero, zero)+        (a1,b1) <+> (a2,b2) =+                (a1 <+> a2, b1 <+> b2)+        one = (one, one)+        (a1,b1) <.> (a2,b2) =+                (a1 <.> a2, b1 <.> b2)++instance (Semiring a, Semiring b, Semiring c) => Semiring (a,b,c) where+        zero = (zero, zero, zero)+        (a1,b1,c1) <+> (a2,b2,c2) =+                (a1 <+> a2, b1 <+> b2, c1 <+> c2)+        one = (one, one, one)+        (a1,b1,c1) <.> (a2,b2,c2) =+                (a1 <.> a2, b1 <.> b2, c1 <.> c2)++instance (Semiring a, Semiring b, Semiring c, Semiring d) => Semiring (a,b,c,d) where+        zero = (zero, zero, zero, zero)+        (a1,b1,c1,d1) <+> (a2,b2,c2,d2) =+                (a1 <+> a2, b1 <+> b2,+                 c1 <+> c2, d1 <+> d2)+        one = (one, one, one, one)+        (a1,b1,c1,d1) <.> (a2,b2,c2,d2) =+                (a1 <.> a2, b1 <.> b2, c1 <.> c2, d1 <.> d2)++instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e) =>+                Semiring (a,b,c,d,e) where+        zero = (zero, zero, zero, zero, zero)+        (a1,b1,c1,d1,e1) <+> (a2,b2,c2,d2,e2) =+                (a1 <+> a2, b1 <+> b2, c1 <+> c2,+                 d1 <+> d2, e1 <+> e2)+        one = (one, one, one, one, one)+        (a1,b1,c1,d1,e1) <.> (a2,b2,c2,d2,e2) =+                (a1 <.> a2, b1 <.> b2, c1 <.> c2,+                 d1 <.> d2, e1 <.> e2)
+ src/Data/Semiring/Numeric.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|+Module: Data.Semiring.Numeric+Description: Some interesting numeric semirings+License: MIT+Maintainer: mail@doisinkidney.com+Stability: experimental+-}+module Data.Semiring.Numeric+  ( Bottleneck(..)+  , Division(..)+  , Łukasiewicz(..)+  , Viterbi(..)+  ) where++import           Data.Coerce+import           Data.Semiring+import           GHC.Generics+import           System.Random+import           Test.QuickCheck+import           Test.QuickCheck.Gen++type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a++-- | '<+>' is 'max', '<.>' is 'min'+newtype Bottleneck a = Bottleneck+  { getBottleneck :: a+  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num+             ,Arbitrary)++instance (Bounded a, Ord a) => Semiring (Bottleneck a) where+  (<+>) = (coerce :: WrapBinary Bottleneck a) max+  (<.>) = (coerce :: WrapBinary Bottleneck a) min+  zero = Bottleneck minBound+  one  = Bottleneck maxBound++-- | '<+>' is 'gcd', '<.>' is 'lcm'. Positive numbers only.+newtype Division a = Division+  { getDivision :: a+  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)++-- | Only expects positive numbers+instance (Integral a, Semiring a) => Semiring (Division a) where+  (<+>) = (coerce :: WrapBinary Division a) gcd+  (<.>) = (coerce :: WrapBinary Division a) lcm+  zero = Division zero+  one = Division one++instance (Integral a, Arbitrary a) => Arbitrary (Division a) where+  arbitrary = fmap (Division . abs) arbitrary++-- | <https://en.wikipedia.org/wiki/Semiring#cite_ref-droste_14-0 Wikipedia>+-- has some information on this. Also+-- <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.304.6152&rep=rep1&type=pdf this>+-- paper.+newtype Łukasiewicz a = Łukasiewicz+  { getŁukasiewicz :: a+  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)++instance (Num a, Random a) => Arbitrary (Łukasiewicz a) where+  arbitrary = fmap Łukasiewicz (choose (0,1))++instance (Ord a, Num a) => Semiring (Łukasiewicz a) where+  (<+>) = (coerce :: WrapBinary Łukasiewicz a) max+  (<.>) = (coerce :: WrapBinary Łukasiewicz a) (\x y -> max 0 (x + y - 1))+  zero = Łukasiewicz 0+  one  = Łukasiewicz 1++-- | <https://en.wikipedia.org/wiki/Semiring#cite_ref-droste_14-0 Wikipedia>+-- has some information on this. Also+-- <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.304.6152&rep=rep1&type=pdf this>+-- paper. Apparently used for probabilistic parsing.+newtype Viterbi a = Viterbi+  { getViterbi :: a+  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)++instance (Semiring a, Random a) => Arbitrary (Viterbi a) where+  arbitrary = fmap Viterbi (choose (zero,one))++instance (Ord a, Semiring a) => Semiring (Viterbi a) where+  (<+>) = (coerce :: WrapBinary Viterbi a) max+  (<.>) = (coerce :: WrapBinary Viterbi a) (<.>)+  zero = Viterbi zero+  one  = Viterbi one++------------------------------------------------------------------------+-- Boring instances+------------------------------------------------------------------------++instance Functor Bottleneck where fmap = coerce+instance Functor Division where fmap = coerce+instance Functor Łukasiewicz where fmap = coerce+instance Functor Viterbi where fmap = coerce++instance Foldable Bottleneck where+  foldr   =+    (coerce :: ((a -> b -> c) -> (b -> a -> c))+            -> (a -> b -> c)+            -> (b -> Bottleneck a -> c)) flip+  foldl   = coerce+  foldMap = coerce+  length  = const 1+  null _ = False++instance Foldable Division where+  foldr   =+    (coerce :: ((a -> b -> c) -> (b -> a -> c))+            -> (a -> b -> c)+            -> (b -> Division a -> c)) flip+  foldl   = coerce+  foldMap = coerce+  length  = const 1+  null _ = False++instance Foldable Łukasiewicz where+  foldr =+    (coerce :: ((a -> b -> c) -> (b -> a -> c))+            -> (a -> b -> c)+            -> (b -> Łukasiewicz a -> c)) flip+  foldl   = coerce+  foldMap = coerce+  length  = const 1+  null _ = False++instance Foldable Viterbi where+  foldr =+    (coerce :: ((a -> b -> c) -> (b -> a -> c))+            -> (a -> b -> c)+            -> (b -> Viterbi a -> c)) flip+  foldl   = coerce+  foldMap = coerce+  length  = const 1+  null _ = False++instance Applicative Bottleneck where+  pure = coerce+  (<*>) =+    (coerce :: ((a -> b) -> a -> b)+            -> (Bottleneck (a -> b) -> Bottleneck a -> Bottleneck b)) ($)++instance Applicative Łukasiewicz where+  pure = coerce+  (<*>) =+    (coerce :: ((a -> b) -> a -> b)+            -> (Łukasiewicz (a -> b) -> Łukasiewicz a -> Łukasiewicz b)) ($)++instance Applicative Division where+  pure = coerce+  (<*>) =+    (coerce :: ((a -> b) -> a -> b)+            -> (Division (a -> b) -> Division a -> Division b)) ($)++instance Applicative Viterbi where+  pure = coerce+  (<*>) =+    (coerce :: ((a -> b) -> a -> b)+            -> (Viterbi (a -> b) -> Viterbi a -> Viterbi b)) ($)++instance Monad Bottleneck where (>>=) = flip coerce+instance Monad Division where (>>=) = flip coerce+instance Monad Łukasiewicz where (>>=) = flip coerce+instance Monad Viterbi where (>>=) = flip coerce
+ src/Test/Semiring.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-|+Module: Test.Semiring+Description: Some QuickCheck properties for Semirings+License: MIT+Maintainer: mail@doisinkidney.com+Stability: experimental+-}++module Test.Semiring+  ( plusAssoc+  , mulAssoc+  , plusComm+  , mulDistribL+  , mulDistribR+  , plusId+  , mulId+  , semiringLaws+  ) where++import           Data.Proxy+import           Data.Semiring   (Semiring (..))+import           Test.QuickCheck (Arbitrary, Property, conjoin, counterexample,+                                  property)++-- | Plus is associative.+plusAssoc :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property+plusAssoc x y z = counterexample s res where+  res = lp == rp+  l = x <+> y+  r = y <+> z+  lp = l <+> z+  rp = x <+> r+  s = unlines+    [ "Testing associativity of plus."+    , "Law: (x <+> y) <+> z = x <+> (y <+> z)"+    , "x <+> y = " ++ show l+    , "y <+> z = " ++ show r+    , "(x <+> y) <+> z = " ++ show lp+    , "x <+> (y <+> z) = " ++ show rp]++-- | Multiplication is associative.+mulAssoc :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property+mulAssoc x y z = counterexample s (lp == rp) where+  l = x <.> y+  r = y <.> z+  lp = l <.> z+  rp = x <.> r+  s = unlines+    [ "Testing associativity of <.>."+    , "Law: (x <.> y) <.> z = x <.> (y <.> z)"+    , "x <.> y = " ++ show l+    , "y <.> z = " ++ show r+    , "(x <.> y) <.> z = " ++ show lp+    , "x <.> (y <.> z) = " ++ show rp]++-- | Plus is commutative.+plusComm :: (Eq a, Semiring a, Show a) => a -> a -> Property+plusComm x y = counterexample s (l == r) where+  l = x <+> y+  r = y <+> x+  s = unlines+    [ "Testing commutativity of <+>."+    , "Law: x <+> y = y <+> x"+    , "x <+> y = " ++ show l+    , "y <+> x = " ++ show r ]++-- | Multiplication distributes left.+mulDistribL :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property+mulDistribL x y z = counterexample s (l == r) where+  l = x <.> (y <+> z)+  r = x <.> y <+> x <.> z+  s = unlines+    [ "Testing left distributivity of <.> over <+>."+    , "Law: x <.> (y <+> z) = x <.> y <+> x <.> z"+    , "x <.> (y <+> z) = " ++ show l+    , "x <.> y <+> x <.> z  = " ++ show r ]++-- | Multiplication distributes right.+mulDistribR :: (Eq a, Semiring a, Show a) => a -> a -> a -> Property+mulDistribR x y z = counterexample s (l == r) where+  l = (x <+> y) <.> z+  r = x <.> z <+> y <.> z+  s = unlines+    [ "Testing right distributivity of <.> over <+>."+    , "Law: (x <+> y) <.> z = x <.> z <+> y <.> z"+    , "(x <+> y) <.> z = " ++ show l+    , "x <.> z <+> y <.> z = " ++ show r ]++-- | Additive identity+plusId :: (Eq a, Semiring a, Show a) => a -> Property+plusId x = counterexample s (l == x && r ==x) where+  l = x <+> zero+  r = zero <+> x+  s = unlines+    [ "Testing identity of <+>."+    , "Law: x <+> zero = zero <+> x = x"+    , "x = " ++ show x+    , "x <+> zero = " ++ show l+    , "zero <+> x = " ++ show r ]++-- | Multiplicative identity+mulId :: (Eq a, Semiring a, Show a) => a -> Property+mulId x = counterexample s (l == x && r ==x) where+  l = x <.> one+  r = one <.> x+  s = unlines+    [ "Testing identity of <.>."+    , "Law: x <.> one = one <.> x = x"+    , "x = " ++ show x+    , "x <.> one = " ++ show l+    , "one <.> x = " ++ show r ]++-- | A property for all laws of 'Semiring'.+semiringLaws :: (Eq a, Semiring a, Show a, Arbitrary a) => Proxy a -> Property+semiringLaws (_ :: Proxy a) = conjoin+  [ property (plusAssoc   :: a -> a -> a -> Property)+  , property (mulAssoc    :: a -> a -> a -> Property)+  , property (plusComm    ::      a -> a -> Property)+  , property (mulDistribL :: a -> a -> a -> Property)+  , property (mulDistribR :: a -> a -> a -> Property)+  , property (plusId      ::           a -> Property)+  , property (mulId       ::           a -> Property)]
+ test/Spec.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TypeApplications #-}++module Main (main) where++import           Data.Proxy            (Proxy (..))+import           Data.Semiring         (Add, Mul)+import           Data.Semiring.Numeric+import           Data.Set              (Set)+import           Test.DocTest+import           Test.QuickCheck+import           Test.Semiring++main :: IO ()+main = do+  quickCheck (semiringLaws (Proxy :: Proxy Integer))+  quickCheck (semiringLaws (Proxy :: Proxy Bool))+  quickCheck (semiringLaws (Proxy :: Proxy (Add Integer)))+  quickCheck (semiringLaws (Proxy :: Proxy (Mul Integer)))+  quickCheck (semiringLaws (Proxy :: Proxy (Set Ordering)))+  quickCheck (semiringLaws (Proxy :: Proxy (Integer,Integer)))+  quickCheck (semiringLaws (Proxy :: Proxy (Integer,Integer,Integer)))+  quickCheck (semiringLaws (Proxy :: Proxy (Integer,Integer,Integer,Integer)))+  quickCheck (semiringLaws (Proxy :: Proxy (Integer,Integer,Integer,Integer,Integer)))+  quickCheck (semiringLaws (Proxy :: Proxy (Division Integer)))+  quickCheck (semiringLaws (Proxy :: Proxy (Bottleneck Int)))+  quickCheck (semiringLaws (Proxy :: Proxy (Łukasiewicz Integer)))+  quickCheck (semiringLaws (Proxy :: Proxy (Viterbi Integer)))+  doctest [ "-isrc"+          , "src/Data/Semiring.hs"+          , "src/Data/Semiring/Numeric.hs"+          , "src/Test/Semiring.hs" ]