finitary-derive 1.0.0.1 → 2.0.0.0

raw patch · 11 files changed

+1394/−224 lines, 11 filesdep +bitvecdep +transformersdep +vector-binary-instancesdep −monad-loopsdep −mtldep −vector-sizeddep ~binarydep ~deepseqdep ~finitaryPVP ok

version bump matches the API change (PVP)

Dependencies added: bitvec, transformers, vector-binary-instances, vector-instances

Dependencies removed: monad-loops, mtl, vector-sized

Dependency ranges changed: binary, deepseq, finitary, hashable

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• README.md +84/−15
• finitary-derive.cabal +22/−11
• src/Data/Finitary/Finiteness.hs +145/−0
• src/Data/Finitary/Pack.hs +0/−190
• src/Data/Finitary/PackBits.hs +221/−0
• src/Data/Finitary/PackBits/Unsafe.hs +221/−0
• src/Data/Finitary/PackBytes.hs +228/−0
• src/Data/Finitary/PackInto.hs +196/−0
• src/Data/Finitary/PackWords.hs +239/−0
• test/Main.hs +29/−8

@@ -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.

@@ -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

@@ -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

@@ -0,0 +1,145 @@+{-+ - Copyright (C) 2019  Koz Ross <koz.ross@retro-freedom.nz>+ -+ - 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 <http://www.gnu.org/licenses/>.+ -}++{-# 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

@@ -1,190 +0,0 @@-{-- - Copyright (C) 2019  Koz Ross <koz.ross@retro-freedom.nz>- -- - 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 <http://www.gnu.org/licenses/>.- -}--{-# 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

@@ -0,0 +1,221 @@+{-+ - Copyright (C) 2019  Koz Ross <koz.ross@retro-freedom.nz>+ -+ - 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 <http://www.gnu.org/licenses/>.+ -}++{-# 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)

@@ -0,0 +1,221 @@+{-+ - Copyright (C) 2019  Koz Ross <koz.ross@retro-freedom.nz>+ -+ - 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 <http://www.gnu.org/licenses/>.+ -}++{-# 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)

@@ -0,0 +1,228 @@+{-+ - Copyright (C) 2019  Koz Ross <koz.ross@retro-freedom.nz>+ -+ - 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 <http://www.gnu.org/licenses/>.+ -}++{-# 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) 

@@ -0,0 +1,196 @@+{-+ - Copyright (C) 2019  Koz Ross <koz.ross@retro-freedom.nz>+ -+ - 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 <http://www.gnu.org/licenses/>.+ -}++{-# 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

@@ -0,0 +1,239 @@+{-+ - Copyright (C) 2019  Koz Ross <koz.ross@retro-freedom.nz>+ -+ - 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 <http://www.gnu.org/licenses/>.+ -}++{-# 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)

@@ -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