semiring-num 1.6.0.0 → 1.6.0.1

raw patch · 7 files changed

+577/−86 lines, 7 filesdep ~scientificdep ~vectorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: scientific, vector

API changes (from Hackage documentation)

Files

• semiring-num.cabal +5/−5
• src/Data/Semiring.hs +2/−2
• src/Data/Semiring/Free.hs +8/−5
• src/Data/Semiring/Infinite.hs +385/−38
• src/Data/Semiring/Newtype.hs +8/−9
• test/Orphans.hs +41/−11
• test/Spec.hs +128/−16

@@ -1,5 +1,5 @@ name:                semiring-num-version:             1.6.0.0+version:             1.6.0.1 synopsis:            Basic semiring class and instances description:         Adds a basic semiring class homepage:            https://github.com/oisdk/semiring-num@@ -25,10 +25,10 @@                      , template-haskell >=2.11                      , containers >=0.5                      , log-domain >=0.10.3.1-                     , scientific >=0.3.4.10+                     , scientific >=0.3.4.4                      , time >=1.6                      , unordered-containers >=0.2.6.0-                     , vector >=0.10.12.3+                     , vector >=0.11.0.0                      , hashable >=1.2.4.0                      , deepseq >=1.4   default-language:    Haskell2010@@ -56,7 +56,7 @@                      , tasty-smallcheck >=0.1                      , tasty-quickcheck >=0.1                      , log-domain >=0.10.3.1-                     , vector >=0.10.12.3+                     , vector >=0.11.0.0   ghc-options:         -threaded                        -rtsopts                        -with-rtsopts=-N@@ -72,7 +72,7 @@                      , criterion >=0.1                      , random >=1.0.0.0                      , containers >=0.5-                     , vector >=0.10.12.3+                     , vector >=0.11.0.0   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010 

@@ -169,7 +169,7 @@     -- True     add         :: [a] -> a-    add = getAdd . foldMap Add+    add = foldl' (<+>) zero     {-# INLINE add #-}     -- | Takes the product of the elements of a list. Analogous to     -- 'product' on numbers, or 'and' on 'Bool's.@@ -184,7 +184,7 @@     -- False     mul         :: [a] -> a-    mul = getMul . foldMap Mul+    mul = foldl' (<.>) one     {-# INLINE mul #-}  -- | The product of the contents of a 'Foldable'.

@@ -10,20 +10,23 @@  import           Data.Semiring -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           Numeric.Natural  import           Data.Semiring.Newtype +import           Data.Sequence         (Seq)+import qualified Data.Sequence         as Seq+ -- | The free semiring newtype Free a = Free-  { getFree :: Map [a] Natural+  { getFree :: Map (Seq a) Natural   } deriving (Show, Read, Eq, Ord, Semiring)  instance Ord a => Num (Free a) where-    fromInteger = Free . Map.singleton [] . fromInteger+    fromInteger = Free . Map.singleton Seq.empty . fromInteger     {-# INLINE fromInteger #-}     (+) = (<+>)     {-# INLINE (+) #-}@@ -38,7 +41,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) . mulFoldable . fmap f) . getFree {-# INLINE runFree #-}  -- | Run a 'Free', interpreting it in the underlying semiring.

@@ -1,9 +1,11 @@-{-# LANGUAGE DeriveFoldable      #-}-{-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE DeriveTraversable   #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFoldable        #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DeriveTraversable     #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}  -- | This module provides various "infinite" wrappers, which can provide -- a detectable infinity to an otherwise non-infinite type.@@ -15,17 +17,19 @@   , Infinite(..)   ) where -import           Control.Applicative (liftA2)-import           Data.Typeable       (Typeable)-import           GHC.Generics        (Generic, Generic1)+import           Control.Applicative         (liftA2)+import           Data.Typeable               (Typeable)+import           GHC.Generics                (Generic, Generic1) -import           Data.Word           (Word8)-import           Foreign.Ptr         (Ptr, castPtr)-import           Foreign.Storable    (Storable, alignment, peek, peekByteOff,-                                      poke, pokeByteOff, sizeOf)+import           Data.Word                   (Word8)+import           Foreign.Ptr                 (Ptr, castPtr)+import           Foreign.Storable            (Storable, alignment, peek,+                                              peekByteOff, poke, pokeByteOff,+                                              sizeOf)  import           Data.Coerce import           Data.Monoid+import           Data.Bool  import           Data.Semiring @@ -36,6 +40,10 @@ import           Data.Functor.Classes import           Text.Read +import qualified Data.Vector.Generic         as G+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Unboxed.Base    as U+ -- | Adds negative infinity to a type. Useful for expressing detectable infinity -- in types like 'Integer', etc. data NegativeInfinite a@@ -358,68 +366,68 @@ instance NFData a =>          NFData (NegativeInfinite a) where     rnf NegativeInfinity = ()-    rnf (NegFinite x) = rnf x+    rnf (NegFinite x)    = rnf x  instance NFData a =>          NFData (PositiveInfinite a) where     rnf PositiveInfinity = ()-    rnf (PosFinite x) = rnf x+    rnf (PosFinite x)    = rnf x  instance NFData a =>          NFData (Infinite a) where-    rnf Negative = ()-    rnf Positive = ()+    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+        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+        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 Positive Positive     = True+        go Negative Negative     = True         go (Finite x) (Finite y) = eq x y-        go _ _ = False+        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+        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+        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 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@@ -481,3 +489,342 @@             (do Ident "Finite" <- lexP                 m <- step (readS_to_Prec rp)                 pure (Finite m))+++data instance+     U.MVector s+       (NegativeInfinite+          a) = MV_NegativeInfinite {-# UNPACK #-} !(U.MVector s Bool)+                                   !(U.MVector s a)+++data instance+     U.Vector+       (NegativeInfinite a) = V_NegativeInfinite {-# UNPACK #-} !(U.Vector+                                                                    Bool)+                                                 !(U.Vector a)++instance U.Unbox a => U.Unbox (NegativeInfinite a)++instance (U.Unbox a) =>+         M.MVector U.MVector (NegativeInfinite a) where+    {-# INLINE basicLength #-}+    basicLength (MV_NegativeInfinite xs _) = M.basicLength xs+    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice i_ m_ (MV_NegativeInfinite as bs) =+        MV_NegativeInfinite+            (M.basicUnsafeSlice i_ m_ as)+            (M.basicUnsafeSlice i_ m_ bs)+    {-# INLINE basicOverlaps #-}+    basicOverlaps (MV_NegativeInfinite as1 bs1) (MV_NegativeInfinite as2 bs2) =+        M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2+    {-# INLINE basicUnsafeNew #-}+    basicUnsafeNew n_ =+        liftA2+            MV_NegativeInfinite+            (M.basicUnsafeNew n_)+            (M.basicUnsafeNew n_)+    {-# INLINE basicInitialize #-}+    basicInitialize (MV_NegativeInfinite as bs) =+        M.basicInitialize as *> M.basicInitialize bs+    {-# INLINE basicUnsafeReplicate #-}+    basicUnsafeReplicate n_ NegativeInfinity =+        liftA2+            MV_NegativeInfinite+            (M.basicUnsafeReplicate n_ False)+            (M.basicUnsafeNew n_)+    basicUnsafeReplicate n_ (NegFinite x) =+        liftA2+            MV_NegativeInfinite+            (M.basicUnsafeReplicate n_ True)+            (M.basicUnsafeReplicate n_ x)+    {-# INLINE basicUnsafeRead #-}+    basicUnsafeRead (MV_NegativeInfinite as bs) i_ =+        M.basicUnsafeRead as i_ >>=+        bool (pure NegativeInfinity) (NegFinite <$> M.basicUnsafeRead bs i_)+    {-# INLINE basicUnsafeWrite #-}+    basicUnsafeWrite (MV_NegativeInfinite as _) i_ NegativeInfinity =+        M.basicUnsafeWrite as i_ False+    basicUnsafeWrite (MV_NegativeInfinite as bs) i_ (NegFinite x) =+        M.basicUnsafeWrite as i_ True *> M.basicUnsafeWrite bs i_ x+    {-# INLINE basicClear #-}+    basicClear (MV_NegativeInfinite as bs) =+        M.basicClear as *> M.basicClear bs+    {-# INLINE basicSet #-}+    basicSet (MV_NegativeInfinite as bs) NegativeInfinity =+        M.basicSet as False *> M.basicClear bs+    basicSet (MV_NegativeInfinite as bs) (NegFinite x) =+        M.basicSet as True *> M.basicSet bs x+    {-# INLINE basicUnsafeCopy #-}+    basicUnsafeCopy (MV_NegativeInfinite as1 bs1) (MV_NegativeInfinite as2 bs2) =+        M.basicUnsafeCopy as1 as2 *> M.basicUnsafeCopy bs1 bs2+    {-# INLINE basicUnsafeMove #-}+    basicUnsafeMove (MV_NegativeInfinite as1 bs1) (MV_NegativeInfinite as2 bs2) =+        M.basicUnsafeMove as1 as2 *> M.basicUnsafeMove bs1 bs2+    {-# INLINE basicUnsafeGrow #-}+    basicUnsafeGrow (MV_NegativeInfinite as bs) m_ =+        liftA2+            MV_NegativeInfinite+            (M.basicUnsafeGrow as m_)+            (M.basicUnsafeGrow bs m_)++instance (U.Unbox a) =>+         G.Vector U.Vector (NegativeInfinite a) where+    {-# INLINE basicUnsafeFreeze #-}+    basicUnsafeFreeze (MV_NegativeInfinite as bs) =+        liftA2+            V_NegativeInfinite+            (G.basicUnsafeFreeze as)+            (G.basicUnsafeFreeze bs)+    {-# INLINE basicUnsafeThaw #-}+    basicUnsafeThaw (V_NegativeInfinite as bs) =+        liftA2+            MV_NegativeInfinite+            (G.basicUnsafeThaw as)+            (G.basicUnsafeThaw bs)+    {-# INLINE basicLength #-}+    basicLength (V_NegativeInfinite xs _) = G.basicLength xs+    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice i_ m_ (V_NegativeInfinite as bs) =+        V_NegativeInfinite+            (G.basicUnsafeSlice i_ m_ as)+            (G.basicUnsafeSlice i_ m_ bs)+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeIndexM (V_NegativeInfinite as bs) i_ =+        G.basicUnsafeIndexM as i_ >>=+        bool (pure NegativeInfinity) (NegFinite <$> G.basicUnsafeIndexM bs i_)+    {-# INLINE basicUnsafeCopy #-}+    basicUnsafeCopy (MV_NegativeInfinite as1 bs1) (V_NegativeInfinite as2 bs2) =+        G.basicUnsafeCopy as1 as2 *> G.basicUnsafeCopy bs1 bs2+    {-# INLINE elemseq #-}+    elemseq _ NegativeInfinity b = b+    elemseq _ (NegFinite x) b = G.elemseq (undefined :: U.Vector a) x b++data instance+     U.MVector s+       (PositiveInfinite+          a) = MV_PositiveInfinite {-# UNPACK #-} !(U.MVector s Bool)+                                   !(U.MVector s a)+++data instance+     U.Vector+       (PositiveInfinite a) = V_PositiveInfinite {-# UNPACK #-} !(U.Vector+                                                                    Bool)+                                                 !(U.Vector a)++instance U.Unbox a => U.Unbox (PositiveInfinite a)++instance (U.Unbox a) =>+         M.MVector U.MVector (PositiveInfinite a) where+    {-# INLINE basicLength #-}+    basicLength (MV_PositiveInfinite xs _) = M.basicLength xs+    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice i_ m_ (MV_PositiveInfinite as bs) =+        MV_PositiveInfinite+            (M.basicUnsafeSlice i_ m_ as)+            (M.basicUnsafeSlice i_ m_ bs)+    {-# INLINE basicOverlaps #-}+    basicOverlaps (MV_PositiveInfinite as1 bs1) (MV_PositiveInfinite as2 bs2) =+        M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2+    {-# INLINE basicUnsafeNew #-}+    basicUnsafeNew n_ =+        liftA2+            MV_PositiveInfinite+            (M.basicUnsafeNew n_)+            (M.basicUnsafeNew n_)+    {-# INLINE basicInitialize #-}+    basicInitialize (MV_PositiveInfinite as bs) =+        M.basicInitialize as *> M.basicInitialize bs+    {-# INLINE basicUnsafeReplicate #-}+    basicUnsafeReplicate n_ PositiveInfinity =+        liftA2+            MV_PositiveInfinite+            (M.basicUnsafeReplicate n_ False)+            (M.basicUnsafeNew n_)+    basicUnsafeReplicate n_ (PosFinite x) =+        liftA2+            MV_PositiveInfinite+            (M.basicUnsafeReplicate n_ True)+            (M.basicUnsafeReplicate n_ x)+    {-# INLINE basicUnsafeRead #-}+    basicUnsafeRead (MV_PositiveInfinite as bs) i_ =+        M.basicUnsafeRead as i_ >>=+        bool (pure PositiveInfinity) (PosFinite <$> M.basicUnsafeRead bs i_)+    {-# INLINE basicUnsafeWrite #-}+    basicUnsafeWrite (MV_PositiveInfinite as _) i_ PositiveInfinity =+        M.basicUnsafeWrite as i_ False+    basicUnsafeWrite (MV_PositiveInfinite as bs) i_ (PosFinite x) =+        M.basicUnsafeWrite as i_ True *> M.basicUnsafeWrite bs i_ x+    {-# INLINE basicClear #-}+    basicClear (MV_PositiveInfinite as bs) =+        M.basicClear as *> M.basicClear bs+    {-# INLINE basicSet #-}+    basicSet (MV_PositiveInfinite as bs) PositiveInfinity =+        M.basicSet as False *> M.basicClear bs+    basicSet (MV_PositiveInfinite as bs) (PosFinite x) =+        M.basicSet as True *> M.basicSet bs x+    {-# INLINE basicUnsafeCopy #-}+    basicUnsafeCopy (MV_PositiveInfinite as1 bs1) (MV_PositiveInfinite as2 bs2) =+        M.basicUnsafeCopy as1 as2 *> M.basicUnsafeCopy bs1 bs2+    {-# INLINE basicUnsafeMove #-}+    basicUnsafeMove (MV_PositiveInfinite as1 bs1) (MV_PositiveInfinite as2 bs2) =+        M.basicUnsafeMove as1 as2 *> M.basicUnsafeMove bs1 bs2+    {-# INLINE basicUnsafeGrow #-}+    basicUnsafeGrow (MV_PositiveInfinite as bs) m_ =+        liftA2+            MV_PositiveInfinite+            (M.basicUnsafeGrow as m_)+            (M.basicUnsafeGrow bs m_)++instance (U.Unbox a) =>+         G.Vector U.Vector (PositiveInfinite a) where+    {-# INLINE basicUnsafeFreeze #-}+    basicUnsafeFreeze (MV_PositiveInfinite as bs) =+        liftA2+            V_PositiveInfinite+            (G.basicUnsafeFreeze as)+            (G.basicUnsafeFreeze bs)+    {-# INLINE basicUnsafeThaw #-}+    basicUnsafeThaw (V_PositiveInfinite as bs) =+        liftA2+            MV_PositiveInfinite+            (G.basicUnsafeThaw as)+            (G.basicUnsafeThaw bs)+    {-# INLINE basicLength #-}+    basicLength (V_PositiveInfinite xs _) = G.basicLength xs+    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice i_ m_ (V_PositiveInfinite as bs) =+        V_PositiveInfinite+            (G.basicUnsafeSlice i_ m_ as)+            (G.basicUnsafeSlice i_ m_ bs)+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeIndexM (V_PositiveInfinite as bs) i_ =+        G.basicUnsafeIndexM as i_ >>=+        bool (pure PositiveInfinity) (PosFinite <$> G.basicUnsafeIndexM bs i_)+    {-# INLINE basicUnsafeCopy #-}+    basicUnsafeCopy (MV_PositiveInfinite as1 bs1) (V_PositiveInfinite as2 bs2) =+        G.basicUnsafeCopy as1 as2 *> G.basicUnsafeCopy bs1 bs2+    {-# INLINE elemseq #-}+    elemseq _ PositiveInfinity b = b+    elemseq _ (PosFinite x) b = G.elemseq (undefined :: U.Vector a) x b++data instance+     U.MVector s (Infinite a) = MV_Infinite {-# UNPACK #-} !(U.MVector s+                                                               Word8)+                                            !(U.MVector s a)+++data instance+     U.Vector (Infinite a) = V_Infinite {-# UNPACK #-} !(U.Vector Word8)+                                        !(U.Vector a)++instance U.Unbox a => U.Unbox (Infinite a)++instance (U.Unbox a) =>+         M.MVector U.MVector (Infinite a) where+    {-# INLINE basicLength #-}+    basicLength (MV_Infinite xs _) = M.basicLength xs+    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice i_ m_ (MV_Infinite as bs) =+        MV_Infinite+            (M.basicUnsafeSlice i_ m_ as)+            (M.basicUnsafeSlice i_ m_ bs)+    {-# INLINE basicOverlaps #-}+    basicOverlaps (MV_Infinite as1 bs1) (MV_Infinite as2 bs2) =+        M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2+    {-# INLINE basicUnsafeNew #-}+    basicUnsafeNew n_ =+        liftA2+            MV_Infinite+            (M.basicUnsafeNew n_)+            (M.basicUnsafeNew n_)+    {-# INLINE basicInitialize #-}+    basicInitialize (MV_Infinite as bs) =+        M.basicInitialize as *> M.basicInitialize bs+    {-# INLINE basicUnsafeReplicate #-}+    basicUnsafeReplicate n_ Positive =+        liftA2+            MV_Infinite+            (M.basicUnsafeReplicate n_ 2)+            (M.basicUnsafeNew n_)+    basicUnsafeReplicate n_ Negative =+        liftA2+            MV_Infinite+            (M.basicUnsafeReplicate n_ 0)+            (M.basicUnsafeNew n_)+    basicUnsafeReplicate n_ (Finite x) =+        liftA2+            MV_Infinite+            (M.basicUnsafeReplicate n_ 1)+            (M.basicUnsafeReplicate n_ x)+    {-# INLINE basicUnsafeRead #-}+    basicUnsafeRead (MV_Infinite as bs) i_ =+        M.basicUnsafeRead as i_ >>= \case+          0 -> pure Negative+          1 -> Finite <$> M.basicUnsafeRead bs i_+          _ -> pure Positive+    {-# INLINE basicUnsafeWrite #-}+    basicUnsafeWrite (MV_Infinite as _) i_ Positive =+        M.basicUnsafeWrite as i_ 2+    basicUnsafeWrite (MV_Infinite as _) i_ Negative =+        M.basicUnsafeWrite as i_ 0+    basicUnsafeWrite (MV_Infinite as bs) i_ (Finite x) =+        M.basicUnsafeWrite as i_ 1 *> M.basicUnsafeWrite bs i_ x+    {-# INLINE basicClear #-}+    basicClear (MV_Infinite as bs) =+        M.basicClear as *> M.basicClear bs+    {-# INLINE basicSet #-}+    basicSet (MV_Infinite as bs) Positive =+        M.basicSet as 2 *> M.basicClear bs+    basicSet (MV_Infinite as bs) Negative =+        M.basicSet as 0 *> M.basicClear bs+    basicSet (MV_Infinite as bs) (Finite x) =+        M.basicSet as 1 *> M.basicSet bs x+    {-# INLINE basicUnsafeCopy #-}+    basicUnsafeCopy (MV_Infinite as1 bs1) (MV_Infinite as2 bs2) =+        M.basicUnsafeCopy as1 as2 *> M.basicUnsafeCopy bs1 bs2+    {-# INLINE basicUnsafeMove #-}+    basicUnsafeMove (MV_Infinite as1 bs1) (MV_Infinite as2 bs2) =+        M.basicUnsafeMove as1 as2 *> M.basicUnsafeMove bs1 bs2+    {-# INLINE basicUnsafeGrow #-}+    basicUnsafeGrow (MV_Infinite as bs) m_ =+        liftA2+            MV_Infinite+            (M.basicUnsafeGrow as m_)+            (M.basicUnsafeGrow bs m_)++instance (U.Unbox a) =>+         G.Vector U.Vector (Infinite a) where+    {-# INLINE basicUnsafeFreeze #-}+    basicUnsafeFreeze (MV_Infinite as bs) =+        liftA2+            V_Infinite+            (G.basicUnsafeFreeze as)+            (G.basicUnsafeFreeze bs)+    {-# INLINE basicUnsafeThaw #-}+    basicUnsafeThaw (V_Infinite as bs) =+        liftA2+            MV_Infinite+            (G.basicUnsafeThaw as)+            (G.basicUnsafeThaw bs)+    {-# INLINE basicLength #-}+    basicLength (V_Infinite xs _) = G.basicLength xs+    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice i_ m_ (V_Infinite as bs) =+        V_Infinite+            (G.basicUnsafeSlice i_ m_ as)+            (G.basicUnsafeSlice i_ m_ bs)+    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeIndexM (V_Infinite as bs) i_ =+        G.basicUnsafeIndexM as i_ >>= \case+          0 -> pure Negative+          1 -> Finite <$> G.basicUnsafeIndexM bs i_+          _ -> pure Positive+    {-# INLINE basicUnsafeCopy #-}+    basicUnsafeCopy (MV_Infinite as1 bs1) (V_Infinite as2 bs2) =+        G.basicUnsafeCopy as1 as2 *> G.basicUnsafeCopy bs1 bs2+    {-# INLINE elemseq #-}+    elemseq _ Positive b = b+    elemseq _ Negative b = b+    elemseq _ (Finite x) b = G.elemseq (undefined :: U.Vector a) x b

@@ -4,7 +4,9 @@  import Data.Coerce import Text.Read-import Control.Monad+import Text.Read.Lex+-- import Text.ParserCombinators.ReadPrec+-- import Control.Monad  -------------------------------------------------------------------------------- -- Show1, Read1@@ -39,7 +41,7 @@         showParen (n > 10) $         showString cons .         showString " {" .-        showString acc . showString " =" . sp 0 (coerce x) . showChar '}'+        showString acc . showString " = " . sp 0 (coerce x) . showChar '}' {-# INLINE showsNewtype #-}  -- | A definition for 'Data.Functor.Classes.liftReadsPrec' suitable for@@ -60,18 +62,15 @@     :: 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)+    r rp _ = readPrec_to_S $ parens $ prec 10 $ do+        lift $ expect (Ident cons)         Punc "{" <- lexP-        Ident a <- lexP-        guard (a == acc)+        lift $ expect (Ident acc)         Punc "=" <- lexP-        x <- prec 0 $ readS_to_Prec rp+        x <- reset (readS_to_Prec rp)         Punc "}" <- lexP         pure (coerce x) {-# INLINE readsNewtype #-}-  -------------------------------------------------------------------------------- -- Typealiases to make coercion signatures shorter

@@ -2,6 +2,7 @@  {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}  module Orphans where @@ -13,30 +14,49 @@ import           Data.Semiring.Infinite import           Data.Semiring.Free import           Data.Semiring.Numeric+ import qualified Data.Vector as Vector+import qualified Data.Vector.Unboxed as Unboxed+import qualified Data.Vector.Storable as Storable+ 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+deriving instance Arbitrary a => Arbitrary (Add a)+deriving instance CoArbitrary a => CoArbitrary (Add a)+deriving instance Arbitrary a => Arbitrary (Mul a)+deriving instance CoArbitrary a => CoArbitrary (Mul a)+deriving instance Arbitrary a => Arbitrary (Min a)+deriving instance CoArbitrary a => CoArbitrary (Min a)+deriving instance Arbitrary a   => Arbitrary (Max a)+deriving instance CoArbitrary a => CoArbitrary (Max a)+deriving instance Arbitrary a => Arbitrary (Bottleneck a)+deriving instance CoArbitrary a => CoArbitrary (Bottleneck a)+deriving instance Arbitrary a => Arbitrary (Division a)+deriving instance CoArbitrary a => CoArbitrary (Division a)+deriving instance Arbitrary a => Arbitrary (Łukasiewicz a)+deriving instance CoArbitrary a => CoArbitrary (Łukasiewicz a)+deriving instance Arbitrary a => Arbitrary (Viterbi a)+deriving instance CoArbitrary a => CoArbitrary (Viterbi a)+deriving instance Arbitrary a => Arbitrary (PosFrac a)+deriving instance CoArbitrary a => CoArbitrary (PosFrac a)+deriving instance Arbitrary a => Arbitrary (PosInt a)+deriving instance CoArbitrary a => CoArbitrary (PosInt a)  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 (NegativeInfinite a) where+    arbitrary = fmap (maybe NegativeInfinity NegFinite) arbitrary+    shrink =+        map (maybe NegativeInfinity NegFinite) .+        shrink . foldr (const . Just) Nothing  instance Arbitrary a => Arbitrary (Infinite a) where   arbitrary = fmap (either (bool Positive Negative) Finite) arbitrary@@ -105,3 +125,13 @@  instance Serial m a => Serial m (Log a) where     series = fmap Exp series++instance (Arbitrary a, Unboxed.Unbox a) =>+         Arbitrary (Unboxed.Vector a) where+    arbitrary = fmap Unboxed.fromList arbitrary+    shrink = map Unboxed.fromList . shrink . Unboxed.toList++instance (Arbitrary a, Storable.Storable a) =>+         Arbitrary (Storable.Vector a) where+    arbitrary = fmap Storable.fromList arbitrary+    shrink = map Storable.fromList . shrink . Storable.toList

@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds             #-}+{-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -17,18 +18,22 @@  import qualified Data.Vector              as Vector import qualified Data.Vector.Storable     as Storable+import qualified Data.Vector.Unboxed      as Unboxed  import           Data.Semiring import           Data.Semiring.Free import           Data.Semiring.Infinite import           Data.Semiring.Numeric +import           Data.Functor.Classes+ import           Numeric.Natural import           Numeric.Sized.WordOfSize  import           Test.DocTest import           Test.QuickCheck          hiding (Positive (..), generate,                                            (.&.))+import           Test.QuickCheck.Poly import           Test.SmallCheck.Series   hiding (Positive) import           Test.Tasty import qualified Test.Tasty.QuickCheck    as QC@@ -43,7 +48,6 @@ import           Orphans                  () import           Vectors - ------------------------------------------------------------------------  semiringLawsSC :: (Show r, Eq r, Semiring r, Serial IO r) => f r -> TestTree@@ -114,6 +118,63 @@ (|.|) f g x = f (g x) {-# NOINLINE (|.|) #-} +deriving instance Ord A++instance Read A where+    readsPrec p xs =+        [ (A x, rs)+        | (x,rs) <- readsPrec p xs ]++liftedQC+    :: (Show1 r+       ,Eq1 r+       ,Ord1 r+       ,Read1 r+       ,Arbitrary (r A)+       ,Show (r A)+       ,Eq (r A)+       ,Ord (r A)+       ,Read A)+    => f (r b) -> TestTree+liftedQC (_ :: f (r b)) =+    testGroup+        "liftedClasses"+        [ testGroup+              "Eq1"+              [ QC.testProperty+                    "x == x"+                    (\(x :: r A) ->+                          eq1 x x)+              , QC.testProperty+                    "same as =="+                    (\(x :: r A) (y :: r A) ->+                          counterexample (show (x, y)) ((x == y) == eq1 x y))]+        , testGroup+              "Ord1"+              [ QC.testProperty+                    "cmp x x == EQ"+                    (\(x :: r A) ->+                          counterexample (show x) (compare1 x x === EQ))+              , QC.testProperty+                    "compare1 == compare"+                    (\(x :: r A) (y :: r A) ->+                          counterexample+                              (show (x, y))+                              (compare x y == compare1 x y))]+        , testGroup+              "Show1"+              [ QC.testProperty+                    "show1 == show"+                    (\(x :: r A) ->+                          liftShowsPrec showsPrec showList 0 x "" === show x)]+        , testGroup+              "Read1"+              [ QC.testProperty+                    "read1 . show == id"+                    (\(x :: r A) ->+                          (liftReadsPrec readsPrec readList 0 . show) x ===+                          [(x, "")])]]+ type Tup2 a = (a,a) type Tup3 a = (a,a,a) type Tup4 a = (a,a,a,a)@@ -134,20 +195,33 @@ 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]]--+        [ let p = Proxy :: Proxy (PositiveInfinite Int)+          in testGroup "PositiveInfinite" [storableQC p, liftedQC p]+        , let p = Proxy :: Proxy (NegativeInfinite Int)+          in testGroup "NegativeInfinite" [storableQC p, liftedQC p]+        , let p = Proxy :: Proxy (Infinite Int)+          in testGroup "Infinite" [storableQC p, liftedQC p]+        , let p = Proxy :: Proxy (Add A)+          in testGroup "Add" [liftedQC p]+        , let p = Proxy :: Proxy (Mul A)+          in testGroup "Mul" [liftedQC p]+        , let p = Proxy :: Proxy (Max A)+          in testGroup "Max" [liftedQC p]+        , let p = Proxy :: Proxy (Min A)+          in testGroup "Min" [liftedQC p]+        , let p = Proxy :: Proxy (Bottleneck A)+          in testGroup "Min" [liftedQC p]+        , let p = Proxy :: Proxy (Division A)+          in testGroup "Min" [liftedQC p]+        , let p = Proxy :: Proxy (Łukasiewicz A)+          in testGroup "Min" [liftedQC p]+        , let p = Proxy :: Proxy (Viterbi A)+          in testGroup "Min" [liftedQC p]+        , let p = Proxy :: Proxy (PosFrac A)+          in testGroup "Min" [liftedQC p]+        , let p = Proxy :: Proxy (PosInt A)+          in testGroup "Min" [liftedQC p]+        ]  semiringLawTests :: TestTree semiringLawTests =@@ -172,7 +246,9 @@                  , testGroup "2" [semiringLawsQC p2]                  , testGroup "5" [semiringLawsQC p5]]         , let p = Proxy :: Proxy Integer-          in testGroup "Integer" [semiringLawsSC p, ordLawsSC p, zeroLawsSC p, ordLawsQC p]+          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@@ -324,6 +400,42 @@                              (xs <.> ys :: [Int]) ===                              Vector.toList                                  (Vector.fromList xs <.> Vector.fromList ys))]+        , let p = Proxy :: Proxy (Storable.Vector Int)+          in testGroup+                 "Storable Vector Int"+                 [ semiringLawsQC p+                 , QC.testProperty+                       "reference implementation of <.>"+                       (\xs ys ->+                             (xs <.> ys :: [Int]) ===+                             Vector.toList+                                 (Vector.fromList xs <.> Vector.fromList ys))]+        , let p = Proxy :: Proxy (Unboxed.Vector Int)+          in testGroup+                 "Unboxed Vector Int"+                 [ semiringLawsQC p+                 , QC.testProperty+                       "reference implementation of <.>"+                       (\xs ys ->+                             (xs <.> ys :: [Int]) ===+                             Unboxed.toList+                                 (Unboxed.fromList xs <.> Unboxed.fromList ys))]+        , testGroup+              "Unboxed Vector (NegativeInfinite Int)"+              [ QC.testProperty+                    "reference implementation of <.>"+                    (\xs ys ->+                          (xs <.> ys :: [NegativeInfinite Int]) ===+                          Unboxed.toList+                              (Unboxed.fromList xs <.> Unboxed.fromList ys))]+        , testGroup+              "Unboxed Vector (Infinite Int)"+              [ QC.testProperty+                    "reference implementation of <.>"+                    (\xs ys ->+                          (xs <.> ys :: [Infinite Int]) ===+                          Unboxed.toList+                              (Unboxed.fromList xs <.> Unboxed.fromList ys))]         , let p = Proxy :: Proxy (Min (PositiveInfinite Integer))           in testGroup "Min Inf Integer" [semiringLawsSC p, zeroLawsSC p]         , let p = Proxy :: Proxy (Min (Infinite Integer))