semiring-num 1.5.0.0 → 1.6.0.0

raw patch · 16 files changed

+1976/−808 lines, 16 filesdep +deepseqdep ~QuickCheckdep ~criteriondep ~doctestPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependency ranges changed: QuickCheck, criterion, doctest, hashable, log-domain, nat-sized-numbers, random, scientific, smallcheck, tasty, tasty-quickcheck, tasty-smallcheck, unordered-containers, vector

API changes (from Hackage documentation)

Files

• bench/bench.hs +19/−14
• semiring-num.cabal +35/−26
• src/Data/Semiring.hs +519/−202
• src/Data/Semiring/Free.hs +4/−12
• src/Data/Semiring/Infinite.hs +146/−13
• src/Data/Semiring/Newtype.hs +97/−0
• src/Data/Semiring/Numeric.hs +371/−53
• src/Test/Semiring.hs +2/−2
• test/ApproxLog.hs +61/−0
• test/CompUtils.hs +18/−0
• test/Fraction.hs +33/−0
• test/Func.hs +81/−0
• test/LimitSize.hs +39/−0
• test/Orphans.hs +107/−0
• test/Spec.hs +247/−486
• test/Vectors.hs +197/−0

@@ -22,30 +22,35 @@     \xs ->          bgroup (show n) [bench "add" $ nf add xs] -prodAtSize :: Int -> Int -> Benchmark-prodAtSize n m =+atSizeList :: Int -> Int -> Benchmark+atSizeList n m =     env ((,) <$> replicateM n int <*> replicateM m int) $     \xs ->-         bench "prod-list" (nf (uncurry (<.>)) xs)+         bgroup+             (show (n, m))+             [ bench (show n ++ "<.>" ++ show m) (nf (uncurry (<.>)) xs)+             , bench (show m ++ "<.>" ++ show n) (nf (uncurry (flip (<.>))) xs)+             , bench (show n ++ "<+>" ++ show m) (nf (uncurry (<+>)) xs)+             , bench (show m ++ "<+>" ++ show n) (nf (uncurry (flip (<+>))) xs)] -prodAtSizeVec :: Int -> Int -> Benchmark-prodAtSizeVec n m =+starList :: Int -> Benchmark+starList n = env (replicateM n (pure ())) $ \xs -> bench (show n) (nf (take n . star) xs)++atSizeVec :: Int -> Int -> Benchmark+atSizeVec n m =     env ((,) <$> Vector.replicateM n int <*> Vector.replicateM m int) $     \xs ->          bgroup-             "vec"+             (show (n, m))              [ bench (show n ++ "<.>" ++ show m) (nf (uncurry (<.>)) xs)              , bench (show m ++ "<.>" ++ show n) (nf (uncurry (flip (<.>))) xs)              , bench (show n ++ "<+>" ++ show m) (nf (uncurry (<+>)) xs)-             , bench (show m ++ "<+>" ++ show n) (nf (uncurry (flip (<+>))) xs)-             ]+             , bench (show m ++ "<+>" ++ show n) (nf (uncurry (flip (<+>))) xs)]  main :: IO () main =     defaultMain-        [ prodAtSizeVec 4000 2000-        , prodAtSizeVec 4000 2000]------ prodAtSize 2000 1000, sumAtSize 10000]+        [ bgroup "list star" [starList 2000]+        , bgroup "vec" [atSizeVec 4000 2000, atSizeVec 4000 2000]+        , bgroup "list" [atSizeList 400 200, atSizeList 4000 2000]+        , bgroup "add" [sumAtSize 100, sumAtSize 1000]]

@@ -1,5 +1,5 @@ name:                semiring-num-version:             1.5.0.0+version:             1.6.0.0 synopsis:            Basic semiring class and instances description:         Adds a basic semiring class homepage:            https://github.com/oisdk/semiring-num@@ -20,15 +20,17 @@                      , Data.Semiring.Infinite                      , Test.Semiring   other-modules:       Data.Semiring.TH-  build-depends:       base >= 4.9 && < 5-                     , template-haskell >= 2.11-                     , containers >= 0.5-                     , log-domain >= 0.10-                     , scientific >= 0.3-                     , time >= 1.6-                     , unordered-containers >= 0.2-                     , vector >= 0.12-                     , hashable >= 1.2+                     , Data.Semiring.Newtype+  build-depends:       base >=4.9 && <5+                     , template-haskell >=2.11+                     , containers >=0.5+                     , log-domain >=0.10.3.1+                     , scientific >=0.3.4.10+                     , time >=1.6+                     , unordered-containers >=0.2.6.0+                     , vector >=0.10.12.3+                     , hashable >=1.2.4.0+                     , deepseq >=1.4   default-language:    Haskell2010   ghc-options:         -Wall @@ -36,18 +38,25 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Spec.hs-  build-depends:       base >= 4.9 && < 5+  other-modules:       Func+                     , CompUtils+                     , Orphans+                     , ApproxLog+                     , Fraction+                     , Vectors+                     , LimitSize+  build-depends:       base >=4.9 && <5                      , semiring-num-                     , smallcheck >= 1.1-                     , doctest >= 0.11-                     , 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-                     , vector >= 0.12+                     , smallcheck >=0.2.1+                     , doctest >=0.3.0+                     , containers >=0.5+                     , QuickCheck >=1.0+                     , nat-sized-numbers >=0.1.0.0+                     , tasty >=0.1+                     , tasty-smallcheck >=0.1+                     , tasty-quickcheck >=0.1+                     , log-domain >=0.10.3.1+                     , vector >=0.10.12.3   ghc-options:         -threaded                        -rtsopts                        -with-rtsopts=-N@@ -58,12 +67,12 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      bench   main-is:             bench.hs-  build-depends:       base+  build-depends:       base -any                      , semiring-num-                     , criterion >=1.1-                     , random >= 1.1-                     , containers >= 0.5-                     , vector >= 0.12+                     , criterion >=0.1+                     , random >=1.0.0.0+                     , containers >=0.5+                     , vector >=0.10.12.3   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010 

@@ -1,13 +1,15 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}  {-| Module: Data.Semiring@@ -40,61 +42,74 @@    -- * Matrix wrapper    Matrix(..)   ,transpose-  ,mulMatrix)+  ,mulMatrix+  ,rows+  ,cols)   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.Scientific(Scientific)-import Data.Time.Clock(DiffTime,NominalDiffTime)+import           Data.Complex                (Complex)+import           Data.Fixed                  (Fixed, HasResolution)+import           Data.Functor.Identity       (Identity (..))+import           Data.Int                    (Int16, Int32, Int64, Int8)+import           Data.Ratio                  (Ratio)+import           Data.Scientific             (Scientific)+import           Data.Time.Clock             (DiffTime, NominalDiffTime)+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           Numeric.Natural             (Natural)+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.Semigroup              hiding (Max (..), Min (..)) -import Data.Coerce-import GHC.Generics (Generic, Generic1)-import Data.Typeable (Typeable)-import Foreign.Storable (Storable)+import           Data.Coerce+import           Data.Typeable               (Typeable)+import           Foreign.Storable            (Storable)+import           GHC.Generics                (Generic, Generic1) -import Data.Semiring.TH-import Data.Functor.Classes-import Text.Read+import           Data.Functor.Classes+import           Data.Semiring.TH -import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map+import           Data.Map.Strict             (Map)+import qualified Data.Map.Strict             as Map -import Data.Set (Set)-import qualified Data.Set as Set+import           Data.Set                    (Set)+import qualified Data.Set                    as Set -import qualified Data.HashMap.Strict as HashMap-import qualified Data.HashSet as HashSet-import Data.Hashable+import           Data.Hashable+import qualified Data.HashMap.Strict         as HashMap+import qualified Data.HashSet                as HashSet -import qualified Data.Vector as Vector-import qualified Data.Vector.Storable as StorableVector-import qualified Data.Vector.Unboxed as UnboxedVector+import qualified Data.Vector                 as Vector+import qualified Data.Vector.Generic         as G+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Storable        as StorableVector+import qualified Data.Vector.Unboxed         as UnboxedVector+import qualified Data.Vector.Unboxed.Base    as U -import Numeric.Log hiding (sum)+import           Control.DeepSeq++import           Numeric.Log                 hiding (sum) import qualified Numeric.Log+import           Numeric.Log.Signed -import Control.Monad-import Control.Applicative-import Data.Foldable-import Data.Traversable+import           Control.Applicative+import           Data.Foldable+import           Data.Traversable +import           Data.Semiring.Newtype+import           GHC.Base                    (build)++ -- $setup -- >>> import Data.Function @@ -141,7 +156,7 @@     -- | An associative, commutative binary operation.     infixl 6 <+>     (<+>) :: a -> a -> a-    -- | Takes the sum of the elements of a 'Foldable'. Analogous to 'sum'+    -- | Takes the sum of the elements of a list. Analogous to 'sum'     -- on numbers, or 'or' on 'Bool's.     --     -- >>> add [1..5]@@ -156,7 +171,7 @@         :: [a] -> a     add = getAdd . foldMap Add     {-# INLINE add #-}-    -- | Takes the product of the elements of a 'Foldable'. Analogous to+    -- | Takes the product of the elements of a list. Analogous to     -- 'product' on numbers, or 'and' on 'Bool's.     --     -- >>> mul [1..5]@@ -369,34 +384,162 @@ -- 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>.+--+-- Effort is made to allow some of these functions to fuse. The reference+-- implementation is:+--+-- @+-- 'one' = ['one']+-- 'zero' = []+-- [] '<+>' ys = ys+-- xs '<+>' [] = xs+-- (x:xs) '<+>' (y:ys) = x '<+>' y : (xs '<+>' ys)+-- _ '<.>' [] = []+-- xs '<.>' ys = 'foldr' f [] xs where+--   f x zs = 'map' (x '<.>') ys '<+>' ('zero' : zs)+-- @ 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) : add' xs ys+    (<+>) = listAdd+    xs <.> ys+      | null ys = []+      | otherwise = foldr f [] xs       where-        add' xs' [] = map (<.> y) xs'-        add' [] ys' = map (x <.>) ys'-        add' xs' ys' =-            map (x <.>) ys' <+> map (<.> y) xs' <+> (zero : (xs' <.> ys'))+        f x zs = foldr (g x) id ys (zero : zs)+        g x y a (z:zs) = x <.> y <+> z : a zs+        g x y a []     = x <.> y : a []+    {-# INLINE (<+>) #-}+    {-# INLINE (<.>) #-}+    {-# INLINE one #-}+    {-# INLINE zero #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Int #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Int8 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Int16 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Int32 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Int64 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Word #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Word8 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Word16 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Word32 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Word64 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Integer #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Double #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Float #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Natural #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped [] Bool #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Int #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Int8 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Int16 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Int32 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Int64 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Word #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Word8 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Word16 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Word32 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Word64 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Integer #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Double #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Float #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Natural #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped [] Bool #-} ++listAdd :: Semiring a => [a] -> [a] -> [a]+listAdd [] ys         = ys+listAdd xs []         = xs+listAdd (x:xs) (y:ys) = (x <+> y) : listAdd xs ys+{-# NOINLINE [0] listAdd #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Int #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Int8 #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Int16 #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Int32 #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Int64 #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Word #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Word8 #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Word16 #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Word32 #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Word64 #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Integer #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Double #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Float #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Natural #-}+{-# SPECIALISE listAdd :: BinaryWrapped [] Bool #-}++-- a definition of addition which can be fused on its left argument+listAddFBL :: Semiring a => ListBuilder a -> [a] -> [a]+listAddFBL xf = xf f id  where+  f x xs (y:ys) = x <+> y : xs ys+  f x xs []     = x : xs []++type FBL a = ListBuilder a -> [a] -> [a]+{-# SPECIALISE listAddFBL :: FBL Int #-}+{-# SPECIALISE listAddFBL :: FBL Int8 #-}+{-# SPECIALISE listAddFBL :: FBL Int16 #-}+{-# SPECIALISE listAddFBL :: FBL Int32 #-}+{-# SPECIALISE listAddFBL :: FBL Int64 #-}+{-# SPECIALISE listAddFBL :: FBL Word #-}+{-# SPECIALISE listAddFBL :: FBL Word8 #-}+{-# SPECIALISE listAddFBL :: FBL Word16 #-}+{-# SPECIALISE listAddFBL :: FBL Word32 #-}+{-# SPECIALISE listAddFBL :: FBL Word64 #-}+{-# SPECIALISE listAddFBL :: FBL Integer #-}+{-# SPECIALISE listAddFBL :: FBL Double #-}+{-# SPECIALISE listAddFBL :: FBL Float #-}+{-# SPECIALISE listAddFBL :: FBL Natural #-}+{-# SPECIALISE listAddFBL :: FBL Bool #-}++-- a definition of addition which can be fused on its right argument+listAddFBR :: Semiring a => [a] -> ListBuilder a -> [a]+listAddFBR xs' yf = yf f id xs' where+  f y ys (x:xs) = x <+> y : ys xs+  f y ys []     = y : ys []++type FBR a = [a] -> ListBuilder a -> [a]+{-# SPECIALISE listAddFBR :: FBR Int #-}+{-# SPECIALISE listAddFBR :: FBR Int8 #-}+{-# SPECIALISE listAddFBR :: FBR Int16 #-}+{-# SPECIALISE listAddFBR :: FBR Int32 #-}+{-# SPECIALISE listAddFBR :: FBR Int64 #-}+{-# SPECIALISE listAddFBR :: FBR Word #-}+{-# SPECIALISE listAddFBR :: FBR Word8 #-}+{-# SPECIALISE listAddFBR :: FBR Word16 #-}+{-# SPECIALISE listAddFBR :: FBR Word32 #-}+{-# SPECIALISE listAddFBR :: FBR Word64 #-}+{-# SPECIALISE listAddFBR :: FBR Integer #-}+{-# SPECIALISE listAddFBR :: FBR Double #-}+{-# SPECIALISE listAddFBR :: FBR Float #-}+{-# SPECIALISE listAddFBR :: FBR Natural #-}+{-# SPECIALISE listAddFBR :: FBR Bool #-}++type ListBuilder a = forall b. (a -> b -> b) -> b -> b++{-# RULES+"listAddFB/left"  forall (g :: ListBuilder a). listAdd (build g) = listAddFBL g+"listAddFB/right" forall xs (g :: ListBuilder a). listAdd xs (build g) = listAddFBR xs g+  #-}+ instance StarSemiring a => StarSemiring [a] where     star [] = one     star (x:xs) = r where-      r = [star x] <.> (one : (xs <.> r))+      r = xst : map (xst <.>) (xs <.> r)+      xst = star x+    {-# SPECIALISE star :: [Bool] -> [Bool] #-}+    {-# SPECIALISE star :: [Min Double]  -> [Min Double] #-}+    {-# SPECIALISE star :: [Min Float]   -> [Min Float] #-}+    {-# SPECIALISE star :: [Min CDouble] -> [Min CDouble] #-}+    {-# SPECIALISE star :: [Min CFloat]  -> [Min CFloat] #-}+    {-# SPECIALISE star :: [Max Double]  -> [Max Double] #-}+    {-# SPECIALISE star :: [Max Float]   -> [Max Float] #-}+    {-# SPECIALISE star :: [Max CDouble] -> [Max CDouble] #-}+    {-# SPECIALISE star :: [Max CFloat]  -> [Max CFloat] #-}  instance DetectableZero a =>          DetectableZero [a] where     isZero = all isZero     {-# INLINE isZero #-} -type BinaryContainer c a = c a -> c a -> c a- instance Semiring a =>          Semiring (Vector.Vector a) where     one = Vector.singleton one@@ -420,36 +563,36 @@                 zero                 [kmin .. kmax]           where-            kmin = max 0 (n - (klen - 1))-            kmax = min n (slen - 1)-        slen = Vector.length signal-        klen = Vector.length kernel-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Double #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Float #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Bool #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int8 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int16 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int32 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Int64 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word8 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word16 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word32 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer Vector.Vector Word64 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Double #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Float #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Bool #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int8 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int16 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int32 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Int64 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word8 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word16 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word32 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer Vector.Vector Word64 #-}+            !kmin = max 0 (n - (klen - 1))+            !kmax = min n (slen - 1)+        !slen = Vector.length signal+        !klen = Vector.length kernel+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Double #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Float #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Bool #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int8 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int16 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int32 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Int64 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word8 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word16 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word32 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Vector.Vector Word64 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Double #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Float #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Bool #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int8 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int16 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int32 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Int64 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word8 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word16 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word32 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Vector.Vector Word64 #-}  instance DetectableZero a => DetectableZero (Vector.Vector a) where     isZero = Vector.all isZero@@ -481,32 +624,32 @@             kmax = min n (slen - 1)         slen = UnboxedVector.length signal         klen = UnboxedVector.length kernel-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Double #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Float #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Bool #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int8 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int16 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int32 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Int64 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word8 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word16 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word32 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer UnboxedVector.Vector Word64 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Double #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Float #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Bool #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int8 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int16 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int32 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Int64 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word8 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word16 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word32 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer UnboxedVector.Vector Word64 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Double #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Float #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Bool #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int8 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int16 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int32 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Int64 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word8 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word16 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word32 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped UnboxedVector.Vector Word64 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Double #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Float #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Bool #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int8 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int16 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int32 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Int64 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word8 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word16 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word32 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped UnboxedVector.Vector Word64 #-}  instance (UnboxedVector.Unbox a, DetectableZero a) => DetectableZero (UnboxedVector.Vector a) where     isZero = UnboxedVector.all isZero@@ -541,34 +684,35 @@             kmax = min n (slen - 1)         slen = StorableVector.length signal         klen = StorableVector.length kernel-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Double #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Float #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Bool #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int8 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int16 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int32 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Int64 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word8 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word16 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word32 #-}-    {-# SPECIALISE (<.>) :: BinaryContainer StorableVector.Vector Word64 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Double #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Float #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Bool #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int8 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int16 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int32 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Int64 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word8 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word16 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word32 #-}-    {-# SPECIALISE (<+>) :: BinaryContainer StorableVector.Vector Word64 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Double #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Float #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Bool #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int8 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int16 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int32 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Int64 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word8 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word16 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word32 #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped StorableVector.Vector Word64 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Double #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Float #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Bool #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int8 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int16 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int32 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Int64 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word8 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word16 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word32 #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped StorableVector.Vector Word64 #-} -instance (StorableVector.Storable a, DetectableZero a) => DetectableZero (StorableVector.Vector a) where+instance (StorableVector.Storable a, DetectableZero a) =>+         DetectableZero (StorableVector.Vector a) where     isZero = StorableVector.all isZero  instance (Monoid a, Ord a) =>@@ -645,50 +789,36 @@     add = Numeric.Log.sum     {-# INLINE add #-} +    {-# SPECIALISE (<.>) :: BinaryWrapped Log Double #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Log Float #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Log Double #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Log Float #-}+ instance (Precise a, RealFloat a) => DetectableZero (Log a) where     isZero = isZeroEq     {-# INLINE isZero #-} ------------------------------------------------------------------------------------ Newtype utilities-----------------------------------------------------------------------------------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 '}'+instance (Precise a, RealFloat a) => Semiring (SignedLog a) where+    (<.>) = (*)+    {-# INLINE (<.>) #-}+    (<+>) = (+)+    {-# INLINE (<+>) #-}+    one = SLExp True 0+    {-# INLINE one #-}+    zero = SLExp False (-(1/0))+    {-# INLINE zero #-} -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)+    {-# SPECIALISE (<.>) :: BinaryWrapped SignedLog Double #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped SignedLog Float #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped SignedLog Double #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped SignedLog Float #-} +instance (Precise a, RealFloat a) => DetectableZero (SignedLog a) where+    isZero = isZeroEq+    {-# 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'.@@ -812,7 +942,7 @@  instance (Traversable f, Applicative f, Semiring a, f ~ g) =>          Semiring (Matrix f g a) where-    (<.>) = mulMatrix+    (<.>) = (coerce :: Binary (f (g a)) -> Binary (Matrix f g a)) mulMatrix     (<+>) = liftA2 (<+>)     zero = pure zero     one =@@ -833,18 +963,23 @@  -- | Multiply two matrices. mulMatrix-    :: (Applicative f, Traversable g, Applicative g, Semiring a)-    => Matrix f g a -> Matrix g f a -> Matrix f f a-mulMatrix (Matrix xs) (Matrix ys) =-    Matrix-        (fmap (\row -> fmap (addFoldable . liftA2 (<.>) row) c) xs)+    :: (Applicative n, Traversable m, Applicative m, Applicative p, Semiring a)+    => n (m a) -> m (p a) -> n (p a)+mulMatrix xs ys = fmap (\row -> fmap (addFoldable . liftA2 (<.>) row) cs) xs   where-    c = sequenceA ys+    cs = sequenceA ys -infixr 9 #.-(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c-(#.) _ = coerce +-- | Convert the matrix to a nested list, in row-major form.+rows :: (Foldable f, Foldable g) => Matrix f g a -> [[a]]+rows = foldr ((:) . toList) [] . getMatrix++-- | Convert the matrix to a nested list, in column-major form.+cols :: (Foldable f, Foldable g) => Matrix f g a -> [[a]]+cols = foldr (foldr f (const [])) (repeat []) . getMatrix where+  f e a (x:xs) = (e:x) : a xs+  f _ _ []     = []+ instance (Show1 f, Show1 g) =>          Show1 (Matrix f g) where     liftShowsPrec (sp :: Int -> a -> ShowS) sl =@@ -915,7 +1050,8 @@ newtype Min a = Min     { getMin :: a     } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable-               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable)+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,NFData)  -- | The "<https://ncatlab.org/nlab/show/max-plus+algebra Arctic>" -- or max-plus semiring. It is a semiring where:@@ -935,64 +1071,91 @@ newtype Max a = Max     { getMax :: a     } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable-               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable)+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,NFData)  instance Eq1 Max where     liftEq = coerce+    {-# INLINE liftEq #-}  instance Ord1 Max where     liftCompare = coerce+    {-# INLINE liftCompare #-}  instance Show1 Max where     liftShowsPrec = showsNewtype "Max" "getMax"+    {-# INLINE liftShowsPrec #-}  instance Read1 Max where     liftReadsPrec = readsNewtype "Max" "getMax"+    {-# INLINE liftReadsPrec #-}  instance Eq1 Min where     liftEq = coerce+    {-# INLINE liftEq #-}  instance Ord1 Min where     liftCompare = coerce+    {-# INLINE liftCompare #-}  instance Show1 Min where     liftShowsPrec = showsNewtype "Min" "getMin"+    {-# INLINE liftShowsPrec #-}  instance Read1 Min where     liftReadsPrec = readsNewtype "Min" "getMin"+    {-# INLINE liftReadsPrec #-}  instance Ord a =>          Semigroup (Max a) where     (<>) = (coerce :: WrapBinary Max a) max     {-# INLINE (<>) #-}+    stimes = stimesIdempotent+    {-# SPECIALISE (<>) :: BinaryWrapped Max Double #-}+    {-# SPECIALISE (<>) :: BinaryWrapped Max Float #-}+    {-# SPECIALISE (<>) :: BinaryWrapped Max CDouble #-}+    {-# SPECIALISE (<>) :: BinaryWrapped Max CFloat #-}  instance Ord a =>          Semigroup (Min a) where     (<>) = (coerce :: WrapBinary Min a) min     {-# INLINE (<>) #-}+    stimes = stimesIdempotent+    {-# SPECIALISE (<>) :: BinaryWrapped Min Double #-}+    {-# SPECIALISE (<>) :: BinaryWrapped Min Float #-}+    {-# SPECIALISE (<>) :: BinaryWrapped Min CDouble #-}+    {-# SPECIALISE (<>) :: BinaryWrapped Min CFloat #-}  -- | >>> (getMax . foldMap Max) [1..10] -- 10.0 instance (Ord a, HasNegativeInfinity a) =>          Monoid (Max a) where     mempty = Max negativeInfinity-    mappend = (<>)+    mappend = (coerce :: WrapBinary Max a) max     {-# INLINE mempty #-}     {-# INLINE mappend #-}+    {-# SPECIALISE mappend :: BinaryWrapped Max Double #-}+    {-# SPECIALISE mappend :: BinaryWrapped Max Float #-}+    {-# SPECIALISE mappend :: BinaryWrapped Max CDouble #-}+    {-# SPECIALISE mappend :: BinaryWrapped Max CFloat #-}  -- | >>> (getMin . foldMap Min) [1..10] -- 1.0 instance (Ord a, HasPositiveInfinity a) =>          Monoid (Min a) where     mempty = Min positiveInfinity-    mappend = (<>)+    mappend = (coerce :: WrapBinary Min a) min     {-# INLINE mempty #-}     {-# INLINE mappend #-}+    {-# SPECIALISE mappend :: BinaryWrapped Min Double #-}+    {-# SPECIALISE mappend :: BinaryWrapped Min Float #-}+    {-# SPECIALISE mappend :: BinaryWrapped Min CDouble #-}+    {-# SPECIALISE mappend :: BinaryWrapped Min CFloat #-}  instance (Semiring a, Ord a, HasNegativeInfinity a) =>          Semiring (Max a) where-    (<+>) = mappend-    zero = mempty+    (<+>) = (coerce :: WrapBinary Max a) max+    zero = Max negativeInfinity     (<.>) = (coerce :: WrapBinary Max a) (<+>)     one = Max zero     {-# INLINE zero #-}@@ -1000,28 +1163,69 @@     {-# INLINE (<+>) #-}     {-# INLINE (<.>) #-} +    {-# SPECIALISE (<+>) :: BinaryWrapped Max Double #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Max Float #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Max CDouble #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Max CFloat #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Max Double #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Max Float #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Max CDouble #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Max CFloat #-}+    {-# SPECIALISE one   :: Max Double #-}+    {-# SPECIALISE one   :: Max Float #-}+    {-# SPECIALISE one   :: Max CDouble #-}+    {-# SPECIALISE one   :: Max CFloat #-}+    {-# SPECIALISE zero  :: Max Double #-}+    {-# SPECIALISE zero  :: Max Float #-}+    {-# SPECIALISE zero  :: Max CDouble #-}+    {-# SPECIALISE zero  :: Max CFloat #-}+ instance (Semiring a, Ord a, HasPositiveInfinity a) =>          Semiring (Min a) where-    (<+>) = mappend-    zero = mempty+    (<+>) = (coerce :: WrapBinary Min a) min+    zero = Min positiveInfinity     (<.>) = (coerce :: WrapBinary Min a) (<+>)     one = Min zero     {-# INLINE zero #-}     {-# INLINE one #-}     {-# INLINE (<+>) #-}     {-# INLINE (<.>) #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Min Double #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Min Float #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Min CDouble #-}+    {-# SPECIALISE (<+>) :: BinaryWrapped Min CFloat #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Min Double #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Min Float #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Min CDouble #-}+    {-# SPECIALISE (<.>) :: BinaryWrapped Min CFloat #-}+    {-# SPECIALISE one   :: Min Double #-}+    {-# SPECIALISE one   :: Min Float #-}+    {-# SPECIALISE one   :: Min CDouble #-}+    {-# SPECIALISE one   :: Min CFloat #-}+    {-# SPECIALISE zero  :: Min Double #-}+    {-# SPECIALISE zero  :: Min Float #-}+    {-# SPECIALISE zero  :: Min CDouble #-}+    {-# SPECIALISE zero  :: Min CFloat #-}  instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>          StarSemiring (Max a) where     star (Max x)       | x > zero = Max positiveInfinity       | otherwise = Max zero+    {-# SPECIALISE star :: Max Double  -> Max Double  #-}+    {-# SPECIALISE star :: Max Float   -> Max Float   #-}+    {-# SPECIALISE star :: Max CDouble -> Max CDouble #-}+    {-# SPECIALISE star :: Max CFloat  -> Max CFloat  #-}  instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) =>          StarSemiring (Min a) where     star (Min x)       | x < zero = Min negativeInfinity       | otherwise = Min zero+    {-# SPECIALISE star :: Min Double  -> Min Double  #-}+    {-# SPECIALISE star :: Min Float   -> Min Float   #-}+    {-# SPECIALISE star :: Min CDouble -> Min CDouble #-}+    {-# SPECIALISE star :: Min CFloat  -> Min CFloat  #-}  instance (Semiring a, Ord a, HasPositiveInfinity a) =>          DetectableZero (Min a) where@@ -1033,6 +1237,119 @@     isZero (Max x) = isNegativeInfinity x     {-# INLINE isZero #-} +newtype instance U.Vector (Min a) = V_Min (U.Vector a)+newtype instance U.MVector s (Min a) = MV_Min (U.MVector s a)++instance U.Unbox a =>+         M.MVector U.MVector (Min a) where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    basicLength =+        (coerce :: (U.MVector s a -> Int) -> U.MVector s (Min a) -> Int)+            M.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Min a) -> U.MVector s (Min a))+            M.basicUnsafeSlice+    basicOverlaps =+        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Min a) -> U.MVector s (Min a) -> Bool)+            M.basicOverlaps+    basicUnsafeNew n =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Min a))+            (M.basicUnsafeNew n)+    basicUnsafeRead (MV_Min xs) i =+        fmap (coerce :: a -> Min a) (M.basicUnsafeRead xs i)+    basicUnsafeWrite =+        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Min a) -> Int -> Min a -> m ())+            M.basicUnsafeWrite+    basicInitialize =+        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Min a) -> m ())+            M.basicInitialize++instance U.Unbox a =>+         G.Vector U.Vector (Min a) where+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeFreeze (MV_Min xs) =+        fmap+            (coerce :: U.Vector a -> U.Vector (Min a))+            (G.basicUnsafeFreeze xs)+    basicUnsafeThaw (V_Min xs) =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Min a))+            (G.basicUnsafeThaw xs)+    basicLength =+        (coerce :: (U.Vector a -> Int) -> U.Vector (Min a) -> Int)+            G.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Min a) -> U.Vector (Min a))+            G.basicUnsafeSlice+    basicUnsafeIndexM (V_Min xs) i =+        fmap (coerce :: a -> Min a) (G.basicUnsafeIndexM xs i)++newtype instance U.Vector (Max a) = V_Max (U.Vector a)+newtype instance U.MVector s (Max a) = MV_Max (U.MVector s a)++instance U.Unbox a =>+         M.MVector U.MVector (Max a) where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    basicLength =+        (coerce :: (U.MVector s a -> Int) -> U.MVector s (Max a) -> Int)+            M.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Max a) -> U.MVector s (Max a))+            M.basicUnsafeSlice+    basicOverlaps =+        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Max a) -> U.MVector s (Max a) -> Bool)+            M.basicOverlaps+    basicUnsafeNew n =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Max a))+            (M.basicUnsafeNew n)+    basicUnsafeRead (MV_Max xs) i =+        fmap (coerce :: a -> Max a) (M.basicUnsafeRead xs i)+    basicUnsafeWrite =+        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Max a) -> Int -> Max a -> m ())+            M.basicUnsafeWrite+    basicInitialize =+        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Max a) -> m ())+            M.basicInitialize++instance U.Unbox a =>+         G.Vector U.Vector (Max a) where+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeFreeze (MV_Max xs) =+        fmap+            (coerce :: U.Vector a -> U.Vector (Max a))+            (G.basicUnsafeFreeze xs)+    basicUnsafeThaw (V_Max xs) =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Max a))+            (G.basicUnsafeThaw xs)+    basicLength =+        (coerce :: (U.Vector a -> Int) -> U.Vector (Max a) -> Int)+            G.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Max a) -> U.Vector (Max a))+            G.basicUnsafeSlice+    basicUnsafeIndexM (V_Max xs) i =+        fmap (coerce :: a -> Max a) (G.basicUnsafeIndexM xs i) -------------------------------------------------------------------------------- -- (->) instance --------------------------------------------------------------------------------

@@ -8,7 +8,6 @@   ,runFree)   where -import           Data.Coerce import           Data.Semiring  import           Data.Map.Strict (Map)@@ -16,6 +15,8 @@  import           Numeric.Natural +import           Data.Semiring.Newtype+ -- | The free semiring newtype Free a = Free   { getFree :: Map [a] Natural@@ -37,7 +38,7 @@  -- | Run a 'Free'. runFree :: Semiring s => (a -> s) -> Free a -> s-runFree f = getAdd .# Map.foldMapWithKey ((rep #. Add) . mul . map f) . getFree+runFree f = getAdd #. Map.foldMapWithKey ((rep .# Add) . mul . map f) . getFree {-# INLINE runFree #-}  -- | Run a 'Free', interpreting it in the underlying semiring.@@ -45,19 +46,10 @@ lowerFree = runFree id {-# INLINE lowerFree #-} +-- | Create a 'Free' with one item. 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-(.#) _ = coerce-{-# INLINE (.#) #-}  instance Foldable Free where     foldMap f (Free xs) = Map.foldMapWithKey (rep . foldMap f) xs

@@ -27,8 +27,15 @@ import           Data.Coerce import           Data.Monoid -import Data.Semiring+import           Data.Semiring +import           Data.Semiring.Newtype++import           Control.DeepSeq++import           Data.Functor.Classes+import           Text.Read+ -- | Adds negative infinity to a type. Useful for expressing detectable infinity -- in types like 'Integer', etc. data NegativeInfinite a@@ -91,8 +98,9 @@     (<+>) =         (coerce :: CoerceBinary (PositiveInfinite (Add a)) (PositiveInfinite a))             mappend-    x <.> y | any isZero x || any isZero y = zero-            | otherwise = liftA2 (<.>) x y+    x <.> y+      | any isZero x || any isZero y = zero+      | otherwise = liftA2 (<.>) x y     {-# INLINE zero #-}     {-# INLINE one #-}     {-# INLINE (<+>) #-}@@ -180,25 +188,25 @@   {-# INLINE negativeInfinity #-}   negativeInfinity = NegativeInfinity   isNegativeInfinity NegativeInfinity = True-  isNegativeInfinity _ = False+  isNegativeInfinity _                = False  instance HasPositiveInfinity (PositiveInfinite a) where   {-# INLINE positiveInfinity #-}   positiveInfinity = PositiveInfinity   isPositiveInfinity PositiveInfinity = True-  isPositiveInfinity _ = False+  isPositiveInfinity _                = False  instance HasNegativeInfinity (Infinite a) where   {-# INLINE negativeInfinity #-}   negativeInfinity = Negative   isNegativeInfinity Negative = True-  isNegativeInfinity _ = False+  isNegativeInfinity _        = False  instance HasPositiveInfinity (Infinite a) where   {-# INLINE positiveInfinity #-}   positiveInfinity = Positive   isPositiveInfinity Positive = True-  isPositiveInfinity _ = False+  isPositiveInfinity _        = False  instance (Enum a, Bounded a, Eq a) => Enum (NegativeInfinite a) where   succ = foldr (const . pure . succ) (pure minBound)@@ -285,8 +293,6 @@   signum = foldr (const . pure . signum) (-1)   (-) = liftA2 (-) -type CoerceBinary a b = (a -> a -> a) -> (b -> b -> b)- instance Num a => Num (Infinite a) where   fromInteger = Finite . fromInteger   (+) = (coerce :: CoerceBinary (Infinite (Sum a)) (Infinite a)) mappend@@ -298,7 +304,7 @@   negate Negative   = Positive   negate (Finite x) = Finite (negate x)   abs Negative = Positive-  abs x = fmap abs x+  abs x        = fmap abs x  -- Adapted from https://www.schoolofhaskell.com/user/snoyberg/random-code-snippets/storable-instance-of-maybe instance Storable a => Storable (NegativeInfinite a) where@@ -329,13 +335,13 @@     sizeOf x = sizeOf (strip x) + 1     alignment x = alignment (strip x)     peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case-      (0 :: Word8) -> Finite <$> peek (stripFPtr ptr)-      1 -> pure Negative+      0 -> pure Negative+      (1 :: Word8) -> Finite <$> peek (stripFPtr ptr)       _ -> pure Positive     poke ptr Positive       = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (2 :: Word8)     poke ptr Negative-      = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (1 :: Word8)+      = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (0 :: Word8)     poke ptr (Finite a)       = poke (stripFPtr ptr) a      *> pokeByteOff ptr (sizeOf a) (1 :: Word8)@@ -348,3 +354,130 @@  stripPtr :: Ptr a -> a stripPtr _ = error "stripPtr"++instance NFData a =>+         NFData (NegativeInfinite a) where+    rnf NegativeInfinity = ()+    rnf (NegFinite x) = rnf x++instance NFData a =>+         NFData (PositiveInfinite a) where+    rnf PositiveInfinity = ()+    rnf (PosFinite x) = rnf x++instance NFData a =>+         NFData (Infinite a) where+    rnf Negative = ()+    rnf Positive = ()+    rnf (Finite x) = rnf x++instance Eq1 NegativeInfinite where+    liftEq eq = go+      where+        go NegativeInfinity NegativeInfinity = True+        go (NegFinite x) (NegFinite y) = eq x y+        go _ _ = False++instance Eq1 PositiveInfinite where+    liftEq eq = go+      where+        go PositiveInfinity PositiveInfinity = True+        go (PosFinite x) (PosFinite y) = eq x y+        go _ _ = False++instance Eq1 Infinite where+    liftEq eq = go+      where+        go Positive Positive = True+        go Negative Negative = False+        go (Finite x) (Finite y) = eq x y+        go _ _ = False++instance Ord1 NegativeInfinite where+    liftCompare cmp = go+      where+        go NegativeInfinity NegativeInfinity = EQ+        go (NegFinite x) (NegFinite y) = cmp x y+        go NegativeInfinity (NegFinite _) = LT+        go (NegFinite _) NegativeInfinity = GT++instance Ord1 PositiveInfinite where+    liftCompare cmp = go+      where+        go PositiveInfinity PositiveInfinity = EQ+        go (PosFinite x) (PosFinite y) = cmp x y+        go PositiveInfinity (PosFinite _) = GT+        go (PosFinite _) PositiveInfinity = LT++instance Ord1 Infinite where+    liftCompare cmp = go+      where+        go Positive Positive = EQ+        go Positive Negative = GT+        go Negative Positive = LT+        go Negative Negative = EQ+        go Positive (Finite _) = GT+        go Negative (Finite _) = LT+        go (Finite _) Positive = LT+        go (Finite _) Negative = GT+        go (Finite x) (Finite y) = cmp x y++instance Show1 PositiveInfinite where+    liftShowsPrec sp _ n = go+      where+        go PositiveInfinity = showString "PositiveInfinity"+        go (PosFinite x) =+            showParen (n > 10) $ showString "PosFinite " . sp 11 x++instance Show1 NegativeInfinite where+    liftShowsPrec sp _ n = go+      where+        go NegativeInfinity = showString "NegativeInfinity"+        go (NegFinite x) =+            showParen (n > 10) $ showString "NegFinite " . sp 11 x++instance Show1 Infinite where+    liftShowsPrec sp _ n = go+      where+        go Positive = showString "Positive"+        go Negative = showString "Negative"+        go (Finite x) =+            showParen (n > 10) $ showString "Finite " . sp 11 x++instance Read1 PositiveInfinite where+    liftReadsPrec rp _ =+        readPrec_to_S $+        parens $+        (do Ident "PositiveInfinity" <- lexP+            pure PositiveInfinity) ++++        prec+            10+            (do Ident "PosFinite" <- lexP+                m <- step (readS_to_Prec rp)+                pure (PosFinite m))++instance Read1 NegativeInfinite where+    liftReadsPrec rp _ =+        readPrec_to_S $+        parens $+        (do Ident "NegativeInfinity" <- lexP+            pure NegativeInfinity) ++++        prec+            10+            (do Ident "NegFinite" <- lexP+                m <- step (readS_to_Prec rp)+                pure (NegFinite m))++instance Read1 Infinite where+    liftReadsPrec rp _ =+        readPrec_to_S $+        parens $+        (do Ident "Negative" <- lexP+            pure Negative) ++++        (do Ident "Positive" <- lexP+            pure Positive) ++++        prec+            10+            (do Ident "Finite" <- lexP+                m <- step (readS_to_Prec rp)+                pure (Finite m))

@@ -0,0 +1,97 @@+-- | Various utilities for working with newtype wrappers.++module Data.Semiring.Newtype where++import Data.Coerce+import Text.Read+import Control.Monad++--------------------------------------------------------------------------------+-- Show1, Read1+--------------------------------------------------------------------------------++-- | A definition for 'Data.Functor.Classes.liftShowsPrec' suitable for+-- newtypes.+-- Given a newtype declared as:+--+-- @+-- newtype T a = T { unT :: a }+-- @+--+-- The 'Data.Functor.Classes.Show1' definition can be given as:+--+-- @+-- instance Show1 T where+--   liftShowsPrec = showsNewtype "T" "unT"+-- @+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 '}'+{-# INLINE showsNewtype #-}++-- | A definition for 'Data.Functor.Classes.liftReadsPrec' suitable for+-- newtypes.+-- Given a newtype declared as:+--+-- @+-- newtype T a = T { unT :: a }+-- @+--+-- The 'Data.Functor.Classes.Read1' definition can be given as:+--+-- @+-- instance Read1 T where+--   liftReadsPrec = readsNewtype "T" "unT"+-- @+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)+{-# INLINE readsNewtype #-}+++--------------------------------------------------------------------------------+-- Typealiases to make coercion signatures shorter+--------------------------------------------------------------------------------++type Binary a = a -> a -> a+type CoerceBinary a b = Binary a -> Binary b+type WrapBinary f a = Binary a -> BinaryWrapped f a+type BinaryWrapped f a = Binary (f a)++--------------------------------------------------------------------------------+-- Coercive composition+--------------------------------------------------------------------------------++infixr 9 #.+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c+(#.) _ = coerce+{-# INLINE (#.) #-}++infixr 9 .#+(.#) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c+(.#) f _ = coerce f+{-# INLINE (.#) #-}

@@ -4,6 +4,8 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses      #-}  {-| Module: Data.Semiring.Numeric@@ -22,8 +24,6 @@   ) where  import           Data.Coerce-import           Text.Read-import           Control.Monad  import           Data.Semiring @@ -32,9 +32,13 @@ import           Foreign.Storable (Storable) import           Data.Functor.Classes +import           Data.Semiring.Newtype +import qualified Data.Vector.Generic         as G+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Unboxed.Base    as U -type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a+import           Control.DeepSeq  -- | Useful for some constraint problems. --@@ -43,10 +47,10 @@ --'zero'  = 'minBound' --'one'   = 'maxBound'@ newtype Bottleneck a = Bottleneck-  { getBottleneck :: a-  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac-             ,Functor, Foldable, Traversable)+    { getBottleneck :: a+    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,NFData)  instance (Bounded a, Ord a) => Semiring (Bottleneck a) where   (<+>) = (coerce :: WrapBinary Bottleneck a) max@@ -80,10 +84,10 @@ --'zero'  = 'zero' --'one'   = 'one'@ newtype Division a = Division-  { getDivision :: a-  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac-             ,Functor, Foldable, Traversable,DetectableZero)+    { getDivision :: a+    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,DetectableZero,NFData)  -- | Only expects positive numbers instance (Integral a, Semiring a) => Semiring (Division a) where@@ -118,10 +122,10 @@ --'zero'    = 'zero' --'one'     = 'one'@ newtype Łukasiewicz a = Łukasiewicz-  { getŁukasiewicz :: a-  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac-             ,Functor, Foldable, Traversable)+    { getŁukasiewicz :: a+    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,NFData)  instance (Ord a, Num a) => Semiring (Łukasiewicz a) where   (<+>) = (coerce :: WrapBinary Łukasiewicz a) max@@ -158,10 +162,10 @@ --'zero'  = 'zero' --'one'   = 'one'@ newtype Viterbi a = Viterbi-  { getViterbi :: a-  } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac-             ,Functor, Foldable, Traversable,DetectableZero)+    { getViterbi :: a+    } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable+               ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,DetectableZero,NFData)  instance (Ord a, Semiring a) => Semiring (Viterbi a) where   (<+>) = (coerce :: WrapBinary Viterbi a) max@@ -193,10 +197,10 @@ --'one'    = 'one' --'star' x = if x < 1 then 1 / (1 - x) else 'positiveInfinity'@ newtype PosFrac a = PosFrac-  { getPosFrac :: a-  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac-             ,Functor, Foldable, Traversable)+    { getPosFrac :: a+    } deriving (Eq,Ord,Read,Show,Generic,Generic1,Num,Enum,Typeable,Storable+               ,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,DetectableZero,NFData)  instance (Bounded a, Semiring a) => Bounded (PosFrac a) where   minBound = PosFrac zero@@ -212,9 +216,6 @@   {-# INLINE zero #-}   {-# INLINE one #-} -instance (Eq a, Semiring a) => DetectableZero (PosFrac a) where-  isZero = (zero==)- instance (Ord a, Fractional a, Semiring a, HasPositiveInfinity a) =>          StarSemiring (PosFrac a) where     star (PosFrac n)@@ -242,10 +243,10 @@ --'star' 0 = 1 --'star' _ = 'positiveInfinity'@ newtype PosInt a = PosInt-  { getPosInt :: a-  } deriving (Eq, Ord, Read, Show, Generic, Generic1, Num-             ,Enum, Typeable, Storable, Fractional, Real, RealFrac-             ,Functor, Foldable, Traversable)+    { getPosInt :: a+    } deriving (Eq,Ord,Read,Show,Generic,Generic1,Num,Enum,Typeable,Storable+               ,Fractional,Real,RealFrac,Functor,Foldable,Traversable+               ,DetectableZero,NFData)  instance (Bounded a, Semiring a) => Bounded (PosInt a) where   minBound = PosInt zero@@ -261,9 +262,6 @@   {-# INLINE zero #-}   {-# INLINE one #-} -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@@ -281,24 +279,344 @@ 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 '}'+newtype instance U.Vector (Bottleneck a) = V_Bottleneck (U.Vector a)+newtype instance U.MVector s (Bottleneck a) = MV_Bottleneck (U.MVector s a) -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 U.Unbox a =>+         M.MVector U.MVector (Bottleneck a) where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    basicLength =+        (coerce :: (U.MVector s a -> Int) -> U.MVector s (Bottleneck a) -> Int)+            M.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Bottleneck a) -> U.MVector s (Bottleneck a))+            M.basicUnsafeSlice+    basicOverlaps =+        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Bottleneck a) -> U.MVector s (Bottleneck a) -> Bool)+            M.basicOverlaps+    basicUnsafeNew n =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Bottleneck a))+            (M.basicUnsafeNew n)+    basicUnsafeRead (MV_Bottleneck xs) i =+        fmap (coerce :: a -> Bottleneck a) (M.basicUnsafeRead xs i)+    basicUnsafeWrite =+        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Bottleneck a) -> Int -> Bottleneck a -> m ())+            M.basicUnsafeWrite+    basicInitialize =+        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Bottleneck a) -> m ())+            M.basicInitialize++instance U.Unbox a =>+         G.Vector U.Vector (Bottleneck a) where+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeFreeze (MV_Bottleneck xs) =+        fmap+            (coerce :: U.Vector a -> U.Vector (Bottleneck a))+            (G.basicUnsafeFreeze xs)+    basicUnsafeThaw (V_Bottleneck xs) =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Bottleneck a))+            (G.basicUnsafeThaw xs)+    basicLength =+        (coerce :: (U.Vector a -> Int) -> U.Vector (Bottleneck a) -> Int)+            G.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Bottleneck a) -> U.Vector (Bottleneck a))+            G.basicUnsafeSlice+    basicUnsafeIndexM (V_Bottleneck xs) i =+        fmap (coerce :: a -> Bottleneck a) (G.basicUnsafeIndexM xs i)++newtype instance U.Vector (Division a) = V_Division (U.Vector a)+newtype instance U.MVector s (Division a) = MV_Division (U.MVector s a)++instance U.Unbox a =>+         M.MVector U.MVector (Division a) where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    basicLength =+        (coerce :: (U.MVector s a -> Int) -> U.MVector s (Division a) -> Int)+            M.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Division a) -> U.MVector s (Division a))+            M.basicUnsafeSlice+    basicOverlaps =+        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Division a) -> U.MVector s (Division a) -> Bool)+            M.basicOverlaps+    basicUnsafeNew n =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Division a))+            (M.basicUnsafeNew n)+    basicUnsafeRead (MV_Division xs) i =+        fmap (coerce :: a -> Division a) (M.basicUnsafeRead xs i)+    basicUnsafeWrite =+        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Division a) -> Int -> Division a -> m ())+            M.basicUnsafeWrite+    basicInitialize =+        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Division a) -> m ())+            M.basicInitialize++instance U.Unbox a =>+         G.Vector U.Vector (Division a) where+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeFreeze (MV_Division xs) =+        fmap+            (coerce :: U.Vector a -> U.Vector (Division a))+            (G.basicUnsafeFreeze xs)+    basicUnsafeThaw (V_Division xs) =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Division a))+            (G.basicUnsafeThaw xs)+    basicLength =+        (coerce :: (U.Vector a -> Int) -> U.Vector (Division a) -> Int)+            G.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Division a) -> U.Vector (Division a))+            G.basicUnsafeSlice+    basicUnsafeIndexM (V_Division xs) i =+        fmap (coerce :: a -> Division a) (G.basicUnsafeIndexM xs i)++newtype instance U.Vector (Łukasiewicz a) = V_Łukasiewicz (U.Vector a)+newtype instance U.MVector s (Łukasiewicz a) = MV_Łukasiewicz (U.MVector s a)++instance U.Unbox a =>+         M.MVector U.MVector (Łukasiewicz a) where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    basicLength =+        (coerce :: (U.MVector s a -> Int) -> U.MVector s (Łukasiewicz a) -> Int)+            M.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Łukasiewicz a) -> U.MVector s (Łukasiewicz a))+            M.basicUnsafeSlice+    basicOverlaps =+        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Łukasiewicz a) -> U.MVector s (Łukasiewicz a) -> Bool)+            M.basicOverlaps+    basicUnsafeNew n =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Łukasiewicz a))+            (M.basicUnsafeNew n)+    basicUnsafeRead (MV_Łukasiewicz xs) i =+        fmap (coerce :: a -> Łukasiewicz a) (M.basicUnsafeRead xs i)+    basicUnsafeWrite =+        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Łukasiewicz a) -> Int -> Łukasiewicz a -> m ())+            M.basicUnsafeWrite+    basicInitialize =+        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Łukasiewicz a) -> m ())+            M.basicInitialize++instance U.Unbox a =>+         G.Vector U.Vector (Łukasiewicz a) where+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeFreeze (MV_Łukasiewicz xs) =+        fmap+            (coerce :: U.Vector a -> U.Vector (Łukasiewicz a))+            (G.basicUnsafeFreeze xs)+    basicUnsafeThaw (V_Łukasiewicz xs) =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Łukasiewicz a))+            (G.basicUnsafeThaw xs)+    basicLength =+        (coerce :: (U.Vector a -> Int) -> U.Vector (Łukasiewicz a) -> Int)+            G.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Łukasiewicz a) -> U.Vector (Łukasiewicz a))+            G.basicUnsafeSlice+    basicUnsafeIndexM (V_Łukasiewicz xs) i =+        fmap (coerce :: a -> Łukasiewicz a) (G.basicUnsafeIndexM xs i)++newtype instance U.Vector (Viterbi a) = V_Viterbi (U.Vector a)+newtype instance U.MVector s (Viterbi a) = MV_Viterbi (U.MVector s a)++instance U.Unbox a =>+         M.MVector U.MVector (Viterbi a) where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    basicLength =+        (coerce :: (U.MVector s a -> Int) -> U.MVector s (Viterbi a) -> Int)+            M.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (Viterbi a) -> U.MVector s (Viterbi a))+            M.basicUnsafeSlice+    basicOverlaps =+        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (Viterbi a) -> U.MVector s (Viterbi a) -> Bool)+            M.basicOverlaps+    basicUnsafeNew n =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Viterbi a))+            (M.basicUnsafeNew n)+    basicUnsafeRead (MV_Viterbi xs) i =+        fmap (coerce :: a -> Viterbi a) (M.basicUnsafeRead xs i)+    basicUnsafeWrite =+        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (Viterbi a) -> Int -> Viterbi a -> m ())+            M.basicUnsafeWrite+    basicInitialize =+        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (Viterbi a) -> m ())+            M.basicInitialize++instance U.Unbox a =>+         G.Vector U.Vector (Viterbi a) where+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeFreeze (MV_Viterbi xs) =+        fmap+            (coerce :: U.Vector a -> U.Vector (Viterbi a))+            (G.basicUnsafeFreeze xs)+    basicUnsafeThaw (V_Viterbi xs) =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (Viterbi a))+            (G.basicUnsafeThaw xs)+    basicLength =+        (coerce :: (U.Vector a -> Int) -> U.Vector (Viterbi a) -> Int)+            G.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (Viterbi a) -> U.Vector (Viterbi a))+            G.basicUnsafeSlice+    basicUnsafeIndexM (V_Viterbi xs) i =+        fmap (coerce :: a -> Viterbi a) (G.basicUnsafeIndexM xs i)++newtype instance U.Vector (PosFrac a) = V_PosFrac (U.Vector a)+newtype instance U.MVector s (PosFrac a) = MV_PosFrac (U.MVector s a)++instance U.Unbox a =>+         M.MVector U.MVector (PosFrac a) where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    basicLength =+        (coerce :: (U.MVector s a -> Int) -> U.MVector s (PosFrac a) -> Int)+            M.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (PosFrac a) -> U.MVector s (PosFrac a))+            M.basicUnsafeSlice+    basicOverlaps =+        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (PosFrac a) -> U.MVector s (PosFrac a) -> Bool)+            M.basicOverlaps+    basicUnsafeNew n =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (PosFrac a))+            (M.basicUnsafeNew n)+    basicUnsafeRead (MV_PosFrac xs) i =+        fmap (coerce :: a -> PosFrac a) (M.basicUnsafeRead xs i)+    basicUnsafeWrite =+        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (PosFrac a) -> Int -> PosFrac a -> m ())+            M.basicUnsafeWrite+    basicInitialize =+        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (PosFrac a) -> m ())+            M.basicInitialize++instance U.Unbox a =>+         G.Vector U.Vector (PosFrac a) where+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeFreeze (MV_PosFrac xs) =+        fmap+            (coerce :: U.Vector a -> U.Vector (PosFrac a))+            (G.basicUnsafeFreeze xs)+    basicUnsafeThaw (V_PosFrac xs) =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (PosFrac a))+            (G.basicUnsafeThaw xs)+    basicLength =+        (coerce :: (U.Vector a -> Int) -> U.Vector (PosFrac a) -> Int)+            G.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (PosFrac a) -> U.Vector (PosFrac a))+            G.basicUnsafeSlice+    basicUnsafeIndexM (V_PosFrac xs) i =+        fmap (coerce :: a -> PosFrac a) (G.basicUnsafeIndexM xs i)++newtype instance U.Vector (PosInt a) = V_PosInt (U.Vector a)+newtype instance U.MVector s (PosInt a) = MV_PosInt (U.MVector s a)++instance U.Unbox a =>+         M.MVector U.MVector (PosInt a) where+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicOverlaps #-}+    {-# INLINE basicUnsafeNew #-}+    {-# INLINE basicUnsafeRead #-}+    {-# INLINE basicUnsafeWrite #-}+    basicLength =+        (coerce :: (U.MVector s a -> Int) -> U.MVector s (PosInt a) -> Int)+            M.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.MVector s a -> U.MVector s a) -> Int -> Int -> U.MVector s (PosInt a) -> U.MVector s (PosInt a))+            M.basicUnsafeSlice+    basicOverlaps =+        (coerce :: (U.MVector s a -> U.MVector s a -> Bool) -> U.MVector s (PosInt a) -> U.MVector s (PosInt a) -> Bool)+            M.basicOverlaps+    basicUnsafeNew n =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (PosInt a))+            (M.basicUnsafeNew n)+    basicUnsafeRead (MV_PosInt xs) i =+        fmap (coerce :: a -> PosInt a) (M.basicUnsafeRead xs i)+    basicUnsafeWrite =+        (coerce :: (U.MVector s a -> Int -> a -> m ()) -> U.MVector s (PosInt a) -> Int -> PosInt a -> m ())+            M.basicUnsafeWrite+    basicInitialize =+        (coerce :: (U.MVector s a -> m ()) -> U.MVector s (PosInt a) -> m ())+            M.basicInitialize++instance U.Unbox a =>+         G.Vector U.Vector (PosInt a) where+    {-# INLINE basicUnsafeFreeze #-}+    {-# INLINE basicUnsafeThaw #-}+    {-# INLINE basicLength #-}+    {-# INLINE basicUnsafeSlice #-}+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeFreeze (MV_PosInt xs) =+        fmap+            (coerce :: U.Vector a -> U.Vector (PosInt a))+            (G.basicUnsafeFreeze xs)+    basicUnsafeThaw (V_PosInt xs) =+        fmap+            (coerce :: U.MVector s a -> U.MVector s (PosInt a))+            (G.basicUnsafeThaw xs)+    basicLength =+        (coerce :: (U.Vector a -> Int) -> U.Vector (PosInt a) -> Int)+            G.basicLength+    basicUnsafeSlice =+        (coerce :: (Int -> Int -> U.Vector a -> U.Vector a) -> Int -> Int -> U.Vector (PosInt a) -> U.Vector (PosInt a))+            G.basicUnsafeSlice+    basicUnsafeIndexM (V_PosInt xs) i =+        fmap (coerce :: a -> PosInt a) (G.basicUnsafeIndexM xs i)

@@ -507,7 +507,7 @@  -- | Multiplication law for ordered 'Semiring's. ----- @x '<=' y => x '<.>' z '<=' y '<.>' z '&&' z '<.>' x '<=' z '<.>' y@+-- @x '<=' y && 'zero' '<=' z => x '<.>' z '<=' y '<.>' z '&&' z '<.>' x '<=' z '<.>' y@ ordMulLaw     :: (Ord a, Semiring a, Show a)     => a -> a -> a -> Either String String@@ -528,7 +528,7 @@                    else " not") ++               " followed."             , "    Law:"-            , "        x <= y => x <.> z <= y <.> z && z <.> x <= z <.> y"+            , "        x <= y && zero <= z => x <.> z <= y <.> z && z <.> x <= z <.> y"             , "    x = " ++ show x             , "    y = " ++ show y             , "    z = " ++ show z]

@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++module ApproxLog where++import           Test.QuickCheck as QC+import           Test.SmallCheck.Series as SC++import           Data.Semiring++import           Numeric.Log+import           Numeric.Log.Signed++import           CompUtils++newtype ApproxLog a =+    ApproxLog (Log a)+    deriving (Show,Num,Fractional,Real,RealFrac,Floating,Semiring)++instance (Arbitrary a, Precise a, RealFloat a) =>+         Arbitrary (ApproxLog a) where+    arbitrary = fmap (ApproxLog #. fromRational .# QC.getNonNegative) arbitrary++instance (Serial m a, Precise a, RealFloat a) =>+         Serial m (ApproxLog a) where+    series = fmap (ApproxLog #. fromRational .# SC.getNonNegative) series++instance (RealFloat a, Ord a) =>+         Eq (ApproxLog a) where+    ApproxLog (Exp x) == ApproxLog (Exp y) =+        isInfinite x && isInfinite y ||+        x == y || abs ((exp x-exp y) / exp x) < 0.01++instance (RealFloat a, Ord a) => Ord (ApproxLog a) where+    compare (ApproxLog x) (ApproxLog y)+      | ApproxLog x == ApproxLog y = EQ+      | otherwise = compare x y++newtype SApproxLog a =+    SApproxLog (SignedLog a)+    deriving (Show,Num,Fractional,Real,RealFrac,Floating,Semiring)++instance (Arbitrary a, Precise a, RealFloat a) =>+         Arbitrary (SApproxLog a) where+    arbitrary = fmap (SApproxLog #. fromRational .# QC.getNonNegative) arbitrary++instance (Serial m a, Precise a, RealFloat a) =>+         Serial m (SApproxLog a) where+    series = fmap (SApproxLog #. fromRational .# SC.getNonNegative) series++instance (RealFloat a, Ord a) =>+         Eq (SApproxLog a) where+    SApproxLog (SLExp xb x) == SApproxLog (SLExp yb y) = xb == yb && (+        isInfinite x && isInfinite y ||+        x == y || abs ((exp x-exp y) / exp x) < 0.01)++instance (RealFloat a, Ord a) => Ord (SApproxLog a) where+    compare (SApproxLog x) (SApproxLog y)+      | SApproxLog x == SApproxLog y = EQ+      | otherwise = compare x y

@@ -0,0 +1,18 @@+module CompUtils where++import Data.Coerce++(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(f .: g) x y = f (g x y)++infixr 9 #.+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c+(#.) _ = coerce++infixr 9 .#+(.#) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c+(.#) f _ = coerce f++infixl 4 <#$>+(<#$>) :: Coercible (f a) (f b) => (a -> b) -> f a -> f b+(<#$>) _ = coerce

@@ -0,0 +1,33 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++module Fraction where++import           Data.Semiring++import           Test.SmallCheck.Series++import           Control.Applicative++newtype Fraction =+    Fraction Double+    deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring)++instance DetectableZero Fraction where isZero = (0==)++instance Eq Fraction where+    Fraction x == Fraction y = abs (x - y) < 0.011++instance Ord Fraction where+    compare (Fraction x) (Fraction y)+      | Fraction x == Fraction y = EQ+      | otherwise = compare x y++instance Monad m => Serial m Fraction where+  series = fmap Fraction $ generate (\d -> if d >= 0 then pure 0 else empty) <|> rest where+    rest = generate $ \d -> take d (1 : go 0 1)+    go lower upper = let mid = (lower + upper) / 2 in+      mid : interleave (go lower mid) (go mid upper)+    interleave (x:xs) (y:ys) = x : y : interleave xs ys+    interleave _ _           = undefined

@@ -0,0 +1,81 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}++module Func where++import           Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap++import           Data.Map.Strict    (Map)+import qualified Data.Map.Strict    as Map++import           Data.Semiring++import           Test.QuickCheck++import           Data.Function+import           Data.Monoid++import           CompUtils++data Func a b = Func+    { def  :: b+    , vals :: IntMap b+    } deriving (Eq,Ord)++(#$) :: Enum a => Func a b -> a -> b+(#$) f x = IntMap.findWithDefault (def f) (fromEnum x) (vals f)++instance (Enum a, Show a, Show b) =>+         Show (Func a b) where+    showsPrec _ (Func c xs :: Func a b) =+        showChar '{' . IntMap.foldrWithKey f b xs+      where+        f x y a =+            shows (toEnum x :: a) .+            showString " -> " . shows y . showString ", " . a+        b = showString "_ -> " . shows c . showChar '}'++fromFunc :: (Enum a, Bounded a, Ord b) => (a -> b) -> Func a b+fromFunc f =+    uncurry Func . fmap IntMap.fromList . remMostFreq $+    [ (fromEnum x, f x)+    | x <- [minBound .. maxBound] ]+  where+    remMostFreq xs = (mf, filter ((mf/=) . snd) xs) where+      Just mf = mostFrequent (map snd xs)++mostFrequent :: Ord a => [a] -> Maybe a+mostFrequent xs = foldr f (const . fmap fst) xs Nothing (Map.empty :: Map a Int) where+  f e a Nothing _ = a (Just (e, 1)) (Map.singleton e 1)+  f e a (Just (b,n)) m+    | d > n = a (Just (e,d)) nm+    | otherwise = a (Just (b,n)) nm where+    (nv,nm) = Map.insertLookupWithKey (const (+)) e 1 m+    d = maybe 1 succ nv++instance (Enum a, Bounded a, Ord b, Semiring b) => Semiring (Func a b) where+    zero = fromFunc zero+    one = fromFunc one+    (<+>) = fromFunc .: (<+>) `on` (#$)+    (<.>) = fromFunc .: (<.>) `on` (#$)++instance (Bounded a, Enum a, Ord b, Arbitrary b, CoArbitrary a) =>+         Arbitrary (Func a b) where+    arbitrary = fmap fromFunc arbitrary+    shrink f = fmap fromFunc (shrink (f #$))++newtype EndoFunc a = EndoFunc+    { getEndoFunc :: Endo a+    } deriving (Semiring,DetectableZero)++instance (Enum a, Bounded a, Ord a) => Eq (EndoFunc a) where+  (==) = (==) `on` (fromFunc .# appEndo .# getEndoFunc)++instance (Enum a, Bounded a, Ord a, Show a) => Show (EndoFunc a) where+  showsPrec n = showsPrec n . fromFunc .# appEndo .# getEndoFunc++instance (Arbitrary a, CoArbitrary a) =>+         Arbitrary (EndoFunc a) where+    arbitrary = (EndoFunc . Endo) <#$> arbitrary+    shrink (EndoFunc (Endo f)) = (EndoFunc . Endo) <#$> shrink f

@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}++module LimitSize where++import           Test.QuickCheck+import           Test.SmallCheck.Series++import           Data.Semiring++import           GHC.TypeLits+import           Data.Function+import           Data.Proxy++newtype LimitSize (n :: Nat) a =+    LimitSize [a]+    deriving (Arbitrary,Semiring,DetectableZero,StarSemiring)++takeFirst+    :: KnownNat n+    => LimitSize n a -> [a]+takeFirst (LimitSize xs :: LimitSize n a) =+    take (fromInteger (natVal (Proxy :: Proxy n))) xs++instance Serial m a =>+         Serial m (LimitSize n a) where+    series = fmap LimitSize series++instance (Eq a, KnownNat n) =>+         Eq (LimitSize n a) where+    (==) = (==) `on` takeFirst++instance (Show a, KnownNat n) =>+         Show (LimitSize n a) where+    showsPrec n = showsPrec n . takeFirst

@@ -0,0 +1,107 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Orphans where++import           Test.QuickCheck hiding (Positive(..), generate)+import           Test.SmallCheck.Series hiding (Positive(..))+import qualified Test.SmallCheck.Series as SC++import           Data.Semiring+import           Data.Semiring.Infinite+import           Data.Semiring.Free+import           Data.Semiring.Numeric+import qualified Data.Vector as Vector+import           Numeric.Natural+import           Numeric.Sized.WordOfSize+import           Data.Monoid+import           Numeric.Log++import           CompUtils++import           Data.Bool+import           GHC.TypeLits+++instance Arbitrary a => Arbitrary (Add a) where+    arbitrary = Add <#$> arbitrary+    shrink = map Add #. shrink .# getAdd++instance CoArbitrary a => CoArbitrary (Add a) where+    coarbitrary = coarbitrary .# getAdd++instance Arbitrary a => Arbitrary (PositiveInfinite a) where+  arbitrary = fmap (maybe PositiveInfinity PosFinite) arbitrary++instance Arbitrary a => Arbitrary (NegativeInfinite a) where+  arbitrary = fmap (maybe NegativeInfinity NegFinite) arbitrary++instance Arbitrary a => Arbitrary (Infinite a) where+  arbitrary = fmap (either (bool Positive Negative) Finite) arbitrary++instance Arbitrary a => Arbitrary (Vector.Vector a) where+    arbitrary = fmap Vector.fromList arbitrary+    shrink = fmap Vector.fromList . shrink . Vector.toList++instance Testable (Either String String) where+  property = either (`counterexample` False) (const (property True))++instance Arbitrary (f (g a)) => Arbitrary (Matrix f g a) where+    arbitrary = fmap Matrix arbitrary+    shrink (Matrix xs) = fmap Matrix (shrink xs)++instance (Monad m, KnownNat n) => Serial m (WordOfSize n) where+  series = generate (`take` [minBound..maxBound])++instance KnownNat n => Arbitrary (WordOfSize n) where+  arbitrary = arbitraryBoundedEnum++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++instance (Monad m, Serial m a) => Serial m (NegativeInfinite a) where+  series = fmap (maybe NegativeInfinity NegFinite) series++instance (Monad m, Serial m a) => Serial m (Infinite a) where+  series = fmap (either (bool Positive Negative) Finite) series++instance Monad m => Serial m Natural where+  series = generate (`take` [0..])++instance Monad m => Serial m Any where+  series = fmap Any series++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 (Serial m a, Monad m, Num a, Ord a) => Serial m (Division a) where+  series = fmap (Division . SC.getPositive) 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 => Serial m (Log a) where+    series = fmap Exp series

@@ -1,43 +1,28 @@-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-} {-# OPTIONS_GHC -fno-warn-orphans       #-}  module Main (main) where -import           Control.Applicative--import           Control.Arrow            (first)-import           Data.Function-import           Data.Bool import           Data.Proxy -import           Data.Foldable import           Data.Monoid -import           Data.IntMap.Strict       (IntMap)-import qualified Data.IntMap.Strict       as IntMap- import           Data.Map.Strict          (Map)-import qualified Data.Map.Strict          as Map -import qualified Data.Vector as Vector+import qualified Data.Vector              as Vector+import qualified Data.Vector.Storable     as Storable  import           Data.Semiring import           Data.Semiring.Free import           Data.Semiring.Infinite import           Data.Semiring.Numeric -import           GHC.TypeLits import           Numeric.Natural import           Numeric.Sized.WordOfSize @@ -45,15 +30,20 @@ import           Test.QuickCheck          hiding (Positive (..), generate,                                            (.&.)) 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+import           ApproxLog+import           Fraction+import           Func+import           LimitSize+import           Orphans                  ()+import           Vectors + ------------------------------------------------------------------------  semiringLawsSC :: (Show r, Eq r, Semiring r, Serial IO r) => f r -> TestTree@@ -90,10 +80,10 @@   [ SC.testProperty "starLaw" (starLaw :: r -> Either String String)   , SC.testProperty "plusLaw" (plusLaw :: r -> Either String String)] --- ordLawsQC :: (Show r, Ord r, Semiring r, Arbitrary r) => f r -> TestTree--- ordLawsQC (_ :: f r) = testGroup "Ordering laws"---   [ QC.testProperty "mulLaw" (ordMulLaw :: r -> r -> r -> Either String String)---   , QC.testProperty "addLaw" (ordAddLaw :: r -> r -> r -> Either String String)]+ordLawsQC :: (Show r, Ord r, Semiring r, Arbitrary r) => f r -> TestTree+ordLawsQC (_ :: f r) = testGroup "Ordering laws"+  [ QC.testProperty "mulLaw" (ordMulLaw :: r -> r -> r -> Either String String)+  , QC.testProperty "addLaw" (ordAddLaw :: r -> r -> r -> Either String String)]  zeroLawsQC :: (Show r, Eq r, DetectableZero r, Arbitrary r) => f r -> TestTree zeroLawsQC (_ :: f r) = testGroup "Zero laws"@@ -110,6 +100,20 @@   [ SC.testProperty "zeroLaw" (zeroLaw :: r -> Either String String)   , SC.testProperty "zeroIsZero" (zeroIsZero (Proxy :: Proxy r))] +storableQC :: (Show r, Eq r, Arbitrary r, Storable.Storable r) => f r -> TestTree+storableQC (_ :: f r) =+    testGroup+        "Storable implementation"+        [ QC.testProperty+              "unstore . store == id"+              (\(xs :: [r]) ->+                    (Storable.toList |.| Storable.fromList) xs === xs)]++infixr 9 |.|+(|.|) :: (b -> c) -> (a -> b) -> a -> c+(|.|) f g x = f (g x)+{-# NOINLINE (|.|) #-}+ type Tup2 a = (a,a) type Tup3 a = (a,a,a) type Tup4 a = (a,a,a,a)@@ -122,467 +126,224 @@ refListMul     :: Semiring a     => [a] -> [a] -> [a]-refListMul [] _ = []-refListMul _ [] = []-refListMul (x:xs) (y:ys) =-    (x <.> y) :-    (map (x <.>) ys <+> map (<.> y) xs <+> (zero : refListMul xs ys))+refListMul [] _              = []+refListMul _ []              = []+refListMul (x:xs) yys@(y:ys) = (x <.> y) : map (x <.>) ys <+> xs <.> yys -newtype Polynomial a =-    Polynomial [a]-    deriving (Show,Arbitrary,Semiring,DetectableZero)+typeclassTests :: TestTree+typeclassTests =+    testGroup+        "typeclass tests"+        [ testGroup+              "PositiveInfinite"+              [ let p = Proxy :: Proxy (PositiveInfinite Int)+                in storableQC p]+        , testGroup+              "NegativeInfinite"+              [ let p = Proxy :: Proxy (NegativeInfinite Int)+                in storableQC p]+        , testGroup+              "Infinite"+              [ let p = Proxy :: Proxy (Infinite Int)+                in storableQC p]] -instance (Monad m, Serial m a) => Serial m (Polynomial a) where-    series = fmap Polynomial series -instance (DetectableZero a, Eq a) => Eq (Polynomial a) where-    Polynomial xs' == Polynomial ys' = go xs' ys' where-      go [] ys = isZero ys-      go xs [] = isZero xs-      go (x:xs) (y:ys) = x == y && go xs ys -newtype LimitSize (n :: Nat) a =-    LimitSize [a]-    deriving (Arbitrary,Semiring,DetectableZero,StarSemiring)--takeFirst :: KnownNat n => LimitSize n a -> [a]-takeFirst (LimitSize xs :: LimitSize n a) = take (fromInteger (natVal (Proxy :: Proxy n))) xs--instance (Monad m, Serial m a) => Serial m (LimitSize n a) where-    series = fmap LimitSize series--instance (Eq a, KnownNat n) => Eq (LimitSize n a) where-    (==) = (==) `on` takeFirst--instance (Show a, KnownNat n) => Show (LimitSize n a) where-    showsPrec n = showsPrec n . takeFirst+semiringLawTests :: TestTree+semiringLawTests =+    testGroup+        "Semiring/StarSemiring Laws"+        [ let p = Proxy :: Proxy (ApproxLog Double)+          in testGroup "Log" [semiringLawsSC p]+        , let p = Proxy :: Proxy (SApproxLog Double)+          in testGroup "Log" [semiringLawsSC p]+        , let p = Proxy :: Proxy (Map String Int)+          in testGroup+                 "Map"+                 [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p]+        , let p0 = Proxy :: Proxy (Matrix V0 V0 Integer)+              p1 = Proxy :: Proxy (Matrix V1 V1 Integer)+              p2 = Proxy :: Proxy (Matrix V2 V2 Integer)+              p5 = Proxy :: Proxy (Matrix V5 V5 Integer)+          in testGroup+                 "Matrix"+                 [ testGroup "0" [semiringLawsQC p0]+                 , testGroup "1" [semiringLawsQC p1]+                 , testGroup "2" [semiringLawsQC p2]+                 , testGroup "5" [semiringLawsQC p5]]+        , let p = Proxy :: Proxy Integer+          in testGroup "Integer" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, ordLawsQC p]+        , let p = Proxy :: Proxy (Func Bool Bool)+          in testGroup "Bool -> Bool" [semiringLawsQC p]+        , testGroup+              "Endo Bool"+              [ QC.testProperty+                    "plusId"+                    (plusId :: UnaryLaws (EndoFunc (Add Bool)))+              , QC.testProperty+                    "mulId"+                    (mulId :: UnaryLaws (EndoFunc (Add Bool)))+              , QC.testProperty+                    "annihilateR"+                    (annihilateR :: UnaryLaws (EndoFunc (Add Bool)))+              , zeroLawsQC (Proxy :: Proxy (EndoFunc (Add Bool)))+              , QC.testProperty+                    "plusComm"+                    (plusComm :: BinaryLaws (EndoFunc (Add Bool)))+              , QC.testProperty+                    "plusAssoc"+                    (plusAssoc :: TernaryLaws (EndoFunc (Add Bool)))+              , QC.testProperty+                    "mulAssoc"+                    (mulAssoc :: TernaryLaws (EndoFunc (Add Bool)))+              , QC.testProperty+                    "mulDistribR"+                    (mulDistribR :: TernaryLaws (EndoFunc (Add Bool)))]+        , let p = Proxy :: Proxy (PositiveInfinite Natural)+          in testGroup+                 "PosInf Natural"+                 [semiringLawsSC p, ordLawsSC p, zeroLawsSC p]+        , let p = Proxy :: Proxy Int+          in testGroup "Int" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p]+        , let p = Proxy :: Proxy (WordOfSize 2)+          in testGroup "WordOfSize 2" [semiringLawsSC p, zeroLawsSC p]+        , let p = Proxy :: Proxy (Tup2 (WordOfSize 2))+          in testGroup "Tup2 (WordOfSize 2)" [semiringLawsSC p, zeroLawsSC p]+        , let p = Proxy :: Proxy (Tup3 (WordOfSize 2))+          in testGroup "Tup3 (WordOfSize 2)" [semiringLawsQC p, zeroLawsQC p]+        , let p = Proxy :: Proxy (Tup4 Int)+          in testGroup "Tup4 Int" [semiringLawsQC p, zeroLawsQC p]+        , let p = Proxy :: Proxy (Tup5 Int)+          in testGroup "Tup5 Int" [semiringLawsQC p, zeroLawsQC p]+        , let p = Proxy :: Proxy (Tup6 Int)+          in testGroup "Tup6 Int" [semiringLawsQC p, zeroLawsQC p]+        , let p = Proxy :: Proxy (Tup7 Int)+          in testGroup "Tup7 Int" [semiringLawsQC p, zeroLawsQC p]+        , let p = Proxy :: Proxy (Tup8 Int)+          in testGroup "Tup8 Int" [semiringLawsQC p, zeroLawsQC p]+        , let p = Proxy :: Proxy (Tup9 Int)+          in testGroup "Tup9 Int" [semiringLawsQC p, zeroLawsQC p]+        , let p = Proxy :: Proxy (Tup2 (PositiveInfinite (WordOfSize 2)))+          in testGroup "Tup2 (WordOfSize 2)" [starLawsSC p]+        , let p = Proxy :: Proxy (Tup3 (PositiveInfinite (WordOfSize 2)))+          in testGroup "Tup3 (WordOfSize 2)" [starLawsSC p]+        , let p = Proxy :: Proxy (Tup4 (PositiveInfinite Int))+          in testGroup "Tup4 Int" [starLawsQC p]+        , let p = Proxy :: Proxy (Tup5 (PositiveInfinite Int))+          in testGroup "Tup5 Int" [starLawsQC p]+        , let p = Proxy :: Proxy (Tup6 (PositiveInfinite Int))+          in testGroup "Tup6 Int" [starLawsQC p]+        , let p = Proxy :: Proxy (Tup7 (PositiveInfinite Int))+          in testGroup "Tup7 Int" [starLawsQC p]+        , let p = Proxy :: Proxy (Tup8 (PositiveInfinite Int))+          in testGroup "Tup8 Int" [starLawsQC p]+        , let p = Proxy :: Proxy (Tup9 (PositiveInfinite Int))+          in testGroup "Tup9 Int" [starLawsQC p]+        , testGroup+              "Negative Infinite Integer"+              [ SC.testProperty+                    "plusId"+                    (plusId :: UnaryLaws (NegativeInfinite Integer))+              , SC.testProperty+                    "mulId"+                    (mulId :: UnaryLaws (NegativeInfinite Integer))+              , SC.testProperty+                    "annihilateR"+                    (annihilateR :: UnaryLaws (NegativeInfinite Integer))+              , zeroLawsSC (Proxy :: Proxy (NegativeInfinite Integer))+              , SC.testProperty+                    "plusComm"+                    (plusComm :: BinaryLaws (NegativeInfinite Integer))+              , ordLawsSC (Proxy :: Proxy (NegativeInfinite Integer))+              , SC.testProperty+                    "plusAssoc"+                    (plusAssoc :: TernaryLaws (NegativeInfinite Integer))+              , SC.testProperty+                    "mulAssoc"+                    (mulAssoc :: TernaryLaws (NegativeInfinite Integer))+              , SC.testProperty+                    "mulDistribL"+                    (mulDistribL :: TernaryLaws (NegativeInfinite Integer))]+        , testGroup+              "Infinite Integer"+              [ SC.testProperty+                    "plusId"+                    (plusId :: UnaryLaws (Infinite Integer))+              , SC.testProperty "mulId" (mulId :: UnaryLaws (Infinite Integer))+              , SC.testProperty+                    "annihilateR"+                    (annihilateR :: UnaryLaws (Infinite Integer))+              , SC.testProperty+                    "annihilateL"+                    (annihilateL :: UnaryLaws (Infinite Integer))+              , zeroLawsSC (Proxy :: Proxy (Infinite Integer))+              , SC.testProperty+                    "plusComm"+                    (plusComm :: BinaryLaws (Infinite Integer))+              , ordLawsSC (Proxy :: Proxy (Infinite Integer))+              , SC.testProperty+                    "plusAssoc"+                    (plusAssoc :: TernaryLaws (Infinite Integer))+              , SC.testProperty+                    "mulAssoc"+                    (mulAssoc :: TernaryLaws (Infinite Integer))]+        , let p = Proxy :: Proxy ()+          in testGroup+                 "()"+                 [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]+        , let p = Proxy :: Proxy Bool+          in testGroup+                 "Bool"+                 [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]+        , let p = Proxy :: Proxy Any+          in testGroup+                 "Any"+                 [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]+        , let p = Proxy :: Proxy All+          in testGroup+                 "All"+                 [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]+        , let p = Proxy :: Proxy [Integer]+          in testGroup+                 "[Integer]"+                 [ semiringLawsQC p+                 , starLawsQC+                       (Proxy :: Proxy (LimitSize 100 (PositiveInfinite Integer)))+                 , QC.testProperty+                       "reference implementation of <.>"+                       (\xs ys ->+                             (xs <.> ys) ===+                             refListMul xs (ys :: [WordOfSize 2]))]+        , let p = Proxy :: Proxy (Vector.Vector Int)+          in testGroup+                 "Vector Int"+                 [ semiringLawsQC p+                 , QC.testProperty+                       "reference implementation of <.>"+                       (\xs ys ->+                             (xs <.> ys :: [Int]) ===+                             Vector.toList+                                 (Vector.fromList xs <.> Vector.fromList ys))]+        , let p = Proxy :: Proxy (Min (PositiveInfinite Integer))+          in testGroup "Min Inf Integer" [semiringLawsSC p, zeroLawsSC p]+        , let p = Proxy :: Proxy (Min (Infinite Integer))+          in testGroup "Min Inf Integer" [starLawsSC p]+        , let p = Proxy :: Proxy (Max (NegativeInfinite Integer))+          in testGroup "Max NegInf Integer" [semiringLawsSC p, zeroLawsSC p]+        , let p = Proxy :: Proxy (Max (Infinite Integer))+          in testGroup "Max Inf Integer" [starLawsSC p]+        , let p = Proxy :: Proxy (Free (WordOfSize 2))+          in testGroup+                 "Free (WordOfSize 2)"+                 [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p]+        , let p = Proxy :: Proxy (Division Integer)+          in testGroup "Division Integer" [semiringLawsSC p, zeroLawsSC p]+        , let p = Proxy :: Proxy (Łukasiewicz Fraction)+          in testGroup "Łukasiewicz Fraction" [semiringLawsSC p, zeroLawsSC p]+        , let p = Proxy :: Proxy (Viterbi Fraction)+          in testGroup "Viterbi Fraction" [semiringLawsSC p, zeroLawsSC p]]  main :: IO () main = do     doctest ["-isrc", "src/"]-    defaultMain $-        testGroup-            "Tests"-            [ let p = Proxy :: Proxy (Map String Int)-              in testGroup-                     "Map"-                     [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p]-            , let p = Proxy :: Proxy (Matrix Quad 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)"-                     [semiringLawsQC p, zeroLawsQC p]-            , let p = Proxy :: Proxy (Tup4 Int)-              in testGroup "Tup4 Int" [semiringLawsQC p, zeroLawsQC p]-            , let p = Proxy :: Proxy (Tup5 Int)-              in testGroup "Tup5 Int" [semiringLawsQC p, zeroLawsQC p]-            , let p = Proxy :: Proxy (Tup6 Int)-              in testGroup "Tup6 Int" [semiringLawsQC p, zeroLawsQC p]-            , let p = Proxy :: Proxy (Tup7 Int)-              in testGroup "Tup7 Int" [semiringLawsQC p, zeroLawsQC p]-            , let p = Proxy :: Proxy (Tup8 Int)-              in testGroup "Tup8 Int" [semiringLawsQC p, zeroLawsQC p]-            , let p = Proxy :: Proxy (Tup9 Int)-              in testGroup "Tup9 Int" [semiringLawsQC p, zeroLawsQC p]-            , let p = Proxy :: Proxy (Tup2 (PositiveInfinite (WordOfSize 2)))-              in testGroup "Tup2 (WordOfSize 2)" [starLawsSC p]-            , let p = Proxy :: Proxy (Tup3 (PositiveInfinite (WordOfSize 2)))-              in testGroup "Tup3 (WordOfSize 2)" [starLawsSC p]-            , let p = Proxy :: Proxy (Tup4 (PositiveInfinite Int))-              in testGroup "Tup4 Int" [starLawsQC p]-            , let p = Proxy :: Proxy (Tup5 (PositiveInfinite Int))-              in testGroup "Tup5 Int" [starLawsQC p]-            , let p = Proxy :: Proxy (Tup6 (PositiveInfinite Int))-              in testGroup "Tup6 Int" [starLawsQC p]-            , let p = Proxy :: Proxy (Tup7 (PositiveInfinite Int))-              in testGroup "Tup7 Int" [starLawsQC p]-            , let p = Proxy :: Proxy (Tup8 (PositiveInfinite Int))-              in testGroup "Tup8 Int" [starLawsQC p]-            , let p = Proxy :: Proxy (Tup9 (PositiveInfinite Int))-              in testGroup "Tup9 Int" [starLawsQC p]-            , testGroup-                  "Negative Infinite Integer"-                  [ SC.testProperty-                        "plusId"-                        (plusId :: UnaryLaws (NegativeInfinite Integer))-                  , SC.testProperty-                        "mulId"-                        (mulId :: UnaryLaws (NegativeInfinite Integer))-                  , SC.testProperty-                        "annihilateR"-                        (annihilateR :: UnaryLaws (NegativeInfinite Integer))-                  , zeroLawsSC (Proxy :: Proxy (NegativeInfinite Integer))-                  , SC.testProperty-                        "plusComm"-                        (plusComm :: BinaryLaws (NegativeInfinite Integer))-                  , ordLawsSC (Proxy :: Proxy (NegativeInfinite Integer))-                  , SC.testProperty-                        "plusAssoc"-                        (plusAssoc :: TernaryLaws (NegativeInfinite Integer))-                  , SC.testProperty-                        "mulAssoc"-                        (mulAssoc :: TernaryLaws (NegativeInfinite Integer))-                  , SC.testProperty-                        "mulDistribL"-                        (mulDistribL :: TernaryLaws (NegativeInfinite Integer))]-            , testGroup-                  "Infinite Integer"-                  [ SC.testProperty-                        "plusId"-                        (plusId :: UnaryLaws (Infinite Integer))-                  , SC.testProperty-                        "mulId"-                        (mulId :: UnaryLaws (Infinite Integer))-                  , SC.testProperty-                        "annihilateR"-                        (annihilateR :: UnaryLaws (Infinite Integer))-                  , SC.testProperty-                        "annihilateL"-                        (annihilateL :: UnaryLaws (Infinite Integer))-                  , zeroLawsSC (Proxy :: Proxy (Infinite Integer))-                  , SC.testProperty-                        "plusComm"-                        (plusComm :: BinaryLaws (Infinite Integer))-                  , ordLawsSC (Proxy :: Proxy (Infinite Integer))-                  , SC.testProperty-                        "plusAssoc"-                        (plusAssoc :: TernaryLaws (Infinite Integer))-                  , SC.testProperty-                        "mulAssoc"-                        (mulAssoc :: TernaryLaws (Infinite Integer))]-            , let p = Proxy :: Proxy ()-              in testGroup-                     "()"-                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]-            , let p = Proxy :: Proxy Bool-              in testGroup-                     "Bool"-                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]-            , let p = Proxy :: Proxy Any-              in testGroup-                     "Any"-                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]-            , let p = Proxy :: Proxy All-              in testGroup-                     "All"-                     [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, starLawsSC p]-            , let p = Proxy :: Proxy [Integer]-              in testGroup-                     "[Integer]"-                     [ semiringLawsQC p-                     , starLawsQC-                           (Proxy :: Proxy (LimitSize 100 (PositiveInfinite Integer)))-                     , QC.testProperty-                           "reference implementation of <.>"-                           (\xs ys ->-                                 Polynomial (xs <.> ys) ===-                                 Polynomial-                                     (refListMul xs (ys :: [WordOfSize 2])))]-            , let p = Proxy :: Proxy (Vector.Vector Int)-              in testGroup-                     "Vector Int"-                     [ semiringLawsQC p-                     , QC.testProperty-                           "reference implementation of <.>"-                           (\xs ys ->-                                 (xs <.> ys :: [Int]) ===-                                 Vector.toList-                                     (Vector.fromList xs <.> Vector.fromList ys))]-            , let p = Proxy :: Proxy (Min (PositiveInfinite Integer))-              in testGroup "Min Inf Integer" [semiringLawsSC p, zeroLawsSC p]-            , let p = Proxy :: Proxy (Min (Infinite Integer))-              in testGroup "Min Inf Integer" [starLawsSC p]-            , let p = Proxy :: Proxy (Max (NegativeInfinite Integer))-              in testGroup-                     "Max NegInf Integer"-                     [semiringLawsSC p, zeroLawsSC p]-            , let p = Proxy :: Proxy (Max (Infinite Integer))-              in testGroup "Max Inf Integer" [starLawsSC p]-            , let p = Proxy :: Proxy (Free (WordOfSize 2))-              in testGroup-                     "Free (WordOfSize 2)"-                     [localOption (QC.QuickCheckMaxSize 10) $ semiringLawsQC p]-            , let p = Proxy :: Proxy (Division (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]]----------------------------------------------------------------------------- Serial wrappers---- | A type with a serial instance between zero and one-newtype Fraction =-    Fraction Double-    deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring)--instance DetectableZero Fraction where isZero = (0==)--newtype Approx a =-    Approx a-    deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring-             ,HasPositiveInfinity)--instance (Arbitrary a, Num a, Ord a) => Arbitrary (Approx a) where-  arbitrary = fmap Approx (suchThat arbitrary ((<100).abs))--instance Eq Fraction where-    Fraction x == Fraction y = abs (x - y) < 0.011--instance (RealFloat a, Ord a) =>-         Eq (Approx a) where-    Approx x == Approx y =-        isInfinite x && isInfinite y ||-        x == y ||-        let n = abs (x - y)-        in max (n / abs x) (n / abs y) < 0.011--instance (RealFloat a, Ord a) => Ord (Approx a) where-    compare (Approx x) (Approx y)-      | Approx x == Approx y = EQ-      | otherwise = compare x y--instance Ord Fraction where-    compare (Fraction x) (Fraction y)-      | Fraction x == Fraction y = EQ-      | otherwise = compare x y--instance Monad m => Serial m Fraction where-  series = fmap Fraction $ generate (\d -> if d >= 0 then pure 0 else empty) <|> rest where-    rest = generate $ \d -> take d (1 : go 0 1)-    go lower upper = let mid = (lower + upper) / 2 in-      mid : interleave (go lower mid) (go mid upper)-    interleave (x:xs) (y:ys) = x : y : interleave xs ys-    interleave _ _           = undefined--instance (Monad m, KnownNat n) => Serial m (WordOfSize n) where-  series = generate (`take` [minBound..maxBound])--instance KnownNat n => Arbitrary (WordOfSize n) where-  arbitrary = arbitraryBoundedEnum--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--instance (Monad m, Serial m a) => Serial m (NegativeInfinite a) where-  series = fmap (maybe NegativeInfinity NegFinite) series--instance (Monad m, Serial m a) => Serial m (Infinite a) where-  series = fmap (either (bool Positive Negative) Finite) series--instance Monad m => Serial m Natural where-  series = generate (`take` [0..])--instance Monad m => Serial m Any where-  series = fmap Any series--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---- | A representation of a function-data Func a b = Func b (IntMap b)-  deriving (Eq, Ord)--newtype EndoFunc a = EndoFunc (Endo a) deriving (Semiring, DetectableZero)--instance (Enum a, Bounded a, Ord a) => Eq (EndoFunc a) where-  EndoFunc (Endo f) == EndoFunc (Endo g) = fromFunc f == fromFunc g--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-  . IntMap.fromList-  . filter ((cnst/=) . snd)--fromList :: (Enum a, Eq b) => b -> [(a,b)] -> Func a b-fromList cnst-  = fromList' cnst-  . map (first fromEnum)--fromFunc :: (Enum a, Bounded a, Ord b) => (a -> b) -> Func a b-fromFunc f = fromList cnst (zip xs ys) where-  xs = [minBound..maxBound]-  ys = map f xs-  Just cnst = mostFrequent ys--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 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 (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--instance (Enum a, Show a, Show b) => Show (Func a b) where-  showsPrec _ (Func c xs :: Func a b)  = showChar '{' . IntMap.foldrWithKey f b xs where-    f x y a = shows (toEnum x :: a) . showString " -> " . shows y . showString ", " . a-    b = showString "_ -> " . shows c . showChar '}'--instance (Enum a, Bounded a, Ord b, Semiring b) => Semiring (Func a b) where-  zero = fromFunc zero-  one = fromFunc one-  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--instance Arbitrary a => Arbitrary (PositiveInfinite a) where-  arbitrary = fmap (maybe PositiveInfinity PosFinite) arbitrary--instance Arbitrary a => Arbitrary (NegativeInfinite a) where-  arbitrary = fmap (maybe NegativeInfinity NegFinite) arbitrary--instance Arbitrary a => Arbitrary (Infinite a) where-  arbitrary = fmap (either (bool Positive Negative) Finite) arbitrary--instance Arbitrary a => Arbitrary (Vector.Vector a) where-    arbitrary = fmap Vector.fromList arbitrary-    shrink = fmap Vector.fromList . shrink . Vector.toList--instance Testable (Either String String) where-  property = either (`counterexample` False) (const (property True))--instance Arbitrary (f (g a)) => Arbitrary (Matrix f g a) where-    arbitrary = fmap Matrix arbitrary-    shrink (Matrix xs) = fmap Matrix (shrink xs)+    defaultMain $ testGroup "Tests" [typeclassTests, semiringLawTests]

@@ -0,0 +1,197 @@+{-# LANGUAGE DeriveFoldable        #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveTraversable     #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Vectors where++import           Test.QuickCheck+import           Test.SmallCheck.Series++import           Data.Functor.Classes++import           CompUtils+import           Control.Applicative+import           Data.Foldable++data V0 a =+    V0+    deriving (Eq,Ord,Show,Functor,Foldable,Traversable)++data V1 a =+    V1 a+    deriving (Eq,Ord,Show,Functor,Foldable,Traversable)++data V2 a =+    V2 a a+    deriving (Eq,Ord,Show,Functor,Foldable,Traversable)++data V3 a =+    V3 a a a+    deriving (Eq,Ord,Show,Functor,Foldable,Traversable)++data V4 a =+    V4 a a a a+    deriving (Eq,Ord,Show,Functor,Foldable,Traversable)++data V5 a =+    V5 a a a a a+    deriving (Eq,Ord,Show,Functor,Foldable,Traversable)++instance Applicative V0 where+    pure _ = V0+    V0 <*> V0 = V0++instance Applicative V1 where+    pure = V1+    V1 f <*> V1 x = V1 (f x)++instance Applicative V2 where+    pure x = V2 x x+    V2 f1 f2 <*> V2 x1 x2 = V2 (f1 x1) (f2 x2)++instance Applicative V3 where+    pure x = V3 x x x+    V3 f1 f2 f3 <*> V3 x1 x2 x3 = V3 (f1 x1) (f2 x2) (f3 x3)++instance Applicative V4 where+    pure x = V4 x x x x+    V4 f1 f2 f3 f4 <*> V4 x1 x2 x3 x4 = V4 (f1 x1) (f2 x2) (f3 x3) (f4 x4)++instance Applicative V5 where+    pure x = V5 x x x x x+    V5 f1 f2 f3 f4 f5 <*> V5 x1 x2 x3 x4 x5 =+        V5 (f1 x1) (f2 x2) (f3 x3) (f4 x4) (f5 x5)++instance Arbitrary a =>+         Arbitrary (V0 a) where+    arbitrary = sequenceA (pure arbitrary)+    shrink V0 = []++instance Arbitrary a =>+         Arbitrary (V1 a) where+    arbitrary = sequenceA (pure arbitrary)+    shrink (V1 x) = map V1 (shrink x)++instance Arbitrary a =>+         Arbitrary (V2 a) where+    arbitrary = sequenceA (pure arbitrary)+    shrink (V2 x y) =+        [ V2 x' y+        | x' <- shrink x ] +++        [ V2 x y'+        | y' <- shrink y ]++instance Arbitrary a =>+         Arbitrary (V3 a) where+    arbitrary = sequenceA (pure arbitrary)+    shrink (V3 x y z) =+        [ V3 x' y z+        | x' <- shrink x ] +++        [ V3 x y' z+        | y' <- shrink y ] +++        [ V3 x y z'+        | z' <- shrink z ]++instance Arbitrary a =>+         Arbitrary (V4 a) where+    arbitrary = sequenceA (pure arbitrary)+    shrink (V4 w x y z) =+        [ V4 w' x y z+        | w' <- shrink w ] +++        [ V4 w x' y z+        | x' <- shrink x ] +++        [ V4 w x y' z+        | y' <- shrink y ] +++        [ V4 w x y z'+        | z' <- shrink z ]++instance Arbitrary a =>+         Arbitrary (V5 a) where+    arbitrary = sequenceA (pure arbitrary)+    shrink (V5 v w x y z) =+        [ V5 v' w x y z+        | v' <- shrink v ] +++        [ V5 v w' x y z+        | w' <- shrink w ] +++        [ V5 v w x' y z+        | x' <- shrink x ] +++        [ V5 v w x y' z+        | y' <- shrink y ] +++        [ V5 v w x y z'+        | z' <- shrink z ]++instance Serial m a => Serial m (V0 a) where+    series = cons0 V0++instance Serial m a => Serial m (V1 a) where+    series = cons1 V1++instance Serial m a => Serial m (V2 a) where+    series = cons2 V2++instance Serial m a => Serial m (V3 a) where+    series = cons3 V3++instance Serial m a => Serial m (V4 a) where+    series = cons4 V4++instance Serial m a =>+         Serial m (V5 a) where+    series =+        decDepth $ V5 <$> series <~> series <~> series <~> series <~> series++instance Eq1 V0 where+    liftEq eq = and .: liftA2 eq++instance Eq1 V1 where+    liftEq eq = and .: liftA2 eq++instance Eq1 V2 where+    liftEq eq = and .: liftA2 eq++instance Eq1 V3 where+    liftEq eq = and .: liftA2 eq++instance Eq1 V4 where+    liftEq eq = and .: liftA2 eq++instance Eq1 V5 where+    liftEq eq = and .: liftA2 eq++instance Ord1 V0 where+    liftCompare cmp = fold .: liftA2 cmp++instance Ord1 V1 where+    liftCompare cmp = fold .: liftA2 cmp++instance Ord1 V2 where+    liftCompare cmp = fold .: liftA2 cmp++instance Ord1 V3 where+    liftCompare cmp = fold .: liftA2 cmp++instance Ord1 V4 where+    liftCompare cmp = fold .: liftA2 cmp++instance Ord1 V5 where+    liftCompare cmp = fold .: liftA2 cmp++instance Show1 V0 where+    liftShowsPrec _ sl _ = sl . toList++instance Show1 V1 where+    liftShowsPrec _ sl _ = sl . toList++instance Show1 V2 where+    liftShowsPrec _ sl _ = sl . toList++instance Show1 V3 where+    liftShowsPrec _ sl _ = sl . toList++instance Show1 V4 where+    liftShowsPrec _ sl _ = sl . toList++instance Show1 V5 where+    liftShowsPrec _ sl _ = sl . toList