diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revision history for finitary-derive +## 2.1.0.0 -- 2019-11-24 + +* Fix bug in ``Ord`` instances for the ``Pack*`` types. +* Fix definition of ``Packed`` pattern to actually agree with the documentation. +* Define a ``newtype`` wrapper for better provision of ``Binary`` and + ``Hashable`` instances for ``Vector``s of ``PackBits`` types. +* Remove ``Hashable`` and ``Binary`` instances for ``PackBits`` (both + varieties). +* Fix documentation typoes. + ## 2.0.0.0 -- 2019-11-23 * Remove ``Data.Finitary.Pack``. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -105,7 +105,7 @@ ## Why do ``PackBytes``, ``PackWords`` and ``PackInto`` have ``Storable`` instances, but not ``PackBits``? -Because it's not clear what they should be. Let's suppose you want to bit-pack a +Because it's not clear what this instance should look like. Let's suppose you want to bit-pack a type ``Giraffe`` with cardinality 11 - what should ``sizeOf`` for ``PackBits Giraffe`` be? How about ``alignment``? The only obvious solution is padding, but in this case, you might as well use ``PackBytes``, ``PackWords`` or diff --git a/finitary-derive.cabal b/finitary-derive.cabal --- a/finitary-derive.cabal +++ b/finitary-derive.cabal @@ -3,7 +3,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Flexible and easy deriving of type classes for finitary types. description: Provides a collection of wrappers, allowing you to easily @@ -52,6 +52,7 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs + ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: test build-depends: base >= 4.12 && < 4.14, hedgehog >= 1.0.1 && < 1.1, diff --git a/src/Data/Finitary/PackBits.hs b/src/Data/Finitary/PackBits.hs --- a/src/Data/Finitary/PackBits.hs +++ b/src/Data/Finitary/PackBits.hs @@ -30,6 +30,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module: Data.Finitary.PackBits @@ -41,7 +43,8 @@ -- Portability: GHC only -- -- From the [Kraft-McMillan --- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality), +-- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality) +-- and -- the fact that we are not able to have \'fractional\' bits, we can derive a -- fixed-length code into a bitstring for any 'Finitary' type @a@, with code -- length \(\lceil \log_{2}(\texttt{Cardinality a}) \rceil\) bits. This code is @@ -66,7 +69,8 @@ -- by using "Data.Finitary.PackBits.Unsafe" instead. module Data.Finitary.PackBits ( - PackBits, pattern Packed + PackBits, pattern Packed, + BulkPack, exposeVector ) where import GHC.TypeLits.Extra @@ -82,6 +86,7 @@ import Data.Finitary(Finitary(..)) import Data.Finite (Finite) import Control.Monad.Trans.State.Strict (evalState, get, modify, put) +import Data.Semigroup (Dual(..)) import qualified Data.Binary as Bin import qualified Data.Bit.ThreadSafe as BT @@ -92,7 +97,7 @@ -- | An opaque wrapper around @a@, representing each value as a 'bit-packed' -- encoding. newtype PackBits (a :: Type) = PackBits (VU.Vector BT.Bit) - deriving (Eq, Ord) + deriving (Eq, Show) type role PackBits nominal @@ -113,19 +118,13 @@ -- Use with this in mind. pattern Packed :: forall (a :: Type) . (Finitary a, 1 <= Cardinality a) => - PackBits a -> a -pattern Packed x <- (packBits -> x) - where Packed x = unpackBits x - -instance Bin.Binary (PackBits a) where - {-# INLINE put #-} - put = Bin.put . BT.cloneToWords . op PackBits - {-# INLINE get #-} - get = PackBits . BT.castFromWords <$> Bin.get + a -> PackBits a +pattern Packed x <- (unpackBits -> x) + where Packed x = packBits x -instance Hashable (PackBits a) where - {-# INLINE hashWithSalt #-} - hashWithSalt salt = hashWithSalt salt . BT.cloneToWords . op PackBits +instance Ord (PackBits a) where + compare (PackBits v1) (PackBits v2) = getDual . VU.foldr go (Dual EQ) . VU.zipWith (,) v1 $ v2 + where go input order = (order <>) . Dual . uncurry compare $ input instance NFData (PackBits a) where {-# INLINE rnf #-} @@ -178,6 +177,27 @@ basicUnsafeIndexM (V_PackBits v) i = pure . PackBits . VG.unsafeSlice (i * bitLength @a) (bitLength @a) $ v instance (Finitary a, 1 <= Cardinality a) => VU.Unbox (PackBits a) + +-- | This wrapper provides an efficient 'Hashable' instance (hash the entire +-- underlying bit-packed vector, rather than each element individually), as well +-- as a 'Bin.Binary' instance (which stores or reads the entire blob of +-- bits \'in one go\'). +newtype BulkPack a = BulkPack { exposeVector :: VU.Vector (PackBits a) } + deriving (NFData) + +deriving instance (Finitary a, 1 <= Cardinality a) => Eq (BulkPack a) + +deriving instance (Finitary a, 1 <= Cardinality a) => Ord (BulkPack a) + +instance Hashable (BulkPack a) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt = hashWithSalt salt . BT.cloneToWords . op V_PackBits . op BulkPack + +instance Bin.Binary (BulkPack a) where + {-# INLINE put #-} + put = Bin.put . BT.cloneToWords . op V_PackBits . op BulkPack + {-# INLINE get #-} + get = BulkPack . V_PackBits . BT.castFromWords <$> Bin.get -- Helpers diff --git a/src/Data/Finitary/PackBits/Unsafe.hs b/src/Data/Finitary/PackBits/Unsafe.hs --- a/src/Data/Finitary/PackBits/Unsafe.hs +++ b/src/Data/Finitary/PackBits/Unsafe.hs @@ -30,6 +30,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module: Data.Finitary.PackBits.Unsafe @@ -41,7 +43,8 @@ -- Portability: GHC only -- -- From the [Kraft-McMillan --- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality), +-- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality) +-- and -- the fact that we are not able to have \'fractional\' bits, we can derive a -- fixed-length code into a bitstring for any 'Finitary' type @a@, with code -- length \(\lceil \log_{2}(\texttt{Cardinality a}) \rceil\) bits. This code is @@ -66,7 +69,8 @@ -- "Data.Finitary.PackBits" instead. module Data.Finitary.PackBits.Unsafe ( - PackBits, pattern Packed + PackBits, pattern Packed, + BulkPack, exposeVector ) where import GHC.TypeLits.Extra @@ -82,6 +86,7 @@ import Data.Finitary(Finitary(..)) import Data.Finite (Finite) import Control.Monad.Trans.State.Strict (evalState, get, modify, put) +import Data.Semigroup (Dual(..)) import qualified Data.Binary as Bin import qualified Data.Bit as B @@ -92,7 +97,7 @@ -- | An opaque wrapper around @a@, representing each value as a 'bit-packed' -- encoding. newtype PackBits (a :: Type) = PackBits (VU.Vector B.Bit) - deriving (Eq, Ord) + deriving (Eq, Show) type role PackBits nominal @@ -113,10 +118,14 @@ -- Use with this in mind. pattern Packed :: forall (a :: Type) . (Finitary a, 1 <= Cardinality a) => - PackBits a -> a -pattern Packed x <- (packBits -> x) - where Packed x = unpackBits x + a -> PackBits a +pattern Packed x <- (unpackBits -> x) + where Packed x = packBits x +instance Ord (PackBits a) where + compare (PackBits v1) (PackBits v2) = getDual . VU.foldr go (Dual EQ) . VU.zipWith (,) v1 $ v2 + where go input order = (order <>) . Dual . uncurry compare $ input + instance Bin.Binary (PackBits a) where {-# INLINE put #-} put = Bin.put . B.cloneToWords . op PackBits @@ -178,6 +187,27 @@ basicUnsafeIndexM (V_PackBits v) i = pure . PackBits . VG.unsafeSlice (i * bitLength @a) (bitLength @a) $ v instance (Finitary a, 1 <= Cardinality a) => VU.Unbox (PackBits a) + +-- | This wrapper provides an efficient 'Hashable' instance (hash the entire +-- underlying bit-packed vector, rather than each element individually), as well +-- as a 'Bin.Binary' instance (which stores or reads the entire blob of +-- bits \'in one go\'). +newtype BulkPack a = BulkPack { exposeVector :: VU.Vector (PackBits a) } + deriving (NFData) + +deriving instance (Finitary a, 1 <= Cardinality a) => Eq (BulkPack a) + +deriving instance (Finitary a, 1 <= Cardinality a) => Ord (BulkPack a) + +instance Hashable (BulkPack a) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt = hashWithSalt salt . B.cloneToWords . op V_PackBits . op BulkPack + +instance Bin.Binary (BulkPack a) where + {-# INLINE put #-} + put = Bin.put . B.cloneToWords . op V_PackBits . op BulkPack + {-# INLINE get #-} + get = BulkPack . V_PackBits . B.castFromWords <$> Bin.get -- Helpers diff --git a/src/Data/Finitary/PackBytes.hs b/src/Data/Finitary/PackBytes.hs --- a/src/Data/Finitary/PackBytes.hs +++ b/src/Data/Finitary/PackBytes.hs @@ -78,6 +78,7 @@ import Numeric.Natural (Natural) import Data.Finite (Finite) import Control.Monad.Trans.State.Strict (evalState, get, modify, put) +import Data.Semigroup (Dual(..)) import qualified Data.Binary as Bin import qualified Data.Vector.Unboxed as VU @@ -86,7 +87,7 @@ -- | An opaque wrapper around @a@, representing each value as a byte string. newtype PackBytes (a :: Type) = PackBytes (VU.Vector Word8) - deriving (Eq, Ord, Show) + deriving (Eq, Show) type role PackBytes nominal @@ -107,9 +108,13 @@ -- Use with this in mind. pattern Packed :: forall (a :: Type) . (Finitary a, 1 <= Cardinality a) => - PackBytes a -> a -pattern Packed x <- (packBytes -> x) - where Packed x = unpackBytes x + a -> PackBytes a +pattern Packed x <- (unpackBytes -> x) + where Packed x = packBytes x + +instance Ord (PackBytes a) where + compare (PackBytes v1) (PackBytes v2) = getDual . VU.foldr go (Dual EQ) . VU.zipWith (,) v1 $ v2 + where go input order = (order <>) . Dual . uncurry compare $ input instance Bin.Binary (PackBytes a) where {-# INLINE put #-} diff --git a/src/Data/Finitary/PackInto.hs b/src/Data/Finitary/PackInto.hs --- a/src/Data/Finitary/PackInto.hs +++ b/src/Data/Finitary/PackInto.hs @@ -23,6 +23,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module: Data.Finitary.PackInto @@ -110,9 +111,9 @@ pattern Packed x <- (packInto -> x) where Packed x = unpackOutOf x -instance (Finitary a, Finitary b, Cardinality a <= Cardinality b) => Ord (PackInto a b) where +instance (Ord a, Finitary a, Finitary b, Cardinality a <= Cardinality b) => Ord (PackInto a b) where {-# INLINE compare #-} - compare = comparing toFinite + compare = comparing @a (fromFinite . toFinite) instance (Hashable b) => Hashable (PackInto a b) where {-# INLINE hashWithSalt #-} diff --git a/src/Data/Finitary/PackWords.hs b/src/Data/Finitary/PackWords.hs --- a/src/Data/Finitary/PackWords.hs +++ b/src/Data/Finitary/PackWords.hs @@ -76,6 +76,7 @@ import Data.Hashable (Hashable(..)) import Control.DeepSeq (NFData(..)) import Control.Monad.Trans.State.Strict (evalState, get, modify, put) +import Data.Semigroup (Dual(..)) import qualified Data.Binary as Bin import qualified Data.Vector.Unboxed as VU @@ -85,7 +86,7 @@ -- | An opaque wrapper around @a@, representing each value as a fixed-length -- array of machine words. newtype PackWords (a :: Type) = PackWords (VU.Vector Word) - deriving (Eq, Ord, Show) + deriving (Eq, Show) type role PackWords nominal @@ -106,9 +107,13 @@ -- Use with this in mind. pattern Packed :: forall (a :: Type) . (Finitary a, 1 <= Cardinality a) => - PackWords a -> a -pattern Packed x <- (packWords -> x) - where Packed x = unpackWords x + a -> PackWords a +pattern Packed x <- (unpackWords -> x) + where Packed x = packWords x + +instance Ord (PackWords a) where + compare (PackWords v1) (PackWords v2) = getDual . VU.foldr go (Dual EQ) . VU.zipWith (,) v1 $ v2 + where go input order = (order <>) . Dual . uncurry compare $ input instance Bin.Binary (PackWords a) where {-# INLINE put #-} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -15,6 +15,8 @@ - along with this program. If not, see . -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -46,6 +48,11 @@ import Data.Finitary.PackWords (PackWords) import Data.Finitary.PackInto (PackInto) +import qualified Data.Finitary.PackBits as Safe +import qualified Data.Finitary.PackBits.Unsafe as Unsafe +import qualified Data.Finitary.PackBytes as PackBytes +import qualified Data.Finitary.PackWords as PackWords + data Foo = Bar | Baz Word8 Word8 | Quux Word16 deriving (Eq, Show, Generic, Finitary) deriving (Ord, Bounded, NFData, Hashable, Binary) via (Finiteness Foo) @@ -68,6 +75,13 @@ packLaws :: (Eq a, Show a, Storable a) => Gen a -> [Laws] packLaws p = [storableLaws p] +ordIsMonotonic :: forall (a :: Type) (t :: Type -> Type) . + (Finitary a, Show a, Ord a, Ord (t a)) => + (a -> t a) -> Property +ordIsMonotonic f = property $ do x <- forAll $ choose @a + y <- forAll $ choose @a + (x < y) === (f x < f y) + finitenessTests :: [(String, [Laws])] finitenessTests = [("Small Finiteness", finitenessLaws @Foo choose), ("Big Finiteness", finitenessLaws @Big choose)] @@ -80,4 +94,13 @@ ("Small packed into Word64", packLaws @(PackInto Foo Word64) choose)] main :: IO Bool -main = (&&) <$> lawsCheckMany finitenessTests <*> lawsCheckMany packTests +main = (&&) <$> checkLaws <*> checkMonotonicity + where checkLaws = (&&) <$> lawsCheckMany finitenessTests <*> lawsCheckMany packTests + checkMonotonicity = checkParallel . Group "Monotonicity" $ [("Small PackBits", ordIsMonotonic @Foo Safe.Packed), + ("Small unsafe PackBits", ordIsMonotonic @Foo Unsafe.Packed), + ("Small PackBytes", ordIsMonotonic @Foo PackBytes.Packed), + ("Small PackWords", ordIsMonotonic @Foo PackWords.Packed), + ("Big PackBits", ordIsMonotonic @Big Safe.Packed), + ("Big unsafe PackBits", ordIsMonotonic @Big Unsafe.Packed), + ("Big PackBytes", ordIsMonotonic @Big PackBytes.Packed), + ("Big PackWords", ordIsMonotonic @Big PackWords.Packed)]