semiring-num 0.6.0.0 → 0.7.0.0

raw patch · 7 files changed

+1013/−468 lines, 7 filesdep +QuickCheckdep +nat-sized-numbersdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, nat-sized-numbers, template-haskell

API changes (from Hackage documentation)

Files

• semiring-num.cabal +6/−1
• src/Data/Semiring.hs +314/−261
• src/Data/Semiring/Infinite.hs +274/−0
• src/Data/Semiring/Numeric.hs +39/−101
• src/Data/Semiring/TH.hs +43/−0
• src/Test/Semiring.hs +83/−2
• test/Spec.hs +254/−103

@@ -1,5 +1,5 @@ name:                semiring-num-version:             0.6.0.0+version:             0.7.0.0 synopsis:            Basic semiring class and instances description:         Adds a basic semiring class homepage:            https://github.com/oisdk/semiring-num@@ -18,8 +18,11 @@                      , Data.Semiring.Numeric                      , Data.Semiring.Free                      , Test.Semiring+  other-modules:       Data.Semiring.Infinite+                     , Data.Semiring.TH   build-depends:       base >= 4.9 && < 5                      , containers >= 0.5+                     , template-haskell >= 2.11   default-language:    Haskell2010   ghc-options:         -Wall @@ -32,6 +35,8 @@                      , smallcheck >= 1.1                      , doctest >= 0.11                      , containers >= 0.5+                     , QuickCheck >= 2.8+                     , nat-sized-numbers >= 0.1   ghc-options:         -threaded                        -rtsopts                        -with-rtsopts=-N

@@ -1,5 +1,9 @@ {-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving         #-} @@ -13,6 +17,12 @@  module Data.Semiring   ( Semiring(..)+  , StarSemiring(..)+  , HasPositiveInfinity(..)+  , HasNegativeInfinity(..)+  , PositiveInfinite(..)+  , NegativeInfinite(..)+  , Infinite(..)   , Add(..)   , Mul(..)   , add@@ -21,7 +31,6 @@   , Min(..)   ) where - import           Data.Functor.Const    (Const (..)) import           Data.Functor.Identity (Identity (..)) @@ -30,9 +39,6 @@ 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,@@ -54,9 +60,12 @@ import           GHC.Generics          (Generic, Generic1)  import           Data.Typeable         (Typeable)- import           Foreign.Storable      (Storable) +import           Data.Semiring.Infinite+import           Data.Semiring.TH++ -- | 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@@ -80,161 +89,209 @@ -- -- == Annihilation -- @'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+--+-- An ordered semiring follows the laws:+-- @x '<=' y => x '<+>' z '<=' y '<+>' z@+-- @x '<=' y => x '<+>' z '<=' y '<+>' z@+-- @'zero' '<=' z '&&' x '<=' y => x '<.>' z '<=' y '<.>' z '&&' z '<.>' x '<=' z '<.>' y@+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+    {-# INLINE zero #-}+    one = 1+    {-# INLINE one #-}+    (<+>) = (+)+    {-# INLINE (<+>) #-}+    (<.>) = (*)+    {-# INLINE (<.>) #-} -  zero = 0-  one = 1-  (<+>) = (+)-  (<.>) = (*)+-- | A <https://en.wikipedia.org/wiki/Semiring#Star_semirings Star semiring>+-- adds one operation, 'star' to a 'Semiring', such that it follows the+-- law:+--+-- @'star' x = 'one' '<+>' x '<.>' 'star' x = 'one' '<+>' 'star' x '<.>' x@+--+-- For the semiring of types, this is equivalent to a list. When looking+-- at the 'Applicative' and 'Control.Applicative.Alternative' classes as+-- (near-) semirings, this is equivalent to the+-- 'Control.Applicative.many' operation.+--+-- Another operation, 'plus', can be defined in relation to 'star':+--+-- @'plus' x = x '<.>' 'star' x@+--+-- This should be recognizable as a non-empty list on types, or the+-- 'Control.Applicative.some' operation in+-- 'Control.Applicative.Alternative'.+class Semiring a =>+      StarSemiring a  where+    {-# MINIMAL star | plus #-}+    star :: a -> a+    plus :: a -> a+    star x = one <+> plus x+    plus x = x <.> star x  ------------------------------------------------------------------------ -- Instances ------------------------------------------------------------------------+type CoerceBinary a b = (a -> a -> a) -> b -> b -> b+ instance Semiring Bool where-  one = True-  zero = False-  (<+>) = (||)-  (<.>) = (&&)+    one = True+    zero = False+    (<+>) = (||)+    (<.>) = (&&)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-} -instance Semiring () where-  one = ()-  zero = ()-  _ <+> _ = ()-  _ <.> _ = ()+instance StarSemiring Bool where+    star _ = True+    plus = id+    {-# INLINE star #-}+    {-# INLINE plus #-} -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+-- | Not lawful. Only for convenience.+instance Semiring a =>+         Semiring (NegativeInfinite a) where+    one = pure one+    zero = pure zero+    (<+>) =+        (coerce :: CoerceBinary (NegativeInfinite (Add a)) (NegativeInfinite a))+            mappend+    (<.>) = liftA2 (<.>)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-} --- | 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+-- | Not lawful. Only for convenience.+instance Semiring a =>+         Semiring (PositiveInfinite a) where+    one = pure one+    zero = pure zero+    (<+>) =+        (coerce :: CoerceBinary (PositiveInfinite (Add a)) (PositiveInfinite a))+            mappend+    (<.>) = liftA2 (<.>)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-} +-- | Not lawful. Only for convenience.+instance Semiring a =>+         Semiring (Infinite a) where+    one = pure one+    zero = pure zero+    (<+>) = (coerce :: CoerceBinary (Infinite (Add a)) (Infinite a)) mappend+    (<.>) = liftA2 (<.>)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance (Eq a, Semiring a) =>+         StarSemiring (PositiveInfinite a) where+    star (PosFinite x)+      | x == zero = one+    star _ = PositiveInfinity++instance Semiring () where+    one = ()+    zero = ()+    _ <+> _ = ()+    _ <.> _ = ()+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance StarSemiring () where+    star _ = ()+    plus _ = ()+    {-# INLINE star #-}+    {-# INLINE plus #-}+ -- | A polynomial in /x/ can be defined as a list of its coefficients, -- where the /i/th element is the coefficient of /x^i/. This is the -- semiring for such a list. Adapted from <https://pdfs.semanticscholar.org/702d/348c32133997e992db362a19697d5607ab32.pdf here>.-instance Semiring a => Semiring [a] where-  one = [one]-  zero = []-  [] <+> ys = ys-  xs <+> [] = xs-  (x:xs) <+> (y:ys) = (x <+> y) : (xs <+> ys)-  [] <.> _ = []-  _ <.> [] = []-  (x:xs) <.> (y:ys) =-    (x <.> y) : (map (x <.>) ys <+> map (<.> y) xs <+> (xs <.> ys))+instance Semiring a =>+         Semiring [a] where+    one = [one]+    zero = []+    [] <+> ys = ys+    xs <+> [] = xs+    (x:xs) <+> (y:ys) = (x <+> y) : (xs <+> ys)+    [] <.> _ = []+    _ <.> [] = []+    (x:xs) <.> (y:ys) =+        (x <.> y) : (map (x <.>) ys <+> map (<.> y) xs <+> (xs <.> ys))  ------------------------------------------------------------------------ -- 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-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac)+    { getAdd :: a+    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,Semiring,StarSemiring)  -- | 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-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac)--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 => Semigroup (Add a) where-  (<>) = (coerce :: WrapBinary Add a) (<+>)--instance Semiring a => Semigroup (Mul a) where-  (<>) = (coerce :: WrapBinary Mul a) (<.>)+    { getMul :: a+    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,Semiring,StarSemiring) -instance Semiring a => Monoid (Add a) where-  mempty = Add zero-  mappend = (<>)+instance Semiring a =>+         Semigroup (Add a) where+    (<>) = (coerce :: WrapBinary Add a) (<+>)+    {-# INLINE (<>) #-} -instance Semiring a => Monoid (Mul a) where-  mempty = Mul one-  mappend = (<>)+instance Semiring a =>+         Semigroup (Mul a) where+    (<>) = (coerce :: WrapBinary Mul a) (<.>)+    {-# INLINE (<>) #-} -instance Semiring a => Semiring (Add a) where-  zero = Add zero-  one = Add one-  (<+>) = (coerce :: WrapBinary Add a) (<+>)-  (<.>) = (coerce :: WrapBinary Add a) (<.>)+instance Semiring a =>+         Monoid (Add a) where+    mempty = Add zero+    mappend = (<>)+    {-# INLINE mempty #-}+    {-# INLINE mappend #-} -instance Semiring a => Semiring (Mul a) where-  zero = Mul zero-  one = Mul one-  (<+>) = (coerce :: WrapBinary Mul a) (<+>)-  (<.>) = (coerce :: WrapBinary Mul a) (<.>)+instance Semiring a =>+         Monoid (Mul a) where+    mempty = Mul one+    mappend = (<>)+    {-# INLINE mempty #-}+    {-# INLINE mappend #-}  ------------------------------------------------------------------------ -- Addition and multiplication folds ------------------------------------------------------------------------- -- | Takes the sum of the elements of a 'Foldable'. Analogous to 'sum' -- on numbers, or 'or' on 'Bool's. --@@ -246,7 +303,9 @@ -- True -- >>> add [True, undefined] -- True-add :: (Foldable f, Semiring a) => f a -> a+add+    :: (Foldable f, Semiring a)+    => f a -> a add = getAdd . foldMap Add  -- | Takes the product of the elements of a 'Foldable'. Analogous to@@ -260,13 +319,14 @@ -- False -- >>> mul [False, undefined] -- False-mul :: (Foldable f, Semiring a) => f a -> a+mul+    :: (Foldable f, Semiring a)+    => f a -> a mul = getMul . foldMap Mul  ------------------------------------------------------------------------ -- Ord wrappers ------------------------------------------------------------------------- -- | The "<https://ncatlab.org/nlab/show/tropical+semiring Tropical>" or -- min-plus semiring. It is a semiring where: --@@ -283,11 +343,9 @@ -- Taking ∞ to be 'maxBound' would break the above law. Using 'Nothing' -- to represent it follows the law. newtype Min a = Min-  { getMin :: Maybe a-  } deriving (Eq, Read, Show, Generic, Generic1, Functor, Foldable-             ,Typeable)-  -- } deriving (Eq, Ord, Read, Show, Generic, Generic1, Functor-  --            ,Foldable)+    { getMin :: a+    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable)  -- | The "<https://ncatlab.org/nlab/show/max-plus+algebra Arctic>" -- or max-plus semiring. It is a semiring where:@@ -305,103 +363,91 @@ -- Taking -∞ to be 'minBound' would break the above law. Using 'Nothing' -- to represent it follows the law. newtype Max a = Max-  { getMax :: Maybe a-  } deriving (Eq, Read, Show, Generic, Generic1, Functor, Foldable-             ,Typeable)--instance Ord a => Ord (Min a) where-  compare (Min Nothing) (Min Nothing)   = EQ-  compare (Min Nothing) _               = LT-  compare _ (Min Nothing)               = GT-  compare (Min (Just x)) (Min (Just y)) = compare x y--instance Ord a => Ord (Max a) where-  compare (Max Nothing) (Max Nothing)   = EQ-  compare (Max Nothing) _               = GT-  compare _ (Max Nothing)               = LT-  compare (Max (Just x)) (Max (Just y)) = compare x y---instance Applicative Max where-  pure = (coerce :: (a -> Maybe a) -> (a -> Max a)) Just-  (<*>) = (coerce :: (Maybe (a -> b) -> Maybe a -> Maybe b)-                  ->  Max   (a -> b) -> Max   a -> Max   b-          ) (<*>)--instance Applicative Min where-  pure = (coerce :: (a -> Maybe a) -> (a -> Min a)) Just-  (<*>) = (coerce :: (Maybe (a -> b) -> Maybe a -> Maybe b)-                  ->  Min   (a -> b) -> Min   a -> Min   b-          ) (<*>)--instance Monad Max where-  (>>=) = (coerce :: (Maybe a -> (a -> Maybe b) -> Maybe b)-                  ->  Max   a -> (a -> Max   b) -> Max   b-          ) (>>=)--instance Monad Min where-  (>>=) = (coerce :: (Maybe a -> (a -> Maybe b) -> Maybe b)-                  ->  Min   a -> (a -> Min   b) -> Min   b-          ) (>>=)+    { getMax :: a+    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable) -instance Ord a => Semigroup (Max a) where-  Max Nothing <> x = x-  x <> Max Nothing = x-  Max (Just x) <> Max (Just y) = (Max . Just) (max x y)+instance Ord a =>+         Semigroup (Max a) where+    (<>) = (coerce :: WrapBinary Max a) max+    {-# INLINE (<>) #-} -instance Ord a => Semigroup (Min a) where-  Min Nothing <> x = x-  x <> Min Nothing = x-  Min (Just x) <> Min (Just y) = (Min . Just) (min x y)+instance Ord a =>+         Semigroup (Min a) where+    (<>) = (coerce :: WrapBinary Min a) min+    {-# INLINE (<>) #-} --- | >>> (getMax . foldMap pure) [1..10]--- Just 10-instance Ord a => Monoid (Max a) where-  mempty = Max Nothing-  mappend = (<>)+-- | >>> (getMax . foldMap Max) [1..10]+-- 10.0+instance (Ord a, HasNegativeInfinity a) =>+         Monoid (Max a) where+    mempty = Max negativeInfinity+    mappend = (<>)+    {-# INLINE mempty #-}+    {-# INLINE mappend #-} --- | >>> (getMin . foldMap pure) [1..10]--- Just 1-instance Ord a => Monoid (Min a) where-  mempty = Min Nothing-  mappend = (<>)+-- | >>> (getMin . foldMap Min) [1..10]+-- 1.0+instance (Ord a, HasPositiveInfinity a) =>+         Monoid (Min a) where+    mempty = Min positiveInfinity+    mappend = (<>)+    {-# INLINE mempty #-}+    {-# INLINE mappend #-} -instance (Semiring a, Ord a) => Semiring (Max a) where-  (<+>) = mappend-  zero = mempty-  (<.>) = liftA2 (<+>)-  one = Max (Just zero)+instance (Semiring a, Ord a, HasNegativeInfinity a) =>+         Semiring (Max a) where+    (<+>) = mappend+    zero = mempty+    (<.>) = (coerce :: WrapBinary Max a) (<+>)+    one = Max zero+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-} -instance (Semiring a, Ord a) => Semiring (Min a) where-  (<+>) = mappend-  zero = mempty-  (<.>) = liftA2 (<+>)-  one = Min (Just zero)+instance (Semiring a, Ord a, HasPositiveInfinity a) =>+         Semiring (Min a) where+    (<+>) = mappend+    zero = mempty+    (<.>) = (coerce :: WrapBinary Min a) (<+>)+    one = Min zero+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-} -instance Bounded a => Bounded (Min a) where-  maxBound = Min (Just maxBound)-  minBound = Min Nothing+instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>+         StarSemiring (Max a) where+    star (Max x)+      | x > zero = Max positiveInfinity+      | otherwise = Max zero -instance Bounded a => Bounded (Max a) where-  minBound = Max (Just minBound)-  maxBound = Max Nothing+instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>+         StarSemiring (Min a) where+    star (Min x)+      | x < zero = Min negativeInfinity+      | otherwise = 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+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 +instance StarSemiring b =>+         StarSemiring (a -> b) where+    star f x = star (f x)+    plus f x = plus (f x)  ------------------------------------------------------------------------ -- Endo instance ------------------------------------------------------------------------- -- | This is /not/ a true semiring. In particular, it requires the -- underlying monoid to be commutative, and even then, it is only a near -- semiring. It is, however, extremely useful. For instance, this type:@@ -410,28 +456,67 @@ -- -- Is a valid encoding of church numerals, with addition and -- multiplication being their semiring variants.-instance Monoid a => Semiring (Endo a) where-  zero = Endo mempty-  Endo f <+> Endo g = Endo (f `mappend` g)-  one = mempty-  (<.>) = mappend+instance Monoid a =>+         Semiring (Endo a) where+    zero = Endo mempty+    Endo f <+> Endo g = Endo (f `mappend` g)+    one = mempty+    (<.>) = mappend+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-} +instance (Monoid a, Eq a) =>+         StarSemiring (Endo a) where+    star (Endo f) = Endo converge+      where+        converge x = go x+          where+            go inp =+                mappend+                    x+                    (if inp == next+                         then inp+                         else go next)+              where+                next = mappend x (f inp)+ ------------------------------------------------------------------------ -- Instances for Bool wrappers ------------------------------------------------------------------------- instance Semiring Any where-  (<+>) = coerce (||)-  zero = Any False-  (<.>) = coerce (&&)-  one = Any True+    (<+>) = coerce (||)+    zero = Any False+    (<.>) = coerce (&&)+    one = Any True+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-} +instance StarSemiring Any where+    star _ = Any True+    plus = id+    {-# INLINE star #-}+    {-# INLINE plus #-}+ instance Semiring All where-  (<+>) = coerce (||)-  zero = All False-  (<.>) = coerce (&&)-  one = All True+    (<+>) = coerce (||)+    zero = All False+    (<.>) = coerce (&&)+    one = All True+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-} +instance StarSemiring All where+    star _ = All True+    plus = id+    {-# INLINE star #-}+    {-# INLINE plus #-}+ ------------------------------------------------------------------------ -- Boring instances ------------------------------------------------------------------------@@ -502,38 +587,6 @@ ------------------------------------------------------------------------ -- 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)+$(traverse semiringIns [2..9])+$(traverse starIns [2..9])

@@ -0,0 +1,274 @@+{-# LANGUAGE DefaultSignatures   #-}+{-# LANGUAGE DeriveFoldable      #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Semiring.Infinite+  ( HasPositiveInfinity(..)+  , HasNegativeInfinity(..)+  , NegativeInfinite(..)+  , PositiveInfinite(..)+  , Infinite(..)+  ) where++import           Foreign.C.Types     (CDouble, CFloat)++import           Control.Applicative (liftA2)+import           Data.Typeable       (Typeable)+import           GHC.Generics        (Generic, Generic1)++import           Data.Word           (Word8)+import           Foreign.Ptr         (Ptr, castPtr)+import           Foreign.Storable    (Storable, alignment, peek, peekByteOff,+                                      poke, pokeByteOff, sizeOf)++import           Data.Coerce+import           Data.Monoid++class HasPositiveInfinity a where+  positiveInfinity :: a+  default positiveInfinity :: RealFloat a => a+  positiveInfinity = 1/0++class HasNegativeInfinity a where+  negativeInfinity :: a+  default negativeInfinity :: RealFloat a => a+  negativeInfinity = negate (1/0)++instance HasPositiveInfinity Double+instance HasNegativeInfinity Double+instance HasPositiveInfinity Float+instance HasNegativeInfinity Float+instance HasPositiveInfinity CDouble+instance HasNegativeInfinity CDouble+instance HasPositiveInfinity CFloat+instance HasNegativeInfinity CFloat++data NegativeInfinite a+  = NegativeInfinity+  | NegFinite !a+  deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor+           ,Foldable, Traversable)++data PositiveInfinite a+  = PosFinite !a+  | PositiveInfinity+  deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor+           ,Foldable, Traversable)++instance Applicative NegativeInfinite where+  pure = NegFinite+  {-# INLINE pure #-}+  NegFinite f <*> NegFinite x = NegFinite (f x)+  _ <*> _ = NegativeInfinity+  {-# INLINE (<*>) #-}++instance Applicative PositiveInfinite where+  pure = PosFinite+  {-# INLINE pure #-}+  PosFinite f <*> PosFinite x = PosFinite (f x)+  _ <*> _ = PositiveInfinity+  {-# INLINE (<*>) #-}++data Infinite a+  = Negative+  | Finite !a+  | Positive+  deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor+           ,Foldable, Traversable)++instance Applicative Infinite where+  pure = Finite+  {-# INLINE pure #-}+  Finite f <*> Finite x = Finite (f x)+  Negative <*> Negative = Positive+  Negative <*> _ = Negative+  _ <*> Negative = Negative+  _ <*> _ = Positive+  {-# INLINE (<*>) #-}++instance Bounded a => Bounded (NegativeInfinite a) where+  {-# INLINE minBound #-}+  {-# INLINE maxBound #-}+  minBound = NegativeInfinity+  maxBound = pure maxBound++instance Bounded a => Bounded (PositiveInfinite a) where+  {-# INLINE minBound #-}+  {-# INLINE maxBound #-}+  minBound = pure minBound+  maxBound = PositiveInfinity++instance Bounded (Infinite a) where+  {-# INLINE minBound #-}+  {-# INLINE maxBound #-}+  minBound = Negative+  maxBound = Positive++instance HasNegativeInfinity (NegativeInfinite a) where+  {-# INLINE negativeInfinity #-}+  negativeInfinity = NegativeInfinity++instance HasPositiveInfinity (PositiveInfinite a) where+  {-# INLINE positiveInfinity #-}+  positiveInfinity = PositiveInfinity++instance HasNegativeInfinity (Infinite a) where+  {-# INLINE negativeInfinity #-}+  negativeInfinity = Negative++instance HasPositiveInfinity (Infinite a) where+  {-# INLINE positiveInfinity #-}+  positiveInfinity = Positive++instance (Enum a, Bounded a, Eq a) => Enum (NegativeInfinite a) where+  succ = foldr (const . pure . succ) (pure minBound)+  pred NegativeInfinity = error "Predecessor of negative infinity"+  pred (NegFinite x) | x == minBound = NegativeInfinity+                     | otherwise = NegFinite (pred x)+  toEnum 0 = NegativeInfinity+  toEnum n = NegFinite (toEnum (n-1))+  fromEnum = foldr (const . succ . fromEnum) 0+  enumFrom NegativeInfinity = NegativeInfinity : map pure [minBound..]+  enumFrom (NegFinite x)    = map pure [x..]++maxBoundOf :: Bounded a => f a -> a+maxBoundOf _ = maxBound++instance (Enum a, Bounded a, Eq a) => Enum (PositiveInfinite a) where+  pred = foldr (const . pure . pred) (pure maxBound)+  succ PositiveInfinity = error "Successor of positive infinity"+  succ (PosFinite x) | x == maxBound = PositiveInfinity+                     | otherwise = PosFinite (succ x)+  toEnum n+    | n == toEnum (maxBoundOf PositiveInfinity) + 1 = PositiveInfinity+    | otherwise = PosFinite (toEnum n)+  fromEnum p@PositiveInfinity = fromEnum (maxBoundOf p) + 1+  fromEnum (PosFinite x)      = fromEnum x+  enumFrom PositiveInfinity = [PositiveInfinity]+  enumFrom (PosFinite x)    = map pure [x..] ++ [PositiveInfinity]++instance (Enum a, Bounded a, Eq a) => Enum (Infinite a) where+  pred Negative = error "Predecessor of negative infinity"+  pred Positive = Finite maxBound+  pred (Finite x) | x == minBound = Negative+                  | otherwise = Finite (pred x)+  succ Negative = Finite minBound+  succ Positive = error "Successor of positive infinity"+  succ (Finite x) | x == maxBound = Positive+                  | otherwise = Finite (succ x)+  toEnum 0 = Negative+  toEnum n | n == toEnum (maxBoundOf Positive) + 2 = Positive+           | otherwise = Finite (toEnum (n-1))+  fromEnum Negative   = 0+  fromEnum (Finite x) = fromEnum x + 1+  fromEnum p@Positive = fromEnum (maxBoundOf p) + 1+  enumFrom Positive   = [Positive]+  enumFrom Negative   = Negative : map pure [minBound..] ++ [Positive]+  enumFrom (Finite x) = map pure (enumFrom x) ++ [Positive]++instance Monoid a => Monoid (NegativeInfinite a) where+  {-# INLINE mempty #-}+  {-# INLINE mappend #-}+  mempty = pure mempty+  mappend = liftA2 mappend++instance Monoid a => Monoid (PositiveInfinite a) where+  {-# INLINE mempty #-}+  {-# INLINE mappend #-}+  mempty = pure mempty+  mappend = liftA2 mappend++instance 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++instance Num a => Num (NegativeInfinite a) where+  fromInteger = pure . fromInteger+  (+) = liftA2 (+)+  (*) = liftA2 (*)+  abs = fmap abs+  signum = foldr (const . pure . signum) (-1)+  (-) = liftA2 (-)++instance Num a => Num (PositiveInfinite a) where+  fromInteger = pure . fromInteger+  (+) = liftA2 (+)+  (*) = liftA2 (*)+  abs = fmap abs+  signum = foldr (const . pure . signum) (-1)+  (-) = liftA2 (-)++type CoerceBinary a b = (a -> a -> a) -> (b -> b -> b)++instance Num a => Num (Infinite a) where+  fromInteger = Finite . fromInteger+  (+) = (coerce :: CoerceBinary (Infinite (Sum a)) (Infinite a)) mappend+  (*) = liftA2 (*)+  signum Positive   = 1+  signum Negative   = -1+  signum (Finite x) = Finite (signum x)+  negate Positive   = Negative+  negate Negative   = Positive+  negate (Finite x) = Finite (negate x)+  abs Negative = Positive+  abs x = fmap abs x++-- Adapted from https://www.schoolofhaskell.com/user/snoyberg/random-code-snippets/storable-instance-of-maybe+instance Storable a => Storable (NegativeInfinite a) where+    sizeOf x = sizeOf (strip x) + 1+    alignment x = alignment (strip x)+    peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case+      (1 :: Word8) -> NegFinite <$> peek (stripFPtr ptr)+      _ -> pure NegativeInfinity+    poke ptr NegativeInfinity+      = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (0 :: Word8)+    poke ptr (NegFinite a)+      = poke (stripFPtr ptr) a+     *> pokeByteOff ptr (sizeOf a) (1 :: Word8)++instance Storable a => Storable (PositiveInfinite a) where+    sizeOf x = sizeOf (strip x) + 1+    alignment x = alignment (strip x)+    peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case+      (1 :: Word8) -> PosFinite <$> peek (stripFPtr ptr)+      _ -> pure PositiveInfinity+    poke ptr PositiveInfinity+      = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (0 :: Word8)+    poke ptr (PosFinite a)+      = poke (stripFPtr ptr) a+     *> pokeByteOff ptr (sizeOf a) (1 :: Word8)++instance Storable a => Storable (Infinite a) where+    sizeOf x = sizeOf (strip x) + 1+    alignment x = alignment (strip x)+    peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case+      (0 :: Word8) -> Finite <$> peek (stripFPtr ptr)+      1 -> pure Negative+      _ -> pure Positive+    poke ptr Positive+      = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (2 :: Word8)+    poke ptr Negative+      = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (1 :: Word8)+    poke ptr (Finite a)+      = poke (stripFPtr ptr) a+     *> pokeByteOff ptr (sizeOf a) (1 :: Word8)++strip :: f a -> a+strip _ = error "strip"++stripFPtr :: Ptr (f a) -> Ptr a+stripFPtr = castPtr++stripPtr :: Ptr a -> a+stripPtr _ = error "stripPtr"

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFoldable             #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-|@@ -36,13 +37,18 @@ newtype Bottleneck a = Bottleneck   { getBottleneck :: a   } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac)+             ,Enum, Typeable, Storable, Fractional, Real, RealFrac+             ,Functor, Foldable, Traversable)  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+  {-# INLINE (<+>) #-}+  {-# INLINE (<.>) #-}+  {-# INLINE zero #-}+  {-# INLINE one #-}  -- | Positive numbers only. --@@ -53,7 +59,8 @@ newtype Division a = Division   { getDivision :: a   } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac)+             ,Enum, Typeable, Storable, Fractional, Real, RealFrac+             ,Functor, Foldable, Traversable)  -- | Only expects positive numbers instance (Integral a, Semiring a) => Semiring (Division a) where@@ -61,6 +68,10 @@   (<.>) = (coerce :: WrapBinary Division a) lcm   zero = Division zero   one = Division one+  {-# INLINE (<+>) #-}+  {-# INLINE (<.>) #-}+  {-# INLINE zero #-}+  {-# INLINE one #-}  -- | <https://en.wikipedia.org/wiki/Semiring#cite_ref-droste_14-0 Wikipedia> -- has some information on this. Also@@ -74,13 +85,18 @@ newtype Łukasiewicz a = Łukasiewicz   { getŁukasiewicz :: a   } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac)+             ,Enum, Typeable, Storable, Fractional, Real, RealFrac+             ,Functor, Foldable, Traversable)  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+  {-# INLINE (<+>) #-}+  {-# INLINE (<.>) #-}+  {-# INLINE zero #-}+  {-# INLINE one #-}  -- | <https://en.wikipedia.org/wiki/Semiring#cite_ref-droste_14-0 Wikipedia> -- has some information on this. Also@@ -94,115 +110,37 @@ newtype Viterbi a = Viterbi   { getViterbi :: a   } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac)+             ,Enum, Typeable, Storable, Fractional, Real, RealFrac+             ,Functor, Foldable, Traversable)  instance (Ord a, Semiring a) => Semiring (Viterbi a) where   (<+>) = (coerce :: WrapBinary Viterbi a) max   (<.>) = (coerce :: WrapBinary Viterbi a) (<.>)   zero = Viterbi zero   one  = Viterbi one+  {-# INLINE (<+>) #-}+  {-# INLINE (<.>) #-}+  {-# INLINE zero #-}+  {-# INLINE one #-}  -- | Useful for optimizing multiplication, or working with large numbers. -- -- @('<.>')   = ('+') --x '<+>' y = -('log' ('exp' (-x) + 'exp' (-y)))---'zero'    = ∞ -- represented by 'Nothing'+--'zero'    = ∞ --'one'     = 0@ newtype Log a = Log-  { getLog :: Maybe a-  } deriving (Eq, Read, Show, Generic, Generic1, Typeable, Functor-             ,Foldable, Applicative, Monad)--instance (Semiring a, Floating a) => Semiring (Log a) where-  zero = Log Nothing-  one = Log (Just zero)-  Log (Just x) <.> Log (Just y) = Log (Just (x + y))-  _ <.> _ = Log Nothing-  Log Nothing <+> y = y-  x <+> Log Nothing = x-  Log (Just x) <+> Log (Just y)-    = Log (Just (-(log (exp (-x) + exp (-y)))))--instance Ord a => Ord (Log a) where-  compare (Log Nothing) (Log Nothing)   = EQ-  compare (Log Nothing) _               = LT-  compare _ (Log Nothing)               = GT-  compare (Log (Just x)) (Log (Just y)) = compare x y----------------------------------------------------------------------------- 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)) ($)+  { getLog :: a+  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor+             ,Foldable) -instance Monad Bottleneck where (>>=) = flip coerce-instance Monad Division where (>>=) = flip coerce-instance Monad Łukasiewicz where (>>=) = flip coerce-instance Monad Viterbi where (>>=) = flip coerce+instance (Floating a, HasPositiveInfinity a) => Semiring (Log a) where+  zero = Log positiveInfinity+  one = Log 0+  (<.>) = (coerce :: WrapBinary Log a) (+)+  Log x <+> Log y+    = Log (-(log (exp (-x) + exp (-y))))+  {-# INLINE (<+>) #-}+  {-# INLINE (<.>) #-}+  {-# INLINE zero #-}+  {-# INLINE one #-}

@@ -0,0 +1,43 @@+module Data.Semiring.TH where++import Control.Monad+import Language.Haskell.TH++repN :: Int -> String -> Q Dec+repN n nm = do+    let v = VarP (mkName nm)+    rhs <- TupE <$> replicateM n (pure (VarE (mkName nm)))+    return $ ValD v (NormalB rhs) []++appN :: Int -> String -> Q Dec+appN n nm = do+    let f = VarE (mkName nm)+    xs <- replicateM n (newName "x")+    let args = [TupP (map VarP xs)]+        ntup = TupE (map (AppE f . VarE) xs)+    return $ FunD (mkName nm) [Clause args (NormalB ntup) []]++cmbN :: Int -> String -> Q Dec+cmbN n nm = do+    let f = VarE (mkName nm)+    xs <- replicateM n (newName "x")+    ys <- replicateM n (newName "y")+    let args = [TupP (map VarP xs), TupP (map VarP ys)]+        ntup = TupE (zipWith (AppE . AppE f) (map VarE xs) (map VarE ys))+    return $ FunD (mkName nm) [Clause args (NormalB ntup) []]++starIns :: Int -> Q Dec+starIns n = do+    names <- replicateM n (newName "a")+    let c = ConT (mkName "StarSemiring")+        ct = map (AppT c . VarT) names+    InstanceD Nothing ct (AppT c $ foldl AppT (TupleT n) (map VarT names)) <$>+        sequence [appN n "star", appN n "plus"]++semiringIns :: Int -> Q Dec+semiringIns n = do+    names <- replicateM n (newName "a")+    let c = ConT (mkName "Semiring")+        ct = map (AppT c . VarT) names+    InstanceD Nothing ct (AppT c $ foldl AppT (TupleT n) (map VarT names)) <$>+        sequence [cmbN n "<+>", cmbN n "<.>", repN n "zero", repN n "one"]

@@ -20,9 +20,15 @@   , unaryLaws   , binaryLaws   , ternaryLaws+  , starLaw+  , plusLaw+  , starLaws+  , nearUnLaws+  , nearTernaryLaws+  , ordLaws   ) where -import           Data.Semiring   (Semiring (..))+import           Data.Semiring   (Semiring (..), StarSemiring (..))  -- | Plus is associative. plusAssoc :: (Eq a, Semiring a, Show a) => a -> a -> a -> Either String String@@ -102,7 +108,7 @@   l = (x <+> y) <.> z   r = x <.> z <+> y <.> z   s = unlines-    [ "<.> does " ++ (if res then "" else "not ") ++ "distribute left over <+>."+    [ "<.> does " ++ (if res then "" else "not ") ++ "distribute right over <+>."     , "    Law:"     , "        (x <+> y) <.> z = x <.> z <+> y <.> z"     , "    x = " ++ show x@@ -159,6 +165,16 @@ unaryLaws :: (Eq a, Semiring a, Show a) => a -> Either String String unaryLaws x = fmap unlines (sequence [plusId x, mulId x, annihilate x]) +nearUnLaws :: (Eq a, Semiring a, Show a) => a -> Either String String+nearUnLaws = plusId++nearTernaryLaws :: (Eq a, Semiring a, Show a)+            => a -> a -> a -> Either String String+nearTernaryLaws x y z =+  fmap unlines (sequence [ plusAssoc x y z+                         , mulAssoc x y z+                         , mulDistribL x y z])+ binaryLaws :: (Eq a, Semiring a, Show a)            => a -> a -> Either String String binaryLaws = plusComm@@ -170,3 +186,68 @@                          , mulAssoc x y z                          , mulDistribL x y z                          , mulDistribR x y z])++starLaw :: (Eq a, StarSemiring a, Show a) => a -> Either String String+starLaw (x :: a) = if res then Right s else Left s where+  res = l == st && r == st+  l = one <+> x <.> star x+  r = one <+> star x <.> x+  st = star x+  s = unlines+    [ "star law" ++ (if res then "" else " not") ++ " followed."+    , "    Law:"+    , "        star x = one <+> x <.> star x = one <+> star x <.> x"+    , "    x = " ++ show x+    , "    one = " ++ show (one :: a)+    , "    star x = " ++ show st+    , "    one <+> x <.> star x = " ++ show l+    , "    one <+> star x <.> x = " ++ show r ]++plusLaw :: (Eq a, StarSemiring a, Show a) => a -> Either String String+plusLaw (x :: a) = if res then Right s else Left s where+  res = r == st+  r = x <.> star x+  st = plus x+  s = unlines+    [ "plus law" ++ (if res then "" else " not") ++ " followed."+    , "    Law:"+    , "        plus x = x <.> star x"+    , "    x = " ++ show x+    , "    star x = " ++ show st+    , "    x <.> star x = " ++ show r ]++starLaws :: (Eq a, StarSemiring a, Show a) => a -> Either String String+starLaws x = fmap unlines (sequence [starLaw x, plusLaw x])+++ordAddLaw :: (Ord a, Semiring a, Show a) => a -> a -> a -> Either String String+ordAddLaw (x :: a) (y :: a) (z :: a) = if res then Right s else Left s where+  cnd = x <= y+  lhs = x <+> z <= y <+> z+  rhs = z <+> x <= z <+> y+  res = not cnd || lhs && rhs+  s = unlines+    [ "ordering law" ++ (if res then "" else " not") ++ " followed."+    , "    Law:"+    , "        x <= y => x <+> z <= y <+> z && z <+> x <= z <+> y"+    , "    x = " ++ show x+    , "    y = " ++ show y+    , "    z = " ++ show z ]++ordMulLaw :: (Ord a, Semiring a, Show a) => a -> a -> a -> Either String String+ordMulLaw (x :: a) (y :: a) (z :: a) = if res then Right s else Left s where+  cnd = x <= y && zero <= z+  lhs = x <.> z <= y <.> z+  rhs = z <.> x <= z <.> y+  res = not cnd || lhs && rhs+  s = unlines+    [ "ordering law" ++ (if res then "" else " not") ++ " followed."+    , "    Law:"+    , "        x <= y => x <.> z <= y <.> z && z <.> x <= z <.> y"+    , "    x = " ++ show x+    , "    y = " ++ show y+    , "    z = " ++ show z ]+++ordLaws :: (Ord a, Semiring a, Show a) => a -> a -> a -> Either String String+ordLaws x y z = fmap unlines (sequence [ordAddLaw x y z, ordMulLaw x y z])

@@ -1,31 +1,34 @@+{-# LANGUAGE DataKinds                  #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE KindSignatures             #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-}  module Main (main) where  import           Control.Applicative-import           Control.Arrow          (first)+import           Control.Arrow            (first)+import           Data.Bool import           Data.Foldable-import           Data.IntMap.Strict     (IntMap)-import qualified Data.IntMap.Strict     as IntMap-import qualified Data.Map.Strict        as Map+import           Data.Function+import           Data.IntMap.Strict       (IntMap)+import qualified Data.IntMap.Strict       as IntMap+import qualified Data.Map.Strict          as Map import           Data.Monoid import           Data.Semiring import           Data.Semiring.Free import           Data.Semiring.Numeric-import qualified Data.Set               as Set+import           GHC.TypeLits+import           Numeric.Sized.WordOfSize import           Test.DocTest+import           Test.QuickCheck          hiding (Positive (..), generate,+                                           (.&.)) import           Test.Semiring-import           Test.SmallCheck-import           Test.SmallCheck.Series-import           GHC.TypeLits-import           Data.Function-import           Data.Bits+import           Test.SmallCheck          hiding (Testable, (==>))+import           Test.SmallCheck.Series   hiding (Positive)+import qualified Test.SmallCheck.Series   as SC  ------------------------------------------------------------------------ @@ -35,41 +38,132 @@   smallCheck 1000 (unaryLaws   :: UnaryLaws   Integer)   smallCheck 100  (binaryLaws  :: BinaryLaws  Integer)   smallCheck 10   (ternaryLaws :: TernaryLaws Integer)+  smallCheck 10   (ordLaws     :: TernaryLaws Integer) -  putStrLn "(WordN 2)"-  smallCheck 16  (unaryLaws   :: UnaryLaws   (WordN 2))-  smallCheck 16  (binaryLaws  :: BinaryLaws  (WordN 2))-  smallCheck 16  (ternaryLaws :: TernaryLaws (WordN 2))+  putStrLn "(WordOfSize 2)"+  smallCheck 16  (unaryLaws   :: UnaryLaws   (WordOfSize 2))+  smallCheck 16  (binaryLaws  :: BinaryLaws  (WordOfSize 2))+  smallCheck 16  (ternaryLaws :: TernaryLaws (WordOfSize 2))+  smallCheck 16  (starLaws    :: UnaryLaws   (PositiveInfinite (WordOfSize 2))) -  putStrLn "(WordN 2,WordN 2)"-  smallCheck 16 (unaryLaws   :: UnaryLaws   (WordN 2,WordN 2))-  smallCheck 14 (binaryLaws  :: BinaryLaws  (WordN 2,WordN 2))-  smallCheck 8  (ternaryLaws :: TernaryLaws (WordN 2,WordN 2))+  putStrLn "(WordOfSize 2,WordOfSize 2)"+  smallCheck 16 (unaryLaws   :: UnaryLaws   (WordOfSize 2,WordOfSize 2))+  smallCheck 14 (binaryLaws  :: BinaryLaws  (WordOfSize 2,WordOfSize 2))+  smallCheck 8  (ternaryLaws :: TernaryLaws (WordOfSize 2,WordOfSize 2))+  smallCheck 16 (starLaws    :: UnaryLaws   (PositiveInfinite (WordOfSize 2)+                                            ,PositiveInfinite (WordOfSize 2))) -  putStrLn "(WordN 2,WordN 2,WordN 2)"-  smallCheck 10 (unaryLaws   :: UnaryLaws   (WordN 2,WordN 2,WordN 2))-  smallCheck 5  (binaryLaws  :: BinaryLaws  (WordN 2,WordN 2,WordN 2))-  smallCheck 2  (ternaryLaws :: TernaryLaws (WordN 2,WordN 2,WordN 2))+  putStrLn "(WordOfSize 2,WordOfSize 2,WordOfSize 2)"+  smallCheck 10 (unaryLaws   :: UnaryLaws   (WordOfSize 2,WordOfSize 2,WordOfSize 2))+  smallCheck 5  (binaryLaws  :: BinaryLaws  (WordOfSize 2,WordOfSize 2,WordOfSize 2))+  smallCheck 2  (ternaryLaws :: TernaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2))+  smallCheck 10 (starLaws    :: UnaryLaws   (PositiveInfinite (WordOfSize 2)+                                            ,PositiveInfinite (WordOfSize 2)+                                            ,PositiveInfinite (WordOfSize 2))) -  putStrLn "(WordN 2,WordN 2,WordN 2,WordN 2)"-  smallCheck 8 (unaryLaws   :: UnaryLaws   (WordN 2,WordN 2,WordN 2,WordN 2))-  smallCheck 4 (binaryLaws  :: BinaryLaws  (WordN 2,WordN 2,WordN 2,WordN 2))-  smallCheck 1 (ternaryLaws :: TernaryLaws (WordN 2,WordN 2,WordN 2,WordN 2))+  putStrLn "(WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)"+  smallCheck 8 (unaryLaws   :: UnaryLaws   (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2))+  smallCheck 4 (binaryLaws  :: BinaryLaws  (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2))+  smallCheck 1 (ternaryLaws :: TernaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2))+  smallCheck 16 (starLaws    :: UnaryLaws   (PositiveInfinite (WordOfSize 2)+                                            ,PositiveInfinite (WordOfSize 2)+                                            ,PositiveInfinite (WordOfSize 2)+                                            ,PositiveInfinite (WordOfSize 2))) +  putStrLn "(Int,Int,Int,Int,Int)"+  quickCheck (unaryLaws   :: UnaryLaws   (Int,Int,Int,Int,Int))+  quickCheck (binaryLaws  :: BinaryLaws  (Int,Int,Int,Int,Int))+  quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int))+  quickCheck (starLaws    :: UnaryLaws   (PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int))++  putStrLn "(Int,Int,Int,Int,Int,Int)"+  quickCheck (unaryLaws   :: UnaryLaws   (Int,Int,Int,Int,Int,Int))+  quickCheck (binaryLaws  :: BinaryLaws  (Int,Int,Int,Int,Int,Int))+  quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int))+  quickCheck (starLaws    :: UnaryLaws   (PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int))++  putStrLn "(Int,Int,Int,Int,Int,Int,Int)"+  quickCheck (unaryLaws   :: UnaryLaws   (Int,Int,Int,Int,Int,Int,Int))+  quickCheck (binaryLaws  :: BinaryLaws  (Int,Int,Int,Int,Int,Int,Int))+  quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int,Int))+  quickCheck (starLaws    :: UnaryLaws   (PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int))++  putStrLn "(Int,Int,Int,Int,Int,Int,Int,Int)"+  quickCheck (unaryLaws   :: UnaryLaws   (Int,Int,Int,Int,Int,Int,Int,Int))+  quickCheck (binaryLaws  :: BinaryLaws  (Int,Int,Int,Int,Int,Int,Int,Int))+  quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int,Int,Int))+  quickCheck (starLaws    :: UnaryLaws   (PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int))++  putStrLn "(Int,Int,Int,Int,Int,Int,Int,Int,Int)"+  quickCheck (unaryLaws   :: UnaryLaws   (Int,Int,Int,Int,Int,Int,Int,Int,Int))+  quickCheck (binaryLaws  :: BinaryLaws  (Int,Int,Int,Int,Int,Int,Int,Int,Int))+  quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int,Int,Int,Int))+  quickCheck (starLaws    :: UnaryLaws   (PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int+                                         ,PositiveInfinite Int))+   putStrLn "Int"   smallCheck 1000 (unaryLaws   :: UnaryLaws   Int)   smallCheck 100  (binaryLaws  :: BinaryLaws  Int)   smallCheck 10   (ternaryLaws :: TernaryLaws Int) +  putStrLn "PosInf Integer"+  smallCheck 1000 (nearUnLaws      :: UnaryLaws   (PositiveInfinite Integer))+  smallCheck 100  (binaryLaws      :: BinaryLaws  (PositiveInfinite Integer))+  smallCheck 10   (nearTernaryLaws :: TernaryLaws (PositiveInfinite Integer))+  smallCheck 10   (ordLaws         :: TernaryLaws (PositiveInfinite Integer))++  putStrLn "NegInf Integer"+  smallCheck 1000 (nearUnLaws      :: UnaryLaws   (NegativeInfinite Integer))+  smallCheck 100  (binaryLaws      :: BinaryLaws  (NegativeInfinite Integer))+  smallCheck 10   (nearTernaryLaws :: TernaryLaws (NegativeInfinite Integer))+  smallCheck 10   (ordLaws         :: TernaryLaws (NegativeInfinite Integer))++  -- putStrLn "Inf Integer"+  -- smallCheck 1000 (nearUnLaws      :: UnaryLaws   (Infinite Integer))+  -- smallCheck 100  (binaryLaws      :: BinaryLaws  (Infinite Integer))+  -- smallCheck 10   (nearTernaryLaws :: TernaryLaws (Infinite Integer))+  -- smallCheck 10   (ordLaws         :: TernaryLaws (Infinite Integer))+   putStrLn "()"   smallCheck 1 (unaryLaws   :: UnaryLaws   ())   smallCheck 1 (binaryLaws  :: BinaryLaws  ())   smallCheck 1 (ternaryLaws :: TernaryLaws ())+  smallCheck 1 (starLaws    :: UnaryLaws   ())    putStrLn "Bool"   smallCheck 2 (unaryLaws   :: UnaryLaws   Bool)   smallCheck 4 (binaryLaws  :: BinaryLaws  Bool)   smallCheck 8 (ternaryLaws :: TernaryLaws Bool)+  smallCheck 2 (starLaws    :: UnaryLaws   Bool)    putStrLn "Any"   smallCheck 2 (unLawsOn   Any :: UnaryLaws   Bool)@@ -81,40 +175,37 @@   smallCheck 4 (binLawsOn  All :: BinaryLaws  Bool)   smallCheck 8 (ternLawsOn All :: TernaryLaws Bool) -  putStrLn "[WordN 2]"-  smallCheck 5 (unaryLaws   :: UnaryLaws   [WordN 2])-  smallCheck 4 (binaryLaws  :: BinaryLaws  [WordN 2])-  smallCheck 3 (ternaryLaws :: TernaryLaws [WordN 2])--  putStrLn "Set [WordN 2]"-  smallCheck 4 (unLawsOn   Set.fromList :: UnaryLaws   [[WordN 2]])-  smallCheck 3 (binLawsOn  Set.fromList :: BinaryLaws  [[WordN 2]])-  smallCheck 3 (ternLawsOn Set.fromList :: TernaryLaws [[WordN 2]])+  putStrLn "[WordOfSize 2]"+  smallCheck 5 (unaryLaws   :: UnaryLaws   [WordOfSize 2])+  smallCheck 4 (binaryLaws  :: BinaryLaws  [WordOfSize 2])+  smallCheck 3 (ternaryLaws :: TernaryLaws [WordOfSize 2])    putStrLn "Min Integer"-  smallCheck 1000 (unLawsOn   Min :: UnaryLaws   (Maybe Integer))-  smallCheck 100  (binLawsOn  Min :: BinaryLaws  (Maybe Integer))-  smallCheck 10   (ternLawsOn Min :: TernaryLaws (Maybe Integer))+  smallCheck 1000 (unLawsOn   Min :: UnaryLaws   (PositiveInfinite Integer))+  smallCheck 100  (binLawsOn  Min :: BinaryLaws  (PositiveInfinite Integer))+  smallCheck 10   (ternLawsOn Min :: TernaryLaws (PositiveInfinite Integer))+  smallCheck 1000 (starLaws . Min :: UnaryLaws   (Infinite    Integer))    putStrLn "Max Integer"-  smallCheck 1000 (unLawsOn   Max :: UnaryLaws   (Maybe Integer))-  smallCheck 100  (binLawsOn  Max :: BinaryLaws  (Maybe Integer))-  smallCheck 10   (ternLawsOn Max :: TernaryLaws (Maybe Integer))+  smallCheck 1000 (unLawsOn   Max :: UnaryLaws   (NegativeInfinite Integer))+  smallCheck 100  (binLawsOn  Max :: BinaryLaws  (NegativeInfinite Integer))+  smallCheck 10   (ternLawsOn Max :: TernaryLaws (NegativeInfinite Integer))+  smallCheck 1000 (starLaws . Max :: UnaryLaws   (Infinite    Integer)) -  putStrLn "Free (WordN 2)"-  smallCheck 4 (unLawsOn   Free :: UnaryLaws   [[WordN 2]])-  smallCheck 3 (binLawsOn  Free :: BinaryLaws  [[WordN 2]])-  smallCheck 3 (ternLawsOn Free :: TernaryLaws [[WordN 2]])+  putStrLn "Free (WordOfSize 2)"+  smallCheck 4 (unLawsOn   Free :: UnaryLaws   [[WordOfSize 2]])+  smallCheck 3 (binLawsOn  Free :: BinaryLaws  [[WordOfSize 2]])+  smallCheck 3 (ternLawsOn Free :: TernaryLaws [[WordOfSize 2]]) -  putStrLn "Bottleneck (WordN 2)"-  smallCheck 1000 (unLawsOn   Bottleneck :: UnaryLaws   (WordN 2))-  smallCheck 100  (binLawsOn  Bottleneck :: BinaryLaws  (WordN 2))-  smallCheck 10   (ternLawsOn Bottleneck :: TernaryLaws (WordN 2))+  putStrLn "Bottleneck (WordOfSize 2)"+  smallCheck 1000 (unLawsOn   Bottleneck :: UnaryLaws   (WordOfSize 2))+  smallCheck 100  (binLawsOn  Bottleneck :: BinaryLaws  (WordOfSize 2))+  smallCheck 10   (ternLawsOn Bottleneck :: TernaryLaws (WordOfSize 2))    putStrLn "Division Integer"-  smallCheck 1000 (unLawsOn   (Division . getPositive) :: UnaryLaws   (Positive Integer))-  smallCheck 100  (binLawsOn  (Division . getPositive) :: BinaryLaws  (Positive Integer))-  smallCheck 10   (ternLawsOn (Division . getPositive) :: TernaryLaws (Positive Integer))+  smallCheck 1000 (unLawsOn   (Division . getPositive) :: UnaryLaws   (SC.Positive Integer))+  smallCheck 100  (binLawsOn  (Division . getPositive) :: BinaryLaws  (SC.Positive Integer))+  smallCheck 10   (ternLawsOn (Division . getPositive) :: TernaryLaws (SC.Positive Integer))    putStrLn "Łukasiewicz Double"   smallCheck 1000 (unLawsOn   Łukasiewicz :: UnaryLaws   Fraction)@@ -127,15 +218,19 @@   smallCheck 10   (ternLawsOn Viterbi :: TernaryLaws Fraction)    putStrLn "Log Double"-  smallCheck 1000 (unLawsOn   Log :: UnaryLaws   (Maybe Fraction))-  smallCheck 100  (binLawsOn  Log :: BinaryLaws  (Maybe Fraction))-  smallCheck 10   (ternLawsOn Log :: TernaryLaws (Maybe Fraction))+  quickCheck (unLawsOn   Log :: UnaryLaws   (Approx Double))+  quickCheck (binLawsOn  Log :: BinaryLaws  (Approx Double))+  quickCheck (ternLawsOn Log :: TernaryLaws (Approx Double))    putStrLn "Bool -> Bool"   smallCheck 3 (unLawsOn   fromFunc :: UnaryLaws   (Bool -> Bool))   smallCheck 2 (binLawsOn  fromFunc :: BinaryLaws  (Bool -> Bool))   smallCheck 2 (ternLawsOn fromFunc :: TernaryLaws (Bool -> Bool))+  quickCheck (unLawsOn   fromFunc :: UnaryLaws   (Bool -> Bool))+  quickCheck (binLawsOn  fromFunc :: BinaryLaws  (Bool -> Bool))+  quickCheck (ternLawsOn fromFunc :: TernaryLaws (Bool -> Bool)) +   putStrLn "Endo (Add Bool)"   smallCheck 3 (unOn plusId        eFromFunc :: UnaryLaws   (Bool -> Bool))   smallCheck 3 (unOn mulId         eFromFunc :: UnaryLaws   (Bool -> Bool))@@ -179,17 +274,38 @@ -- Serial wrappers  -- | A type with a serial instance between zero and one-newtype Fraction-  = Fraction Double-  deriving (Show, Num, Fractional, Real, RealFrac, Floating, RealFloat, Semiring)+newtype Fraction =+    Fraction Double+    deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring) +newtype Approx a =+    Approx a+    deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring+             ,HasPositiveInfinity)++instance (Arbitrary a, Num a, Ord a) => Arbitrary (Approx a) where+  arbitrary = fmap Approx (suchThat arbitrary ((<100).abs))+ instance Eq Fraction where-  Fraction x == Fraction y = abs (x-y) < 0.011+    Fraction x == Fraction y = abs (x - y) < 0.011 +instance (RealFloat a, Ord a) =>+         Eq (Approx a) where+    Approx x == Approx y =+        isInfinite x && isInfinite y ||+        x == y ||+        let n = abs (x - y)+        in max (n / abs x) (n / abs y) < 0.011++instance (RealFloat a, Ord a) => Ord (Approx a) where+    compare (Approx x) (Approx y)+      | Approx x == Approx y = EQ+      | otherwise = compare x y+ instance Ord Fraction where-  compare (Fraction x) (Fraction y)-    | Fraction x == Fraction y = EQ-    | otherwise = compare x y+    compare (Fraction x) (Fraction y)+      | Fraction x == Fraction y = EQ+      | otherwise = compare x y  instance Monad m => Serial m Fraction where   series = fmap Fraction $ generate (\d -> if d >= 0 then pure 0 else empty) <|> rest where@@ -197,50 +313,24 @@     go lower upper = let mid = (lower + upper) / 2 in       mid : interleave (go lower mid) (go mid upper)     interleave (x:xs) (y:ys) = x : y : interleave xs ys-    interleave _ _ = undefined---- | A very small numeric type for exhaustiveness-newtype WordN (n :: Nat) = WordN { getWordN :: Word } deriving Show--mask :: KnownNat n => WordN n -> Word-mask x = shift 1 (fromInteger (natVal x)) - 1--trunc :: KnownNat n => WordN n -> WordN n-trunc v@(WordN x) = WordN (x .&. mask v)--instance KnownNat n => Bounded (WordN n) where-  minBound = WordN 0-  maxBound = res where res = WordN (mask res)--instance KnownNat n => Num (WordN n) where-  WordN x + WordN y = trunc (WordN (x + y))-  WordN x * WordN y = trunc (WordN (x * y))-  WordN x - WordN y = trunc (WordN (x - y))-  fromInteger x = trunc (WordN (fromInteger x))-  abs = id-  signum (WordN x) = WordN (signum x)--instance KnownNat n => Eq (WordN n) where-  (==) = (==) `on` getWordN . trunc+    interleave _ _           = undefined -instance KnownNat n => Ord (WordN n) where-  compare = compare `on` getWordN . trunc+instance (Monad m, KnownNat n) => Serial m (WordOfSize n) where+  series = generate (`take` [minBound..maxBound]) -instance KnownNat n => Real (WordN n) where-  toRational = toRational . getWordN+instance KnownNat n => Arbitrary (WordOfSize n) where+  arbitrary = arbitraryBoundedEnum -instance KnownNat n => Enum (WordN n) where-  fromEnum = fromEnum . getWordN-  toEnum = trunc . WordN . toEnum+instance KnownNat n => Semiring (WordOfSize n) -instance KnownNat n => Integral (WordN n) where-  toInteger = toInteger . getWordN-  quotRem (WordN x) (WordN y) = (WordN (quot x y), WordN (rem x y))+instance (Monad m, Serial m a) => Serial m (PositiveInfinite a) where+  series = fmap (maybe PositiveInfinity PosFinite) series -instance (Monad m, KnownNat n) => Serial m (WordN n) where-  series = generate (`take` [minBound..maxBound])+instance (Monad m, Serial m a) => Serial m (NegativeInfinite a) where+  series = fmap (maybe NegativeInfinity NegFinite) series -instance KnownNat n => Semiring (WordN n)+instance (Monad m, Serial m a) => Serial m (Infinite a) where+  series = fmap (either (bool Positive Negative) Finite) series  ------------------------------------------------------------------------ -- Function Equality@@ -283,7 +373,7 @@     c = maybe 1 succ (Map.lookup e m)     nb = case b of       Just (a,d) | d >= c -> (a,d)-      _ -> (e,c)+      _          -> (e,c)  apply :: Enum a => Func a b -> a -> b apply (Func c cs) x = IntMap.findWithDefault c (fromEnum x) cs@@ -298,3 +388,64 @@   one = fromFunc one   f <+> g = fromFunc (apply f <+> apply g)   f <.> g = fromFunc (apply f <.> apply g)++------------------------------------------------------------------------+-- QuickCheck wrappers++instance Arbitrary a => Arbitrary (PositiveInfinite a) where+  arbitrary = fmap (maybe PositiveInfinity PosFinite) arbitrary++instance Arbitrary a => Arbitrary (NegativeInfinite a) where+  arbitrary = fmap (maybe NegativeInfinity NegFinite) arbitrary++instance Arbitrary a => Arbitrary (Infinite a) where+  arbitrary = fmap (either (bool Positive Negative) Finite) arbitrary++instance Testable (Either String String) where+  property = either (`counterexample` False) (const (property True))++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e+         ,Arbitrary f)+  => Arbitrary (a,b,c,d,e,f) where+    arbitrary = (,,,,,) <$> arbitrary+                        <*> arbitrary+                        <*> arbitrary+                        <*> arbitrary+                        <*> arbitrary+                        <*> arbitrary++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e+         ,Arbitrary f, Arbitrary g)+  => Arbitrary (a,b,c,d,e,f,g) where+    arbitrary = (,,,,,,) <$> arbitrary+                         <*> arbitrary+                         <*> arbitrary+                         <*> arbitrary+                         <*> arbitrary+                         <*> arbitrary+                         <*> arbitrary++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e+         ,Arbitrary f, Arbitrary g, Arbitrary h)+  => Arbitrary (a,b,c,d,e,f,g,h) where+    arbitrary = (,,,,,,,) <$> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e+         ,Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i)+  => Arbitrary (a,b,c,d,e,f,g,h,i) where+    arbitrary = (,,,,,,,,) <$> arbitrary+                           <*> arbitrary+                           <*> arbitrary+                           <*> arbitrary+                           <*> arbitrary+                           <*> arbitrary+                           <*> arbitrary+                           <*> arbitrary+                           <*> arbitrary