{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where
import Data.Proxy
import Data.Monoid
import Data.Map.Strict (Map)
import qualified Data.Vector as Vector
import qualified Data.Vector.Storable as Storable
import Data.Semiring
import Data.Semiring.Free
import Data.Semiring.Infinite
import Data.Semiring.Numeric
import Numeric.Natural
import Numeric.Sized.WordOfSize
import Test.DocTest
import Test.QuickCheck hiding (Positive (..), generate,
(.&.))
import Test.SmallCheck.Series hiding (Positive)
import Test.Tasty
import qualified Test.Tasty.QuickCheck as QC
import qualified Test.Tasty.SmallCheck as SC
import Test.Semiring
import ApproxLog
import Fraction
import Func
import LimitSize
import Orphans ()
import Vectors
------------------------------------------------------------------------
semiringLawsSC :: (Show r, Eq r, Semiring r, Serial IO r) => f r -> TestTree
semiringLawsSC (_ :: f r) = testGroup "Semiring Laws"
[ SC.testProperty "plusId" (plusId :: r -> Either String String)
, SC.testProperty "mulId" (mulId :: r -> Either String String)
, SC.testProperty "annihilateL" (annihilateL :: r -> Either String String)
, SC.testProperty "annihilateR" (annihilateR :: r -> Either String String)
, SC.testProperty "plusComm" (plusComm :: r -> r -> Either String String)
, SC.testProperty "plusAssoc" (plusAssoc :: r -> r -> r -> Either String String)
, SC.testProperty "mulAssoc" (mulAssoc :: r -> r -> r -> Either String String)
, SC.testProperty "mulDistribL" (mulDistribL :: r -> r -> r -> Either String String)
, SC.testProperty "mulDistribR" (mulDistribR :: r -> r -> r -> Either String String)]
semiringLawsQC :: (Show r, Eq r, Semiring r, Arbitrary r) => f r -> TestTree
semiringLawsQC (_ :: f r) = testGroup "Semiring Laws"
[ QC.testProperty "plusId" (plusId :: r -> Either String String)
, QC.testProperty "mulId" (mulId :: r -> Either String String)
, QC.testProperty "annihilateL" (annihilateL :: r -> Either String String)
, QC.testProperty "annihilateR" (annihilateR :: r -> Either String String)
, QC.testProperty "plusComm" (plusComm :: r -> r -> Either String String)
, QC.testProperty "plusAssoc" (plusAssoc :: r -> r -> r -> Either String String)
, QC.testProperty "mulAssoc" (mulAssoc :: r -> r -> r -> Either String String)
, QC.testProperty "mulDistribL" (mulDistribL :: r -> r -> r -> Either String String)
, QC.testProperty "mulDistribR" (mulDistribR :: r -> r -> r -> Either String String)]
starLawsQC :: (Show r, Eq r, StarSemiring r, Arbitrary r) => f r -> TestTree
starLawsQC (_ :: f r) = testGroup "Star laws"
[ QC.testProperty "starLaw" (starLaw :: r -> Either String String)
, QC.testProperty "plusLaw" (plusLaw :: r -> Either String String)]
starLawsSC :: (Show r, Eq r, StarSemiring r, Serial IO r) => f r -> TestTree
starLawsSC (_ :: f r) = testGroup "Star laws"
[ SC.testProperty "starLaw" (starLaw :: r -> Either String String)
, SC.testProperty "plusLaw" (plusLaw :: r -> Either String String)]
ordLawsQC :: (Show r, Ord r, Semiring r, Arbitrary r) => f r -> TestTree
ordLawsQC (_ :: f r) = testGroup "Ordering laws"
[ QC.testProperty "mulLaw" (ordMulLaw :: r -> r -> r -> Either String String)
, QC.testProperty "addLaw" (ordAddLaw :: r -> r -> r -> Either String String)]
zeroLawsQC :: (Show r, Eq r, DetectableZero r, Arbitrary r) => f r -> TestTree
zeroLawsQC (_ :: f r) = testGroup "Zero laws"
[ QC.testProperty "zeroLaw" (zeroLaw :: r -> Either String String)
, QC.testProperty "zeroIsZero" (once $ zeroIsZero (Proxy :: Proxy r))]
ordLawsSC :: (Show r, Ord r, Semiring r, Serial IO r) => f r -> TestTree
ordLawsSC (_ :: f r) = testGroup "Ordering laws"
[ SC.testProperty "mulLaw" (ordMulLaw :: r -> r -> r -> Either String String)
, SC.testProperty "addLaw" (ordAddLaw :: r -> r -> r -> Either String String)]
zeroLawsSC :: (Show r, Eq r, DetectableZero r, Serial IO r) => f r -> TestTree
zeroLawsSC (_ :: f r) = testGroup "Zero laws"
[ SC.testProperty "zeroLaw" (zeroLaw :: r -> Either String String)
, SC.testProperty "zeroIsZero" (zeroIsZero (Proxy :: Proxy r))]
storableQC :: (Show r, Eq r, Arbitrary r, Storable.Storable r) => f r -> TestTree
storableQC (_ :: f r) =
testGroup
"Storable implementation"
[ QC.testProperty
"unstore . store == id"
(\(xs :: [r]) ->
(Storable.toList |.| Storable.fromList) xs === xs)]
infixr 9 |.|
(|.|) :: (b -> c) -> (a -> b) -> a -> c
(|.|) f g x = f (g x)
{-# NOINLINE (|.|) #-}
type Tup2 a = (a,a)
type Tup3 a = (a,a,a)
type Tup4 a = (a,a,a,a)
type Tup5 a = (a,a,a,a,a)
type Tup6 a = (a,a,a,a,a,a)
type Tup7 a = (a,a,a,a,a,a,a)
type Tup8 a = (a,a,a,a,a,a,a,a)
type Tup9 a = (a,a,a,a,a,a,a,a,a)
refListMul
:: Semiring a
=> [a] -> [a] -> [a]
refListMul [] _ = []
refListMul _ [] = []
refListMul (x:xs) yys@(y:ys) = (x <.> y) : map (x <.>) ys <+> xs <.> yys
typeclassTests :: TestTree
typeclassTests =
testGroup
"typeclass tests"
[ testGroup
"PositiveInfinite"
[ let p = Proxy :: Proxy (PositiveInfinite Int)
in storableQC p]
, testGroup
"NegativeInfinite"
[ let p = Proxy :: Proxy (NegativeInfinite Int)
in storableQC p]
, testGroup
"Infinite"
[ let p = Proxy :: Proxy (Infinite Int)
in storableQC p]]
semiringLawTests :: TestTree
semiringLawTests =
testGroup
"Semiring/StarSemiring Laws"
[ let p = Proxy :: Proxy (ApproxLog Double)
in testGroup "Log" [semiringLawsSC p]
, let p = Proxy :: Proxy (SApproxLog Double)
in testGroup "Log" [semiringLawsSC p]
, let p = Proxy :: Proxy (Map String Int)
in testGroup
"Map"
[localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p]
, let p0 = Proxy :: Proxy (Matrix V0 V0 Integer)
p1 = Proxy :: Proxy (Matrix V1 V1 Integer)
p2 = Proxy :: Proxy (Matrix V2 V2 Integer)
p5 = Proxy :: Proxy (Matrix V5 V5 Integer)
in testGroup
"Matrix"
[ testGroup "0" [semiringLawsQC p0]
, testGroup "1" [semiringLawsQC p1]
, testGroup "2" [semiringLawsQC p2]
, testGroup "5" [semiringLawsQC p5]]
, let p = Proxy :: Proxy Integer
in testGroup "Integer" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, ordLawsQC p]
, let p = Proxy :: Proxy (Func Bool Bool)
in testGroup "Bool -> Bool" [semiringLawsQC p]
, testGroup
"Endo Bool"
[ QC.testProperty
"plusId"
(plusId :: UnaryLaws (EndoFunc (Add Bool)))
, QC.testProperty
"mulId"
(mulId :: UnaryLaws (EndoFunc (Add Bool)))
, QC.testProperty
"annihilateR"
(annihilateR :: UnaryLaws (EndoFunc (Add Bool)))
, zeroLawsQC (Proxy :: Proxy (EndoFunc (Add Bool)))
, QC.testProperty
"plusComm"
(plusComm :: BinaryLaws (EndoFunc (Add Bool)))
, QC.testProperty
"plusAssoc"
(plusAssoc :: TernaryLaws (EndoFunc (Add Bool)))
, QC.testProperty
"mulAssoc"
(mulAssoc :: TernaryLaws (EndoFunc (Add Bool)))
, QC.testProperty
"mulDistribR"
(mulDistribR :: TernaryLaws (EndoFunc (Add Bool)))]
, let p = Proxy :: Proxy (PositiveInfinite Natural)
in testGroup
"PosInf Natural"
[semiringLawsSC p, ordLawsSC p, zeroLawsSC p]
, let p = Proxy :: Proxy Int
in testGroup "Int" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p]
, let p = Proxy :: Proxy (WordOfSize 2)
in testGroup "WordOfSize 2" [semiringLawsSC p, zeroLawsSC p]
, let p = Proxy :: Proxy (Tup2 (WordOfSize 2))
in testGroup "Tup2 (WordOfSize 2)" [semiringLawsSC p, zeroLawsSC p]
, let p = Proxy :: Proxy (Tup3 (WordOfSize 2))
in testGroup "Tup3 (WordOfSize 2)" [semiringLawsQC p, zeroLawsQC p]
, let p = Proxy :: Proxy (Tup4 Int)
in testGroup "Tup4 Int" [semiringLawsQC p, zeroLawsQC p]
, let p = Proxy :: Proxy (Tup5 Int)
in testGroup "Tup5 Int" [semiringLawsQC p, zeroLawsQC p]
, let p = Proxy :: Proxy (Tup6 Int)
in testGroup "Tup6 Int" [semiringLawsQC p, zeroLawsQC p]
, let p = Proxy :: Proxy (Tup7 Int)
in testGroup "Tup7 Int" [semiringLawsQC p, zeroLawsQC p]
, let p = Proxy :: Proxy (Tup8 Int)
in testGroup "Tup8 Int" [semiringLawsQC p, zeroLawsQC p]
, let p = Proxy :: Proxy (Tup9 Int)
in testGroup "Tup9 Int" [semiringLawsQC p, zeroLawsQC p]
, let p = Proxy :: Proxy (Tup2 (PositiveInfinite (WordOfSize 2)))
in testGroup "Tup2 (WordOfSize 2)" [starLawsSC p]
, let p = Proxy :: Proxy (Tup3 (PositiveInfinite (WordOfSize 2)))
in testGroup "Tup3 (WordOfSize 2)" [starLawsSC p]
, let p = Proxy :: Proxy (Tup4 (PositiveInfinite Int))
in testGroup "Tup4 Int" [starLawsQC p]
, let p = Proxy :: Proxy (Tup5 (PositiveInfinite Int))
in testGroup "Tup5 Int" [starLawsQC p]
, let p = Proxy :: Proxy (Tup6 (PositiveInfinite Int))
in testGroup "Tup6 Int" [starLawsQC p]
, let p = Proxy :: Proxy (Tup7 (PositiveInfinite Int))
in testGroup "Tup7 Int" [starLawsQC p]
, let p = Proxy :: Proxy (Tup8 (PositiveInfinite Int))
in testGroup "Tup8 Int" [starLawsQC p]
, let p = Proxy :: Proxy (Tup9 (PositiveInfinite Int))
in testGroup "Tup9 Int" [starLawsQC p]
, testGroup
"Negative Infinite Integer"
[ SC.testProperty
"plusId"
(plusId :: UnaryLaws (NegativeInfinite Integer))
, SC.testProperty
"mulId"
(mulId :: UnaryLaws (NegativeInfinite Integer))
, SC.testProperty
"annihilateR"
(annihilateR :: UnaryLaws (NegativeInfinite Integer))
, zeroLawsSC (Proxy :: Proxy (NegativeInfinite Integer))
, SC.testProperty
"plusComm"
(plusComm :: BinaryLaws (NegativeInfinite Integer))
, ordLawsSC (Proxy :: Proxy (NegativeInfinite Integer))
, SC.testProperty
"plusAssoc"
(plusAssoc :: TernaryLaws (NegativeInfinite Integer))
, SC.testProperty
"mulAssoc"
(mulAssoc :: TernaryLaws (NegativeInfinite Integer))
, SC.testProperty
"mulDistribL"
(mulDistribL :: TernaryLaws (NegativeInfinite Integer))]
, testGroup
"Infinite Integer"
[ SC.testProperty
"plusId"
(plusId :: UnaryLaws (Infinite Integer))
, SC.testProperty "mulId" (mulId :: UnaryLaws (Infinite Integer))
, SC.testProperty
"annihilateR"
(annihilateR :: UnaryLaws (Infinite Integer))
, SC.testProperty
"annihilateL"
(annihilateL :: UnaryLaws (Infinite Integer))
, zeroLawsSC (Proxy :: Proxy (Infinite Integer))
, SC.testProperty
"plusComm"
(plusComm :: BinaryLaws (Infinite Integer))
, ordLawsSC (Proxy :: Proxy (Infinite Integer))
, SC.testProperty
"plusAssoc"
(plusAssoc :: TernaryLaws (Infinite Integer))
, SC.testProperty
"mulAssoc"
(mulAssoc :: TernaryLaws (Infinite Integer))]
, let p = Proxy :: Proxy ()
in testGroup
"()"
[semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]
, let p = Proxy :: Proxy Bool
in testGroup
"Bool"
[semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]
, let p = Proxy :: Proxy Any
in testGroup
"Any"
[semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]
, let p = Proxy :: Proxy All
in testGroup
"All"
[semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]
, let p = Proxy :: Proxy [Integer]
in testGroup
"[Integer]"
[ semiringLawsQC p
, starLawsQC
(Proxy :: Proxy (LimitSize 100 (PositiveInfinite Integer)))
, QC.testProperty
"reference implementation of <.>"
(\xs ys ->
(xs <.> ys) ===
refListMul xs (ys :: [WordOfSize 2]))]
, let p = Proxy :: Proxy (Vector.Vector Int)
in testGroup
"Vector Int"
[ semiringLawsQC p
, QC.testProperty
"reference implementation of <.>"
(\xs ys ->
(xs <.> ys :: [Int]) ===
Vector.toList
(Vector.fromList xs <.> Vector.fromList ys))]
, let p = Proxy :: Proxy (Min (PositiveInfinite Integer))
in testGroup "Min Inf Integer" [semiringLawsSC p, zeroLawsSC p]
, let p = Proxy :: Proxy (Min (Infinite Integer))
in testGroup "Min Inf Integer" [starLawsSC p]
, let p = Proxy :: Proxy (Max (NegativeInfinite Integer))
in testGroup "Max NegInf Integer" [semiringLawsSC p, zeroLawsSC p]
, let p = Proxy :: Proxy (Max (Infinite Integer))
in testGroup "Max Inf Integer" [starLawsSC p]
, let p = Proxy :: Proxy (Free (WordOfSize 2))
in testGroup
"Free (WordOfSize 2)"
[localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p]
, let p = Proxy :: Proxy (Division Integer)
in testGroup "Division Integer" [semiringLawsSC p, zeroLawsSC p]
, let p = Proxy :: Proxy (Łukasiewicz Fraction)
in testGroup "Łukasiewicz Fraction" [semiringLawsSC p, zeroLawsSC p]
, let p = Proxy :: Proxy (Viterbi Fraction)
in testGroup "Viterbi Fraction" [semiringLawsSC p, zeroLawsSC p]]
main :: IO ()
main = do
doctest ["-isrc", "src/"]
defaultMain $ testGroup "Tests" [typeclassTests, semiringLawTests]