diff --git a/semiring-num.cabal b/semiring-num.cabal --- a/semiring-num.cabal +++ b/semiring-num.cabal @@ -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 diff --git a/src/Data/Semiring.hs b/src/Data/Semiring.hs --- a/src/Data/Semiring.hs +++ b/src/Data/Semiring.hs @@ -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'. diff --git a/src/Data/Semiring/Free.hs b/src/Data/Semiring/Free.hs --- a/src/Data/Semiring/Free.hs +++ b/src/Data/Semiring/Free.hs @@ -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. diff --git a/src/Data/Semiring/Infinite.hs b/src/Data/Semiring/Infinite.hs --- a/src/Data/Semiring/Infinite.hs +++ b/src/Data/Semiring/Infinite.hs @@ -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 diff --git a/src/Data/Semiring/Newtype.hs b/src/Data/Semiring/Newtype.hs --- a/src/Data/Semiring/Newtype.hs +++ b/src/Data/Semiring/Newtype.hs @@ -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 diff --git a/test/Orphans.hs b/test/Orphans.hs --- a/test/Orphans.hs +++ b/test/Orphans.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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))