semiring-num 1.1.0.1 → 1.2.0.0

raw patch · 7 files changed

+2348/−1057 lines, 7 filesdep +criteriondep +log-domaindep +randomdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, log-domain, random, tasty, tasty-quickcheck, tasty-smallcheck

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• bench/bench.hs +20/−0
• semiring-num.cabal +19/−1
• src/Data/Semiring.hs +1747/−674
• src/Data/Semiring/Free.hs +58/−29
• src/Data/Semiring/Numeric.hs +108/−29
• src/Data/Semiring/TH.hs +28/−9
• test/Spec.hs +368/−315

@@ -0,0 +1,20 @@+module Main (main) where++import           Criterion.Main++import           System.Random++import           Control.Monad++import           Data.Semiring++threeInts :: IO (Int,Int,Int)+threeInts = (,,) <$> randomIO <*> randomIO <*> randomIO++sumAtSize :: Int -> Benchmark+sumAtSize n =+    env (replicateM n threeInts) $+    \xs ->+         bgroup (show n) [bench "add" $ nf add xs]+main :: IO ()+main = defaultMain [sumAtSize 10000]

@@ -1,5 +1,5 @@ name:                semiring-num-version:             1.1.0.1+version:             1.2.0.0 synopsis:            Basic semiring class and instances description:         Adds a basic semiring class homepage:            https://github.com/oisdk/semiring-num@@ -22,6 +22,8 @@   other-modules:       Data.Semiring.TH   build-depends:       base >= 4.9 && < 5                      , template-haskell >= 2.11+                     , containers >= 0.5+                     , log-domain >= 0.10   default-language:    Haskell2010   ghc-options:         -Wall @@ -36,10 +38,26 @@                      , containers >= 0.5                      , QuickCheck >= 2.8                      , nat-sized-numbers >= 0.1+                     , tasty >= 0.11+                     , tasty-smallcheck >= 0.8+                     , tasty-quickcheck >= 0.8+                     , log-domain >= 0.10   ghc-options:         -threaded                        -rtsopts                        -with-rtsopts=-N                        -Wall+  default-language:    Haskell2010++benchmark bench+  type:                exitcode-stdio-1.0+  hs-source-dirs:      bench+  main-is:             bench.hs+  build-depends:       base+                     , semiring-num+                     , criterion >=1.1+                     , random >= 1.1+                     , containers >= 0.5+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010  source-repository head

@@ -1,674 +1,1747 @@-{-# LANGUAGE DefaultSignatures          #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving         #-}--{-|-Module: Data.Semiring-Description: Haskell semirings-License: MIT-Maintainer: mail@doisinkidney.com-Stability: experimental--}--module Data.Semiring-  ( -- * Semiring classes-    Semiring(..)-  , StarSemiring(..)-    -- * Helper classes-  , HasPositiveInfinity(..)-  , HasNegativeInfinity(..)-  , DetectableZero(..)-  -- * Monoidal wrappers-  , Add(..)-  , Mul(..)-  , add-  , mul-  -- * Ordering wrappers-  , Max(..)-  , Min(..)-  ) where--import           Data.Functor.Identity (Identity (..))--import           Data.Complex          (Complex)-import           Data.Fixed            (Fixed, HasResolution)-import           Data.Ratio            (Ratio)-import           Numeric.Natural       (Natural)--import           Data.Int              (Int16, Int32, Int64, Int8)-import           Data.Word             (Word16, Word32, Word64, Word8)-import           Foreign.C.Types       (CChar, CClock, CDouble, CFloat, CInt,-                                        CIntMax, CIntPtr, CLLong, CLong,-                                        CPtrdiff, CSChar, CSUSeconds, CShort,-                                        CSigAtomic, CSize, CTime, CUChar, CUInt,-                                        CUIntMax, CUIntPtr, CULLong, CULong,-                                        CUSeconds, CUShort, CWchar)--import           Foreign.Ptr           (IntPtr, WordPtr)-import           System.Posix.Types    (CCc, CDev, CGid, CIno, CMode, CNlink,-                                        COff, CPid, CRLim, CSpeed, CSsize,-                                        CTcflag, CUid, Fd)--import           Data.Semigroup        hiding (Max (..), Min (..))--import           Data.Coerce           (coerce)-import           GHC.Generics          (Generic, Generic1)--import           Data.Typeable         (Typeable)-import           Foreign.Storable      (Storable)--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--- commutative. The second is called '<.>'; it has identity element 'one',--- and it must distribute over '<+>'.------ = Laws--- == Normal 'Monoid' laws------ @(a '<+>' b) '<+>' c = a '<+>' (b '<+>' c)---'zero' '<+>' a = a '<+>' 'zero' = a---(a '<.>' b) '<.>' c = a '<.>' (b '<.>' c)---'one' '<.>' a = a '<.>' 'one' = a@------ == Commutativity of '<+>'--- @a '<+>' b = b '<+>' a@------ == Distribution of '<.>' over '<+>'--- @a '<.>' (b '<+>' c) = (a '<.>' b) '<+>' (a '<.>' c)---(a '<+>' b) '<.>' c = (a '<.>' c) '<+>' (b '<.>' c)@------ == Annihilation--- @'zero' '<.>' a = a '<.>' 'zero' = 'zero'@------ 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 (<.>) #-}---- | 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---- | Useful for operations where zeroes may need to be discarded: for instance--- in sparse matrix calculations.-class Semiring a => DetectableZero a where-  -- | 'True' if x is 'zero'.-  isZero :: a -> Bool-  default isZero :: Eq a => a -> Bool-  isZero = (zero==)------------------------------------------------------------------------------------- Infinites------------------------------------------------------------------------------------- | A class for semirings with a concept of "infinity". It's important that--- this isn't regarded as the same as "bounded":--- @x '<+>' 'positiveInfinity'@ should probably equal 'positiveInfinity'.-class HasPositiveInfinity a where-  -- | A positive infinite value-  positiveInfinity :: a-  default positiveInfinity :: RealFloat a => a-  positiveInfinity = 1/0-  -- | Test if a value is positive infinity.-  isPositiveInfinity :: a -> Bool-  default isPositiveInfinity :: RealFloat a => a -> Bool-  isPositiveInfinity x = isInfinite x && x > 0---- | A class for semirings with a concept of "negative infinity". It's important\--- that this isn't regarded as the same as "bounded":--- @x '<+>' 'negativeInfinity'@ should probably equal 'negativeInfinity'.-class HasNegativeInfinity a where-  -- | A negative infinite value-  negativeInfinity :: a-  default negativeInfinity :: RealFloat a => a-  negativeInfinity = negate (1/0)-  -- | Test if a value is negative infinity.-  isNegativeInfinity :: a -> Bool-  default isNegativeInfinity :: RealFloat a => a -> Bool-  isNegativeInfinity x = isInfinite x && x < 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------------------------------------------------------------------------------------- Instances----------------------------------------------------------------------------------instance Semiring Bool where-    one = True-    zero = False-    (<+>) = (||)-    (<.>) = (&&)-    {-# INLINE zero #-}-    {-# INLINE one #-}-    {-# INLINE (<+>) #-}-    {-# INLINE (<.>) #-}--instance StarSemiring Bool where-    star _ = True-    plus = id-    {-# INLINE star #-}-    {-# INLINE plus #-}--instance DetectableZero Bool---instance Semiring () where-    one = ()-    zero = ()-    _ <+> _ = ()-    _ <.> _ = ()-    {-# INLINE zero #-}-    {-# INLINE one #-}-    {-# INLINE (<+>) #-}-    {-# INLINE (<.>) #-}--instance DetectableZero ()--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 => DetectableZero [a] where-  isZero = null------------------------------------------------------------------------------------- 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,Functor,Foldable,Traversable-               ,Semiring,StarSemiring,DetectableZero)---- | 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,Functor,Foldable,Traversable-               ,Semiring,StarSemiring,DetectableZero)--instance Semiring a =>-         Semigroup (Add a) where-    (<>) = (coerce :: WrapBinary Add a) (<+>)-    {-# INLINE (<>) #-}--instance Semiring a =>-         Semigroup (Mul a) where-    (<>) = (coerce :: WrapBinary Mul a) (<.>)-    {-# INLINE (<>) #-}--instance Semiring a =>-         Monoid (Add a) where-    mempty = Add zero-    mappend = (<>)-    {-# INLINE mempty #-}-    {-# INLINE mappend #-}--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.------ >>> add [1..5]--- 15--- >>> add [False, False]--- False--- >>> add [False, True]--- True--- >>> add [True, undefined]--- True-add-    :: (Foldable f, Semiring a)-    => f a -> a-add = getAdd . foldMap Add---- | Takes the product of the elements of a 'Foldable'. Analogous to--- 'product' on numbers, or 'and' on 'Bool's.------ >>> mul [1..5]--- 120--- >>> mul [True, True]--- True--- >>> mul [True, False]--- False--- >>> mul [False, undefined]--- False-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:------ @'<+>'  = 'min'---'zero' = ∞---'<.>'  = '<+>'---'one'  = 'zero'@------ Note that we can't use 'Data.Semigroup.Min' from 'Data.Semigroup'--- because annihilation needs to hold:------ @∞ '<+>' x = x '<+>' ∞ = ∞@------ Taking ∞ to be 'maxBound' would break the above law. Using 'positiveInfinity'--- to represent it follows the law.-newtype Min a = Min-    { 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:------ @'<+>'  = 'max'---'zero' = -∞---'<.>'  = '<+>'---'one'  = 'zero'@------ Note that we can't use 'Data.Semigroup.Max' from 'Data.Semigroup'--- because annihilation needs to hold:------ @-∞ '<+>' x = x '<+>' -∞ = -∞@------ Taking -∞ to be 'minBound' would break the above law. Using--- 'negativeInfinity' to represent it follows the law.-newtype Max a = Max-    { 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-    (<>) = (coerce :: WrapBinary Max a) max-    {-# INLINE (<>) #-}--instance Ord a =>-         Semigroup (Min a) where-    (<>) = (coerce :: WrapBinary Min a) min-    {-# INLINE (<>) #-}---- | >>> (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 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, 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, HasPositiveInfinity a) =>-         Semiring (Min a) where-    (<+>) = mappend-    zero = mempty-    (<.>) = (coerce :: WrapBinary Min a) (<+>)-    one = Min zero-    {-# INLINE zero #-}-    {-# INLINE one #-}-    {-# INLINE (<+>) #-}-    {-# INLINE (<.>) #-}--instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>-         StarSemiring (Max a) where-    star (Max x)-      | x > zero = Max positiveInfinity-      | otherwise = Max zero--instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>-         StarSemiring (Min a) where-    star (Min x)-      | x < zero = Min negativeInfinity-      | otherwise = Min zero--instance (Semiring a, Ord a, HasPositiveInfinity a) => DetectableZero (Min a) where-  isZero (Min x) = isPositiveInfinity x--instance (Semiring a, Ord a, HasNegativeInfinity a) => DetectableZero (Max a) where-  isZero (Max x) = isNegativeInfinity x------------------------------------------------------------------------------------- (->) 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 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:------ @forall a. 'Endo' ('Endo' a)@------ 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-    {-# 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)--instance (Enum a, Bounded a, Eq a, Monoid a) => DetectableZero (Endo a) where-  isZero (Endo f) = all (mempty==) (map f [minBound..maxBound])------------------------------------------------------------------------------------- Instances for Bool wrappers----------------------------------------------------------------------------------instance Semiring Any where-    (<+>) = 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-    {-# INLINE zero #-}-    {-# INLINE one #-}-    {-# INLINE (<+>) #-}-    {-# INLINE (<.>) #-}--instance StarSemiring All where-    star _ = All True-    plus = id-    {-# INLINE star #-}-    {-# INLINE plus #-}--instance DetectableZero Any-instance DetectableZero All------------------------------------------------------------------------------------- Boring instances-----------------------------------------------------------------------------------instance Semiring Int-instance Semiring Int8-instance Semiring Int16-instance Semiring Int32-instance Semiring Int64-instance Semiring Integer-instance Semiring Word-instance Semiring Word8-instance Semiring Word16-instance Semiring Word32-instance Semiring Word64-instance Semiring Float-instance Semiring Double-instance Semiring CUIntMax-instance Semiring CIntMax-instance Semiring CUIntPtr-instance Semiring CIntPtr-instance Semiring CSUSeconds-instance Semiring CUSeconds-instance Semiring CTime-instance Semiring CClock-instance Semiring CSigAtomic-instance Semiring CWchar-instance Semiring CSize-instance Semiring CPtrdiff-instance Semiring CDouble-instance Semiring CFloat-instance Semiring CULLong-instance Semiring CLLong-instance Semiring CULong-instance Semiring CLong-instance Semiring CUInt-instance Semiring CInt-instance Semiring CUShort-instance Semiring CShort-instance Semiring CUChar-instance Semiring CSChar-instance Semiring CChar-instance Semiring IntPtr-instance Semiring WordPtr-instance Semiring Fd-instance Semiring CRLim-instance Semiring CTcflag-instance Semiring CSpeed-instance Semiring CCc-instance Semiring CUid-instance Semiring CNlink-instance Semiring CGid-instance Semiring CSsize-instance Semiring CPid-instance Semiring COff-instance Semiring CMode-instance Semiring CIno-instance Semiring CDev-instance Semiring Natural-instance Integral a => Semiring (Ratio a)-deriving instance Semiring a => Semiring (Product a)-deriving instance Semiring a => Semiring (Sum a)-instance RealFloat a => Semiring (Complex a)-instance HasResolution a => Semiring (Fixed a)-deriving instance Semiring a => Semiring (Identity a)--instance DetectableZero Int-instance DetectableZero Int8-instance DetectableZero Int16-instance DetectableZero Int32-instance DetectableZero Int64-instance DetectableZero Integer-instance DetectableZero Word-instance DetectableZero Word8-instance DetectableZero Word16-instance DetectableZero Word32-instance DetectableZero Word64-instance DetectableZero Float-instance DetectableZero Double-instance DetectableZero CUIntMax-instance DetectableZero CIntMax-instance DetectableZero CUIntPtr-instance DetectableZero CIntPtr-instance DetectableZero CSUSeconds-instance DetectableZero CUSeconds-instance DetectableZero CTime-instance DetectableZero CClock-instance DetectableZero CSigAtomic-instance DetectableZero CWchar-instance DetectableZero CSize-instance DetectableZero CPtrdiff-instance DetectableZero CDouble-instance DetectableZero CFloat-instance DetectableZero CULLong-instance DetectableZero CLLong-instance DetectableZero CULong-instance DetectableZero CLong-instance DetectableZero CUInt-instance DetectableZero CInt-instance DetectableZero CUShort-instance DetectableZero CShort-instance DetectableZero CUChar-instance DetectableZero CSChar-instance DetectableZero CChar-instance DetectableZero IntPtr-instance DetectableZero WordPtr-instance DetectableZero Fd-instance DetectableZero CRLim-instance DetectableZero CTcflag-instance DetectableZero CSpeed-instance DetectableZero CCc-instance DetectableZero CUid-instance DetectableZero CNlink-instance DetectableZero CGid-instance DetectableZero CSsize-instance DetectableZero CPid-instance DetectableZero COff-instance DetectableZero CMode-instance DetectableZero CIno-instance DetectableZero CDev-instance DetectableZero Natural-instance Integral a => DetectableZero (Ratio a)-deriving instance DetectableZero a => DetectableZero (Product a)-deriving instance DetectableZero a => DetectableZero (Sum a)-instance RealFloat a => DetectableZero (Complex a)-instance HasResolution a => DetectableZero (Fixed a)-deriving instance DetectableZero a => DetectableZero (Identity a)------------------------------------------------------------------------------------- Very boring instances-----------------------------------------------------------------------------------$(traverse semiringIns [2..9])-$(traverse starIns [2..9])-$(traverse zeroIns [2..9])+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++{-|+Module: Data.Semiring+Description: Haskell semirings+License: MIT+Maintainer: mail@doisinkidney.com+Stability: experimental+-}+module Data.Semiring+  (+   -- * Semiring classes+   Semiring(..)+  ,StarSemiring(..)+  ,mulFoldable+  ,addFoldable+  ,+   -- * Helper classes+   HasPositiveInfinity(..)+  ,HasNegativeInfinity(..)+  ,DetectableZero(..)+  ,+   -- * Monoidal wrappers+   Add(..)+  ,Mul(..)+  ,+   -- * Ordering wrappers+   Max(..)+  ,Min(..)+  ,+   -- * Matrix wrapper+   Matrix(..))+  where++import Data.Functor.Identity (Identity(..))+import Data.Complex (Complex)+import Data.Fixed (Fixed, HasResolution)+import Data.Ratio (Ratio)+import Numeric.Natural (Natural)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)+import Foreign.C.Types+       (CChar, CClock, CDouble, CFloat, CInt, CIntMax, CIntPtr, CLLong,+        CLong, CPtrdiff, CSChar, CSUSeconds, CShort, CSigAtomic, CSize,+        CTime, CUChar, CUInt, CUIntMax, CUIntPtr, CULLong, CULong,+        CUSeconds, CUShort, CWchar)+import Foreign.Ptr (IntPtr, WordPtr)+import System.Posix.Types+       (CCc, CDev, CGid, CIno, CMode, CNlink, COff, CPid, CRLim, CSpeed,+        CSsize, CTcflag, CUid, Fd)+import Data.Semigroup hiding (Max(..), Min(..))+import Data.Coerce+import GHC.Generics (Generic, Generic1)+import Data.Typeable (Typeable)+import Foreign.Storable (Storable)+import Data.Semiring.TH+import Data.Functor.Classes+import Text.Read++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import Data.Set (Set)+import qualified Data.Set as Set++import Numeric.Log hiding (sum)+import qualified Numeric.Log++import Control.Monad+import Control.Applicative+import Data.Foldable++-- $setup+-- >>> import Data.Function++-- | A <https://en.wikipedia.org/wiki/Semiring Semiring> is like the+-- the combination of two 'Data.Monoid.Monoid's. The first+-- is called '<+>'; it has the identity element 'zero', and it is+-- commutative. The second is called '<.>'; it has identity element 'one',+-- and it must distribute over '<+>'.+--+-- = Laws+-- == Normal 'Monoid' laws+--+-- @(a '<+>' b) '<+>' c = a '<+>' (b '<+>' c)+--'zero' '<+>' a = a '<+>' 'zero' = a+--(a '<.>' b) '<.>' c = a '<.>' (b '<.>' c)+--'one' '<.>' a = a '<.>' 'one' = a@+--+-- == Commutativity of '<+>'+-- @a '<+>' b = b '<+>' a@+--+-- == Distribution of '<.>' over '<+>'+-- @a '<.>' (b '<+>' c) = (a '<.>' b) '<+>' (a '<.>' c)+--(a '<+>' b) '<.>' c = (a '<.>' c) '<+>' (b '<.>' c)@+--+-- == Annihilation+-- @'zero' '<.>' a = a '<.>' 'zero' = 'zero'@+--+-- 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+    {-# MINIMAL zero , one , (<.>) , (<+>) #-}+    -- | 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+    -- | Takes the sum of the elements of a 'Foldable'. Analogous to 'sum'+    -- on numbers, or 'or' on 'Bool's.+    --+    -- >>> add [1..5]+    -- 15+    -- >>> add [False, False]+    -- False+    -- >>> add [False, True]+    -- True+    -- >>> add [True, undefined]+    -- True+    add+        :: [a] -> a+    add = getAdd . foldMap Add+    {-# INLINE add #-}+    -- | Takes the product of the elements of a 'Foldable'. Analogous to+    -- 'product' on numbers, or 'and' on 'Bool's.+    --+    -- >>> mul [1..5]+    -- 120+    -- >>> mul [True, True]+    -- True+    -- >>> mul [True, False]+    -- False+    -- >>> mul [False, undefined]+    -- False+    mul+        :: [a] -> a+    mul = getMul . foldMap Mul+    {-# INLINE mul #-}++-- | The product of the contents of a 'Foldable'.+mulFoldable :: (Foldable f, Semiring a) => f a -> a+mulFoldable = mul . toList+{-# INLINE mulFoldable #-}++-- | The sum of the contents of a 'Foldable'.+addFoldable :: (Foldable f, Semiring a) => f a -> a+addFoldable = add . toList+{-# INLINE addFoldable #-}+++-- | 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+    {-# INLINE star #-}+    plus x = x <.> star x+    {-# INLINE plus #-}++-- | Useful for operations where zeroes may need to be discarded: for instance+-- in sparse matrix calculations.+class Semiring a =>+      DetectableZero a  where+    -- | 'True' if x is 'zero'.+    isZero+        :: a -> Bool++isZeroEq+    :: (Semiring a, Eq a)+    => a -> Bool+isZeroEq = (zero ==)+{-# INLINE isZeroEq #-}++--------------------------------------------------------------------------------+-- Infinites+--------------------------------------------------------------------------------+-- | A class for semirings with a concept of "infinity". It's important that+-- this isn't regarded as the same as "bounded":+-- @x '<+>' 'positiveInfinity'@ should probably equal 'positiveInfinity'.+class HasPositiveInfinity a  where+    -- | A positive infinite value+    positiveInfinity+        :: a+    -- | Test if a value is positive infinity.+    isPositiveInfinity+        :: a -> Bool++defaultPositiveInfinity+    :: RealFloat a+    => a+defaultPositiveInfinity = 1 / 0+{-# INLINE defaultPositiveInfinity #-}++defaultIsPositiveInfinity+    :: RealFloat a+    => a -> Bool+defaultIsPositiveInfinity x = isInfinite x && x > 0+{-# INLINE defaultIsPositiveInfinity #-}++-- | A class for semirings with a concept of "negative infinity". It's important\+-- that this isn't regarded as the same as "bounded":+-- @x '<+>' 'negativeInfinity'@ should probably equal 'negativeInfinity'.+class HasNegativeInfinity a  where+    -- | A negative infinite value+    negativeInfinity+        :: a+    -- | Test if a value is negative infinity.+    isNegativeInfinity+        :: a -> Bool++defaultIsNegativeInfinity+    :: RealFloat a+    => a -> Bool+defaultIsNegativeInfinity x = isInfinite x && x < 0+{-# INLINE defaultIsNegativeInfinity #-}++defaultNegativeInfinity+    :: RealFloat a+    => a+defaultNegativeInfinity = negate (1 / 0)+{-# INLINE defaultNegativeInfinity #-}++instance HasPositiveInfinity Double where+    positiveInfinity = defaultPositiveInfinity+    isPositiveInfinity = defaultIsPositiveInfinity+    {-# INLINE positiveInfinity #-}+    {-# INLINE isPositiveInfinity #-}++instance HasNegativeInfinity Double where+    negativeInfinity = defaultNegativeInfinity+    isNegativeInfinity = defaultIsNegativeInfinity+    {-# INLINE negativeInfinity #-}+    {-# INLINE isNegativeInfinity #-}++instance HasPositiveInfinity Float where+    positiveInfinity = defaultPositiveInfinity+    isPositiveInfinity = defaultIsPositiveInfinity+    {-# INLINE positiveInfinity #-}+    {-# INLINE isPositiveInfinity #-}++instance HasNegativeInfinity Float where+    negativeInfinity = defaultNegativeInfinity+    isNegativeInfinity = defaultIsNegativeInfinity+    {-# INLINE negativeInfinity #-}+    {-# INLINE isNegativeInfinity #-}++instance HasPositiveInfinity CDouble where+    positiveInfinity = defaultPositiveInfinity+    isPositiveInfinity = defaultIsPositiveInfinity+    {-# INLINE positiveInfinity #-}+    {-# INLINE isPositiveInfinity #-}++instance HasNegativeInfinity CDouble where+    negativeInfinity = defaultNegativeInfinity+    isNegativeInfinity = defaultIsNegativeInfinity+    {-# INLINE negativeInfinity #-}+    {-# INLINE isNegativeInfinity #-}++instance HasPositiveInfinity CFloat where+    positiveInfinity = defaultPositiveInfinity+    isPositiveInfinity = defaultIsPositiveInfinity+    {-# INLINE positiveInfinity #-}+    {-# INLINE isPositiveInfinity #-}++instance HasNegativeInfinity CFloat where+    negativeInfinity = defaultNegativeInfinity+    isNegativeInfinity = defaultIsNegativeInfinity+    {-# INLINE negativeInfinity #-}+    {-# INLINE isNegativeInfinity #-}++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------+instance Semiring Bool where+    one = True+    zero = False+    (<+>) = (||)+    (<.>) = (&&)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance StarSemiring Bool where+    star _ = True+    plus = id+    {-# INLINE star #-}+    {-# INLINE plus #-}++instance DetectableZero Bool where+    isZero = not+    {-# INLINE isZero #-}++instance Semiring () where+    one = ()+    zero = ()+    _ <+> _ = ()+    _ <.> _ = ()+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance DetectableZero () where+    isZero _ = True+    {-# INLINE isZero #-}++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 =>+         DetectableZero [a] where+    isZero = null+    {-# INLINE isZero #-}++instance (Monoid a, Ord a) =>+         Semiring (Set a) where+    (<+>) = Set.union+    zero = Set.empty+    one = Set.singleton mempty+    xs <.> ys = foldMap (flip Set.map ys . mappend) xs+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}+    {-# INLINE zero #-}+    {-# INLINE one #-}++instance (Ord a, Monoid a, Semiring b) =>+         Semiring (Map a b) where+    one = Map.singleton mempty one+    {-# INLINE one #-}+    zero = Map.empty+    {-# INLINE zero #-}+    (<+>) = Map.unionWith (<+>)+    {-# INLINE (<+>) #-}+    xs <.> ys =+        Map.fromListWith+            (<+>)+            [ (mappend k l, v <.> u)+            | (k,v) <- Map.toList xs+            , (l,u) <- Map.toList ys ]+    {-# INLINE (<.>) #-}++instance (Monoid a, Ord a) =>+         DetectableZero (Set a) where+    isZero = Set.null+    {-# INLINE isZero #-}++instance (Precise a, RealFloat a) => Semiring (Log a) where+    (<.>) = (*)+    {-# INLINE (<.>) #-}+    (<+>) = (+)+    {-# INLINE (<+>) #-}+    one = Exp 0+    {-# INLINE one #-}+    zero = Exp (-(1/0))+    {-# INLINE zero #-}+    add = Numeric.Log.sum+    {-# INLINE add #-}++instance (Precise a, RealFloat a) => DetectableZero (Log a) where+    isZero = isZeroEq+    {-# INLINE isZero #-}++--------------------------------------------------------------------------------+-- 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,Functor,Foldable,Traversable+               ,Semiring,DetectableZero,StarSemiring)++instance Eq1 Add where+    liftEq = coerce++instance Ord1 Add where+    liftCompare = coerce++showsNewtype :: Coercible b a => String -> String -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> b -> ShowS+showsNewtype cons acc = s+  where+    s sp _ n x =+        showParen (n > 10) $+        showString cons .+        showString " {" .+        showString acc . showString " =" . sp 0 (coerce x) . showChar '}'++readsNewtype :: Coercible a b => String -> String -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS b+readsNewtype cons acc = r where+    r rp _ = readPrec_to_S $ prec 10 $ do+        Ident c <- lexP+        guard (c == cons)+        Punc "{" <- lexP+        Ident a <- lexP+        guard (a == acc)+        Punc "=" <- lexP+        x <- prec 0 $ readS_to_Prec rp+        Punc "}" <- lexP+        pure (coerce x)++instance Show1 Add where+    liftShowsPrec = showsNewtype "Add" "getAdd"++instance Read1 Add where+    liftReadsPrec = readsNewtype "Add" "getAdd"++-- | 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,Functor,Foldable,Traversable+               ,Semiring,DetectableZero,StarSemiring)++instance Eq1 Mul where+    liftEq = coerce++instance Ord1 Mul where+    liftCompare = coerce++instance Show1 Mul where+    liftShowsPrec = showsNewtype "Mul" "getMul"++instance Read1 Mul where+    liftReadsPrec = readsNewtype "Mul" "getMul"++instance Semiring a =>+         Semigroup (Add a) where+    (<>) = (coerce :: WrapBinary Add a) (<+>)+    {-# INLINE (<>) #-}++instance Semiring a =>+         Semigroup (Mul a) where+    (<>) = (coerce :: WrapBinary Mul a) (<.>)+    {-# INLINE (<>) #-}++instance Semiring a =>+         Monoid (Add a) where+    mempty = Add zero+    {-# INLINE mempty #-}+    mappend = (<>)+    {-# INLINE mappend #-}+    mconcat = (coerce :: ([a] -> a) -> [Add a] -> Add a) add+    {-# INLINE mconcat #-}++instance Semiring a =>+         Monoid (Mul a) where+    mempty = Mul one+    {-# INLINE mempty #-}+    mappend = (<>)+    {-# INLINE mappend #-}+    mconcat = (coerce :: ([a] -> a) -> [Mul a] -> Mul a) mul+    {-# INLINE mconcat #-}++--------------------------------------------------------------------------------+-- Traversable newtype+--------------------------------------------------------------------------------+-- | A suitable definition of a square matrix for certain types which are both+-- 'Applicative' and 'Traversable'. For instance, given a type like so:+--+-- >>> :{+-- data Quad a = Quad a a a a deriving Show+-- instance Functor Quad where+--     fmap f (Quad w x y z) = Quad (f w) (f x) (f y) (f z)+-- instance Applicative Quad where+--     pure x = Quad x x x x+--     Quad fw fx fy fz <*> Quad xw xx xy xz =+--         Quad (fw xw) (fx xx) (fy xy) (fz xz)+-- instance Foldable Quad where+--     foldr f b (Quad w x y z) = f w (f x (f y (f z b)))+-- instance Traversable Quad where+--     traverse f (Quad w x y z) = Quad <$> f w <*> f x <*> f y <*> f z+-- :}+--+-- The newtype performs as you would expect:+--+-- >>> getMatrix one :: Quad (Quad Integer)+-- Quad (Quad 1 0 0 0) (Quad 0 1 0 0) (Quad 0 0 1 0) (Quad 0 0 0 1)+--+-- 'ZipList's are another type which works with this newtype:+--+-- >>> :{+-- let xs = (Matrix . ZipList . map ZipList) [[1,2],[3,4]]+--     ys = (Matrix . ZipList . map ZipList) [[5,6],[7,8]]+-- in (map getZipList . getZipList . getMatrix) (xs <.> ys)+-- :}+-- [[19,22],[43,50]]+newtype Matrix f a = Matrix+    { getMatrix :: f (f a)+    } deriving (Generic,Generic1,Typeable,Functor,Foldable,Traversable)++instance Applicative f =>+         Applicative (Matrix f) where+    pure = Matrix #. pure . pure+    (<*>) =+        (coerce :: (f (f (a -> b)) -> f (f a) -> f (f b)) -> Matrix f (a -> b) -> Matrix f a -> Matrix f b)+            (liftA2 (<*>))++instance (Traversable f, Applicative f, Semiring a) =>+         Semiring (Matrix f a) where+    Matrix xs <.> Matrix ys =+        Matrix (fmap (\row -> fmap (addFoldable . liftA2 (<.>) row) c) xs)+      where+        c = sequenceA ys+    (<+>) = liftA2 (<+>)+    zero = pure zero+    one = case zero of+      Matrix xs -> Matrix (imap (\i -> imap (\j x -> if i == j then one else x)) xs)++newtype State a = State (Int -> (a, Int)) deriving Functor++instance Applicative State where+    pure x = State (\i -> (x, i))+    State fs <*> State xs = State (\i -> case fs i of+                                      (f, i') -> case xs i' of+                                        (x,i'') -> (f x, i''))++evalState :: State a -> Int -> a+evalState (State r) i = case r i of+  (x,_) -> x++imap :: Traversable t => (Int -> a -> b) -> t a -> t b+imap f xs = evalState (traverse (\x -> State (\i -> (f i x, i + 1))) xs) 0++infixr 9 #.+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c+(#.) _ = coerce++instance Show1 f =>+         Show1 (Matrix f) where+    liftShowsPrec (sp :: Int -> a -> ShowS) sl =+        showsNewtype "Matrix" "getMatrix" liftedTwiceSP liftedTwiceSL+      where+        liftedOnceSP :: Int -> f a -> ShowS+        liftedOnceSP = liftShowsPrec sp sl+        liftedOnceSL :: [f a] -> ShowS+        liftedOnceSL = liftShowList sp sl+        liftedTwiceSP :: Int -> f (f a) -> ShowS+        liftedTwiceSP = liftShowsPrec liftedOnceSP liftedOnceSL+        liftedTwiceSL :: [f (f a)] -> ShowS+        liftedTwiceSL = liftShowList liftedOnceSP liftedOnceSL++instance Read1 f =>+         Read1 (Matrix f) where+    liftReadsPrec (rp :: Int -> ReadS a) rl =+        readsNewtype "Matrix" "getMatrix" liftedTwiceRP liftedTwiceRL+      where+        liftedOnceRP :: Int -> ReadS (f a)+        liftedOnceRP = liftReadsPrec rp rl+        liftedOnceRL :: ReadS [f a]+        liftedOnceRL = liftReadList rp rl+        liftedTwiceRP :: Int -> ReadS (f (f a))+        liftedTwiceRP = liftReadsPrec liftedOnceRP liftedOnceRL+        liftedTwiceRL :: ReadS [f (f a)]+        liftedTwiceRL = liftReadList liftedOnceRP liftedOnceRL++instance Eq1 f =>+         Eq1 (Matrix f) where+    liftEq (eq :: a -> b -> Bool) =+        coerce (liftEq (liftEq eq) :: f (f a) -> f (f b) -> Bool)++instance Ord1 f => Ord1 (Matrix f) where+    liftCompare (cmp :: a -> b -> Ordering) =+        coerce (liftCompare (liftCompare cmp) :: f (f a) -> f (f b) -> Ordering)++instance (Show1 f, Show a) => Show (Matrix f a) where+    showsPrec = showsPrec1++instance (Read1 f, Read a) => Read (Matrix f a) where+    readsPrec = readsPrec1++instance (Eq1 f, Eq a) => Eq (Matrix f a) where+    (==) = eq1++instance (Ord1 f, Ord a) => Ord (Matrix f a) where+    compare = compare1++--------------------------------------------------------------------------------+-- Ord wrappers+--------------------------------------------------------------------------------+-- | The "<https://ncatlab.org/nlab/show/tropical+semiring Tropical>" or+-- min-plus semiring. It is a semiring where:+--+-- @'<+>'  = 'min'+--'zero' = ∞+--'<.>'  = '<+>'+--'one'  = 'zero'@+--+-- Note that we can't use 'Data.Semigroup.Min' from 'Data.Semigroup'+-- because annihilation needs to hold:+--+-- @∞ '<+>' x = x '<+>' ∞ = ∞@+--+-- Taking ∞ to be 'maxBound' would break the above law. Using 'positiveInfinity'+-- to represent it follows the law.+newtype Min a = Min+    { 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:+--+-- @'<+>'  = 'max'+--'zero' = -∞+--'<.>'  = '<+>'+--'one'  = 'zero'@+--+-- Note that we can't use 'Data.Semigroup.Max' from 'Data.Semigroup'+-- because annihilation needs to hold:+--+-- @-∞ '<+>' x = x '<+>' -∞ = -∞@+--+-- Taking -∞ to be 'minBound' would break the above law. Using+-- 'negativeInfinity' to represent it follows the law.+newtype Max a = Max+    { getMax :: a+    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable)++instance Eq1 Max where+    liftEq = coerce++instance Ord1 Max where+    liftCompare = coerce++instance Show1 Max where+    liftShowsPrec = showsNewtype "Max" "getMax"++instance Read1 Max where+    liftReadsPrec = readsNewtype "Max" "getMax"++instance Eq1 Min where+    liftEq = coerce++instance Ord1 Min where+    liftCompare = coerce++instance Show1 Min where+    liftShowsPrec = showsNewtype "Min" "getMin"++instance Read1 Min where+    liftReadsPrec = readsNewtype "Min" "getMin"++instance Ord a =>+         Semigroup (Max a) where+    (<>) = (coerce :: WrapBinary Max a) max+    {-# INLINE (<>) #-}++instance Ord a =>+         Semigroup (Min a) where+    (<>) = (coerce :: WrapBinary Min a) min+    {-# INLINE (<>) #-}++-- | >>> (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 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, 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, HasPositiveInfinity a) =>+         Semiring (Min a) where+    (<+>) = mappend+    zero = mempty+    (<.>) = (coerce :: WrapBinary Min a) (<+>)+    one = Min zero+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>+         StarSemiring (Max a) where+    star (Max x)+      | x > zero = Max positiveInfinity+      | otherwise = Max zero++instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>+         StarSemiring (Min a) where+    star (Min x)+      | x < zero = Min negativeInfinity+      | otherwise = Min zero++instance (Semiring a, Ord a, HasPositiveInfinity a) =>+         DetectableZero (Min a) where+    isZero (Min x) = isPositiveInfinity x+    {-# INLINE isZero #-}++instance (Semiring a, Ord a, HasNegativeInfinity a) =>+         DetectableZero (Max a) where+    isZero (Max x) = isNegativeInfinity x+    {-# INLINE isZero #-}++--------------------------------------------------------------------------------+-- (->) instance+--------------------------------------------------------------------------------+-- | The @(->)@ instance is analogous to the one for 'Monoid'.+instance Semiring b =>+         Semiring (a -> b) where+    zero = const zero+    {-# INLINE zero #-}+    one = const one+    {-# INLINE one #-}+    (f <+> g) x = f x <+> g x+    {-# INLINE (<+>) #-}+    (f <.> g) x = f x <.> g x+    {-# INLINE (<.>) #-}++instance StarSemiring b =>+         StarSemiring (a -> b) where+    star = (.) star+    {-# INLINE star #-}+    plus = (.) plus+    {-# INLINE plus #-}++--------------------------------------------------------------------------------+-- 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:+--+-- @forall a. 'Endo' ('Endo' a)@+--+-- 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+    {-# 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)++instance (Enum a, Bounded a, Eq a, Monoid a) =>+         DetectableZero (Endo a) where+    isZero (Endo f) = all (mempty ==) (map f [minBound .. maxBound])++--------------------------------------------------------------------------------+-- Instances for Bool wrappers+--------------------------------------------------------------------------------+instance Semiring Any where+    (<+>) = 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+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance StarSemiring All where+    star _ = All True+    plus = id+    {-# INLINE star #-}+    {-# INLINE plus #-}++instance DetectableZero Any where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero All where+    isZero = isZeroEq+    {-# INLINE isZero #-}++--------------------------------------------------------------------------------+-- Boring instances+--------------------------------------------------------------------------------++instance Semiring Int where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Int8 where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Int16 where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Int32 where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Int64 where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Integer where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Word where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Word8 where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Word16 where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Word32 where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Word64 where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Float where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Double where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CUIntMax where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CIntMax where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CUIntPtr where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CIntPtr where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CSUSeconds where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CUSeconds where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CTime where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CClock where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CSigAtomic where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CWchar where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CSize where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CPtrdiff where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CDouble where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CFloat where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CULLong where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CLLong where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CULong where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CLong where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CUInt where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CInt where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CUShort where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CShort where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CUChar where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CSChar where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CChar where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring IntPtr where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring WordPtr where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Fd where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CRLim where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CTcflag where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CSpeed where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CCc where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CUid where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CNlink where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CGid where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CSsize where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CPid where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring COff where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CMode where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CIno where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring CDev where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring Natural where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Integral a =>+         Semiring (Ratio a) where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring a => Semiring (Product a) where+    one = Product one+    {-# INLINE one #-}+    zero = Product zero+    {-# INLINE zero #-}+    (<+>) = (coerce :: WrapBinary Product a) (<+>)+    {-# INLINE (<+>) #-}+    (<.>) = (coerce :: WrapBinary Product a) (<.>)+    {-# INLINE (<.>) #-}++instance Semiring a => Semiring (Sum a) where+    one = Sum one+    {-# INLINE one #-}+    zero = Sum zero+    {-# INLINE zero #-}+    (<+>) = (coerce :: WrapBinary Sum a) (<+>)+    {-# INLINE (<+>) #-}+    (<.>) = (coerce :: WrapBinary Sum a) (<.>)+    {-# INLINE (<.>) #-}++instance RealFloat a =>+         Semiring (Complex a) where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance HasResolution a =>+         Semiring (Fixed a) where+    one = 1+    zero = 0+    (<+>) = (+)+    (<.>) = (*)+    {-# INLINE zero #-}+    {-# INLINE one #-}+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}++instance Semiring a => Semiring (Identity a) where+    one = Identity one+    {-# INLINE one #-}+    zero = Identity zero+    {-# INLINE zero #-}+    (<+>) = (coerce :: WrapBinary Identity a) (<+>)+    {-# INLINE (<+>) #-}+    (<.>) = (coerce :: WrapBinary Identity a) (<.>)+    {-# INLINE (<.>) #-}++instance DetectableZero Int where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Int8 where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Int16 where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Int32 where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Int64 where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Integer where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Word where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Word8 where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Word16 where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Word32 where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Word64 where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Float where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Double where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CUIntMax where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CIntMax where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CUIntPtr where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CIntPtr where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CSUSeconds where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CUSeconds where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CTime where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CClock where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CSigAtomic where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CWchar where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CSize where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CPtrdiff where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CDouble where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CFloat where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CULLong where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CLLong where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CULong where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CLong where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CUInt where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CInt where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CUShort where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CShort where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CUChar where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CSChar where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CChar where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero IntPtr where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero WordPtr where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Fd where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CRLim where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CTcflag where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CSpeed where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CCc where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CUid where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CNlink where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CGid where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CSsize where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CPid where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero COff where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CMode where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CIno where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero CDev where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance DetectableZero Natural where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance Integral a =>+         DetectableZero (Ratio a) where+    isZero = isZeroEq+    {-# INLINE isZero #-}++deriving instance DetectableZero a => DetectableZero (Product a)++deriving instance DetectableZero a => DetectableZero (Sum a)++instance RealFloat a =>+         DetectableZero (Complex a) where+    isZero = isZeroEq+    {-# INLINE isZero #-}++instance HasResolution a =>+         DetectableZero (Fixed a) where+    isZero = isZeroEq+    {-# INLINE isZero #-}++deriving instance DetectableZero a => DetectableZero (Identity a)++--------------------------------------------------------------------------------+-- Very boring instances+--------------------------------------------------------------------------------+$(traverse semiringIns [2 .. 15])++$(traverse starIns [2 .. 15])++$(traverse zeroIns [2 .. 15])

@@ -1,47 +1,76 @@-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | The Free semiring. module Data.Semiring.Free-  ( Free(..)-  , liftFree-  , unFree-  ) where+  (Free(..)+  ,liftFree+  ,lowerFree+  ,runFree)+  where -import           Control.Applicative (liftA2) import           Data.Coerce import           Data.Semiring --- | The free semiring. Adapted from PureScript's version, available--- <https://pursuit.purescript.org/packages/purescript-semirings/3.0.0/docs/Data.Semiring.Free here>.--- Only a valid semiring if treated as a multiset, as in:------ > Free [[1],[0]] = Free [[0],[1]]-newtype Free a = Free-  { getFree :: [[a]]-  } deriving (Show, Read, Functor, Foldable, Traversable, Monoid)+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map -instance Semiring (Free a) where-  Free xs <+> Free ys = Free (xs ++ ys)-  Free xs <.> Free ys = Free (liftA2 (++) xs ys)-  one = Free [[]]-  zero = Free []+import           Numeric.Natural -instance Applicative Free where-  pure = Free . pure . pure-  Free fs <*> Free xs = Free (liftA2 (<*>) fs xs)+-- | The free semiring+newtype Free a = Free+  { getFree :: Map [a] Natural+  } deriving (Show, Read, Eq, Ord, Semiring) +instance Ord a => Num (Free a) where+    fromInteger = Free . Map.singleton [] . fromInteger+    {-# INLINE fromInteger #-}+    (+) = (<+>)+    {-# INLINE (+) #-}+    (*) = (<.>)+    {-# INLINE (*) #-}+    abs = id+    {-# INLINE abs #-}+    signum (Free x) = if Map.null x then zero else one+    {-# INLINE signum #-}+    negate = id+    {-# INLINE negate #-}+ -- | Run a 'Free'.-liftFree :: Semiring s => (a -> s) -> Free a -> s-liftFree f = unFree . fmap f+runFree :: Semiring s => (a -> s) -> Free a -> s+runFree f = getAdd .# Map.foldMapWithKey ((rep #. Add) . mul . map f) . getFree+{-# INLINE runFree #-}  -- | Run a 'Free', interpreting it in the underlying semiring.-unFree :: Semiring s => Free s -> s-unFree = getAdd .# foldMap (Add .# getMul .# foldMap Mul) . getFree+lowerFree :: Semiring s => Free s -> s+lowerFree = runFree id+{-# INLINE lowerFree #-} +liftFree :: a -> Free a+liftFree = Free . flip Map.singleton one . pure+{-# INLINE liftFree #-}++infixr 9 #.+(#.) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c+(#.) f _ = coerce f+{-# INLINE (#.) #-}+ infixr 9 .#-(.#) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c+(.#) :: Coercible b c => (b -> c) -> (a  -> b) -> a -> c (.#) _ = coerce+{-# INLINE (.#) #-} +instance Foldable Free where+    foldMap f (Free xs) = Map.foldMapWithKey (rep . foldMap f) xs+    {-# INLINE foldMap #-}++rep :: Monoid m => m -> Natural -> m+rep x = go+  where+    go 0 = mempty+    go 1 = x+    go n+      | even n = r `mappend` r+      | otherwise = x `mappend` r `mappend` r+      where+        r = go (n `div` 2)+{-# INLINE rep #-}

@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-|@@ -16,18 +17,23 @@   , Division(..)   , Łukasiewicz(..)   , Viterbi(..)-  , Log(..)   , PosFrac(..)   , PosInt(..)   ) where  import           Data.Coerce+import           Text.Read+import           Control.Monad+ import           Data.Semiring-import           GHC.Generics +import           GHC.Generics     (Generic,Generic1) import           Data.Typeable    (Typeable) import           Foreign.Storable (Storable)+import           Data.Functor.Classes ++ type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a  -- | Useful for some constraint problems.@@ -52,8 +58,21 @@   {-# INLINE zero #-}   {-# INLINE one #-} -instance (Bounded a, Ord a) => DetectableZero (Bottleneck a)+instance (Bounded a, Ord a) => DetectableZero (Bottleneck a) where+  isZero = (zero==) +instance Eq1 Bottleneck where+    liftEq = coerce++instance Ord1 Bottleneck where+    liftCompare = coerce++instance Show1 Bottleneck where+    liftShowsPrec = showsNewtype "Bottleneck" "getBottleneck"++instance Read1 Bottleneck where+    liftReadsPrec = readsNewtype "Bottleneck" "getBottleneck"+ -- | Positive numbers only. -- -- @('<+>') = 'gcd'@@ -77,6 +96,18 @@   {-# INLINE zero #-}   {-# INLINE one #-} +instance Eq1 Division where+    liftEq = coerce++instance Ord1 Division where+    liftCompare = coerce++instance Show1 Division where+    liftShowsPrec = showsNewtype "Division" "getDivision"++instance Read1 Division where+    liftReadsPrec = readsNewtype "Division" "getDivision"+ -- | <https://en.wikipedia.org/wiki/Semiring#cite_ref-droste_14-0 Wikipedia> -- has some information on this. Also -- <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.304.6152&rep=rep1&type=pdf this>@@ -102,8 +133,21 @@   {-# INLINE zero #-}   {-# INLINE one #-} -instance (Ord a, Num a) => DetectableZero (Łukasiewicz a)+instance (Ord a, Num a) => DetectableZero (Łukasiewicz a) where+  isZero = (zero==) +instance Eq1 Łukasiewicz where+    liftEq = coerce++instance Ord1 Łukasiewicz where+    liftCompare = coerce++instance Show1 Łukasiewicz where+    liftShowsPrec = showsNewtype "Łukasiewicz" "getŁukasiewicz"++instance Read1 Łukasiewicz where+    liftReadsPrec = readsNewtype "Łukasiewicz" "getŁukasiewicz"+ -- | <https://en.wikipedia.org/wiki/Semiring#cite_ref-droste_14-0 Wikipedia> -- has some information on this. Also -- <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.304.6152&rep=rep1&type=pdf this>@@ -129,31 +173,18 @@   {-# INLINE zero #-}   {-# INLINE one #-} --- | Useful for optimizing multiplication, or working with large numbers.------ @('<.>')   = ('+')---x '<+>' y = -('log' ('exp' (-x) + 'exp' (-y)))---'zero'    = 'positiveInfinity'---'one'     = 0@-newtype Log a = Log-  { getLog :: a-  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor-             ,Foldable)+instance Eq1 Viterbi where+    liftEq = 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 #-}+instance Ord1 Viterbi where+    liftCompare = coerce -instance (Floating a, HasPositiveInfinity a) => DetectableZero (Log a) where-  isZero (Log x) = isPositiveInfinity x+instance Show1 Viterbi where+    liftShowsPrec = showsNewtype "Viterbi" "getViterbi" +instance Read1 Viterbi where+    liftReadsPrec = readsNewtype "Viterbi" "getViterbi"+ -- | Adds a star operation to fractional types. -- -- @('<+>')  = ('<+>')@@ -181,7 +212,8 @@   {-# INLINE zero #-}   {-# INLINE one #-} -instance (Eq a, Semiring a) => DetectableZero (PosFrac a)+instance (Eq a, Semiring a) => DetectableZero (PosFrac a) where+  isZero = (zero==)  instance (Ord a, Fractional a, Semiring a, HasPositiveInfinity a) =>          StarSemiring (PosFrac a) where@@ -189,6 +221,18 @@       | n < 1 = PosFrac (1 / (1 - n))       | otherwise = PosFrac positiveInfinity +instance Eq1 PosFrac where+    liftEq = coerce++instance Ord1 PosFrac where+    liftCompare = coerce++instance Show1 PosFrac where+    liftShowsPrec = showsNewtype "PosFrac" "getPosFrac"++instance Read1 PosFrac where+    liftReadsPrec = readsNewtype "PosFrac" "getPosFrac"+ -- | Adds a star operation to integral types. -- -- @('<+>')  = ('<+>')@@ -217,9 +261,44 @@   {-# INLINE zero #-}   {-# INLINE one #-} -instance (Eq a, Semiring a) => DetectableZero (PosInt a)+instance (Eq a, Semiring a) => DetectableZero (PosInt a) where+  isZero = (zero==)  instance (Eq a, Semiring a, HasPositiveInfinity a) =>          StarSemiring (PosInt a) where     star (PosInt n) | n == zero = PosInt one-    star _ = PosInt positiveInfinity+    star _          = PosInt positiveInfinity++instance Eq1 PosInt where+    liftEq = coerce++instance Ord1 PosInt where+    liftCompare = coerce++instance Show1 PosInt where+    liftShowsPrec = showsNewtype "PosInt" "getPosInt"++instance Read1 PosInt where+    liftReadsPrec = readsNewtype "PosInt" "getPosInt"++showsNewtype :: Coercible b a => String -> String -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> b -> ShowS+showsNewtype cons acc = s+  where+    s sp _ n x =+        showParen (n > 10) $+        showString cons .+        showString " {" .+        showString acc . showString " =" . sp 0 (coerce x) . showChar '}'++readsNewtype :: Coercible a b => String -> String -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS b+readsNewtype cons acc = r where+    r rp _ = readPrec_to_S $ prec 10 $ do+        Ident c <- lexP+        guard (c == cons)+        Punc "{" <- lexP+        Ident a <- lexP+        guard (a == acc)+        Punc "=" <- lexP+        x <- prec 0 $ readS_to_Prec rp+        Punc "}" <- lexP+        pure (coerce x)

@@ -3,6 +3,14 @@ import Control.Monad import Language.Haskell.TH +typeNames :: Int -> Q [Name]+typeNames = traverse (pure . mkName) . map pure . flip take ['a'..]++varNames :: Int -> Q [Name]+varNames n =+    (traverse newName . map pure . reverse . take n . reverse . take 26)+        ['a' ..]+ repN :: Int -> String -> Q Dec repN n nm = do     let v = VarP (mkName nm)@@ -12,7 +20,7 @@ appN :: Int -> String -> Q Dec appN n nm = do     let f = VarE (mkName nm)-    xs <- replicateM n (newName "x")+    xs <- varNames n     let args = [TupP (map VarP xs)]         ntup = TupE (map (AppE f . VarE) xs)     return $ FunD (mkName nm) [Clause args (NormalB ntup) []]@@ -20,35 +28,46 @@ cmbN :: Int -> String -> Q Dec cmbN n nm = do     let f = VarE (mkName nm)-    xs <- replicateM n (newName "x")-    ys <- replicateM n (newName "y")+    xs <- varNames n+    ys <- varNames n     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")+    names <- typeNames n     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"]+        sequence [appN n "star", pure (inline "star"), appN n "plus", pure (inline "plus")] +inline :: String -> Dec+inline n = PragmaD (InlineP (mkName n) Inline FunLike AllPhases)+ semiringIns :: Int -> Q Dec semiringIns n = do-    names <- replicateM n (newName "a")+    names <- typeNames n     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"]+        sequence+            [ cmbN n "<+>"+            , pure (inline "<+>")+            , cmbN n "<.>"+            , pure (inline "<.>")+            , repN n "zero"+            , pure (inline "zero")+            , repN n "one"+            , pure (inline "one")]  zeroIns :: Int -> Q Dec zeroIns n = do-    names <- replicateM n (newName "a")+    names <- typeNames n     let c = ConT (mkName "DetectableZero")         ct = map (AppT c . VarT) names     InstanceD Nothing ct (AppT c $ foldl AppT (TupleT n) (map VarT names)) <$>-      sequence [andAll n]+      sequence [andAll n, pure (inline "isZero")]  andAll :: Int -> Q Dec andAll n = do

@@ -1,10 +1,14 @@-{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-} {-# OPTIONS_GHC -fno-warn-orphans       #-}  module Main (main) where@@ -13,7 +17,7 @@  import           Control.Arrow            (first) import           Data.Bool-import           Data.Function+import           Data.Proxy  import           Data.Foldable import           Data.Monoid@@ -24,7 +28,6 @@ import           Data.Map.Strict          (Map) import qualified Data.Map.Strict          as Map - import           Data.Semiring import           Data.Semiring.Free import           Data.Semiring.Infinite@@ -37,286 +40,295 @@ import           Test.DocTest import           Test.QuickCheck          hiding (Positive (..), generate,                                            (.&.))-import           Test.SmallCheck          hiding (Testable, (==>)) import           Test.SmallCheck.Series   hiding (Positive) import qualified Test.SmallCheck.Series   as SC+import           Test.Tasty+import qualified Test.Tasty.QuickCheck    as QC+import qualified Test.Tasty.SmallCheck    as SC  import           Test.Semiring +import           Data.Functor.Classes  ------------------------------------------------------------------------ -main :: IO ()-main = do-  putStrLn "Integer"-  smallCheck 1000 (unaryLaws   :: UnaryLaws   Integer)-  smallCheck 1000 (zeroLaws    :: UnaryLaws   Integer)-  smallCheck 100  (binaryLaws  :: BinaryLaws  Integer)-  smallCheck 10   (ternaryLaws :: TernaryLaws Integer)-  smallCheck 10   (ordLaws     :: TernaryLaws Integer)--  putStrLn "(WordOfSize 2)"-  smallCheck 16  (unaryLaws   :: UnaryLaws   (WordOfSize 2))-  smallCheck 16  (zeroLaws    :: UnaryLaws   (WordOfSize 2))-  smallCheck 16  (binaryLaws  :: BinaryLaws  (WordOfSize 2))-  smallCheck 16  (ternaryLaws :: TernaryLaws (WordOfSize 2))-  smallCheck 16  (starLaws    :: UnaryLaws   (PositiveInfinite (WordOfSize 2)))--  putStrLn "(WordOfSize 2,WordOfSize 2)"-  smallCheck 16 (unaryLaws   :: UnaryLaws   (WordOfSize 2,WordOfSize 2))-  smallCheck 16 (zeroLaws    :: 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 "(WordOfSize 2,WordOfSize 2,WordOfSize 2)"-  smallCheck 10 (unaryLaws   :: UnaryLaws   (WordOfSize 2,WordOfSize 2,WordOfSize 2))-  smallCheck 10 (zeroLaws    :: 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 "(WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)"-  smallCheck 8 (unaryLaws   :: UnaryLaws   (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2))-  smallCheck 8 (zeroLaws    :: 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 (zeroLaws    :: 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 (zeroLaws    :: 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 (zeroLaws    :: 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 (zeroLaws    :: 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 (zeroLaws    :: 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 1000 (zeroLaws    :: UnaryLaws   Int)-  smallCheck 100  (binaryLaws  :: BinaryLaws  Int)-  smallCheck 10   (ternaryLaws :: TernaryLaws Int)--  putStrLn "PosInf Natural"-  smallCheck 1000 (unaryLaws   :: UnaryLaws   (PositiveInfinite Natural))-  smallCheck 1000 (zeroLaws    :: UnaryLaws   (PositiveInfinite Natural))-  smallCheck 100  (binaryLaws  :: BinaryLaws  (PositiveInfinite Natural))-  smallCheck 10   (ternaryLaws :: TernaryLaws (PositiveInfinite Natural))-  smallCheck 10   (ordLaws     :: TernaryLaws (PositiveInfinite Natural))--  putStrLn "NegInf Integer"-  smallCheck 1000 (nearUnaryLaws :: UnaryLaws   (NegativeInfinite Integer))-  smallCheck 1000 (zeroLaws      :: UnaryLaws   (NegativeInfinite Integer))-  smallCheck 100  (binaryLaws    :: BinaryLaws  (NegativeInfinite Integer))-  smallCheck 10   (plusAssoc     :: TernaryLaws (NegativeInfinite Integer))-  smallCheck 10   (mulAssoc      :: TernaryLaws (NegativeInfinite Integer))-  smallCheck 10   (mulDistribL   :: TernaryLaws (NegativeInfinite Integer))-  smallCheck 10   (ordLaws       :: TernaryLaws (NegativeInfinite Integer))--  putStrLn "Inf Integer"-  smallCheck 1000 (unaryLaws   :: UnaryLaws   (Infinite Integer))-  smallCheck 1000 (zeroLaws    :: UnaryLaws   (Infinite Integer))-  smallCheck 100  (binaryLaws  :: BinaryLaws  (Infinite Integer))-  smallCheck 10   (plusAssoc   :: TernaryLaws (Infinite Integer))-  smallCheck 10   (mulAssoc    :: TernaryLaws (Infinite Integer))-  smallCheck 10   (ordLaws     :: TernaryLaws (Infinite Integer))--  putStrLn "()"-  smallCheck 1 (unaryLaws   :: UnaryLaws   ())-  smallCheck 1 (zeroLaws    :: UnaryLaws   ())-  smallCheck 1 (binaryLaws  :: BinaryLaws  ())-  smallCheck 1 (ternaryLaws :: TernaryLaws ())-  smallCheck 1 (starLaws    :: UnaryLaws   ())--  putStrLn "Bool"-  smallCheck 2 (unaryLaws   :: UnaryLaws   Bool)-  smallCheck 2 (zeroLaws    :: 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)-  smallCheck 2 (zeroLaws . Any :: UnaryLaws   Bool)-  smallCheck 4 (binLawsOn  Any :: BinaryLaws  Bool)-  smallCheck 8 (ternLawsOn Any :: TernaryLaws Bool)--  putStrLn "All"-  smallCheck 2 (unLawsOn   All :: UnaryLaws   Bool)-  smallCheck 2 (zeroLaws . All :: UnaryLaws   Bool)-  smallCheck 4 (binLawsOn  All :: BinaryLaws  Bool)-  smallCheck 8 (ternLawsOn All :: TernaryLaws Bool)--  putStrLn "[WordOfSize 2]"-  smallCheck 5 (unaryLaws   :: UnaryLaws   [WordOfSize 2])-  smallCheck 5 (zeroLaws    :: UnaryLaws   [WordOfSize 2])-  smallCheck 4 (binaryLaws  :: BinaryLaws  [WordOfSize 2])-  smallCheck 3 (ternaryLaws :: TernaryLaws [WordOfSize 2])--  putStrLn "Min 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   (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 (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 (WordOfSize 2)"-  smallCheck 1000 (unLawsOn   Bottleneck :: UnaryLaws   (WordOfSize 2))-  smallCheck 1000 (zeroLaws . 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   (SC.Positive Integer))-  smallCheck 1000 (zeroLaws .  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)-  smallCheck 1000 (zeroLaws . Łukasiewicz :: UnaryLaws   Fraction)-  smallCheck 100  (binLawsOn  Łukasiewicz :: BinaryLaws  Fraction)-  smallCheck 10   (ternLawsOn Łukasiewicz :: TernaryLaws Fraction)--  putStrLn "Viterbi Double"-  smallCheck 1000 (unLawsOn   Viterbi :: UnaryLaws   Fraction)-  smallCheck 1000 (zeroLaws . Viterbi :: UnaryLaws   Fraction)-  smallCheck 100  (binLawsOn  Viterbi :: BinaryLaws  Fraction)-  smallCheck 10   (ternLawsOn Viterbi :: TernaryLaws Fraction)--  putStrLn "Log Double"-  quickCheck (unLawsOn   Log :: UnaryLaws   (Approx Double))-  quickCheck (zeroLaws . 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 (nearUnaryLaws .        eFromFunc :: UnaryLaws   (Bool -> Bool))-  smallCheck 3 (zeroLaws .             eFromFunc :: UnaryLaws   (Bool -> Bool))-  smallCheck 2 (binLawsOn              eFromFunc :: BinaryLaws  (Bool -> Bool))-  smallCheck 2 (ternOn nearTernaryLaws eFromFunc :: TernaryLaws (Bool -> Bool))+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)] -  doctest [ "-isrc"-          , "src/" ]+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)] --- Test helpers+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)] -unOn :: UnaryLaws b -> (a -> b) -> UnaryLaws a-unOn = (.)+-- 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)] -binOn :: BinaryLaws b -> (a -> b) -> BinaryLaws a-binOn = on+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))] -ternOn :: TernaryLaws b -> (a -> b) -> TernaryLaws a-ternOn t f x y z = t (f x) (f y) (f z)+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)] -unLawsOn :: (Eq b, Semiring b, Show b) => (a -> b) -> UnaryLaws a-unLawsOn = unOn unaryLaws+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))] -binLawsOn :: (Eq b, Semiring b, Show b) => (a -> b) -> BinaryLaws a-binLawsOn = binOn binaryLaws+type Tup2 a = (a,a)+type Tup3 a = (a,a,a)+type Tup4 a = (a,a,a,a)+type Tup5 a = (a,a,a,a,a)+type Tup6 a = (a,a,a,a,a,a)+type Tup7 a = (a,a,a,a,a,a,a)+type Tup8 a = (a,a,a,a,a,a,a,a)+type Tup9 a = (a,a,a,a,a,a,a,a,a) -ternLawsOn :: (Eq b, Semiring b, Show b) => (a -> b) -> TernaryLaws a-ternLawsOn = ternOn ternaryLaws+main :: IO ()+main = do+    doctest ["-isrc", "src/"]+    defaultMain $+        testGroup+            "Tests"+            [ let p = Proxy :: Proxy (Map String Int)+              in testGroup "Map" [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p]+            , let p = Proxy :: Proxy (Matrix Quad Integer)+              in testGroup "Matrix" [semiringLawsQC p]+            , let p = Proxy :: Proxy Integer+              in testGroup+                     "Integer"+                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p]+            , let p = Proxy :: Proxy (Func Bool Bool)+              in testGroup "Bool -> Bool"+                     [semiringLawsQC p]+            , testGroup "Endo Bool"+                  [ QC.testProperty+                        "plusId"+                        (plusId :: UnaryLaws (EndoFunc (Add Bool)))+                  , QC.testProperty+                        "mulId"+                        (mulId :: UnaryLaws (EndoFunc (Add Bool)))+                  , QC.testProperty+                        "annihilateR"+                        (annihilateR :: UnaryLaws (EndoFunc (Add Bool)))+                  , zeroLawsQC (Proxy :: Proxy (EndoFunc (Add Bool)))+                  , QC.testProperty+                        "plusComm"+                        (plusComm :: BinaryLaws (EndoFunc (Add Bool)))+                  , QC.testProperty+                        "plusAssoc"+                        (plusAssoc :: TernaryLaws (EndoFunc (Add Bool)))+                  , QC.testProperty+                        "mulAssoc"+                        (mulAssoc :: TernaryLaws (EndoFunc (Add Bool)))+                  , QC.testProperty+                        "mulDistribR"+                        (mulDistribR :: TernaryLaws (EndoFunc (Add Bool)))]+            , let p = Proxy :: Proxy (PositiveInfinite Natural)+              in testGroup+                     "PosInf Natural"+                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p]+            , let p = Proxy :: Proxy Int+              in testGroup "Int" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p]+            , let p = Proxy :: Proxy (WordOfSize 2)+              in testGroup+                     "WordOfSize 2"+                     [semiringLawsSC p, zeroLawsSC p]+            , let p = Proxy :: Proxy (Tup2 (WordOfSize 2))+              in testGroup+                     "Tup2 (WordOfSize 2)"+                     [semiringLawsSC p, zeroLawsSC p]+            , let p = Proxy :: Proxy (Tup3 (WordOfSize 2))+              in testGroup+                     "Tup3 (WordOfSize 2)"+                     [semiringLawsSC p, zeroLawsSC p]+            , let p = Proxy :: Proxy (Tup4 Int)+              in testGroup+                     "Tup4 Int"+                     [semiringLawsQC p, zeroLawsQC p]+            , let p = Proxy :: Proxy (Tup5 Int)+              in testGroup+                     "Tup5 Int"+                     [semiringLawsQC p, zeroLawsQC p]+            , let p = Proxy :: Proxy (Tup6 Int)+              in testGroup+                     "Tup6 Int"+                     [semiringLawsQC p, zeroLawsQC p]+            , let p = Proxy :: Proxy (Tup7 Int)+              in testGroup+                     "Tup7 Int"+                     [semiringLawsQC p, zeroLawsQC p]+            , let p = Proxy :: Proxy (Tup8 Int)+              in testGroup+                     "Tup8 Int"+                     [semiringLawsQC p, zeroLawsQC p]+            , let p = Proxy :: Proxy (Tup9 Int)+              in testGroup+                     "Tup9 Int"+                     [semiringLawsQC p, zeroLawsQC p]+            , let p = Proxy :: Proxy (Tup2 (PositiveInfinite (WordOfSize 2)))+              in testGroup+                     "Tup2 (WordOfSize 2)"+                     [starLawsSC p]+            , let p = Proxy :: Proxy (Tup3 (PositiveInfinite (WordOfSize 2)))+              in testGroup+                     "Tup3 (WordOfSize 2)"+                     [starLawsSC p]+            , let p = Proxy :: Proxy (Tup4 (PositiveInfinite Int))+              in testGroup+                     "Tup4 Int"+                     [starLawsQC p]+            , let p = Proxy :: Proxy (Tup5 (PositiveInfinite Int))+              in testGroup+                     "Tup5 Int"+                     [starLawsQC p]+            , let p = Proxy :: Proxy (Tup6 (PositiveInfinite Int))+              in testGroup+                     "Tup6 Int"+                     [starLawsQC p]+            , let p = Proxy :: Proxy (Tup7 (PositiveInfinite Int))+              in testGroup+                     "Tup7 Int"+                     [starLawsQC p]+            , let p = Proxy :: Proxy (Tup8 (PositiveInfinite Int))+              in testGroup+                     "Tup8 Int"+                     [starLawsQC p]+            , let p = Proxy :: Proxy (Tup9 (PositiveInfinite Int))+              in testGroup+                     "Tup9 Int"+                     [starLawsQC p]+            , testGroup+                  "Negative Infinite Integer"+                  [ SC.testProperty+                        "plusId"+                        (plusId :: UnaryLaws (NegativeInfinite Integer))+                  , SC.testProperty+                        "mulId"+                        (mulId :: UnaryLaws (NegativeInfinite Integer))+                  , SC.testProperty+                        "annihilateR"+                        (annihilateR :: UnaryLaws (NegativeInfinite Integer))+                  , zeroLawsSC (Proxy :: Proxy (NegativeInfinite Integer))+                  , SC.testProperty+                        "plusComm"+                        (plusComm :: BinaryLaws (NegativeInfinite Integer))+                  , ordLawsSC (Proxy :: Proxy (NegativeInfinite Integer))+                  , SC.testProperty+                        "plusAssoc"+                        (plusAssoc :: TernaryLaws (NegativeInfinite Integer))+                  , SC.testProperty+                        "mulAssoc"+                        (mulAssoc :: TernaryLaws (NegativeInfinite Integer))+                  , SC.testProperty+                        "mulDistribL"+                        (mulDistribL :: TernaryLaws (NegativeInfinite Integer))]+            , testGroup+                  "Infinite Integer"+                  [ SC.testProperty+                        "plusId"+                        (plusId :: UnaryLaws (Infinite Integer))+                  , SC.testProperty+                        "mulId"+                        (mulId :: UnaryLaws (Infinite Integer))+                  , SC.testProperty+                        "annihilateR"+                        (annihilateR :: UnaryLaws (Infinite Integer))+                  , SC.testProperty+                        "annihilateL"+                        (annihilateL :: UnaryLaws (Infinite Integer))+                  , zeroLawsSC (Proxy :: Proxy (Infinite Integer))+                  , SC.testProperty+                        "plusComm"+                        (plusComm :: BinaryLaws (Infinite Integer))+                  , ordLawsSC (Proxy :: Proxy (Infinite Integer))+                  , SC.testProperty+                        "plusAssoc"+                        (plusAssoc :: TernaryLaws (Infinite Integer))+                  , SC.testProperty+                        "mulAssoc"+                        (mulAssoc :: TernaryLaws (Infinite Integer))]+            , let p = Proxy :: Proxy ()+              in testGroup+                     "()"+                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]+            , let p = Proxy :: Proxy Bool+              in testGroup+                     "Bool"+                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]+            , let p = Proxy :: Proxy Any+              in testGroup+                     "Any"+                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]+            , let p = Proxy :: Proxy All+              in testGroup+                     "All"+                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]+            , let p = Proxy :: Proxy [WordOfSize 2]+              in testGroup "[WordOfSize 2]" [semiringLawsSC p, zeroLawsSC p]+            , 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 (SC.Positive 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]]+            -- , let p = Proxy :: Proxy (Log (Approx Double))+            --   in testGroup+            --          "Log (Approx Double)"+            --          [semiringLawsQC p, zeroLawsQC p]]  -isAnagram :: Ord a => [a] -> [a] -> Bool-isAnagram = go (Map.empty :: Map a Int) where-  go !m (x:xs) (y:ys) =-    go ( Map.alter (remZero . maybe (-1) pred) x-       $ Map.alter (remZero . maybe 1    succ) y-    m) xs ys-  go !m [] [] = Map.null m-  go _ _ _ = False-  remZero 0 = Nothing-  remZero n = Just n--instance Ord a => Eq (Free a) where-  (==) = isAnagram `on` getFree- ------------------------------------------------------------------------ -- Serial wrappers @@ -370,9 +382,15 @@ instance KnownNat n => Arbitrary (WordOfSize n) where   arbitrary = arbitraryBoundedEnum -instance KnownNat n => Semiring (WordOfSize n)-instance KnownNat n => DetectableZero (WordOfSize n)+instance KnownNat n => Semiring (WordOfSize n) where+  one = 1+  zero = 0+  (<+>) = (+)+  (<.>) = (*) +instance KnownNat n => DetectableZero (WordOfSize n) where+  isZero = (zero==)+ instance (Monad m, Serial m a) => Serial m (PositiveInfinite a) where   series = fmap (maybe PositiveInfinity PosFinite) series @@ -385,6 +403,45 @@ instance Monad m => Serial m Natural where   series = generate (`take` [0..]) +instance Monad m => Serial m Any where+  series = fmap Any series++instance Monad m => Serial m All where+  series = fmap All series++instance (Monad m, Serial m a) => Serial m (Min a) where+  series = fmap Min series++instance (Monad m, Serial m a) => Serial m (Max a) where+  series = fmap Max series++instance (Ord a, Arbitrary a) => Arbitrary (Free a) where+  arbitrary = fmap Free arbitrary++instance Num a => Semiring (SC.Positive a) where+  zero = 0+  one = 1+  (<+>) = (+)+  (<.>) = (*)++instance (Eq a, Num a) => DetectableZero (SC.Positive a) where+  isZero = (zero==)++instance (Serial m a, Monad m) => Serial m (Division a) where+  series = fmap Division series++instance (Serial m a, Monad m) => Serial m (Łukasiewicz a) where+  series = fmap Łukasiewicz series++instance (Serial m a, Monad m) => Serial m (Viterbi a) where+  series = fmap Viterbi series++-- instance (Serial m a, Monad m) => Serial m (Log a) where+--   series = fmap Log series++-- instance Arbitrary a => Arbitrary (Log a) where+--   arbitrary = fmap Log arbitrary+ ------------------------------------------------------------------------ -- Function Equality @@ -400,6 +457,14 @@ instance (Enum a, Bounded a, Ord a, Show a) => Show (EndoFunc a) where   show (EndoFunc (Endo f)) = show (fromFunc f) +instance (Bounded a, Enum a, Ord b, Arbitrary b, CoArbitrary a) =>+         Arbitrary (Func a b) where+    arbitrary = fmap fromFunc arbitrary++instance (Arbitrary a, CoArbitrary a) =>+         Arbitrary (EndoFunc (Add a)) where+    arbitrary = fmap eFromFunc arbitrary+ fromList' :: Eq b => b -> [(Int,b)] -> Func a b fromList' cnst   = Func cnst@@ -420,13 +485,23 @@ eFromFunc :: (a -> a) -> EndoFunc (Add a) eFromFunc f = (EndoFunc . Endo) (Add . f . getAdd) +data Pair a b = !a :*: !b++fst' :: Pair a b -> a+fst' (x :*: _) = x++data Many a = (:#:) {-# UNPACK #-} !Int !a++val :: Many a -> a+val (_ :#: x) = x+ mostFrequent :: (Ord a, Foldable f) => f a -> Maybe a-mostFrequent = fmap fst . fst . foldl' f (Nothing, Map.empty :: Map.Map a Int) where-  f (b,m) e = (Just nb, Map.insert e c m) where+mostFrequent = fmap val . fst' . foldl' f (Nothing :*: (Map.empty :: Map a Int)) where+  f (b :*: m) e = Just nb :*: Map.insert e c m where     c = maybe 1 succ (Map.lookup e m)     nb = case b of-      Just (a,d) | d >= c -> (a,d)-      _          -> (e,c)+      Just (d :#: a) | d >= c -> d :#: a+      _              -> c :#: e  apply :: Enum a => Func a b -> a -> b apply (Func c cs) x = IntMap.findWithDefault c (fromEnum x) cs@@ -442,8 +517,28 @@   f <+> g = fromFunc (apply f <+> apply g)   f <.> g = fromFunc (apply f <.> apply g) +data Quad a = Quad a a a a deriving (Show, Eq, Ord, Functor, Foldable, Traversable) +instance Applicative Quad where+    pure x = Quad x x x x+    Quad fw fx fy fz <*> Quad xw xx xy xz = Quad (fw xw) (fx xx) (fy xy) (fz xz) +instance Eq1 Quad where+    liftEq eq x y = mulFoldable (liftA2 eq x y)++instance Ord1 Quad where+    liftCompare cmp x y = fold (liftA2 cmp x y)++instance Show1 Quad where+    liftShowsPrec sp _ n (Quad w x y z) =+        showParen (n > 10) $+        showString "Quad " .+        sp 10 w . sp 10 x . sp 10 y . sp 10 z++instance Arbitrary a => Arbitrary (Quad a) where+    arbitrary = Quad <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+    shrink = traverse shrink+ ------------------------------------------------------------------------ -- QuickCheck wrappers @@ -459,48 +554,6 @@ 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+instance Arbitrary (f (f a)) => Arbitrary (Matrix f a) where+    arbitrary = fmap Matrix arbitrary+    shrink (Matrix xs) = fmap Matrix (shrink xs)