diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/semiring-num.cabal b/semiring-num.cabal new file mode 100644 --- /dev/null +++ b/semiring-num.cabal @@ -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 diff --git a/src/Data/Semiring.hs b/src/Data/Semiring.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semiring.hs @@ -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 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) diff --git a/src/Data/Semiring/Numeric.hs b/src/Data/Semiring/Numeric.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semiring/Numeric.hs @@ -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 + +-- | +-- has some information on this. Also +-- +-- 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 + +-- | +-- has some information on this. Also +-- +-- 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 diff --git a/src/Test/Semiring.hs b/src/Test/Semiring.hs new file mode 100644 --- /dev/null +++ b/src/Test/Semiring.hs @@ -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)] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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" ]