diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for finitary-derive +## 2.0.0.0 -- 2019-11-23 + +* Remove ``Data.Finitary.Pack``. +* Add ``Data.Finitary.PackBits``, ``Data.Finitary.PackWords``, + ``Data.Finitary.PackBytes``, ``Data.Finitary.PackBits.Unsafe`` and + ``Data.Finitary.PackInto`` +* Refactor 'packing-agnostic' functionality into ``Data.Finitary.Finiteness``. +* A lot of documentation changes. + ## 1.0.0.1 -- 2019-09-21 * Fix documentation. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,8 +8,8 @@ is the kind of 'work' that we as Haskellers ought not to put up with. Now, you don't have to! As long as your type is [``Finitary``][2], you can now -get ``Unbox`` and ``Storable`` (as well as ``Binary`` and ``Hashable``, because -we could) instances _almost_ automagically: +get ``Unbox`` and ``Storable`` (as well as a whole bunch of other) instances +_almost_ automagically: ```haskell {-# LANGUAGE DeriveAnyClass #-} @@ -17,33 +17,101 @@ {-# LANGUAGE DerivingVia #-} import Data.Finitary -import Data.Finitary.Pack +import Data.Finitary.Finiteness +import Data.Finitary.PackInto import Data.Word import Data.Hashable import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Storable as VS data Foo = Bar | Baz (Word8, Word8) | Quux Word16 deriving (Eq, Generic, Finitary) - deriving (Storable, Binary, Hashable) via (Pack Foo) + deriving (Ord, Bounded, Hashable, NFData, Binary) via (Finiteness Foo) -someVector :: VU.Vector (Pack Foo) -someVector = VU.fromList . fmap Pack $ [Bar, Baz 0x0 0xf, Quux 0x134] +someVector :: VU.Vector (PackInto Foo Word64) +someVector = VU.fromList . fmap Packed $ [Bar, Baz 0x0 0xf, Quux 0x134] + +someStorableVector :: VS.Vector (PackInto Foo Word64) +someStorableVector = VS.fromList . fmap Packed $ [Bar, Baz 0x0 0xf, Quux 0x134] ``` If you don't have access to ``DerivingVia``, you can still get the benefits of -this library -- just use ``Pack a`` instead of ``a`` in all cases where you need -any such instances. As it is a ``newtype``, you can ``coerce`` through it if you -care about efficiency. +this library -- just use ``Finitary a`` instead of ``a``. As it is a ``newtype``, +you can ``coerce`` through it if you care about efficiency. -## Why can't I automagic up ``Unbox`` too? +## What's the deal with ``Unbox`` and ``Storable`` exactly? What's with all the ``Pack`` types? -The short answer is 'role restrictions on unboxed vectors'. If you want a more -detailed explanation, check out the [GHC wiki on roles][3], as well as the -[implementation of ``Data.Vector.Unboxed``][4]. You might also want to check out -[stuff about data families][5], as it ties into this rather aggravating -limitation closely too. +Essentially, being ``Finitary`` means that there's a finite set of indexes, one +for each inhabitant. That means we can essentially represent any inhabitant as a +fixed-length number. It's on the basis of this that we can 'magic up' +``Storable`` and ``Unbox``. +However, how we _represent_ this fixed-length number isn't immediately obvious. +We have a couple of options: + +- A string of bits +- A string of bytes +- An array of machine words + +Additionally, if we have _another_ finitary type whose cardinality is not +smaller, we could potentially 'borrow' its instances as well. Which of these +choices is appropriate isn't obvious in general: it depends on whether you care +about space or speed, the cardinality of the type, and a bunch of other things +too. As we believe that the best people to judge tradeoffs like these are the +people using our library, we provide _all_ of these options for you to choose +from, so that you can choose the one that best suits you. + +## So... what's the difference exactly? + +``PackBits`` represents indexes as strings of bits. This is the most compact +representation possible (honestly, [maths says so][6]), but the least efficient, +as accessing individual bits is slower on most architectures than whole bytes or words. +Unless you've got large ``Vector``s, you probably don't need this encoding, but +if space is at an absolute premium, this is the best choice. + +``PackBytes`` instead represents indexes as byte strings. This is a more +efficient choice than a string of bits, but can still be slow for architectures +which prefer whole-word access. It's also fairly compact, especially if your +architecture has big ``Word``s. + +``PackWords`` represents indexes as fixed-length arrays of ``Word``s. This is +the most efficient encoding from the point of view of random reads and writes, +but will likely waste a lot of space, unless your type is _extremely_ large (as +in, multiple copies of ``Word`` large). + +Lastly, ``PackInto`` lets you choose another finitary type whose instances you +want to 'borrow', and will use that type as a representation. This is the most +flexible, and should be preferred whenever possible. However, it requires that a +type of appropriate cardinality (at least as big as the one you want to encode) +exists, and has the appropriate instances. + +## Why can't I ``DerivingVia`` through these ``Pack`` types? + +For ``Unbox``, the short answer is 'role restrictions on unboxed vectors'. If +you want a more detailed explanation, check out the [GHC wiki on roles][3], as +well as the [implementation of ``Data.Vector.Unboxed``][4]. You might also want +to check out [stuff about data families][5]. + +Additionally, there is some tension in the design. We could have made one of two +choices: either define ``Pack`` types as transparent ``newtype``s, and encode or +decode whenever a type class method required it; or define ``Pack`` types as +opaque, and encode or decode only when the values were constructed or +deconstructed. Ultimately, we went with the second option, as it makes the +occurences of encodes and decodes explicit to the user. Had we gone with the +first choice, it would be unclear where encodes and decodes occur, especially +when using functions built from type class methods. We believe this clarity is +worth the inability to use ``DerivingVia`` to define ``Storable`` instances. + +## 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 +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 +``PackInto``, since then you'll at least know what you're getting, and are +explicit about it. + ## Sounds good! Can I use it? Certainly - we've tested on GHC 8.4.4, 8.6.5 and 8.8.1, on GNU/Linux only. If @@ -65,3 +133,4 @@ [3]: https://gitlab.haskell.org/ghc/ghc/wikis/roles [4]: http://hackage.haskell.org/package/vector-0.12.0.3/docs/src/Data.Vector.Unboxed.Base.html [5]: https://wiki.haskell.org/GHC/Type_families +[6]: https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality diff --git a/finitary-derive.cabal b/finitary-derive.cabal --- a/finitary-derive.cabal +++ b/finitary-derive.cabal @@ -3,12 +3,14 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 1.0.0.1 -synopsis: Easy and efficient Unbox, Storable, Binary and Hashable - instances for Finitary types. -description: Provides a wrapper with pre-made instances of Unbox, - Storable, Binary and Hashable, suitable for use with types that - have Finitary instances. Never write Unbox by hand again! +version: 2.0.0.0 +synopsis: Flexible and easy deriving of type classes for finitary + types. +description: Provides a collection of wrappers, allowing you to easily + define (among others) Unbox, Storable, Hashable and + Binary instances for finitary types with flexibility in + terms of representation and efficiency. Never write an + Unbox instance by hand again! homepage: https://notabug.org/koz.ross/finitary-derive license: GPL-3.0-or-later license-file: LICENSE.md @@ -24,9 +26,14 @@ README.md library - exposed-modules: Data.Finitary.Pack + exposed-modules: Data.Finitary.Finiteness, + Data.Finitary.PackBits, + Data.Finitary.PackBits.Unsafe, + Data.Finitary.PackBytes, + Data.Finitary.PackWords, + Data.Finitary.PackInto build-depends: base >= 4.11 && < 4.14, - finitary >= 1.1.0.0 && < 1.2.0.0, + finitary >= 1.2.0.0 && < 1.3.0.0, vector >= 0.12.0.3 && < 0.13.0.0, coercible-utils >= 0.0.0 && < 0.1.0, finite-typelits >= 0.1.4.2 && < 0.2.0.0, @@ -35,8 +42,10 @@ hashable >= 1.3.0.0 && < 1.4.0.0, ghc-typelits-extra >= 0.3.1 && < 0.4.0, ghc-typelits-knownnat >= 0.7 && < 0.8, - mtl >= 2.2.2 && < 2.3, - vector-sized >= 1.4.0.0 && < 1.5.0.0 + vector-instances >= 3.4 && < 3.5, + transformers >= 0.5.5.0 && < 0.6.0.0, + bitvec >= 1.0.2.0 && < 1.1.0.0, + vector-binary-instances >= 0.2.5.1 && < 0.3.0.0 hs-source-dirs: src default-language: Haskell2010 @@ -50,5 +59,7 @@ finitary-derive, finitary, finite-typelits, - monad-loops >= 0.4.3 && < 0.5.0 + hashable, + binary, + deepseq default-language: Haskell2010 diff --git a/src/Data/Finitary/Finiteness.hs b/src/Data/Finitary/Finiteness.hs new file mode 100644 --- /dev/null +++ b/src/Data/Finitary/Finiteness.hs @@ -0,0 +1,145 @@ +{- + - Copyright (C) 2019 Koz Ross + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU General Public License for more details. + - + - You should have received a copy of the GNU General Public License + - along with this program. If not, see . + -} + +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module: Data.Finitary.Finiteness +-- Description: Newtype wrapper for deriving various typeclasses for +-- @Finitary@ types. +-- Copyright: (C) Koz Ross 2019 +-- License: GPL version 3.0 or later +-- Maintainer: koz.ross@retro-freedom.nz +-- Stability: Experimental +-- Portability: GHC only +-- +-- Knowing that a type @a@ is an instance of @Finitary@ gives us the knowledge +-- that there is an isomorphism between @a@ and @Finite n@ for some @KnownNat +-- n@. This gives us a lot of information, which we can exploit to automagically +-- derive a range of type class instances. +-- +-- 'Finiteness' is a @newtype@ wrapper providing this functionality, while +-- 're-exporting' as many type class instances of the underlying type as +-- possible. It is designed for use with @DerivingVia@ - an example of use: +-- +-- > {-# LANGUAGE DerivingVia #-} +-- > {-# LANGUAGE DeriveAnyClass #-} +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > import GHC.Generics +-- > import Data.Finitary +-- > import Data.Finitary.Finiteness +-- > import Data.Word +-- > import Control.DeepSeq +-- > import Data.Hashable +-- > import Data.Binary +-- > +-- > data Foo = Bar | Baz (Word8, Word8) | Quux Word16 +-- > deriving (Eq, Generic, Finitary) +-- > deriving (Ord, Bounded, NFData, Hashable, Binary) via (Finiteness Foo) +-- +-- Currently, the following type class instances can be derived in this manner: +-- +-- * 'Ord' +-- * 'Bounded' +-- * 'NFData' +-- * 'Hashable' +-- * 'Binary' +-- +-- Additionally, 'Finiteness' \'forwards\' definitions of the following type +-- classes: +-- +-- * 'Eq' +-- * 'Show' +-- * 'Read' +-- * 'Typeable' +-- * 'Data' +-- * 'Semigroup' +-- * 'Monoid' +module Data.Finitary.Finiteness +( + Finiteness(..) +) where + +import GHC.TypeNats +import Data.Typeable (Typeable) +import Data.Data (Data) +import Data.Finitary (Finitary(..)) +import Data.Ord (comparing) +import Control.DeepSeq (NFData(..)) +import Data.Hashable (Hashable(..)) +import Data.Binary (Binary(..)) + +-- | Essentially 'Data.Functor.Identity' with a different name. Named this way due to the +-- wordplay you get from use with @DerivingVia@. +newtype Finiteness a = Finiteness { unFiniteness :: a } + deriving (Eq, Show, Read, Typeable, Data, Functor, Semigroup, Monoid) + +-- | 'Finiteness' merely replicates the @Finitary@ behaviour of the underlying +-- type. +instance (Finitary a) => Finitary (Finiteness a) where + type Cardinality (Finiteness a) = Cardinality a + {-# INLINE fromFinite #-} + fromFinite = Finiteness . fromFinite + {-# INLINE toFinite #-} + toFinite = toFinite . unFiniteness + {-# INLINE start #-} + start = Finiteness start + {-# INLINE end #-} + end = Finiteness end + {-# INLINE previous #-} + previous = fmap Finiteness . previous . unFiniteness + {-# INLINE next #-} + next = fmap Finiteness . next . unFiniteness + +-- | 'Ord' can be derived by deferring to the order on @Finite (Cardinality a)@. +instance (Finitary a) => Ord (Finiteness a) where + {-# INLINE compare #-} + compare (Finiteness x) (Finiteness y) = comparing toFinite x y + +-- | Since any inhabited 'Finitary' type is also 'Bounded', we can forward this +-- definition also. +instance (Finitary a, 1 <= Cardinality a) => Bounded (Finiteness a) where + {-# INLINE minBound #-} + minBound = Finiteness start + {-# INLINE maxBound #-} + maxBound = Finiteness end + +-- | We can force evaluation of a 'Finitary' type by converting it to its index. +instance (Finitary a) => NFData (Finiteness a) where + {-# INLINE rnf #-} + rnf = rnf . toFinite . unFiniteness + +-- | Any 'Finitary' type can be hashed by hashing its index. +instance (Finitary a) => Hashable (Finiteness a) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt = hashWithSalt salt . fromIntegral @_ @Integer . toFinite . unFiniteness + +-- | Any 'Finitary' type can be converted to a binary representation by +-- converting its index. +instance (Finitary a) => Binary (Finiteness a) where + {-# INLINE put #-} + put = put . fromIntegral @_ @Integer . toFinite . unFiniteness + {-# INLINE get #-} + get = Finiteness . fromFinite . fromIntegral @Integer <$> get diff --git a/src/Data/Finitary/Pack.hs b/src/Data/Finitary/Pack.hs deleted file mode 100644 --- a/src/Data/Finitary/Pack.hs +++ /dev/null @@ -1,190 +0,0 @@ -{- - - Copyright (C) 2019 Koz Ross - - - - This program is free software: you can redistribute it and/or modify - - it under the terms of the GNU General Public License as published by - - the Free Software Foundation, either version 3 of the License, or - - (at your option) any later version. - - - - This program is distributed in the hope that it will be useful, - - but WITHOUT ANY WARRANTY; without even the implied warranty of - - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - - GNU General Public License for more details. - - - - You should have received a copy of the GNU General Public License - - along with this program. If not, see . - -} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-} - -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Module: Data.Finitary.Pack --- Description: A wrapper around @Finitary@ types, designed to provide easy --- derivation of @Storable@, @Binary@ and @Unbox@ instances. --- Copyright: (C) Koz Ross, 2019 --- License: GPL version 3.0 or later --- Maintainer: koz.ross@retro-freedom.nz --- Stability: Experimental --- Portability: GHC only --- --- Defines a newtype for easy derivation of 'Data.Vector.Unboxed.Unbox', 'Storable', --- 'Data.Binary.Binary' and 'Hashable' instances for any type with a 'Finitary' instance. The easiest way to use --- this is with the @DerivingVia@ extension: --- --- > {-# LANGUAGE DeriveAnyClass #-} --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE DerivingVia #-} --- > --- > import Data.Finitary --- > import Data.Finitary.Pack --- > import Data.Word --- > import Data.Hashable --- > --- > data Foo = Bar | Baz (Word8, Word8) | Quux Word16 --- > deriving (Eq, Generic, Finitary) --- > deriving (Storable, Binary, Hashable) via (Pack Foo) --- --- Alternatively, you can just use @Pack a@ instead of @a@ wherever appropriate. --- Unfortunately (due to role restrictions on unboxed vectors), you /must/ use --- @Pack a@ if you want a 'Data.Vector.Unboxed.Vector' full of @a@s - --- @DerivingVia@ is of no help here. -module Data.Finitary.Pack -( - Pack(..) -) where - -import Data.Foldable (traverse_) -import CoercibleUtils (op, over, over2) -import Control.DeepSeq (NFData) -import GHC.Generics (Generic, Generic1) -import Data.Data (Data) -import Type.Reflection (Typeable) -import Data.Finitary (Finitary(..)) -import GHC.TypeNats -import GHC.TypeLits.Extra -import Data.Word (Word8) -import Numeric.Natural (Natural) -import Control.Monad.State.Strict (evalState, MonadState(..), modify) -import Data.Proxy (Proxy(..)) -import Data.Hashable (Hashable(..)) -import Foreign.Storable (Storable(..)) -import Foreign.Ptr (castPtr) - -import qualified Data.Vector.Generic as VG -import qualified Data.Vector.Generic.Mutable as VGM -import qualified Data.Vector.Generic.Sized as VGS -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Sized as VSS -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Sized as VUS -import qualified Data.Binary as B - --- | Essentially @Identity a@, but with different instances. So named due to the \'packing\' of the --- type's indices densely into arrays, memory or bits. -newtype Pack a = Pack { unPack :: a } - deriving (Eq, Ord, Bounded, Generic, Show, Read, Typeable, Data, Generic1, Functor, Semigroup, Monoid) - -instance (NFData a) => NFData (Pack a) - -instance (Finitary a) => Finitary (Pack a) - --- | We can hash any @Finitary@ by hashing its index. -instance (Finitary a, 1 <= Cardinality a) => Hashable (Pack a) where - {-# INLINE hashWithSalt #-} - hashWithSalt salt = hashWithSalt salt . packWords @VU.Vector - --- | We can serialize any @Finitary@ by serializing its index. -instance (Finitary a, 1 <= Cardinality a) => B.Binary (Pack a) where - {-# INLINE put #-} - put = B.put . packWords @VU.Vector - {-# INLINE get #-} - get = unpackWords @VU.Vector <$> B.get - --- | As @Finitary@ instances have known limits on their indices, they can be --- stored as their indices. -instance (Finitary a, 1 <= Cardinality a) => Storable (Pack a) where - {-# INLINE sizeOf #-} - sizeOf _ = sizeOf (undefined :: VSS.Vector (WordCount a) Word8) - {-# INLINE alignment #-} - alignment _ = alignment (undefined :: VSS.Vector (WordCount a) Word8) - {-# INLINE peek #-} - peek = fmap unpackWords . peek @(VSS.Vector (WordCount a) Word8) . castPtr - {-# INLINE poke #-} - poke ptr = poke (castPtr ptr) . packWords @VS.Vector - -newtype instance VU.MVector s (Pack a) = MV_Pack (VU.MVector s Word8) - -instance (Finitary a, 1 <= Cardinality a) => VGM.MVector VU.MVector (Pack a) where - {-# INLINE basicLength #-} - basicLength = (\x -> x `div` lenOf @a) . VGM.basicLength . op MV_Pack - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i len = over MV_Pack (VGM.basicUnsafeSlice (i * lenOf @a) (len * lenOf @a)) - {-# INLINE basicOverlaps #-} - basicOverlaps = over2 MV_Pack VGM.basicOverlaps - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew len = MV_Pack <$> VGM.basicUnsafeNew (len * lenOf @a) - {-# INLINE basicInitialize #-} - basicInitialize = VGM.basicInitialize . op MV_Pack - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MV_Pack v) i = unpackWords <$> VSS.generateM (VGM.basicUnsafeRead v . (i +) . fromIntegral) - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MV_Pack v) i x = do let arr = packWords x - let ixes = [i .. (i * lenOf @a - 1)] - traverse_ (\j -> VGM.basicUnsafeWrite v j (VUS.unsafeIndex arr (j - i))) ixes - -newtype instance VU.Vector (Pack a) = V_Pack (VU.Vector Word8) - -instance (Finitary a, 1 <= Cardinality a) => VG.Vector VU.Vector (Pack a) where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze = fmap V_Pack . VG.basicUnsafeFreeze . op MV_Pack - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw = fmap MV_Pack . VG.basicUnsafeThaw . op V_Pack - {-# INLINE basicLength #-} - basicLength = over V_Pack VG.basicLength - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i len = over V_Pack (VG.basicUnsafeSlice (i * lenOf @a) (len * lenOf @a)) - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (V_Pack v) i = unpackWords <$> VSS.generateM (VG.basicUnsafeIndexM v . (i +) . fromIntegral) - --- | We can rely on the fact that indexes of any @Finitary@ type have a fixed --- maximum size to \'unravel\' them into a block of 'Word8's, which we can --- easily unbox. -instance (Finitary a, 1 <= Cardinality a) => VU.Unbox (Pack a) - --- helpers - -type WordCount a = CLog (Cardinality Word8) (Cardinality a) - -{-# INLINE packWords #-} -packWords :: forall v a . (Finitary a, 1 <= Cardinality a, VG.Vector v Word8) => Pack a -> VGS.Vector v (WordCount a) Word8 -packWords = evalState (VGS.replicateM go) . fromIntegral @_ @Natural . toFinite . unPack - where go = do n <- get - let (d, r) = quotRem n (natVal @(Cardinality Word8) Proxy) - put d - return . fromIntegral $ r - -{-# INLINE unpackWords #-} -unpackWords :: forall v a . (Finitary a, VG.Vector v Word8) => VGS.Vector v (WordCount a) Word8 -> Pack a -unpackWords v = Pack . fromFinite . evalState (VGS.foldM go 0 v) $ 1 - where go acc w = do power <- get - modify (\x -> x * natVal @(Cardinality Word8) Proxy) - return (acc + fromIntegral power * fromIntegral w) - -{-# INLINE lenOf #-} -lenOf :: forall a . (Finitary a, 1 <= Cardinality a) => Int -lenOf = fromIntegral . natVal @(WordCount a) $ Proxy diff --git a/src/Data/Finitary/PackBits.hs b/src/Data/Finitary/PackBits.hs new file mode 100644 --- /dev/null +++ b/src/Data/Finitary/PackBits.hs @@ -0,0 +1,221 @@ +{- + - Copyright (C) 2019 Koz Ross + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU General Public License for more details. + - + - You should have received a copy of the GNU General Public License + - along with this program. If not, see . + -} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Data.Finitary.PackBits +-- Description: Scheme for bit-packing @Finitary@ types. +-- Copyright: (C) Koz Ross 2019 +-- License: GPL version 3.0 or later +-- Maintainer: koz.ross@retro-freedom.nz +-- Stability: Experimental +-- Portability: GHC only +-- +-- From the [Kraft-McMillan +-- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality), +-- 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 +-- essentially a binary representation of the index of each inhabitant of @a@. +-- On that basis, we can derive an 'VU.Unbox' instance, representing +-- the entire 'VU.Vector' as an unboxed [bit +-- array](https://en.wikipedia.org/wiki/Bit_array). +-- +-- This encoding is advantageous from the point of view of space - there is no +-- tighter possible packing that preserves \(\Theta(1)\) random access and also +-- allows the full range of 'VU.Vector' operations. If you are concerned about +-- space usage above all, this is the best choice for you. +-- +-- Because access to individual bits is slower than whole bytes or words, this +-- encoding adds some overhead. Additionally, a primary advantage of bit arrays +-- (the ability to perform \'bulk\' operations on bits efficiently) is not made +-- use of here. Therefore, if speed matters more than compactness, this encoding +-- is suboptimal. +-- +-- This encoding is __thread-safe__, and thus slightly slower. If you are certain +-- that race conditions cannot occur for your code, you can gain a speed improvement +-- by using "Data.Finitary.PackBits.Unsafe" instead. +module Data.Finitary.PackBits +( + PackBits, pattern Packed +) where + +import GHC.TypeLits.Extra +import Data.Proxy (Proxy(..)) +import Numeric.Natural (Natural) +import GHC.TypeNats +import CoercibleUtils (op, over, over2) +import Data.Kind (Type) +import Data.Hashable (Hashable(..)) +import Data.Vector.Instances () +import Data.Vector.Binary () +import Control.DeepSeq (NFData(..)) +import Data.Finitary(Finitary(..)) +import Data.Finite (Finite) +import Control.Monad.Trans.State.Strict (evalState, get, modify, put) + +import qualified Data.Binary as Bin +import qualified Data.Bit.ThreadSafe as BT +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Unboxed as VU + +-- | 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) + +type role PackBits nominal + +-- | To provide (something that resembles a) data constructor for 'PackBits', we +-- provide the following pattern. It can be used like any other data +-- constructor: +-- +-- > import Data.Finitary.PackBits +-- > +-- > anInt :: PackBits Int +-- > anInt = Packed 10 +-- > +-- > isPackedEven :: PackBits Int -> Bool +-- > isPackedEven (Packed x) = even x +-- +-- __Every__ pattern match, and data constructor call, performs a +-- \(\Theta(\log_{2}(\texttt{Cardinality a}))\) encoding or decoding operation. +-- 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 + +instance Hashable (PackBits a) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt = hashWithSalt salt . BT.cloneToWords . op PackBits + +instance NFData (PackBits a) where + {-# INLINE rnf #-} + rnf = rnf . op PackBits + +instance (Finitary a, 1 <= Cardinality a) => Finitary (PackBits a) where + type Cardinality (PackBits a) = Cardinality a + {-# INLINE fromFinite #-} + fromFinite = PackBits . intoBits + {-# INLINE toFinite #-} + toFinite = outOfBits . op PackBits + +instance (Finitary a, 1 <= Cardinality a) => Bounded (PackBits a) where + {-# INLINE minBound #-} + minBound = start + {-# INLINE maxBound #-} + maxBound = end + +newtype instance VU.MVector s (PackBits a) = MV_PackBits (VU.MVector s BT.Bit) + +instance (Finitary a, 1 <= Cardinality a) => VGM.MVector VU.MVector (PackBits a) where + {-# INLINE basicLength #-} + basicLength = over MV_PackBits ((`div` bitLength @a) . VGM.basicLength) + {-# INLINE basicOverlaps #-} + basicOverlaps = over2 MV_PackBits VGM.basicOverlaps + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over MV_PackBits (VGM.basicUnsafeSlice (i * bitLength @a) (len * bitLength @a)) + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew len = fmap MV_PackBits (VGM.basicUnsafeNew (len * bitLength @a)) + {-# INLINE basicInitialize #-} + basicInitialize = VGM.basicInitialize . op MV_PackBits + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_PackBits v) i = fmap PackBits . VG.freeze . VGM.unsafeSlice (i * bitLength @a) (bitLength @a) $ v + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_PackBits v) i (PackBits x) = let slice = VGM.unsafeSlice (i * bitLength @a) (bitLength @a) v in + VG.unsafeCopy slice x + +newtype instance VU.Vector (PackBits a) = V_PackBits (VU.Vector BT.Bit) + +instance (Finitary a, 1 <= Cardinality a) => VG.Vector VU.Vector (PackBits a) where + {-# INLINE basicLength #-} + basicLength = over V_PackBits ((`div` bitLength @a) . VG.basicLength) + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze = fmap V_PackBits . VG.basicUnsafeFreeze . op MV_PackBits + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw = fmap MV_PackBits . VG.basicUnsafeThaw . op V_PackBits + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over V_PackBits (VG.basicUnsafeSlice (i * bitLength @a) (len * bitLength @a)) + {-# INLINE basicUnsafeIndexM #-} + 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) + +-- Helpers + +type BitLength a = CLog 2 (Cardinality a) + +{-# INLINE packBits #-} +packBits :: forall (a :: Type) . + (Finitary a, 1 <= Cardinality a) => + a -> PackBits a +packBits = fromFinite . toFinite + +{-# INLINE unpackBits #-} +unpackBits :: forall (a :: Type) . + (Finitary a, 1 <= Cardinality a) => + PackBits a -> a +unpackBits = fromFinite . toFinite + +{-# INLINE bitLength #-} +bitLength :: forall (a :: Type) (b :: Type) . + (Finitary a, 1 <= Cardinality a, Num b) => + b +bitLength = fromIntegral . natVal $ (Proxy :: Proxy (BitLength a)) + +{-# INLINE intoBits #-} +intoBits :: forall (n :: Nat) . + (KnownNat n, 1 <= n) => + Finite n -> VU.Vector BT.Bit +intoBits = evalState (VU.replicateM (bitLength @(Finite n)) go) . fromIntegral @_ @Natural + where go = do remaining <- get + let (d, r) = quotRem remaining 2 + put d >> pure (BT.Bit . toEnum . fromIntegral $ r) + +{-# INLINE outOfBits #-} +outOfBits :: forall (n :: Nat) . + (KnownNat n) => + VU.Vector BT.Bit -> Finite n +outOfBits v = evalState (VU.foldM' go 0 v) 1 + where go old (BT.Bit b) = do power <- get + let placeValue = power * (fromIntegral . fromEnum $ b) + modify (* 2) + return (old + placeValue) diff --git a/src/Data/Finitary/PackBits/Unsafe.hs b/src/Data/Finitary/PackBits/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Finitary/PackBits/Unsafe.hs @@ -0,0 +1,221 @@ +{- + - Copyright (C) 2019 Koz Ross + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU General Public License for more details. + - + - You should have received a copy of the GNU General Public License + - along with this program. If not, see . + -} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Data.Finitary.PackBits.Unsafe +-- Description: Scheme for bit-packing @Finitary@ types. +-- Copyright: (C) Koz Ross 2019 +-- License: GPL version 3.0 or later +-- Maintainer: koz.ross@retro-freedom.nz +-- Stability: Experimental +-- Portability: GHC only +-- +-- From the [Kraft-McMillan +-- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality), +-- 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 +-- essentially a binary representation of the index of each inhabitant of @a@. +-- On that basis, we can derive an 'VU.Unbox' instance, representing +-- the entire 'VU.Vector' as an unboxed [bit +-- array](https://en.wikipedia.org/wiki/Bit_array). +-- +-- This encoding is advantageous from the point of view of space - there is no +-- tighter possible packing that preserves \(\Theta(1)\) random access and also +-- allows the full range of 'VU.Vector' operations. If you are concerned about +-- space usage above all, this is the best choice for you. +-- +-- Because access to individual bits is slower than whole bytes or words, this +-- encoding adds some overhead. Additionally, a primary advantage of bit arrays +-- (the ability to perform \'bulk\' operations on bits efficiently) is not made +-- use of here. Therefore, if speed matters more than compactness, this encoding +-- is suboptimal. +-- +-- This encoding is __not__ thread-safe, in exchange for performance. If you +-- suspect race conditions are possible, it's better to use +-- "Data.Finitary.PackBits" instead. +module Data.Finitary.PackBits.Unsafe +( + PackBits, pattern Packed +) where + +import GHC.TypeLits.Extra +import Data.Proxy (Proxy(..)) +import Numeric.Natural (Natural) +import GHC.TypeNats +import CoercibleUtils (op, over, over2) +import Data.Kind (Type) +import Data.Hashable (Hashable(..)) +import Data.Vector.Instances () +import Data.Vector.Binary () +import Control.DeepSeq (NFData(..)) +import Data.Finitary(Finitary(..)) +import Data.Finite (Finite) +import Control.Monad.Trans.State.Strict (evalState, get, modify, put) + +import qualified Data.Binary as Bin +import qualified Data.Bit as B +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Unboxed as VU + +-- | 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) + +type role PackBits nominal + +-- | To provide (something that resembles a) data constructor for 'PackBits', we +-- provide the following pattern. It can be used like any other data +-- constructor: +-- +-- > import Data.Finitary.PackBits +-- > +-- > anInt :: PackBits Int +-- > anInt = Packed 10 +-- > +-- > isPackedEven :: PackBits Int -> Bool +-- > isPackedEven (Packed x) = even x +-- +-- __Every__ pattern match, and data constructor call, performs a +-- \(\Theta(\log_{2}(\texttt{Cardinality a}))\) encoding or decoding operation. +-- 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 . B.cloneToWords . op PackBits + {-# INLINE get #-} + get = PackBits . B.castFromWords <$> Bin.get + +instance Hashable (PackBits a) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt = hashWithSalt salt . B.cloneToWords . op PackBits + +instance NFData (PackBits a) where + {-# INLINE rnf #-} + rnf = rnf . op PackBits + +instance (Finitary a, 1 <= Cardinality a) => Finitary (PackBits a) where + type Cardinality (PackBits a) = Cardinality a + {-# INLINE fromFinite #-} + fromFinite = PackBits . intoBits + {-# INLINE toFinite #-} + toFinite = outOfBits . op PackBits + +instance (Finitary a, 1 <= Cardinality a) => Bounded (PackBits a) where + {-# INLINE minBound #-} + minBound = start + {-# INLINE maxBound #-} + maxBound = end + +newtype instance VU.MVector s (PackBits a) = MV_PackBits (VU.MVector s B.Bit) + +instance (Finitary a, 1 <= Cardinality a) => VGM.MVector VU.MVector (PackBits a) where + {-# INLINE basicLength #-} + basicLength = over MV_PackBits ((`div` bitLength @a) . VGM.basicLength) + {-# INLINE basicOverlaps #-} + basicOverlaps = over2 MV_PackBits VGM.basicOverlaps + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over MV_PackBits (VGM.basicUnsafeSlice (i * bitLength @a) (len * bitLength @a)) + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew len = fmap MV_PackBits (VGM.basicUnsafeNew (len * bitLength @a)) + {-# INLINE basicInitialize #-} + basicInitialize = VGM.basicInitialize . op MV_PackBits + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_PackBits v) i = fmap PackBits . VG.freeze . VGM.unsafeSlice (i * bitLength @a) (bitLength @a) $ v + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_PackBits v) i (PackBits x) = let slice = VGM.unsafeSlice (i * bitLength @a) (bitLength @a) v in + VG.unsafeCopy slice x + +newtype instance VU.Vector (PackBits a) = V_PackBits (VU.Vector B.Bit) + +instance (Finitary a, 1 <= Cardinality a) => VG.Vector VU.Vector (PackBits a) where + {-# INLINE basicLength #-} + basicLength = over V_PackBits ((`div` bitLength @a) . VG.basicLength) + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze = fmap V_PackBits . VG.basicUnsafeFreeze . op MV_PackBits + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw = fmap MV_PackBits . VG.basicUnsafeThaw . op V_PackBits + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over V_PackBits (VG.basicUnsafeSlice (i * bitLength @a) (len * bitLength @a)) + {-# INLINE basicUnsafeIndexM #-} + 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) + +-- Helpers + +type BitLength a = CLog 2 (Cardinality a) + +{-# INLINE packBits #-} +packBits :: forall (a :: Type) . + (Finitary a, 1 <= Cardinality a) => + a -> PackBits a +packBits = fromFinite . toFinite + +{-# INLINE unpackBits #-} +unpackBits :: forall (a :: Type) . + (Finitary a, 1 <= Cardinality a) => + PackBits a -> a +unpackBits = fromFinite . toFinite + +{-# INLINE bitLength #-} +bitLength :: forall (a :: Type) (b :: Type) . + (Finitary a, 1 <= Cardinality a, Num b) => + b +bitLength = fromIntegral . natVal $ (Proxy :: Proxy (BitLength a)) + +{-# INLINE intoBits #-} +intoBits :: forall (n :: Nat) . + (KnownNat n, 1 <= n) => + Finite n -> VU.Vector B.Bit +intoBits = evalState (VU.replicateM (bitLength @(Finite n)) go) . fromIntegral @_ @Natural + where go = do remaining <- get + let (d, r) = quotRem remaining 2 + put d >> pure (B.Bit . toEnum . fromIntegral $ r) + +{-# INLINE outOfBits #-} +outOfBits :: forall (n :: Nat) . + (KnownNat n) => + VU.Vector B.Bit -> Finite n +outOfBits v = evalState (VU.foldM' go 0 v) 1 + where go old (B.Bit b) = do power <- get + let placeValue = power * (fromIntegral . fromEnum $ b) + modify (* 2) + return (old + placeValue) diff --git a/src/Data/Finitary/PackBytes.hs b/src/Data/Finitary/PackBytes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Finitary/PackBytes.hs @@ -0,0 +1,228 @@ +{- + - Copyright (C) 2019 Koz Ross + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU General Public License for more details. + - + - You should have received a copy of the GNU General Public License + - along with this program. If not, see . + -} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module: Data.Finitary.PackBytes +-- Description: Scheme for byte-packing @Finitary@ types. +-- Copyright: (C) Koz Ross 2019 +-- License: GPL version 3.0 or later +-- Maintainer: koz.ross@retro-freedom.nz +-- Stability: Experimental +-- Portability: GHC only +-- +-- If a type @a@ is 'Finitary', each inhabitant of @a@ has an index, which can +-- be represented as a byte string of a fixed length (as the number of indexes +-- is finite). Essentially, we can represent any value of @a@ as a fixed-length +-- string over an alphabet of cardinality \(256\). Based on this, we can derive +-- a 'VU.Unbox' instance, representing a 'VU.Vector' as a large byte string. +-- This also allows us to provide a 'Storable' instance for @a@. +-- +-- This encoding is fairly tight in terms of space use, especially for types +-- whose cardinalities are large. Additionally, byte-access is considerably +-- faster than bit-access on most architectures. If your types have large +-- cardinalities, and minimal space use isn't a concern, this encoding is good. +-- +-- Some architectures prefer whole-word access - on these, there can be some +-- overheads using this encoding. Additionally, the encoding and decoding step +-- for this encoding is longer than the one for "Data.Finitary.PackWords". If +-- @Cardinality a < Cardinality Word@, you should +-- consider a different encoding - in particular, check "Data.Finitary.PackInto", +-- which is more flexible and faster, with greater control over space usage. +module Data.Finitary.PackBytes +( + PackBytes, pattern Packed +) where + +import Data.Proxy (Proxy(..)) +import GHC.TypeLits.Extra +import GHC.TypeNats +import CoercibleUtils (op, over, over2) +import Data.Kind (Type) +import Data.Word (Word8) +import Data.Vector.Binary () +import Data.Vector.Instances () +import Data.Hashable (Hashable(..)) +import Control.DeepSeq (NFData(..)) +import Data.Finitary (Finitary(..)) +import Foreign.Storable (Storable(..)) +import Foreign.Ptr (castPtr, plusPtr) +import Numeric.Natural (Natural) +import Data.Finite (Finite) +import Control.Monad.Trans.State.Strict (evalState, get, modify, put) + +import qualified Data.Binary as Bin +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM + +-- | An opaque wrapper around @a@, representing each value as a byte string. +newtype PackBytes (a :: Type) = PackBytes (VU.Vector Word8) + deriving (Eq, Ord, Show) + +type role PackBytes nominal + +-- | To provide (something that resembles a) data constructor for 'PackBytes', we +-- provide the following pattern. It can be used like any other data +-- constructor: +-- +-- > import Data.Finitary.PackBytes +-- > +-- > anInt :: PackBytes Int +-- > anInt = Packed 10 +-- > +-- > isPackedEven :: PackBytes Int -> Bool +-- > isPackedEven (Packed x) = even x +-- +-- __Every__ pattern match, and data constructor call, performs a +-- \(\Theta(\log_{256}(\texttt{Cardinality a}))\) encoding or decoding of @a@. +-- 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 + +instance Bin.Binary (PackBytes a) where + {-# INLINE put #-} + put = Bin.put . op PackBytes + {-# INLINE get #-} + get = PackBytes <$> Bin.get + +instance Hashable (PackBytes a) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt = hashWithSalt salt . op PackBytes + +instance NFData (PackBytes a) where + {-# INLINE rnf #-} + rnf = rnf . op PackBytes + +instance (Finitary a, 1 <= Cardinality a) => Finitary (PackBytes a) where + type Cardinality (PackBytes a) = Cardinality a + {-# INLINE fromFinite #-} + fromFinite = PackBytes . intoBytes + {-# INLINE toFinite #-} + toFinite = outOfBytes . op PackBytes + +instance (Finitary a, 1 <= Cardinality a) => Bounded (PackBytes a) where + {-# INLINE minBound #-} + minBound = start + {-# INLINE maxBound #-} + maxBound = end + +instance (Finitary a, 1 <= Cardinality a) => Storable (PackBytes a) where + {-# INLINE sizeOf #-} + sizeOf _ = byteLength @a + {-# INLINE alignment #-} + alignment _ = alignment (undefined :: Word8) + {-# INLINE peek #-} + peek ptr = do let bytePtr = castPtr ptr + PackBytes <$> VU.generateM (byteLength @a) (peek . plusPtr bytePtr) + {-# INLINE poke #-} + poke ptr (PackBytes v) = do let bytePtr = castPtr ptr + VU.foldM'_ go bytePtr v + where go p e = poke p e >> pure (plusPtr p 1) + +newtype instance VU.MVector s (PackBytes a) = MV_PackBytes (VU.MVector s Word8) + +instance (Finitary a, 1 <= Cardinality a) => VGM.MVector VU.MVector (PackBytes a) where + {-# INLINE basicLength #-} + basicLength = over MV_PackBytes ((`div` byteLength @a) . VGM.basicLength) + {-# INLINE basicOverlaps #-} + basicOverlaps = over2 MV_PackBytes VGM.basicOverlaps + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over MV_PackBytes (VGM.basicUnsafeSlice (i * byteLength @a) (len * byteLength @a)) + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew len = MV_PackBytes <$> VGM.basicUnsafeNew (len * byteLength @a) + {-# INLINE basicInitialize #-} + basicInitialize = VGM.basicInitialize . op MV_PackBytes + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_PackBytes v) i = fmap PackBytes . VG.freeze . VGM.unsafeSlice (i * byteLength @a) (byteLength @a) $ v + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_PackBytes v) i (PackBytes x) = let slice = VGM.unsafeSlice (i * byteLength @a) (byteLength @a) v in + VG.unsafeCopy slice x + +newtype instance VU.Vector (PackBytes a) = V_PackBytes (VU.Vector Word8) + +instance (Finitary a, 1 <= Cardinality a) => VG.Vector VU.Vector (PackBytes a) where + {-# INLINE basicLength #-} + basicLength = over V_PackBytes ((`div` byteLength @a) . VG.basicLength) + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze = fmap V_PackBytes . VG.basicUnsafeFreeze . op MV_PackBytes + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw = fmap MV_PackBytes . VG.basicUnsafeThaw . op V_PackBytes + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over V_PackBytes (VG.basicUnsafeSlice (i * byteLength @a) (len * byteLength @a)) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_PackBytes v) i = pure . PackBytes . VG.unsafeSlice (i * byteLength @a) (byteLength @a) $ v + +instance (Finitary a, 1 <= Cardinality a) => VU.Unbox (PackBytes a) + +-- Helpers + +type ByteLength a = CLog (Cardinality Word8) (Cardinality a) + +{-# INLINE byteLength #-} +byteLength :: forall (a :: Type) (b :: Type) . + (Finitary a, 1 <= Cardinality a, Num b) => + b +byteLength = fromIntegral . natVal $ (Proxy :: Proxy (ByteLength a)) + +{-# INLINE packBytes #-} +packBytes :: forall (a :: Type) . + (Finitary a, 1 <= Cardinality a) => + a -> PackBytes a +packBytes = fromFinite . toFinite + +{-# INLINE unpackBytes #-} +unpackBytes :: forall (a :: Type) . + (Finitary a, 1 <= Cardinality a) => + PackBytes a -> a +unpackBytes = fromFinite . toFinite + +{-# INLINE intoBytes #-} +intoBytes :: forall (n :: Nat) . + (KnownNat n, 1 <= n) => + Finite n -> VU.Vector Word8 +intoBytes = evalState (VU.replicateM (byteLength @(Finite n)) go) . fromIntegral @_ @Natural + where go = do remaining <- get + let (d, r) = quotRem remaining 256 + put d >> pure (fromIntegral r) + +{-# INLINE outOfBytes #-} +outOfBytes :: forall (n :: Nat) . + (KnownNat n) => + VU.Vector Word8 -> Finite n +outOfBytes v = evalState (VU.foldM' go 0 v) 1 + where go old w = do power <- get + let placeValue = power * fromIntegral w + modify (* 256) + return (old + placeValue) diff --git a/src/Data/Finitary/PackInto.hs b/src/Data/Finitary/PackInto.hs new file mode 100644 --- /dev/null +++ b/src/Data/Finitary/PackInto.hs @@ -0,0 +1,196 @@ +{- + - Copyright (C) 2019 Koz Ross + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU General Public License for more details. + - + - You should have received a copy of the GNU General Public License + - along with this program. If not, see . + -} + +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- Module: Data.Finitary.PackInto +-- Description: Scheme for packing @Finitary@ types into other @Finitary@ +-- types. +-- Copyright: (C) Koz Ross 2019 +-- License: GPL version 3.0 or later +-- Maintainer: koz.ross@retro-freedom.nz +-- Stability: Experimental +-- Portability: GHC only +-- +-- This allows us to \'borrow\' implementations of certain type classes from +-- \'larger\' finitary types for \'smaller\' finitary types. Essentially, for +-- any types @a@ and @b@, if both @a@ and @b@ are 'Finitary' and @Cardinality a +-- <= Cardinality b@, the set of indexes for @a@ is a subset (strictly speaking, +-- a prefix) of the set of indexes for @b@. Therefore, we have an injective +-- mapping from @a@ to @b@, whose +-- [preimage](https://en.wikipedia.org/wiki/Preimage) +-- is also injective, witnessed by the function @fromFinite . toFinite@ in both +-- directions. When combined with the monotonicity of @toFinite@ and +-- @fromFinite@, we can operate on inhabitants of @b@ in certain ways while +-- always being able to recover the \'equivalent\' inhabitant of @a@. +-- +-- On this basis, we can \'borrow\' both 'VU.Unbox' and 'Storable' instances +-- from @b@. This is done by way of the @PackInto a b@ type; here, @a@ is the +-- type to which instances are being \'lent\' and @b@ is the type from which +-- instances are being \'borrowed\'. @PackInto a b@ does not store any values of +-- type @a@ - construction and deconstruction of @PackInto@ performs a +-- conversion as described above. +-- +-- If an existing 'Finitary' type exists with desired instances, this encoding +-- is the most flexible and efficient. Unless you have good reasons to consider +-- something else (such as space use), use this encoding. However, its +-- usefulness is conditional on a suitable \'packing\' type existing of +-- appropriate cardinality. Additionally, if @Cardinality a < Cardinality b@, +-- any @PackInto a b@ will waste some space, with larger cardinality differences +-- creating proportionately more waste. +module Data.Finitary.PackInto +( + PackInto, pattern Packed +) where + +import GHC.TypeNats +import Data.Vector.Instances () +import Data.Kind (Type) +import CoercibleUtils (op, over, over2) +import Data.Hashable (Hashable(..)) +import Control.DeepSeq (NFData(..)) +import Foreign.Storable (Storable(..)) +import Foreign.Ptr (castPtr) +import Data.Finitary (Finitary(..)) +import Data.Finite (weakenN, strengthenN) +import Data.Maybe (fromJust) +import Data.Ord (comparing) + +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM + +-- | An opaque wrapper, representing values of type @a@ as \'corresponding\' +-- values of type @b@. +newtype PackInto (a :: Type) (b :: Type) = PackInto b + deriving (Eq, Show) + +type role PackInto nominal nominal + +-- | To provide (something that resembles a) data constructor for 'PackInto', we +-- provide the following pattern. It can be used like any other data +-- constructor: +-- +-- > import Data.Finitary.PackInt +-- > +-- > anInt :: PackInto Int Word +-- > anInt = Packed 10 +-- > +-- > isPackedEven :: PackInto Int Word -> Bool +-- > isPackedEven (Packed x) = even x +-- +-- __Every__ pattern match, and data constructor call, performs a re-encoding by +-- way of @fromFinite . toFinite@ on @b@ and @a@ respectively. Use with this in +-- mind. +pattern Packed :: forall (b :: Type) (a :: Type) . + (Finitary a, Finitary b, Cardinality a <= Cardinality b) => + PackInto a b -> a +pattern Packed x <- (packInto -> x) + where Packed x = unpackOutOf x + +instance (Finitary a, Finitary b, Cardinality a <= Cardinality b) => Ord (PackInto a b) where + {-# INLINE compare #-} + compare = comparing toFinite + +instance (Hashable b) => Hashable (PackInto a b) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt = over PackInto (hashWithSalt salt) + +instance (NFData b) => NFData (PackInto a b) where + {-# INLINE rnf #-} + rnf = over PackInto rnf + +instance (Storable b) => Storable (PackInto a b) where + {-# INLINE sizeOf #-} + sizeOf = over PackInto sizeOf + {-# INLINE alignment #-} + alignment = over PackInto alignment + {-# INLINE peek #-} + peek = fmap PackInto . peek . castPtr + {-# INLINE poke #-} + poke ptr = poke (castPtr ptr) . op PackInto + +-- We can pack a into b if the cardinality of b is at least as large as a (could +-- be larger) +instance (Finitary a, Finitary b, Cardinality a <= Cardinality b) => Finitary (PackInto a b) where + type Cardinality (PackInto a b) = Cardinality a + {-# INLINE fromFinite #-} + fromFinite = PackInto . fromFinite . weakenN + {-# INLINE toFinite #-} + toFinite = fromJust . strengthenN . toFinite . op PackInto + +instance (Finitary a, Finitary b, 1 <= Cardinality a, Cardinality a <= Cardinality b) => Bounded (PackInto a b) where + {-# INLINE minBound #-} + minBound = start + {-# INLINE maxBound #-} + maxBound = end + +newtype instance VU.MVector s (PackInto a b) = MV_PackInto (VU.MVector s b) + +instance (VU.Unbox b) => VGM.MVector VU.MVector (PackInto a b) where + {-# INLINE basicLength #-} + basicLength = over MV_PackInto VGM.basicLength + {-# INLINE basicOverlaps #-} + basicOverlaps = over2 MV_PackInto VGM.basicOverlaps + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over MV_PackInto (VGM.basicUnsafeSlice i len) + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew len = MV_PackInto <$> VGM.basicUnsafeNew len + {-# INLINE basicInitialize #-} + basicInitialize = VGM.basicInitialize . op MV_PackInto + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_PackInto v) i = PackInto <$> VGM.basicUnsafeRead v i + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_PackInto v) i (PackInto x) = VGM.basicUnsafeWrite v i x + +newtype instance VU.Vector (PackInto a b) = V_PackInto (VU.Vector b) + +instance (VU.Unbox b) => VG.Vector VU.Vector (PackInto a b) where + {-# INLINE basicLength #-} + basicLength = over V_PackInto VG.basicLength + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze = fmap V_PackInto . VG.basicUnsafeFreeze . op MV_PackInto + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw = fmap MV_PackInto . VG.basicUnsafeThaw . op V_PackInto + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over V_PackInto (VG.basicUnsafeSlice i len) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_PackInto v) i = PackInto <$> VG.basicUnsafeIndexM v i + +instance (VU.Unbox b) => VU.Unbox (PackInto a b) + +-- Helpers + +{-# INLINE packInto #-} +packInto :: forall (b :: Type) (a :: Type) . + (Finitary a, Finitary b, Cardinality a <= Cardinality b) => + a -> PackInto a b +packInto = fromFinite . toFinite + +{-# INLINE unpackOutOf #-} +unpackOutOf :: forall (b :: Type) (a :: Type) . + (Finitary a, Finitary b, Cardinality a <= Cardinality b) => + PackInto a b -> a +unpackOutOf = fromFinite . toFinite diff --git a/src/Data/Finitary/PackWords.hs b/src/Data/Finitary/PackWords.hs new file mode 100644 --- /dev/null +++ b/src/Data/Finitary/PackWords.hs @@ -0,0 +1,239 @@ +{- + - Copyright (C) 2019 Koz Ross + - + - This program is free software: you can redistribute it and/or modify + - it under the terms of the GNU General Public License as published by + - the Free Software Foundation, either version 3 of the License, or + - (at your option) any later version. + - + - This program is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU General Public License for more details. + - + - You should have received a copy of the GNU General Public License + - along with this program. If not, see . + -} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module: Data.Finitary.PackBytes +-- Description: Scheme for packing @Finitary@ types into @Word@ arrays. +-- Copyright: (C) Koz Ross 2019 +-- License: GPL version 3.0 or later +-- Maintainer: koz.ross@retro-freedom.nz +-- Stability: Experimental +-- Portability: GHC only +-- +-- If a type @a@ is 'Finitary', each inhabitant of @a@ has an index, which can +-- be represented as an unsigned integer, spread across one or more machine +-- words. This unsigned integer will have fixed length (as the number of +-- inhabitants of @a@ is finite). We can use this to derive a 'VU.Unbox' +-- instance, by representing 'VU.Vector' as a large array of machine words. We +-- can also derive a 'Storable' instance similarly. +-- +-- This is the most efficient encoding of an arbitrary finitary type, both due +-- to the asymptotics of encoding and decoding (logarithmic in @Cardinality a@ +-- with base @Cardinality Word@) and the fact that word accesses are faster than +-- byte and bit accesses on almost all architectures. Unless you have concerns +-- regarding space, this encoding is a good choice. +-- +-- Unless your type's cardinality is extremely large (a non-trivial multiple of +-- @Cardinality Word@), this encoding is wasteful. If your type's cardinality is +-- smaller than that of @Word@, you should consider "Data.Finitary.PackInto" +-- instead, as you will have much larger control over space usage at almost no +-- performance penalty. +module Data.Finitary.PackWords +( + PackWords, pattern Packed +) where + +import Data.Vector.Binary () +import Data.Vector.Instances () +import GHC.TypeNats +import Data.Proxy (Proxy(..)) +import GHC.TypeLits.Extra +import CoercibleUtils (op, over, over2) +import Data.Kind (Type) +import Data.Finitary (Finitary(..)) +import Data.Finite (Finite) +import Foreign.Storable (Storable(..)) +import Foreign.Ptr (castPtr, plusPtr) +import Numeric.Natural (Natural) +import Data.Hashable (Hashable(..)) +import Control.DeepSeq (NFData(..)) +import Control.Monad.Trans.State.Strict (evalState, get, modify, put) + +import qualified Data.Binary as Bin +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM + +-- | 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) + +type role PackWords nominal + +-- | To provide (something that resembles a) data constructor for 'PackWords', we +-- provide the following pattern. It can be used like any other data +-- constructor: +-- +-- > import Data.Finitary.PackWords +-- > +-- > anInt :: PackWords Int +-- > anInt = Packed 10 +-- > +-- > isPackedEven :: PackWords Int -> Bool +-- > isPackedEven (Packed x) = even x +-- +-- __Every__ pattern match, and data constructor call, performs a +-- \(\Theta(\log_{\texttt{Cardinality Word}}(\texttt{Cardinality a}))\) encoding or decoding of @a@. +-- 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 + +instance Bin.Binary (PackWords a) where + {-# INLINE put #-} + put = Bin.put . op PackWords + {-# INLINE get #-} + get = PackWords <$> Bin.get + +instance Hashable (PackWords a) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt = hashWithSalt salt . op PackWords + +instance NFData (PackWords a) where + {-# INLINE rnf #-} + rnf = rnf . op PackWords + +instance (Finitary a, 1 <= Cardinality a) => Finitary (PackWords a) where + type Cardinality (PackWords a) = Cardinality a + {-# INLINE fromFinite #-} + fromFinite = PackWords . intoWords + {-# INLINE toFinite #-} + toFinite = outOfWords . op PackWords + +instance (Finitary a, 1 <= Cardinality a) => Bounded (PackWords a) where + {-# INLINE minBound #-} + minBound = start + {-# INLINE maxBound #-} + maxBound = end + +instance (Finitary a, 1 <= Cardinality a) => Storable (PackWords a) where + {-# INLINE sizeOf #-} + sizeOf _ = wordLength @a * bytesPerWord + {-# INLINE alignment #-} + alignment _ = alignment (undefined :: Word) + {-# INLINE peek #-} + peek ptr = do let wordPtr = castPtr ptr + PackWords <$> VU.generateM (wordLength @a) (peek . plusPtr wordPtr . (* bytesPerWord)) + {-# INLINE poke #-} + poke ptr (PackWords v) = do let wordPtr = castPtr ptr + VU.foldM'_ go wordPtr v + where go p e = poke p e >> pure (plusPtr p bytesPerWord) + +newtype instance VU.MVector s (PackWords a) = MV_PackWords (VU.MVector s Word) + +instance (Finitary a, 1 <= Cardinality a) => VGM.MVector VU.MVector (PackWords a) where + {-# INLINE basicLength #-} + basicLength = over MV_PackWords ((`div` wordLength @a) . VGM.basicLength) + {-# INLINE basicOverlaps #-} + basicOverlaps = over2 MV_PackWords VGM.basicOverlaps + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over MV_PackWords (VGM.basicUnsafeSlice (i * wordLength @a) (len * wordLength @a)) + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew len = MV_PackWords <$> VGM.basicUnsafeNew (len * wordLength @a) + {-# INLINE basicInitialize #-} + basicInitialize = VGM.basicInitialize . op MV_PackWords + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_PackWords v) i = fmap PackWords . VG.freeze . VGM.unsafeSlice (i * wordLength @a) (wordLength @a) $ v + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_PackWords v) i (PackWords x) = let slice = VGM.unsafeSlice (i * wordLength @a) (wordLength @a) v in + VG.unsafeCopy slice x + +newtype instance VU.Vector (PackWords a) = V_PackWords (VU.Vector Word) + +instance (Finitary a, 1 <= Cardinality a) => VG.Vector VU.Vector (PackWords a) where + {-# INLINE basicLength #-} + basicLength = over V_PackWords ((`div` wordLength @a) . VG.basicLength) + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze = fmap V_PackWords . VG.basicUnsafeFreeze . op MV_PackWords + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw = fmap MV_PackWords . VG.basicUnsafeThaw . op V_PackWords + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i len = over V_PackWords (VG.basicUnsafeSlice (i * wordLength @a) (len * wordLength @a)) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_PackWords v) i = pure . PackWords . VG.unsafeSlice (i * wordLength @a) (wordLength @a) $ v + +instance (Finitary a, 1 <= Cardinality a) => VU.Unbox (PackWords a) + +-- Helpers + +type WordLength a = CLog (Cardinality Word) (Cardinality a) + +{-# INLINE bitsPerWord #-} +bitsPerWord :: forall (a :: Type) . + (Num a) => + a +bitsPerWord = 8 * bytesPerWord + +{-# INLINE bytesPerWord #-} +bytesPerWord :: forall (a :: Type) . + (Num a) => + a +bytesPerWord = fromIntegral . sizeOf $ (undefined :: Word) + +{-# INLINE wordLength #-} +wordLength :: forall (a :: Type) (b :: Type) . + (Finitary a, 1 <= Cardinality a, Num b) => + b +wordLength = fromIntegral . natVal $ (Proxy :: Proxy (WordLength a)) + +{-# INLINE packWords #-} +packWords :: forall (a :: Type) . + (Finitary a, 1 <= Cardinality a) => + a -> PackWords a +packWords = fromFinite . toFinite + +{-# INLINE unpackWords #-} +unpackWords :: forall (a :: Type) . + (Finitary a, 1 <= Cardinality a) => + PackWords a -> a +unpackWords = fromFinite . toFinite + +{-# INLINE intoWords #-} +intoWords :: forall (n :: Nat) . + (KnownNat n, 1 <= n) => + Finite n -> VU.Vector Word +intoWords = evalState (VU.replicateM (wordLength @(Finite n)) go) . fromIntegral @_ @Natural + where go = do remaining <- get + let (d, r) = quotRem remaining bitsPerWord + put d >> pure (fromIntegral r) + +{-# INLINE outOfWords #-} +outOfWords :: forall (n :: Nat) . + (KnownNat n) => + VU.Vector Word -> Finite n +outOfWords v = evalState (VU.foldM' go 0 v) 1 + where go old w = do power <- get + let placeValue = power * fromIntegral w + modify (* bitsPerWord) + return (old + placeValue) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -20,6 +20,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} module Main where @@ -32,18 +33,26 @@ import Data.Finitary (Finitary(..)) import Data.Finite (Finite) import Data.Proxy (Proxy(..)) -import Control.Monad.Loops (andM) +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable(..)) +import Data.Binary (Binary) +import Foreign.Storable (Storable) import qualified Hedgehog.Gen as G import qualified Hedgehog.Range as R -import Data.Finitary.Pack (Pack) +import Data.Finitary.Finiteness (Finiteness(..)) +import Data.Finitary.PackBytes (PackBytes) +import Data.Finitary.PackWords (PackWords) +import Data.Finitary.PackInto (PackInto) data Foo = Bar | Baz Word8 Word8 | Quux Word16 deriving (Eq, Show, Generic, Finitary) + deriving (Ord, Bounded, NFData, Hashable, Binary) via (Finiteness Foo) data Big = Big Word64 Word64 deriving (Eq, Show, Generic, Finitary) + deriving (Ord, Bounded, NFData, Hashable, Binary) via (Finiteness Big) -- Generators choose :: forall (a :: Type) m . (MonadGen m, Finitary a) => m a @@ -53,10 +62,22 @@ chooseFinite = fromIntegral <$> G.integral (R.linear 0 limit) where limit = subtract @Integer 1 . fromIntegral . natVal @n $ Proxy +finitenessLaws :: (Show a, Binary a, Ord a) => Gen a -> [Laws] +finitenessLaws p = [binaryLaws p, ordLaws p] + +packLaws :: (Eq a, Show a, Storable a) => Gen a -> [Laws] +packLaws p = [storableLaws p] + +finitenessTests :: [(String, [Laws])] +finitenessTests = [("Small Finiteness", finitenessLaws @Foo choose), + ("Big Finiteness", finitenessLaws @Big choose)] + +packTests :: [(String, [Laws])] +packTests = [("Small PackBytes", packLaws @(PackBytes Foo) choose), + ("Big PackBytes", packLaws @(PackBytes Big) choose), + ("Small PackWords", packLaws @(PackWords Foo) choose), + ("Big PackWords", packLaws @(PackWords Big) choose), + ("Small packed into Word64", packLaws @(PackInto Foo Word64) choose)] + main :: IO Bool -main = andM . fmap lawsCheck $ [binaryLaws @(Pack Foo) choose, - binaryLaws @(Pack Big) choose, - binaryLaws @(Pack Int) choose, - storableLaws @(Pack Foo) choose, - storableLaws @(Pack Big) choose, - storableLaws @(Pack Int) choose] +main = (&&) <$> lawsCheckMany finitenessTests <*> lawsCheckMany packTests