semiring-num 1.6.0.1 → 1.6.0.3
raw patch · 8 files changed
+653/−523 lines, 8 filesdep ~QuickCheckdep ~basedep ~smallcheck
Dependency ranges changed: QuickCheck, base, smallcheck
Files
- semiring-num.cabal +5/−3
- src/Data/Semiring.hs +0/−177
- src/Data/Semiring/Infinite.hs +37/−15
- test/CompUtils.hs +5/−0
- test/Orphans.hs +13/−4
- test/Properties.hs +427/−0
- test/Spec.hs +126/−324
- test/TypeLevel.hs +40/−0
semiring-num.cabal view
@@ -1,5 +1,5 @@ name: semiring-num-version: 1.6.0.1+version: 1.6.0.3 synopsis: Basic semiring class and instances description: Adds a basic semiring class homepage: https://github.com/oisdk/semiring-num@@ -45,12 +45,14 @@ , Fraction , Vectors , LimitSize+ , TypeLevel+ , Properties build-depends: base >=4.9 && <5 , semiring-num- , smallcheck >=0.2.1+ , smallcheck >=1.1.3 , doctest >=0.3.0 , containers >=0.5- , QuickCheck >=1.0+ , QuickCheck >=2.10 , nat-sized-numbers >=0.1.0.0 , tasty >=0.1 , tasty-smallcheck >=0.1
src/Data/Semiring.hs view
@@ -218,7 +218,6 @@ -- 'Control.Applicative.Alternative'. class Semiring a => StarSemiring a where- {-# MINIMAL star | plus #-} star :: a -> a plus :: a -> a star x = one <+> plus x@@ -415,35 +414,11 @@ {-# INLINE one #-} {-# INLINE zero #-} {-# SPECIALISE (<.>) :: BinaryWrapped [] Int #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Int8 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Int16 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Int32 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Int64 #-} {-# SPECIALISE (<.>) :: BinaryWrapped [] Word #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Word8 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Word16 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Word32 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Word64 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Integer #-} {-# SPECIALISE (<.>) :: BinaryWrapped [] Double #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Float #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Natural #-}- {-# SPECIALISE (<.>) :: BinaryWrapped [] Bool #-} {-# SPECIALISE (<+>) :: BinaryWrapped [] Int #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Int8 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Int16 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Int32 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Int64 #-} {-# SPECIALISE (<+>) :: BinaryWrapped [] Word #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Word8 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Word16 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Word32 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Word64 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Integer #-} {-# SPECIALISE (<+>) :: BinaryWrapped [] Double #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Float #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Natural #-}- {-# SPECIALISE (<+>) :: BinaryWrapped [] Bool #-} listAdd :: Semiring a => [a] -> [a] -> [a]@@ -452,20 +427,8 @@ listAdd (x:xs) (y:ys) = (x <+> y) : listAdd xs ys {-# NOINLINE [0] listAdd #-} {-# SPECIALISE listAdd :: BinaryWrapped [] Int #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Int8 #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Int16 #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Int32 #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Int64 #-} {-# SPECIALISE listAdd :: BinaryWrapped [] Word #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Word8 #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Word16 #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Word32 #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Word64 #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Integer #-} {-# SPECIALISE listAdd :: BinaryWrapped [] Double #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Float #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Natural #-}-{-# SPECIALISE listAdd :: BinaryWrapped [] Bool #-} -- a definition of addition which can be fused on its left argument listAddFBL :: Semiring a => ListBuilder a -> [a] -> [a]@@ -475,20 +438,8 @@ type FBL a = ListBuilder a -> [a] -> [a] {-# SPECIALISE listAddFBL :: FBL Int #-}-{-# SPECIALISE listAddFBL :: FBL Int8 #-}-{-# SPECIALISE listAddFBL :: FBL Int16 #-}-{-# SPECIALISE listAddFBL :: FBL Int32 #-}-{-# SPECIALISE listAddFBL :: FBL Int64 #-} {-# SPECIALISE listAddFBL :: FBL Word #-}-{-# SPECIALISE listAddFBL :: FBL Word8 #-}-{-# SPECIALISE listAddFBL :: FBL Word16 #-}-{-# SPECIALISE listAddFBL :: FBL Word32 #-}-{-# SPECIALISE listAddFBL :: FBL Word64 #-}-{-# SPECIALISE listAddFBL :: FBL Integer #-} {-# SPECIALISE listAddFBL :: FBL Double #-}-{-# SPECIALISE listAddFBL :: FBL Float #-}-{-# SPECIALISE listAddFBL :: FBL Natural #-}-{-# SPECIALISE listAddFBL :: FBL Bool #-} -- a definition of addition which can be fused on its right argument listAddFBR :: Semiring a => [a] -> ListBuilder a -> [a]@@ -498,20 +449,8 @@ type FBR a = [a] -> ListBuilder a -> [a] {-# SPECIALISE listAddFBR :: FBR Int #-}-{-# SPECIALISE listAddFBR :: FBR Int8 #-}-{-# SPECIALISE listAddFBR :: FBR Int16 #-}-{-# SPECIALISE listAddFBR :: FBR Int32 #-}-{-# SPECIALISE listAddFBR :: FBR Int64 #-} {-# SPECIALISE listAddFBR :: FBR Word #-}-{-# SPECIALISE listAddFBR :: FBR Word8 #-}-{-# SPECIALISE listAddFBR :: FBR Word16 #-}-{-# SPECIALISE listAddFBR :: FBR Word32 #-}-{-# SPECIALISE listAddFBR :: FBR Word64 #-}-{-# SPECIALISE listAddFBR :: FBR Integer #-} {-# SPECIALISE listAddFBR :: FBR Double #-}-{-# SPECIALISE listAddFBR :: FBR Float #-}-{-# SPECIALISE listAddFBR :: FBR Natural #-}-{-# SPECIALISE listAddFBR :: FBR Bool #-} type ListBuilder a = forall b. (a -> b -> b) -> b -> b @@ -527,13 +466,7 @@ xst = star x {-# SPECIALISE star :: [Bool] -> [Bool] #-} {-# SPECIALISE star :: [Min Double] -> [Min Double] #-}- {-# SPECIALISE star :: [Min Float] -> [Min Float] #-}- {-# SPECIALISE star :: [Min CDouble] -> [Min CDouble] #-}- {-# SPECIALISE star :: [Min CFloat] -> [Min CFloat] #-} {-# SPECIALISE star :: [Max Double] -> [Max Double] #-}- {-# SPECIALISE star :: [Max Float] -> [Max Float] #-}- {-# SPECIALISE star :: [Max CDouble] -> [Max CDouble] #-}- {-# SPECIALISE star :: [Max CFloat] -> [Max CFloat] #-} instance DetectableZero a => DetectableZero [a] where@@ -568,31 +501,11 @@ !slen = Vector.length signal !klen = Vector.length kernel {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Double #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Float #-} {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Bool #-} {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int8 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int16 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int32 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int64 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word8 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word16 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word32 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word64 #-} {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Double #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Float #-} {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Bool #-} {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int8 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int16 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int32 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int64 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word8 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word16 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word32 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word64 #-} instance DetectableZero a => DetectableZero (Vector.Vector a) where isZero = Vector.all isZero@@ -625,31 +538,11 @@ slen = UnboxedVector.length signal klen = UnboxedVector.length kernel {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Double #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Float #-} {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Bool #-} {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int8 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int16 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int32 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int64 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word8 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word16 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word32 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word64 #-} {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Double #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Float #-} {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Bool #-} {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int8 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int16 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int32 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int64 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word8 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word16 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word32 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word64 #-} instance (UnboxedVector.Unbox a, DetectableZero a) => DetectableZero (UnboxedVector.Vector a) where isZero = UnboxedVector.all isZero@@ -685,31 +578,11 @@ slen = StorableVector.length signal klen = StorableVector.length kernel {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Double #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Float #-} {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Bool #-} {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int8 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int16 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int32 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int64 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word8 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word16 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word32 #-}- {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word64 #-} {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Double #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Float #-} {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Bool #-} {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int8 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int16 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int32 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int64 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word8 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word16 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word32 #-}- {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word64 #-} instance (StorableVector.Storable a, DetectableZero a) => DetectableZero (StorableVector.Vector a) where@@ -790,9 +663,7 @@ {-# INLINE add #-} {-# SPECIALISE (<.>) :: BinaryWrapped Log Double #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Log Float #-} {-# SPECIALISE (<+>) :: BinaryWrapped Log Double #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Log Float #-} instance (Precise a, RealFloat a) => DetectableZero (Log a) where isZero = isZeroEq@@ -809,9 +680,7 @@ {-# INLINE zero #-} {-# SPECIALISE (<.>) :: BinaryWrapped SignedLog Double #-}- {-# SPECIALISE (<.>) :: BinaryWrapped SignedLog Float #-} {-# SPECIALISE (<+>) :: BinaryWrapped SignedLog Double #-}- {-# SPECIALISE (<+>) :: BinaryWrapped SignedLog Float #-} instance (Precise a, RealFloat a) => DetectableZero (SignedLog a) where isZero = isZeroEq@@ -1112,9 +981,6 @@ {-# INLINE (<>) #-} stimes = stimesIdempotent {-# SPECIALISE (<>) :: BinaryWrapped Max Double #-}- {-# SPECIALISE (<>) :: BinaryWrapped Max Float #-}- {-# SPECIALISE (<>) :: BinaryWrapped Max CDouble #-}- {-# SPECIALISE (<>) :: BinaryWrapped Max CFloat #-} instance Ord a => Semigroup (Min a) where@@ -1122,9 +988,6 @@ {-# INLINE (<>) #-} stimes = stimesIdempotent {-# SPECIALISE (<>) :: BinaryWrapped Min Double #-}- {-# SPECIALISE (<>) :: BinaryWrapped Min Float #-}- {-# SPECIALISE (<>) :: BinaryWrapped Min CDouble #-}- {-# SPECIALISE (<>) :: BinaryWrapped Min CFloat #-} -- | >>> (getMax . foldMap Max) [1..10] -- 10.0@@ -1135,9 +998,6 @@ {-# INLINE mempty #-} {-# INLINE mappend #-} {-# SPECIALISE mappend :: BinaryWrapped Max Double #-}- {-# SPECIALISE mappend :: BinaryWrapped Max Float #-}- {-# SPECIALISE mappend :: BinaryWrapped Max CDouble #-}- {-# SPECIALISE mappend :: BinaryWrapped Max CFloat #-} -- | >>> (getMin . foldMap Min) [1..10] -- 1.0@@ -1148,9 +1008,6 @@ {-# INLINE mempty #-} {-# INLINE mappend #-} {-# SPECIALISE mappend :: BinaryWrapped Min Double #-}- {-# SPECIALISE mappend :: BinaryWrapped Min Float #-}- {-# SPECIALISE mappend :: BinaryWrapped Min CDouble #-}- {-# SPECIALISE mappend :: BinaryWrapped Min CFloat #-} instance (Semiring a, Ord a, HasNegativeInfinity a) => Semiring (Max a) where@@ -1164,21 +1021,7 @@ {-# INLINE (<.>) #-} {-# SPECIALISE (<+>) :: BinaryWrapped Max Double #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Max Float #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Max CDouble #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Max CFloat #-} {-# SPECIALISE (<.>) :: BinaryWrapped Max Double #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Max Float #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Max CDouble #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Max CFloat #-}- {-# SPECIALISE one :: Max Double #-}- {-# SPECIALISE one :: Max Float #-}- {-# SPECIALISE one :: Max CDouble #-}- {-# SPECIALISE one :: Max CFloat #-}- {-# SPECIALISE zero :: Max Double #-}- {-# SPECIALISE zero :: Max Float #-}- {-# SPECIALISE zero :: Max CDouble #-}- {-# SPECIALISE zero :: Max CFloat #-} instance (Semiring a, Ord a, HasPositiveInfinity a) => Semiring (Min a) where@@ -1191,21 +1034,7 @@ {-# INLINE (<+>) #-} {-# INLINE (<.>) #-} {-# SPECIALISE (<+>) :: BinaryWrapped Min Double #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Min Float #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Min CDouble #-}- {-# SPECIALISE (<+>) :: BinaryWrapped Min CFloat #-} {-# SPECIALISE (<.>) :: BinaryWrapped Min Double #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Min Float #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Min CDouble #-}- {-# SPECIALISE (<.>) :: BinaryWrapped Min CFloat #-}- {-# SPECIALISE one :: Min Double #-}- {-# SPECIALISE one :: Min Float #-}- {-# SPECIALISE one :: Min CDouble #-}- {-# SPECIALISE one :: Min CFloat #-}- {-# SPECIALISE zero :: Min Double #-}- {-# SPECIALISE zero :: Min Float #-}- {-# SPECIALISE zero :: Min CDouble #-}- {-# SPECIALISE zero :: Min CFloat #-} instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) => StarSemiring (Max a) where@@ -1213,9 +1042,6 @@ | x > zero = Max positiveInfinity | otherwise = Max zero {-# SPECIALISE star :: Max Double -> Max Double #-}- {-# SPECIALISE star :: Max Float -> Max Float #-}- {-# SPECIALISE star :: Max CDouble -> Max CDouble #-}- {-# SPECIALISE star :: Max CFloat -> Max CFloat #-} instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) => StarSemiring (Min a) where@@ -1223,9 +1049,6 @@ | x < zero = Min negativeInfinity | otherwise = Min zero {-# SPECIALISE star :: Min Double -> Min Double #-}- {-# SPECIALISE star :: Min Float -> Min Float #-}- {-# SPECIALISE star :: Min CDouble -> Min CDouble #-}- {-# SPECIALISE star :: Min CFloat -> Min CFloat #-} instance (Semiring a, Ord a, HasPositiveInfinity a) => DetectableZero (Min a) where
src/Data/Semiring/Infinite.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}@@ -28,7 +29,7 @@ sizeOf) import Data.Coerce-import Data.Monoid+import Data.Semigroup as Sem import Data.Bool import Data.Semiring@@ -262,28 +263,49 @@ enumFrom Negative = Negative : map pure [minBound..] ++ [Positive] enumFrom (Finite x) = map pure (enumFrom x) ++ [Positive] -instance Monoid a => Monoid (NegativeInfinite a) where+-- Follows advice for compatible Semigroup/Monoid code from+-- https://prime.haskell.org/wiki/Libraries/Proposals/SemigroupMonoid#Writingcompatiblecode++instance Sem.Semigroup a => Sem.Semigroup (NegativeInfinite a) where+ {-# INLINE (<>) #-}+ (<>) = liftA2 (<>)++instance (Sem.Semigroup a, Monoid a) => Monoid (NegativeInfinite a) where {-# INLINE mempty #-}- {-# INLINE mappend #-} mempty = pure mempty- mappend = liftA2 mappend+#if !(MIN_VERSION_base(4,11,0))+ {-# INLINE mappend #-}+ mappend = (<>)+#endif -instance Monoid a => Monoid (PositiveInfinite a) where+instance Sem.Semigroup a => Sem.Semigroup (PositiveInfinite a) where+ {-# INLINE (<>) #-}+ (<>) = liftA2 (<>)++instance (Sem.Semigroup a, Monoid a) => Monoid (PositiveInfinite a) where {-# INLINE mempty #-}- {-# INLINE mappend #-} mempty = pure mempty- mappend = liftA2 mappend+#if !(MIN_VERSION_base(4,11,0))+ {-# INLINE mappend #-}+ mappend = (<>)+#endif -instance Monoid a => Monoid (Infinite a) where+instance Sem.Semigroup a => Sem.Semigroup (Infinite a) where+ {-# INLINE (<>) #-}+ Negative <> Positive = Positive+ Positive <> Negative = Positive+ Finite x <> Finite y = pure (x <> y)+ Negative <> _ = Negative+ Positive <> _ = Positive+ _ <> y = y++instance (Sem.Semigroup a, Monoid a) => Monoid (Infinite a) where {-# INLINE mempty #-}- {-# INLINE mappend #-} mempty = pure mempty- Negative `mappend` Positive = Positive- Positive `mappend` Negative = Positive- Finite x `mappend` Finite y = pure (x `mappend` y)- Negative `mappend` _ = Negative- Positive `mappend` _ = Positive- _ `mappend` y = y+#if !(MIN_VERSION_base(4,11,0))+ {-# INLINE mappend #-}+ mappend = (<>)+#endif instance Num a => Num (NegativeInfinite a) where fromInteger = pure . fromInteger
test/CompUtils.hs view
@@ -16,3 +16,8 @@ infixl 4 <#$> (<#$>) :: Coercible (f a) (f b) => (a -> b) -> f a -> f b (<#$>) _ = coerce++infixr 9 |.|+(|.|) :: (b -> c) -> (a -> b) -> a -> c+(|.|) f g x = f (g x)+{-# NOINLINE (|.|) #-}
test/Orphans.hs view
@@ -6,7 +6,8 @@ module Orphans where -import Test.QuickCheck hiding (Positive(..), generate)+import Test.QuickCheck as QC hiding (Positive(..), generate)+import Test.QuickCheck.Poly import Test.SmallCheck.Series hiding (Positive(..)) import qualified Test.SmallCheck.Series as SC @@ -96,9 +97,6 @@ instance (Monad m, Serial m a) => Serial m (Infinite a) where series = fmap (either (bool Positive Negative) Finite) series -instance Monad m => Serial m Natural where- series = generate (`take` [0..])- instance Monad m => Serial m Any where series = fmap Any series @@ -111,6 +109,10 @@ instance (Monad m, Serial m a) => Serial m (Max a) where series = fmap Max series +instance Arbitrary Natural where+ arbitrary = fmap (fromInteger . QC.getNonNegative) arbitrary+ shrink = fmap (fromInteger . QC.getNonNegative) . shrink . QC.NonNegative . toInteger+ instance (Ord a, Arbitrary a) => Arbitrary (Free a) where arbitrary = fmap Free arbitrary @@ -135,3 +137,10 @@ Arbitrary (Storable.Vector a) where arbitrary = fmap Storable.fromList arbitrary shrink = map Storable.fromList . shrink . Storable.toList++deriving instance Ord A++instance Read A where+ readsPrec p xs =+ [ (A x, rs)+ | (x,rs) <- readsPrec p xs ]
+ test/Properties.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}++module Properties where++import Data.Semiring+import Test.Semiring++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.QuickCheck.Poly++import qualified Data.Vector.Storable as Storable+import Data.Proxy+import Data.Typeable+import Data.Functor.Classes+import GHC.Exts (IsList(..))++import TypeLevel+import Orphans ()+import CompUtils++--------------------------------------------------------------------------------+-- Property lists, generic to the test framework+--------------------------------------------------------------------------------++semiringLawsCL+ :: (Show r+ ,Eq r+ ,Semiring r+ ,testable (r -> Either String String)+ ,testable (r -> r -> Either String String)+ ,testable (r -> r -> r -> Either String String))+ => Proxy testable+ -> (forall f. testable f =>+ String -> f -> TestTree)+ -> Proxy r+ -> [TestTree]+semiringLawsCL _ f (_ :: Proxy r) =+ [ f "plusId" (plusId :: r -> Either String String)+ , f "mulId" (mulId :: r -> Either String String)+ , f "annihilateL" (annihilateL :: r -> Either String String)+ , f "annihilateR" (annihilateR :: r -> Either String String)+ , f "plusComm" (plusComm :: r -> r -> Either String String)+ , f "plusAssoc" (plusAssoc :: r -> r -> r -> Either String String)+ , f "mulAssoc" (mulAssoc :: r -> r -> r -> Either String String)+ , f "mulDistribL" (mulDistribL :: r -> r -> r -> Either String String)+ , f "mulDistribR" (mulDistribR :: r -> r -> r -> Either String String)]++starLawsCL+ :: (Show r, Eq r, StarSemiring r, testable (r -> Either String String))+ => Proxy testable+ -> (forall f. testable f =>+ String -> f -> TestTree)+ -> Proxy r+ -> [TestTree]+starLawsCL _ f (_ :: Proxy r) =+ [ f "starLaw" (starLaw :: r -> Either String String)+ , f "plusLaw" (plusLaw :: r -> Either String String)]++ordLawsCL+ :: (Show r, Ord r, Semiring r, testable (r -> r -> r -> Either String String))+ => Proxy testable+ -> (forall f. testable f =>+ String -> f -> TestTree)+ -> Proxy r+ -> [TestTree]+ordLawsCL _ f (_ :: Proxy r) =+ [ f "mulLaw" (ordMulLaw :: r -> r -> r -> Either String String)+ , f "addLaw" (ordAddLaw :: r -> r -> r -> Either String String)]++--------------------------------------------------------------------------------+-- Property lists: SmallCheck+--------------------------------------------------------------------------------++semiringLawsSCL :: (Show r, Eq r, Semiring r, Serial IO r) => f r -> [TestTree]+semiringLawsSCL (_ :: f r) =+ semiringLawsCL+ (Proxy :: Proxy (SC.Testable IO))+ SC.testProperty+ (Proxy :: Proxy r)++starLawsSCL+ :: (Show r, Eq r, StarSemiring r, Serial IO r)+ => f r -> [TestTree]+starLawsSCL (_ :: f r) =+ starLawsCL+ (Proxy :: Proxy (SC.Testable IO))+ SC.testProperty+ (Proxy :: Proxy r)++zeroLawsSCL+ :: (Show r, Eq r, DetectableZero r, Serial IO r)+ => f r -> [TestTree]+zeroLawsSCL (_ :: f r) =+ [ SC.testProperty "zeroLaw" (zeroLaw :: r -> Either String String)+ , SC.testProperty "zeroIsZero" (zeroIsZero (Proxy :: Proxy r))]++ordLawsSCL+ :: (Show r, Ord r, Semiring r, Serial IO r)+ => f r -> [TestTree]+ordLawsSCL (_ :: f r) =+ ordLawsCL+ (Proxy :: Proxy (SC.Testable IO))+ SC.testProperty+ (Proxy :: Proxy r)++--------------------------------------------------------------------------------+-- Property lists: QuickCheck+--------------------------------------------------------------------------------++semiringLawsQCL :: (Show r, Eq r, Semiring r, Arbitrary r) => f r -> [TestTree]+semiringLawsQCL (_ :: f r) =+ semiringLawsCL+ (Proxy :: Proxy QC.Testable)+ QC.testProperty+ (Proxy :: Proxy r)++starLawsQCL+ :: (Show r, Eq r, StarSemiring r, Arbitrary r)+ => f r -> [TestTree]+starLawsQCL (_ :: f r) =+ starLawsCL (Proxy :: Proxy QC.Testable) QC.testProperty (Proxy :: Proxy r)++zeroLawsQCL+ :: (Show r, Eq r, DetectableZero r, Arbitrary r)+ => f r -> [TestTree]+zeroLawsQCL (_ :: f r) =+ [ QC.testProperty "zeroLaw" (zeroLaw :: r -> Either String String)+ , QC.testProperty "zeroIsZero" (once $ zeroIsZero (Proxy :: Proxy r))]++ordLawsQCL+ :: (Show r, Ord r, Semiring r, Arbitrary r)+ => f r -> [TestTree]+ordLawsQCL (_ :: f r) =+ ordLawsCL+ (Proxy :: Proxy QC.Testable)+ QC.testProperty+ (Proxy :: Proxy r)++storableQCL+ :: (Show r, Eq r, Arbitrary r, Storable.Storable r)+ => f r -> [TestTree]+storableQCL (_ :: f r) =+ [ QC.testProperty+ "unstore . store == id"+ (\(xs :: [r]) ->+ (Storable.toList |.| Storable.fromList) xs === xs)]++liftedQCL+ :: (Show1 r+ ,Eq1 r+ ,Ord1 r+ ,Read1 r+ ,Arbitrary (r A)+ ,Show (r A)+ ,Eq (r A)+ ,Ord (r A)+ ,Read A)+ => f r -> [TestTree]+liftedQCL (_ :: f r) =+ [ testGroup+ "Eq1"+ [ QC.testProperty+ "x == x"+ (\(x :: r A) ->+ eq1 x x)+ , QC.testProperty+ "same as =="+ (\(x :: r A) (y :: r A) ->+ counterexample (show (x, y)) ((x == y) == eq1 x y))]+ , testGroup+ "Ord1"+ [ QC.testProperty+ "cmp x x == EQ"+ (\(x :: r A) ->+ counterexample (show x) (compare1 x x === EQ))+ , QC.testProperty+ "compare1 == compare"+ (\(x :: r A) (y :: r A) ->+ counterexample+ (show (x, y))+ (compare x y == compare1 x y))]+ , testGroup+ "Show1"+ [ QC.testProperty+ "show1 == show"+ (\(x :: r A) ->+ liftShowsPrec showsPrec showList 0 x "" === show x)]+ , testGroup+ "Read1"+ [ QC.testProperty+ "read1 . show == id"+ (\(x :: r A) ->+ (liftReadsPrec readsPrec readList 0 . show) x ===+ [(x, "")])]]++--------------------------------------------------------------------------------+-- Single-type tests: SmallCheck+--------------------------------------------------------------------------------++ordLawsSC :: (Show r, Ord r, Semiring r, Serial IO r) => f r -> TestTree+ordLawsSC (p :: f r) = testGroup "Ordering laws" (ordLawsSCL p)++zeroLawsSC :: (Show r, Eq r, DetectableZero r, Serial IO r) => f r -> TestTree+zeroLawsSC (p :: f r) = testGroup "Zero laws" (zeroLawsSCL p)++--------------------------------------------------------------------------------+-- Single-type tests: QuickCheck+--------------------------------------------------------------------------------++semiringLawsQC+ :: (Show r, Eq r, Semiring r, Arbitrary r)+ => f r -> TestTree+semiringLawsQC (p :: f r) = testGroup "Semiring Laws" (semiringLawsQCL p)++zeroLawsQC :: (Show r, Eq r, DetectableZero r, Arbitrary r) => f r -> TestTree+zeroLawsQC (p :: f r) = testGroup "Zero laws" (zeroLawsQCL p)++refListMulQC+ :: (Semiring (Item t), Semiring t, Eq (Item t), Show (Item t), IsList t)+ => Proxy t -> [Item t] -> [Item t] -> Property+refListMulQC (_ :: Proxy t) xs ys =+ refListMul xs ys ===+ (toList :: t -> [Item t]) (fromList xs <.> fromList ys)+ where+ refListMul [] _ = []+ refListMul _ [] = []+ refListMul (x:xs') yys@(y:ys') = (x <.> y) : map (x <.>) ys' <+> xs' <.> yys++--------------------------------------------------------------------------------+-- Multi-type tests: SmallCheck+--------------------------------------------------------------------------------++semiringLawsSCT+ :: (Reifiable xs+ ,AllAre (Diffable & Semiring & Serial IO) xs)+ => Proxy xs -> TestTree+semiringLawsSCT p =+ testGroup+ "Semiring Laws"+ (reify+ (Proxy :: Proxy (Diffable & Semiring & Serial IO))+ p+ (nameType semiringLawsSCL))++starLawsSCT+ :: (Reifiable xs+ ,AllAre (Diffable & StarSemiring & Serial IO) xs)+ => Proxy xs -> TestTree+starLawsSCT p =+ testGroup+ "Star Laws"+ (reify+ (Proxy :: Proxy (Diffable & StarSemiring & Serial IO))+ p+ (nameType starLawsSCL))++ordLawsSCT+ :: (Reifiable xs+ ,AllAre (Diffable & Serial IO & Semiring & Ord) xs)+ => Proxy xs -> TestTree+ordLawsSCT p =+ testGroup+ "Ordering laws"+ (reify+ (Proxy :: Proxy (Diffable & Serial IO & Semiring & Ord))+ p+ (nameType ordLawsSCL))++zeroLawsSCT+ :: (Reifiable xs+ ,AllAre (Diffable & Serial IO & DetectableZero) xs)+ => Proxy xs -> TestTree+zeroLawsSCT p =+ testGroup+ "Zero laws"+ (reify+ (Proxy :: Proxy (Diffable & Serial IO & DetectableZero))+ p+ (nameType zeroLawsSCL))++--------------------------------------------------------------------------------+-- Multi-type tests: QuickCheck+--------------------------------------------------------------------------------++starLawsQCT+ :: (Reifiable xs+ ,AllAre (Diffable & StarSemiring & Arbitrary) xs)+ => Proxy xs -> TestTree+starLawsQCT p =+ testGroup+ "Star Laws"+ (reify+ (Proxy :: Proxy (Diffable & StarSemiring & Arbitrary))+ p+ (nameType starLawsQCL))++semiringLawsQCT+ :: (Reifiable xs+ ,AllAre (Show & Eq & Semiring & Arbitrary & Typeable) xs)+ => Proxy xs -> TestTree+semiringLawsQCT p =+ testGroup+ "Semiring Laws"+ (reify+ (Proxy :: Proxy (Show & Eq & Semiring & Arbitrary & Typeable))+ p+ (nameType semiringLawsQCL))++ordLawsQCT+ :: (Reifiable xs+ ,AllAre (Diffable & Arbitrary & Semiring & Ord) xs)+ => Proxy xs -> TestTree+ordLawsQCT p =+ testGroup+ "Ordering laws"+ (reify+ (Proxy :: Proxy (Diffable & Arbitrary & Semiring & Ord))+ p+ (nameType ordLawsQCL))++zeroLawsQCT+ :: (Reifiable xs+ ,AllAre (Diffable & Arbitrary & DetectableZero) xs)+ => Proxy xs -> TestTree+zeroLawsQCT p =+ testGroup+ "Zero laws"+ (reify+ (Proxy :: Proxy (Diffable & Arbitrary & DetectableZero))+ p+ (nameType zeroLawsQCL))++storableQCT+ :: (Reifiable xs+ ,AllAre (Diffable & Arbitrary & Storable.Storable) xs)+ => Proxy xs -> TestTree+storableQCT p =+ testGroup+ "Storable implementation"+ (reify+ (Proxy :: Proxy (Diffable & Arbitrary & Storable.Storable))+ p+ (nameType storableQCL))++class (IsList t+ ,Semiring (Item t)+ ,Arbitrary (Item t)+ ,Show (Item t)+ ,Eq (Item t)+ ,Typeable t+ ,Semiring t) =>+ ListPoly t+instance (IsList t+ ,Semiring (Item t)+ ,Arbitrary (Item t)+ ,Show (Item t)+ ,Eq (Item t)+ ,Typeable t+ ,Semiring t) =>+ ListPoly t++refListMulQCT+ :: (Reifiable xs, AllAre ListPoly xs)+ => Proxy xs -> TestTree+refListMulQCT p =+ testGroup+ "Reference convolution"+ (reify+ (Proxy :: Proxy ListPoly)+ p+ (\(t :: Proxy l) ->+ QC.testProperty (show (typeRep t)) (refListMulQC t)))++class (Show1 r+ ,Eq1 r+ ,Ord1 r+ ,Read1 r+ ,Arbitrary (r A)+ ,Show (r A)+ ,Eq (r A)+ ,Ord (r A)+ ,Typeable (r A)) =>+ Lifted r+instance (Show1 r+ ,Eq1 r+ ,Ord1 r+ ,Read1 r+ ,Arbitrary (r A)+ ,Show (r A)+ ,Eq (r A)+ ,Ord (r A)+ ,Typeable (r A)) =>+ Lifted r++liftedQCT+ :: (Reifiable xs, AllAre Lifted xs)+ => Proxy xs -> TestTree+liftedQCT p =+ testGroup+ "Lifted Classes"+ (reify+ (Proxy :: Proxy Lifted)+ p+ (\(t :: Proxy f) ->+ testGroup+ (show (typeRep (Proxy :: Proxy (f A))))+ (liftedQCL t)))++--------------------------------------------------------------------------------+-- Utils+--------------------------------------------------------------------------------++nameType :: Typeable a => (Proxy a -> [TestTree]) -> Proxy a -> TestTree+nameType f p = testGroup (show (typeRep p)) (f p)++type Diffable = Show & Eq & Typeable
test/Spec.hs view
@@ -6,12 +6,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Data.Proxy-+import Data.Typeable import Data.Monoid import Data.Map.Strict (Map)@@ -21,20 +20,13 @@ import qualified Data.Vector.Unboxed as Unboxed import Data.Semiring-import Data.Semiring.Free import Data.Semiring.Infinite import Data.Semiring.Numeric -import Data.Functor.Classes- import Numeric.Natural import Numeric.Sized.WordOfSize import Test.DocTest-import Test.QuickCheck hiding (Positive (..), generate,- (.&.))-import Test.QuickCheck.Poly-import Test.SmallCheck.Series hiding (Positive) import Test.Tasty import qualified Test.Tasty.QuickCheck as QC import qualified Test.Tasty.SmallCheck as SC@@ -47,133 +39,7 @@ 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 (|.|) #-}--deriving instance Ord A--instance Read A where- readsPrec p xs =- [ (A x, rs)- | (x,rs) <- readsPrec p xs ]--liftedQC- :: (Show1 r- ,Eq1 r- ,Ord1 r- ,Read1 r- ,Arbitrary (r A)- ,Show (r A)- ,Eq (r A)- ,Ord (r A)- ,Read A)- => f (r b) -> TestTree-liftedQC (_ :: f (r b)) =- testGroup- "liftedClasses"- [ testGroup- "Eq1"- [ QC.testProperty- "x == x"- (\(x :: r A) ->- eq1 x x)- , QC.testProperty- "same as =="- (\(x :: r A) (y :: r A) ->- counterexample (show (x, y)) ((x == y) == eq1 x y))]- , testGroup- "Ord1"- [ QC.testProperty- "cmp x x == EQ"- (\(x :: r A) ->- counterexample (show x) (compare1 x x === EQ))- , QC.testProperty- "compare1 == compare"- (\(x :: r A) (y :: r A) ->- counterexample- (show (x, y))- (compare x y == compare1 x y))]- , testGroup- "Show1"- [ QC.testProperty- "show1 == show"- (\(x :: r A) ->- liftShowsPrec showsPrec showList 0 x "" === show x)]- , testGroup- "Read1"- [ QC.testProperty- "read1 . show == id"- (\(x :: r A) ->- (liftReadsPrec readsPrec readList 0 . show) x ===- [(x, "")])]]+import Properties type Tup2 a = (a,a) type Tup3 a = (a,a,a)@@ -184,73 +50,139 @@ 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+groupType :: Typeable a => Proxy a -> [Proxy a -> TestTree] -> TestTree+groupType p = testGroup (show (typeRep p)) . map ($p) typeclassTests :: TestTree typeclassTests = testGroup "typeclass tests"- [ let p = Proxy :: Proxy (PositiveInfinite Int)- in testGroup "PositiveInfinite" [storableQC p, liftedQC p]- , let p = Proxy :: Proxy (NegativeInfinite Int)- in testGroup "NegativeInfinite" [storableQC p, liftedQC p]- , let p = Proxy :: Proxy (Infinite Int)- in testGroup "Infinite" [storableQC p, liftedQC p]- , let p = Proxy :: Proxy (Add A)- in testGroup "Add" [liftedQC p]- , let p = Proxy :: Proxy (Mul A)- in testGroup "Mul" [liftedQC p]- , let p = Proxy :: Proxy (Max A)- in testGroup "Max" [liftedQC p]- , let p = Proxy :: Proxy (Min A)- in testGroup "Min" [liftedQC p]- , let p = Proxy :: Proxy (Bottleneck A)- in testGroup "Min" [liftedQC p]- , let p = Proxy :: Proxy (Division A)- in testGroup "Min" [liftedQC p]- , let p = Proxy :: Proxy (Łukasiewicz A)- in testGroup "Min" [liftedQC p]- , let p = Proxy :: Proxy (Viterbi A)- in testGroup "Min" [liftedQC p]- , let p = Proxy :: Proxy (PosFrac A)- in testGroup "Min" [liftedQC p]- , let p = Proxy :: Proxy (PosInt A)- in testGroup "Min" [liftedQC p]- ]+ [ storableQCT (Proxy :: Proxy+ [ PositiveInfinite Int+ , NegativeInfinite Int+ , Infinite Int+ ])+ , liftedQCT (Proxy :: Proxy+ [ PositiveInfinite+ , NegativeInfinite+ , Infinite+ , Add+ , Mul+ , Max+ , Min+ , Bottleneck+ , Division+ , Łukasiewicz+ , Viterbi+ , PosFrac+ , PosInt+ ])] 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]+ [ semiringLawsSCT (Proxy :: Proxy+ [ ApproxLog Double+ , SApproxLog Double+ , Integer+ , PositiveInfinite Natural+ , Int+ , WordOfSize 2+ , Tup2 (WordOfSize 2)+ , ()+ , Bool+ , Any+ , All+ , Min (PositiveInfinite Integer)+ , Max (NegativeInfinite Integer)+ , Division Integer+ , Viterbi Fraction+ , Łukasiewicz Fraction+ ])+ , semiringLawsQCT (Proxy :: Proxy+ [ Matrix V0 V0 Integer+ , Matrix V1 V1 Integer+ , Matrix V2 V2 Integer+ , Matrix V5 V5 Integer+ , Func Bool Bool+ , Tup3 (WordOfSize 2)+ , Tup4 Int+ , Tup5 Int+ , Tup6 Int+ , Tup7 Int+ , Tup8 Int+ , Tup9 Int+ , [Int]+ , Vector.Vector Int+ , Storable.Vector Int+ , Unboxed.Vector Int+ ])+ , starLawsQCT (Proxy :: Proxy+ [ Tup4 (PositiveInfinite Int)+ , Tup5 (PositiveInfinite Int)+ , Tup6 (PositiveInfinite Int)+ , Tup7 (PositiveInfinite Int)+ , Tup8 (PositiveInfinite Int)+ , Tup9 (PositiveInfinite Int)+ , LimitSize 100 (PositiveInfinite Integer)+ ])+ , starLawsSCT (Proxy :: Proxy+ [ Tup2 (PositiveInfinite (WordOfSize 2))+ , Tup3 (PositiveInfinite (WordOfSize 2))+ , ()+ , Bool+ , Any+ , All+ , Min (Infinite Integer)+ , Max (Infinite Integer)+ ])+ , ordLawsQCT (Proxy :: Proxy '[])+ , ordLawsSCT (Proxy :: Proxy+ [ Integer+ , PositiveInfinite Natural+ , Int+ , ()+ , Bool+ , Any+ , All+ ])+ , zeroLawsQCT (Proxy :: Proxy+ [ Tup3 (WordOfSize 2)+ , Tup4 Int+ , Tup5 Int+ , Tup6 Int+ , Tup7 Int+ , Tup8 Int+ , Tup9 Int+ ])+ , zeroLawsSCT (Proxy :: Proxy+ [ Integer+ , PositiveInfinite Natural+ , Int+ , WordOfSize 2+ , Tup2 (WordOfSize 2)+ , ()+ , Bool+ , Any+ , All+ , Min (PositiveInfinite Integer)+ , Max (NegativeInfinite Integer)+ , Division Integer+ , Viterbi Fraction+ , Łukasiewicz Fraction+ ])+ , refListMulQCT (Proxy :: Proxy+ [ [Int]+ , Vector.Vector Int+ , Unboxed.Vector Int+ , Storable.Vector Int+ , Unboxed.Vector (NegativeInfinite Int)+ , Unboxed.Vector (Infinite Int)+ ])+ , groupType+ (Proxy :: Proxy (Map String Int))+ [localOption (QC.QuickCheckMaxSize 10) . semiringLawsQC] , testGroup "Endo Bool" [ QC.testProperty@@ -275,46 +207,6 @@ , 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@@ -363,97 +255,7 @@ , 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 (Storable.Vector Int)- in testGroup- "Storable 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 (Unboxed.Vector Int)- in testGroup- "Unboxed Vector Int"- [ semiringLawsQC p- , QC.testProperty- "reference implementation of <.>"- (\xs ys ->- (xs <.> ys :: [Int]) ===- Unboxed.toList- (Unboxed.fromList xs <.> Unboxed.fromList ys))]- , testGroup- "Unboxed Vector (NegativeInfinite Int)"- [ QC.testProperty- "reference implementation of <.>"- (\xs ys ->- (xs <.> ys :: [NegativeInfinite Int]) ===- Unboxed.toList- (Unboxed.fromList xs <.> Unboxed.fromList ys))]- , testGroup- "Unboxed Vector (Infinite Int)"- [ QC.testProperty- "reference implementation of <.>"- (\xs ys ->- (xs <.> ys :: [Infinite Int]) ===- Unboxed.toList- (Unboxed.fromList xs <.> Unboxed.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
+ test/TypeLevel.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableSuperClasses #-}++module TypeLevel where++import Data.Proxy+import GHC.Exts++type family AllAre (c :: k -> Constraint) (xs :: [k]) :: Constraint where+ AllAre c '[] = ()+ AllAre c (x ': xs) = (c x, AllAre c xs)++class Reifiable (xs :: [k]) where+ reify+ :: AllAre c xs+ => Proxy c+ -> Proxy xs+ -> (forall a. c a =>+ Proxy a -> b)+ -> [b]++instance Reifiable '[] where+ reify _ _ _ = []++instance Reifiable xs =>+ Reifiable (x ': xs) where+ reify p _ f = f (Proxy :: Proxy x) : reify p (Proxy :: Proxy xs) f++class (c a, d a) => (c & d) a where+instance (c a, d a) => (c & d) a