finitary-derive 2.2.0.1 → 3.0.0.1

raw patch · 9 files changed

+821/−550 lines, 9 filesdep +ghc-bignumdep +integer-gmpdep +primitivedep −transformersdep ~basedep ~binarydep ~bitvecPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-bignum, integer-gmp, primitive

Dependencies removed: transformers

Dependency ranges changed: base, binary, bitvec, coercible-utils, deepseq, finitary, finite-typelits, hashable, hedgehog-classes, vector, vector-binary-instances

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• finitary-derive.cabal +90/−37
• src/Data/Finitary/Finiteness.hs +17/−6
• src/Data/Finitary/PackBits.hs +141/−66
• src/Data/Finitary/PackBits/Unsafe.hs +3/−249
• src/Data/Finitary/PackBytes.hs +224/−74
• src/Data/Finitary/PackInto.hs +1/−0
• src/Data/Finitary/PackWords.hs +200/−78
• test/Main.hs +136/−40

@@ -1,5 +1,14 @@ # Revision history for finitary-derive
 
+## 3.0.0.1 -- 2021-02-10
+
+* Use ``ByteArray`` for packed data internally,
+  re-using the ``BigNat`` functionality where possible.
+  This significantly improves the performance of packing/unpacking operations.
+* Export internal packing/unpacking functions and newtype wrappers.
+* Add ``COMPLETE`` pragmas to ``Packed`` pattern synonyms.
+* Adapt to using ``ghc-bignum`` on GHC 9.0 and above.
+
 ## 2.2.0.1 -- 2021-02-09
 
 * Update bounds for compatibility with GHC 9.0

@@ -3,7 +3,7 @@ -- PVP summary:        +-+------- breaking API changes
 --                     | | +----- non-breaking API additions
 --                     | | | +--- code changes with no API change
-version:               2.2.0.1
+version:               3.0.0.1
 synopsis:              Flexible and easy deriving of type classes for finitary
                        types.
 description:           Provides a collection of wrappers, allowing you to easily
@@ -27,42 +27,95 @@ extra-source-files:    CHANGELOG.md,
                        README.md
 
+common common
+
+  build-depends:
+    finitary
+      >= 1.2.0.0 && < 2.2,
+
+    base
+      >= 4.11 && < 4.16,
+    binary
+      >= 0.8.5.1 && < 0.11,
+    deepseq
+      >= 1.4.3.0 && < 1.5,
+    finite-typelits
+      >= 0.1.4.2 && < 0.2,
+    hashable
+      >= 1.3.0.0 && < 1.4,
+    vector
+      >= 0.12.0.3 && < 0.13,
+
+  default-language:
+    Haskell2010
+
+  ghc-options:
+    -Wall -Wcompat
+
 library
-  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.16,
-                       finitary >= 1.2.0.0 && < 2.2,
-                       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,
-                       binary >= 0.8.5.1 && < 0.11.0.0,
-                       deepseq >= 1.4.3.0 && < 1.5.0.0,
-                       hashable >= 1.3.0.0 && < 1.4.0.0,
-                       ghc-typelits-extra >= 0.3.1 && < 0.5,
-                       ghc-typelits-knownnat >= 0.7 && < 0.8,
-                       vector-instances >= 3.4 && < 3.5,
-                       transformers >= 0.5.5.0 && < 0.6.0.0,
-                       bitvec >= 1.0.2.0 && < 1.2.0.0,
-                       vector-binary-instances >= 0.2.5.1 && < 0.3.0.0
-  hs-source-dirs:      src
-  default-language:    Haskell2010
 
+  import:
+    common
+
+  hs-source-dirs:
+    src
+
+  exposed-modules:
+    Data.Finitary.Finiteness,
+    Data.Finitary.PackBits,
+    Data.Finitary.PackBits.Unsafe,
+    Data.Finitary.PackBytes,
+    Data.Finitary.PackWords,
+    Data.Finitary.PackInto
+
+  build-depends:
+    bitvec
+      >= 1.1.1.0 && < 1.2,
+    coercible-utils
+      >= 0.0.0 && < 0.1,
+    ghc-typelits-extra
+      >= 0.3.1 && < 0.5,
+    ghc-typelits-knownnat
+      >= 0.7 && < 0.8,
+    primitive
+      >= 0.7.1.0 && < 0.8,
+    vector-instances
+      >= 3.4 && < 3.5,
+    vector-binary-instances
+      >= 0.2.5.1 && < 0.3,
+
+  if impl(ghc >= 9.0)
+    cpp-options:
+      -DBIGNUM
+    build-depends:
+      ghc-bignum
+        >= 1.0 && < 1.1,
+  else
+    build-depends:
+      integer-gmp
+        >= 1.0.2.0 && < 1.2,
+
 test-suite tests
-  type:                exitcode-stdio-1.0
-  main-is:             Main.hs
-  ghc-options:         -O2 -threaded -rtsopts -with-rtsopts=-N
-  hs-source-dirs:      test
-  build-depends:       base >= 4.12 && < 4.16,
-                       hedgehog >= 1.0.1 && < 1.1,
-                       hedgehog-classes >= 0.2.4 && < 0.3.0,
-                       finitary-derive,
-                       finitary,
-                       finite-typelits,
-                       hashable,
-                       binary,
-                       deepseq
-  default-language:    Haskell2010
+
+  import:
+    common
+
+  hs-source-dirs:
+    test
+
+  main-is:
+    Main.hs
+
+  type:
+    exitcode-stdio-1.0
+
+  build-depends:
+    finitary-derive,
+
+    hedgehog
+      >= 1.0.1 && < 1.1,
+    hedgehog-classes
+      >= 0.2.4 && < 0.3,
+
+  ghc-options:
+    -O2 -threaded -rtsopts -with-rtsopts=-N

@@ -81,15 +81,26 @@   Finiteness(..)
 ) where
 
-import GHC.TypeNats
-import Data.Typeable (Typeable)
+-- base
 import Data.Data (Data)
-import Data.Finitary (Finitary(..))
 import Data.Ord (comparing)
+import Data.Typeable (Typeable)
+import GHC.TypeNats
+
+-- binary
+import Data.Binary (Binary(..))
+
+-- deepseq
 import Control.DeepSeq (NFData(..))
+
+-- finitary
+import Data.Finitary (Finitary(..))
+
+-- hashable
 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 }
@@ -114,7 +125,7 @@ 
 -- | 'Ord' can be derived by deferring to the order on @Finite (Cardinality a)@.
 instance (Finitary a) => Ord (Finiteness a) where
-  {-# INLINE compare #-}
+  {-# INLINABLE compare #-}
   compare (Finiteness x) (Finiteness y) = comparing toFinite x y
 
 -- | Since any inhabited 'Finitary' type is also 'Bounded', we can forward this
@@ -132,7 +143,7 @@ 
 -- | Any 'Finitary' type can be hashed by hashing its index.
 instance (Finitary a) => Hashable (Finiteness a) where 
-  {-# INLINE hashWithSalt #-}
+  {-# INLINABLE hashWithSalt #-}
   hashWithSalt salt = hashWithSalt salt . fromIntegral @_ @Integer . toFinite . unFiniteness
 
 -- | Any 'Finitary' type can be converted to a binary representation by

@@ -18,21 +18,25 @@ {-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-}
 {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
 
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ViewPatterns #-}
 
+#ifndef BITVEC_UNSAFE
 -- |
 -- Module:        Data.Finitary.PackBits
 -- Description:   Scheme for bit-packing @Finitary@ types.
@@ -66,36 +70,107 @@ -- 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,
-  BulkPack, exposeVector
-) where
+#else
+-- |
+-- Module:        Data.Finitary.PackBits.Unsafe
+-- Description:   Scheme for bit-packing @Finitary@ types.
+-- Copyright:     (C) Koz Ross 2019
+-- License:       GPL version 3.0 or later
+-- Stability:     Experimental
+-- Portability:   GHC only
+--
+-- From the [Kraft-McMillan
+-- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality)
+-- and 
+-- the fact that we are not able to have \'fractional\' bits, we can derive a
+-- fixed-length code into a bitstring for any 'Finitary' type @a@, with code
+-- length \(\lceil \log_{2}(\texttt{Cardinality a}) \rceil\) bits. This code is
+-- 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
+#endif
+  ( -- * Packing and unpacking between a type and a bit vector
+    PackBits(PackedBits, Packed)
+  , BulkPack, exposeVector
+  
+  -- * Helpers
+  , intoBits, outOfBits
+  )
+where
 
-import GHC.TypeLits.Extra
-import Data.Proxy (Proxy(..))
-import Numeric.Natural (Natural)
-import GHC.TypeNats
-import CoercibleUtils (op, over, over2)
+-- base
 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 Data.Semigroup (Dual(..))
+import GHC.Exts
+import GHC.TypeNats
 
+-- binary
 import qualified Data.Binary as Bin
-import qualified Data.Bit.ThreadSafe as BT
-import qualified Data.Vector.Generic as VG
+
+-- bitvec
+#ifndef BITVEC_UNSAFE
+import qualified Data.Bit.ThreadSafe as BV
+#else
+import qualified Data.Bit as BV
+#endif
+
+-- coercible-utils
+import CoercibleUtils (op, over, over2)
+
+-- deepseq
+import Control.DeepSeq (NFData(..))
+
+-- finitary
+import Data.Finitary (Finitary(..))
+
+-- finitary-derive
+import Data.Finitary.PackWords
+  ( PackWords(PackedWords), intoWords, outOfWords )
+
+-- finite-typelits
+import Data.Finite.Internal (Finite(..))
+
+-- ghc-typelits-extra
+import GHC.TypeLits.Extra
+
+-- primitive
+import Data.Primitive.ByteArray (ByteArray(..))
+
+-- vector
+import qualified Data.Vector.Unboxed.Base    as VU
+import qualified Data.Vector.Generic         as VG
 import qualified Data.Vector.Generic.Mutable as VGM
-import qualified Data.Vector.Unboxed as VU
 
+-- vector-binary-instances
+import Data.Vector.Binary ()
+
+-- vector-instances
+import Data.Vector.Instances ()
+
+--------------------------------------------------------------------------------
+
 -- | An opaque wrapper around @a@, representing each value as a 'bit-packed'
 -- encoding.
-newtype PackBits (a :: Type) = PackBits (VU.Vector BT.Bit)
+newtype PackBits (a :: Type) = PackedBits (VU.Vector BV.Bit)
   deriving (Eq, Show)
 
 type role PackBits nominal
@@ -115,26 +190,28 @@ -- __Every__ pattern match, and data constructor call, performs a
 -- \(\Theta(\log_{2}(\texttt{Cardinality a}))\) encoding or decoding operation. 
 -- Use with this in mind.
+{-# COMPLETE Packed #-}
 pattern Packed :: forall (a :: Type) . 
   (Finitary a, 1 <= Cardinality a) => 
   a -> PackBits a
 pattern Packed x <- (unpackBits -> x)
   where Packed x = packBits x
 
-instance Ord (PackBits a) where
-  compare (PackBits v1) (PackBits v2) = getDual . VU.foldr go (Dual EQ) . VU.zipWith (,) v1 $ v2
-    where go input order = (order <>) . Dual . uncurry compare $ input
+instance (Finitary a, 1 <= Cardinality a) => Ord (PackBits a) where
+  {-# INLINABLE compare #-}
+  compare (PackedBits (BV.BitVec _ _ v1)) (PackedBits (BV.BitVec _ _ v2)) =
+    compare (PackedWords v1 :: PackWords a) (PackedWords v2 :: PackWords a)
 
 instance NFData (PackBits a) where
   {-# INLINE rnf #-}
-  rnf = rnf . op PackBits
+  rnf = rnf . op PackedBits
 
 instance (Finitary a, 1 <= Cardinality a) => Finitary (PackBits a) where
   type Cardinality (PackBits a) = Cardinality a
   {-# INLINE fromFinite #-}
-  fromFinite = PackBits . intoBits
+  fromFinite = PackedBits . intoBits
   {-# INLINE toFinite #-}
-  toFinite = outOfBits . op PackBits
+  toFinite = outOfBits . op PackedBits
 
 instance (Finitary a, 1 <= Cardinality a) => Bounded (PackBits a) where
   {-# INLINE minBound #-}
@@ -142,26 +219,26 @@   {-# INLINE maxBound #-}
   maxBound = end
 
-newtype instance VU.MVector s (PackBits a) = MV_PackBits (VU.MVector s BT.Bit)
+newtype instance VU.MVector s (PackBits a) = MV_PackBits (VU.MVector s BV.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 #-}
+  {-# INLINABLE basicUnsafeSlice #-}
   basicUnsafeSlice i len = over MV_PackBits (VGM.basicUnsafeSlice (i * bitLength @a) (len * bitLength @a))
-  {-# INLINE basicUnsafeNew #-}
+  {-# INLINABLE 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
+  {-# INLINABLE basicUnsafeRead #-}
+  basicUnsafeRead (MV_PackBits v) i = fmap PackedBits . VG.freeze . VGM.unsafeSlice (i * bitLength @a) (bitLength @a) $ v
+  {-# INLINABLE basicUnsafeWrite #-}
+  basicUnsafeWrite (MV_PackBits v) i (PackedBits 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)
+newtype instance VU.Vector (PackBits a) = V_PackBits (VU.Vector BV.Bit)
 
 instance (Finitary a, 1 <= Cardinality a) => VG.Vector VU.Vector (PackBits a) where
   {-# INLINE basicLength #-}
@@ -170,10 +247,10 @@   basicUnsafeFreeze = fmap V_PackBits . VG.basicUnsafeFreeze . op MV_PackBits
   {-# INLINE basicUnsafeThaw #-}
   basicUnsafeThaw = fmap MV_PackBits . VG.basicUnsafeThaw . op V_PackBits
-  {-# INLINE basicUnsafeSlice #-}
+  {-# INLINABLE 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
+  {-# INLINABLE basicUnsafeIndexM #-}
+  basicUnsafeIndexM (V_PackBits v) i = pure . PackedBits . VG.unsafeSlice (i * bitLength @a) (bitLength @a) $ v
 
 instance (Finitary a, 1 <= Cardinality a) => VU.Unbox (PackBits a)
 
@@ -189,14 +266,14 @@ deriving instance (Finitary a, 1 <= Cardinality a) => Ord (BulkPack a)
 
 instance Hashable (BulkPack a) where
-  {-# INLINE hashWithSalt #-}
-  hashWithSalt salt = hashWithSalt salt . BT.cloneToWords . op V_PackBits . op BulkPack
+  {-# INLINABLE hashWithSalt #-}
+  hashWithSalt salt = hashWithSalt salt . BV.cloneToWords . op V_PackBits . op BulkPack
 
 instance Bin.Binary (BulkPack a) where
   {-# INLINE put #-}
-  put = Bin.put . BT.cloneToWords . op V_PackBits . op BulkPack
+  put = Bin.put . BV.cloneToWords . op V_PackBits . op BulkPack
   {-# INLINE get #-}
-  get = BulkPack . V_PackBits . BT.castFromWords <$> Bin.get
+  get = BulkPack . V_PackBits . BV.castFromWords <$> Bin.get
 
 -- Helpers
 
@@ -218,23 +295,21 @@ bitLength :: forall (a :: Type) (b :: Type) . 
   (Finitary a, 1 <= Cardinality a, Num b) => 
   b
-bitLength = fromIntegral . natVal $ (Proxy :: Proxy (BitLength a))
+bitLength = fromIntegral $ natVal' @(BitLength a) proxy#
 
-{-# INLINE intoBits #-}
+{-# INLINABLE 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 #-}
+  Finite n -> VU.Vector BV.Bit
+intoBits f = BV.BitVec 0 nbBits wordArray
+  where
+    wordArray :: ByteArray
+    wordArray = intoWords f
+    nbBits :: Int
+    nbBits = fromIntegral $ natVal' @( CLog 2 n ) proxy#
+
+{-# INLINABLE 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)
+  VU.Vector BV.Bit -> Finite n
+outOfBits (BV.BitVec _ _ wordArray) = outOfWords @n wordArray

@@ -1,250 +1,4 @@-{-
- - 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 #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
--- |
--- Module:        Data.Finitary.PackBits.Unsafe
--- Description:   Scheme for bit-packing @Finitary@ types.
--- Copyright:     (C) Koz Ross 2019
--- License:       GPL version 3.0 or later
--- Stability:     Experimental
--- Portability:   GHC only
---
--- From the [Kraft-McMillan
--- inequality](https://en.wikipedia.org/wiki/Kraft%E2%80%93McMillan_inequality)
--- and 
--- the fact that we are not able to have \'fractional\' bits, we can derive a
--- fixed-length code into a bitstring for any 'Finitary' type @a@, with code
--- length \(\lceil \log_{2}(\texttt{Cardinality a}) \rceil\) bits. This code is
--- 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,
-  BulkPack, exposeVector
-) 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 Data.Semigroup (Dual(..))
-
-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, Show)
-
-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) => 
-  a -> PackBits a
-pattern Packed x <- (unpackBits -> x)
-  where Packed x = packBits x
-
-instance Ord (PackBits a) where
-  compare (PackBits v1) (PackBits v2) = getDual . VU.foldr go (Dual EQ) . VU.zipWith (,) v1 $ v2
-    where go input order = (order <>) . Dual . uncurry compare $ input
-
-instance Bin.Binary (PackBits a) where
-  {-# INLINE put #-}
-  put = Bin.put . B.cloneToWords . op PackBits
-  {-# 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)
-
--- | This wrapper provides an efficient 'Hashable' instance (hash the entire
--- underlying bit-packed vector, rather than each element individually), as well
--- as a 'Bin.Binary' instance (which stores or reads the entire blob of
--- bits \'in one go\').
-newtype BulkPack a = BulkPack { exposeVector :: VU.Vector (PackBits a) }
-  deriving (NFData)
-
-deriving instance (Finitary a, 1 <= Cardinality a) => Eq (BulkPack a)
-
-deriving instance (Finitary a, 1 <= Cardinality a) => Ord (BulkPack a)
-
-instance Hashable (BulkPack a) where
-  {-# INLINE hashWithSalt #-}
-  hashWithSalt salt = hashWithSalt salt . B.cloneToWords . op V_PackBits . op BulkPack
-
-instance Bin.Binary (BulkPack a) where
-  {-# INLINE put #-}
-  put = Bin.put . B.cloneToWords . op V_PackBits . op BulkPack
-  {-# INLINE get #-}
-  get = BulkPack . V_PackBits . B.castFromWords <$> Bin.get
-
--- Helpers
-
-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))
+{-# LANGUAGE CPP #-}
 
-{-# 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)
+#define BITVEC_UNSAFE
+#include "../PackBits.hs"

@@ -19,16 +19,20 @@ {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
 
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE TypeInType #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeInType #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- |
 -- Module:        Data.Finitary.PackBytes
@@ -57,35 +61,76 @@ -- 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
+  (
+  -- * Packing and unpacking between a type and a 'ByteArray'
+    PackBytes(.., Packed)
 
-import Data.Proxy (Proxy(..))
-import GHC.TypeLits.Extra
-import GHC.TypeNats
-import CoercibleUtils (op, over, over2)
+  -- * Helpers
+  , intoBytes, outOfBytes
+  )
+  where
+
+-- base
 import Data.Kind (Type)
 import Data.Word (Word8)
-import Data.Vector.Binary ()
-import Data.Vector.Instances ()
-import Data.Hashable (Hashable(..))
+import Data.Hashable (Hashable(..), hashByteArrayWithSalt)
+import Foreign.Storable (Storable(..))
+import GHC.Exts
+import GHC.IO
+import GHC.TypeNats
+
+-- binary
+import qualified Data.Binary as Bin
+
+-- coercible-utils
+import CoercibleUtils (op, over, over2)
+
+-- deepseq
 import Control.DeepSeq (NFData(..))
+
+-- finitary
 import Data.Finitary (Finitary(..))
-import Foreign.Storable (Storable(..))
-import Foreign.Ptr (castPtr, plusPtr)
+
+-- finite-typelits
+import Data.Finite.Internal (Finite(..), getFinite)
+
+-- ghc-typelits-extra
+import GHC.TypeLits.Extra
+
+-- primitive
+import Control.Monad.Primitive (PrimMonad(primitive))
+import Data.Primitive.ByteArray (ByteArray(..), MutableByteArray(..))
+
+-- vector
+import qualified Data.Vector.Unboxed.Base      as VU
+import qualified Data.Vector.Generic           as VG
+import qualified Data.Vector.Primitive         as VP
+import qualified Data.Vector.Generic.Mutable   as VGM
+import qualified Data.Vector.Primitive.Mutable as VPM
+
+-- vector-binary-instances
+import Data.Vector.Binary ()
+
+-- vector-instances
+import Data.Vector.Instances ()
+
+#ifdef BIGNUM
+-- base
 import Numeric.Natural (Natural)
-import Data.Finite (Finite)
-import Control.Monad.Trans.State.Strict (evalState, get, modify, put)
-import Data.Semigroup (Dual(..))
 
-import qualified Data.Binary as Bin
-import qualified Data.Vector.Unboxed as VU
-import qualified Data.Vector.Generic as VG
-import qualified Data.Vector.Generic.Mutable as VGM
+-- ghc-bignum
+import GHC.Num.Integer (integerToNaturalClamp)
+import GHC.Num.Natural (naturalFromByteArray#, naturalToMutableByteArray#)
+#else
+-- integer-gmp
+import GHC.Integer.GMP.Internals
+  ( importIntegerFromByteArray, exportIntegerToMutableByteArray )
+#endif
 
--- | An opaque wrapper around @a@, representing each value as a byte string.
-newtype PackBytes (a :: Type) = PackBytes (VU.Vector Word8)
+--------------------------------------------------------------------------------
+
+-- | An opaque wrapper around @a@, representing each value as a byte array.
+newtype PackBytes (a :: Type) = PackedBytes ByteArray
   deriving (Eq, Show)
 
 type role PackBytes nominal
@@ -105,36 +150,44 @@ -- __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.
+{-# COMPLETE Packed #-}
 pattern Packed :: forall (a :: Type) . 
   (Finitary a, 1 <= Cardinality a) => 
   a -> PackBytes a
 pattern Packed x <- (unpackBytes -> x)
   where Packed x = packBytes x
 
-instance Ord (PackBytes a) where
-  compare (PackBytes v1) (PackBytes v2) = getDual . VU.foldr go (Dual EQ) . VU.zipWith (,) v1 $ v2
-    where go input order = (order <>) . Dual . uncurry compare $ input
+instance (Finitary a, 1 <= Cardinality a) => Ord (PackBytes a) where
+  compare (PackedBytes (ByteArray arr1)) (PackedBytes (ByteArray arr2)) =
+    compareByteArraysLE arr1 arr2 ( nbBytes -# 1# )
+      where
+        nbBytes :: Int#
+        !(I# nbBytes) = byteLength @a
 
-instance Bin.Binary (PackBytes a) where
+-- Re-use primitive vector instance for 'Binary'.
+instance (Finitary a, 1 <= Cardinality a) => Bin.Binary (PackBytes a) where
   {-# INLINE put #-}
-  put = Bin.put . op PackBytes
+  put = Bin.put . VP.Vector @Word8 0 (byteLength @a) . op PackedBytes
   {-# INLINE get #-}
-  get = PackBytes <$> Bin.get
+  get = PackedBytes . ( \ ( VP.Vector _ _ ba :: VP.Vector Word8 ) -> ba ) <$> Bin.get
+            --                        ^
+            -- binary instance for ( VP.Vector Word8 ) always returns 0 offset
 
-instance Hashable (PackBytes a) where
+instance (Finitary a, 1 <= Cardinality a) => Hashable (PackBytes a) where
   {-# INLINE hashWithSalt #-}
-  hashWithSalt salt = hashWithSalt salt . op PackBytes
+  hashWithSalt salt = ( \ ( ByteArray ba ) -> hashByteArrayWithSalt ba 0 (byteLength @a) salt )
+                    . op PackedBytes
 
 instance NFData (PackBytes a) where
   {-# INLINE rnf #-}
-  rnf = rnf . op PackBytes
+  rnf = rnf . op PackedBytes
 
 instance (Finitary a, 1 <= Cardinality a) => Finitary (PackBytes a) where
   type Cardinality (PackBytes a) = Cardinality a
   {-# INLINE fromFinite #-}
-  fromFinite = PackBytes . intoBytes
+  fromFinite = PackedBytes . intoBytes
   {-# INLINE toFinite #-}
-  toFinite = outOfBytes . op PackBytes
+  toFinite = outOfBytes . op PackedBytes
 
 instance (Finitary a, 1 <= Cardinality a) => Bounded (PackBytes a) where
   {-# INLINE minBound #-}
@@ -143,17 +196,28 @@   maxBound = end
 
 instance (Finitary a, 1 <= Cardinality a) => Storable (PackBytes a) where
-  {-# INLINE sizeOf #-}
+  {-# INLINABLE sizeOf #-}
   sizeOf _ = byteLength @a
-  {-# INLINE alignment #-}
+  {-# INLINABLE alignment #-}
   alignment _ = alignment (undefined :: Word8)
-  {-# INLINE peek #-}
-  peek ptr = do let bytePtr = castPtr ptr
-                PackBytes <$> VU.generateM (byteLength @a) (peek . plusPtr bytePtr)
+  {-# INLINABLE peek #-}
+  peek (Ptr addr) =
+    IO $ \ s1 ->
+      case newByteArray# nbBytes s1 of
+        (# s2, mba #) -> case copyAddrToByteArray# addr mba 0# nbBytes s2 of
+          s3 -> case unsafeFreezeByteArray# mba s3 of
+            (# s4, ba #) -> (# s4, PackedBytes (ByteArray ba) #)
+    where
+      nbBytes :: Int#
+      !(I# nbBytes) = byteLength @a
   {-# 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)
+  poke (Ptr addr) (PackedBytes (ByteArray ba)) =
+    IO $ \ s1 ->
+      case copyByteArrayToAddr# ba 0# addr nbBytes s1 of
+        s2 -> (# s2, () #)
+    where
+      nbBytes :: Int#
+      !(I# nbBytes) = byteLength @a
 
 newtype instance VU.MVector s (PackBytes a) = MV_PackBytes (VU.MVector s Word8)
 
@@ -162,44 +226,71 @@   basicLength = over MV_PackBytes ((`div` byteLength @a) . VGM.basicLength)
   {-# INLINE basicOverlaps #-}
   basicOverlaps = over2 MV_PackBytes VGM.basicOverlaps
-  {-# INLINE basicUnsafeSlice #-}
+  {-# INLINABLE basicUnsafeSlice #-}
   basicUnsafeSlice i len = over MV_PackBytes (VGM.basicUnsafeSlice (i * byteLength @a) (len * byteLength @a))
-  {-# INLINE basicUnsafeNew #-}
+  {-# INLINABLE 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
+  {-# INLINABLE basicUnsafeRead #-}
+  basicUnsafeRead (MV_PackBytes (VU.MV_Word8 (VPM.MVector (I# off) _ (MutableByteArray full_mba)))) (I# i) =
+    primitive $ \ s1 ->
+      case newByteArray# nbBytes s1 of
+        (# s2, elem_mba #) -> case copyMutableByteArray# full_mba (off +# nbBytes *# i) elem_mba 0# nbBytes s2 of
+          s3 -> case unsafeFreezeByteArray# elem_mba s3 of
+            (# s4, elem_ba #) -> (# s4, PackedBytes (ByteArray elem_ba) #)
+    where
+      nbBytes :: Int#
+      !(I# nbBytes) = byteLength @a
+  {-# INLINABLE basicUnsafeWrite #-}
+  basicUnsafeWrite (MV_PackBytes (VU.MV_Word8 (VPM.MVector (I# off) _ (MutableByteArray full_mba)))) (I# i) (PackedBytes (ByteArray val_ba)) =
+    primitive $ \ s1 -> case copyByteArray# val_ba 0# full_mba (off +# nbBytes *# i) nbBytes s1 of
+      s2 -> (# s2, () #)
+      where
+        nbBytes :: Int#
+        !(I# nbBytes) = byteLength @a
 
-newtype instance VU.Vector (PackBytes a) = V_PackBytes (VU.Vector Word8)
+newtype instance VU.Vector (PackBytes a) = V_PackedBytes (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)
+  basicLength = over V_PackedBytes ((`div` byteLength @a) . VG.basicLength)
   {-# INLINE basicUnsafeFreeze #-}
-  basicUnsafeFreeze = fmap V_PackBytes . VG.basicUnsafeFreeze . op MV_PackBytes
+  basicUnsafeFreeze = fmap V_PackedBytes . VG.basicUnsafeFreeze . op MV_PackBytes
   {-# INLINE basicUnsafeThaw #-} 
-  basicUnsafeThaw = fmap MV_PackBytes . VG.basicUnsafeThaw . op V_PackBytes
+  basicUnsafeThaw = fmap MV_PackBytes . VG.basicUnsafeThaw . op V_PackedBytes
   {-# INLINE basicUnsafeSlice #-}
-  basicUnsafeSlice i len = over V_PackBytes (VG.basicUnsafeSlice (i * byteLength @a) (len * byteLength @a))
+  basicUnsafeSlice i len = over V_PackedBytes (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
+  basicUnsafeIndexM (V_PackedBytes (VU.V_Word8 (VP.Vector (I# off) _ (ByteArray full_ba)))) (I# i) =
+    pure $ runRW# $ \ s1 ->
+      case newByteArray# nbBytes s1 of
+        (# s2, elem_mba #) -> case copyByteArray# full_ba (off +# nbBytes *# i) elem_mba 0# nbBytes s2 of
+          s3 -> case unsafeFreezeByteArray# elem_mba s3 of
+            (# _, elem_ba #) -> PackedBytes (ByteArray elem_ba)
+    where
+      nbBytes :: Int#
+      !(I# nbBytes) = byteLength @a
 
 instance (Finitary a, 1 <= Cardinality a) => VU.Unbox (PackBytes a)
 
 -- Helpers
 
-type ByteLength a = CLog (Cardinality Word8) (Cardinality a)
+type ByteLength a = NatBytes (Cardinality a)
+type NatBytes n = CLog (Cardinality Word8) n
 
 {-# INLINE byteLength #-}
 byteLength :: forall (a :: Type) (b :: Type) . 
   (Finitary a, 1 <= Cardinality a, Num b) =>
   b
-byteLength = fromIntegral . natVal $ (Proxy :: Proxy (ByteLength a)) 
+byteLength = fromIntegral $ natVal' @(ByteLength a) proxy#
 
+{-# INLINE natBytes #-}
+natBytes :: forall (n :: Nat) (b :: Type) .
+  (KnownNat n, 1 <= n, Num b) =>
+  b
+natBytes = fromIntegral $ natVal' @(NatBytes n) proxy#
+
 {-# INLINE packBytes #-}
 packBytes :: forall (a :: Type) . 
   (Finitary a, 1 <= Cardinality a) => 
@@ -212,21 +303,80 @@   PackBytes a -> a
 unpackBytes = fromFinite . toFinite
 
-{-# INLINE intoBytes #-}
+{-# INLINABLE compareByteArraysLE #-}
+compareByteArraysLE :: ByteArray# -> ByteArray# -> Int# -> Ordering
+compareByteArraysLE ba1 ba2 off
+  | isTrue# ( off <# 0# )
+  = EQ
+  | isTrue# ( b1 `eqWord#` b2 )
+  = compareByteArraysLE ba1 ba2 ( off -# 1# )
+  | isTrue# ( b1 `ltWord#` b2 )
+  = LT
+  | otherwise
+  = GT
+  where
+    b1, b2 :: Word#
+    b1 = indexWord8Array# ba1 off
+    b2 = indexWord8Array# ba2 off
+
+-- | Pack a natural number less than @n@ into a 'ByteArray',
+-- with the limbs stored in little-endian order.
+{-# INLINABLE 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)
+  Finite n -> ByteArray
 
-{-# INLINE outOfBytes #-}
+-- | Unpack a natural number less than @n@ from a 'ByteArray',
+-- in which the limbs are stored in little-endian order.
+{-# INLINABLE 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) 
+  (KnownNat n, 1 <= n) =>
+  ByteArray -> Finite n
+
+#ifdef BIGNUM
+
+intoBytes f = runRW# $ \ s1 ->
+  case newByteArray# nbBytes s1 of
+    (# s2, mba #) -> case naturalToMutableByteArray# i mba 0## 0# s2 of
+      (# s3, bytesWritten' #) ->
+        let bytesWritten = word2Int# bytesWritten' in
+          case setByteArray# mba bytesWritten (nbBytes -# bytesWritten) 0# s3 of
+            s4 -> case unsafeFreezeByteArray# mba s4 of
+              (# _, ba #) -> ByteArray ba
+  where
+    i :: Natural
+    i = integerToNaturalClamp ( getFinite f )
+    nbBytes :: Int#
+    !(I# nbBytes) = natBytes @n
+
+outOfBytes (ByteArray ba) = runRW# $ \ s1 ->
+  case naturalFromByteArray# nbBytes ba 0## 0# s1 of
+    (# _, nat #) -> Finite (toInteger nat)
+  where
+    nbBytes :: Word#
+    !(W# nbBytes) = natBytes @n
+  
+#else
+
+intoBytes f = runRW# $ \ s1 ->
+  case newByteArray# nbBytes s1 of
+    (# s2, mba #) ->
+      let IO toMBA = exportIntegerToMutableByteArray i mba 0## 0# in
+        case toMBA s2 of
+          (# s3, W# bytesWritten' #) ->
+            let bytesWritten = word2Int# bytesWritten' in
+              case setByteArray# mba bytesWritten (nbBytes -# bytesWritten) 0# s3 of
+                s4 -> case unsafeFreezeByteArray# mba s4 of
+                  (# _, ba #) -> ByteArray ba
+  where
+    i :: Integer
+    i = getFinite f
+    nbBytes :: Int#
+    !(I# nbBytes) = natBytes @n
+
+outOfBytes (ByteArray ba) = Finite $ importIntegerFromByteArray ba 0## nbBytes 0#
+  where
+    nbBytes :: Word#
+    !(W# nbBytes) = natBytes @n
+
+#endif

@@ -104,6 +104,7 @@ -- __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.
+{-# COMPLETE Packed #-}
 pattern Packed :: forall (b :: Type) (a :: Type) . 
   (Finitary a, Finitary b, Cardinality a <= Cardinality b) =>
   a -> PackInto a b

@@ -19,15 +19,20 @@ {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
 
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE TypeInType #-}
-{-# LANGUAGE RoleAnnotations #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeInType #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- |
 -- Module:        Data.Finitary.PackBytes
@@ -56,35 +61,73 @@ -- instead, as you will have much larger control over space usage at almost no
 -- performance penalty. 
 module Data.Finitary.PackWords 
-(
-  PackWords, pattern Packed
-) where
+  ( -- * Packing and unpacking between a type and a little-endian array of 'Word's
+    PackWords(.., Packed)
 
-import Data.Vector.Binary ()
-import Data.Vector.Instances ()
-import GHC.TypeNats
-import Data.Proxy (Proxy(..))
-import GHC.TypeLits.Extra
-import CoercibleUtils (op, over, over2)
+  -- * Helpers
+  , intoWords, outOfWords
+  )
+  where
+
+-- base
 import Data.Kind (Type)
-import Data.Finitary (Finitary(..))
-import Data.Finite (Finite)
+import Data.Hashable (Hashable(..), hashByteArrayWithSalt)
 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 Data.Semigroup (Dual(..))
+import GHC.Exts
+import GHC.IO
+import GHC.Natural (Natural(..))
+import GHC.TypeNats
 
+-- binary
 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
 
+-- coercible-utils
+import CoercibleUtils (op, over, over2)
+
+-- deepseq
+import Control.DeepSeq (NFData(..))
+
+-- finitary
+import Data.Finitary (Finitary(..))
+
+-- finite-typelits
+import Data.Finite.Internal (Finite(..), getFinite)
+
+-- ghc-typelits-extra
+import GHC.TypeLits.Extra
+
+-- primitive
+import Control.Monad.Primitive (PrimMonad(primitive))
+import Data.Primitive.ByteArray (ByteArray(..), MutableByteArray(..))
+
+-- vector
+import qualified Data.Vector.Unboxed.Base      as VU
+import qualified Data.Vector.Generic           as VG
+import qualified Data.Vector.Primitive         as VP
+import qualified Data.Vector.Generic.Mutable   as VGM
+import qualified Data.Vector.Primitive.Mutable as VPM
+
+-- vector-binary-instances
+import Data.Vector.Binary ()
+
+-- vector-instances
+import Data.Vector.Instances ()
+
+#ifdef BIGNUM
+-- ghc-bignum
+import GHC.Num.BigNat (BigNat(..), bigNatCompare, bigNatSize#)
+import GHC.Num.Integer (integerToNaturalClamp, integerFromBigNat#)
+#else
+-- integer-gmp
+import GHC.Integer.GMP.Internals
+  ( BigNat(..), bigNatToInteger, compareBigNat, sizeofBigNat# )
+#endif
+
+--------------------------------------------------------------------------------
+
 -- | An opaque wrapper around @a@, representing each value as a fixed-length
 -- array of machine words.
-newtype PackWords (a :: Type) = PackWords (VU.Vector Word)
+newtype PackWords (a :: Type) = PackedWords ByteArray
   deriving (Eq, Show)
 
 type role PackWords nominal
@@ -104,36 +147,43 @@ -- __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.
+{-# COMPLETE Packed #-}
 pattern Packed :: forall (a :: Type) . 
   (Finitary a, 1 <= Cardinality a) => 
   a -> PackWords a
 pattern Packed x <- (unpackWords -> x)
   where Packed x = packWords x
 
-instance Ord (PackWords a) where
-  compare (PackWords v1) (PackWords v2) = getDual . VU.foldr go (Dual EQ) . VU.zipWith (,) v1 $ v2
-    where go input order = (order <>) . Dual . uncurry compare $ input
+instance (Finitary a, 1 <= Cardinality a) => Ord (PackWords a) where
+  compare (PackedWords (ByteArray ba1)) (PackedWords (ByteArray ba2)) =
+#ifdef BIGNUM
+    bigNatCompare ba1 ba2
+#else
+    compareBigNat (BN# ba1) (BN# ba2)
+#endif
 
-instance Bin.Binary (PackWords a) where
+-- Re-use primitive vector instance for 'Binary'.
+instance (Finitary a, 1 <= Cardinality a) => Bin.Binary (PackWords a) where
   {-# INLINE put #-}
-  put = Bin.put . op PackWords
+  put = Bin.put . VP.Vector @Word 0 (wordLength @a) . op PackedWords
   {-# INLINE get #-}
-  get = PackWords <$> Bin.get
+  get = PackedWords . ( \ ( VP.Vector _ _ ba :: VP.Vector Word ) -> ba ) <$> Bin.get
 
-instance Hashable (PackWords a) where
+instance (Finitary a, 1 <= Cardinality a) => Hashable (PackWords a) where
   {-# INLINE hashWithSalt #-}
-  hashWithSalt salt = hashWithSalt salt . op PackWords
+  hashWithSalt salt = ( \ ( ByteArray ba ) -> hashByteArrayWithSalt ba 0 (bytesPerWord * wordLength @a) salt )
+                    . op PackedWords
 
 instance NFData (PackWords a) where
   {-# INLINE rnf #-}
-  rnf = rnf . op PackWords
+  rnf = rnf . op PackedWords
 
 instance (Finitary a, 1 <= Cardinality a) => Finitary (PackWords a) where
   type Cardinality (PackWords a) = Cardinality a
   {-# INLINE fromFinite #-}
-  fromFinite = PackWords . intoWords
+  fromFinite = PackedWords . intoWords
   {-# INLINE toFinite #-}
-  toFinite = outOfWords . op PackWords
+  toFinite = outOfWords . op PackedWords
 
 instance (Finitary a, 1 <= Cardinality a) => Bounded (PackWords a) where
   {-# INLINE minBound #-}
@@ -142,17 +192,28 @@   maxBound = end
 
 instance (Finitary a, 1 <= Cardinality a) => Storable (PackWords a) where
-  {-# INLINE sizeOf #-}
+  {-# INLINABLE sizeOf #-}
   sizeOf _ = wordLength @a * bytesPerWord
-  {-# INLINE alignment #-}
+  {-# INLINABLE alignment #-}
   alignment _ = alignment (undefined :: Word)
-  {-# INLINE peek #-}
-  peek ptr = do let wordPtr = castPtr ptr
-                PackWords <$> VU.generateM (wordLength @a) (peek . plusPtr wordPtr . (* bytesPerWord))
+  {-# INLINABLE peek #-}
+  peek (Ptr addr) =
+    IO $ \ s1 ->
+      case newByteArray# nbBytes s1 of
+        (# s2, mba #) -> case copyAddrToByteArray# addr mba 0# nbBytes s2 of
+          s3 -> case unsafeFreezeByteArray# mba s3 of
+            (# s4, ba #) -> (# s4, PackedWords (ByteArray ba) #)
+    where
+      nbBytes :: Int#
+      !(I# nbBytes) = bytesPerWord * wordLength @a
   {-# 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) 
+  poke (Ptr addr) (PackedWords (ByteArray ba)) =
+    IO $ \ s1 ->
+      case copyByteArrayToAddr# ba 0# addr nbBytes s1 of
+        s2 -> (# s2, () #)
+    where
+      nbBytes :: Int#
+      !(I# nbBytes) = bytesPerWord * wordLength @a
 
 newtype instance VU.MVector s (PackWords a) = MV_PackWords (VU.MVector s Word)
 
@@ -161,17 +222,31 @@   basicLength = over MV_PackWords ((`div` wordLength @a) . VGM.basicLength)
   {-# INLINE basicOverlaps #-}
   basicOverlaps = over2 MV_PackWords VGM.basicOverlaps
-  {-# INLINE basicUnsafeSlice #-}
+  {-# INLINABLE basicUnsafeSlice #-}
   basicUnsafeSlice i len = over MV_PackWords (VGM.basicUnsafeSlice (i * wordLength @a) (len * wordLength @a))
-  {-# INLINE basicUnsafeNew #-}
+  {-# INLINABLE 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
+  {-# INLINABLE basicUnsafeRead #-}
+  basicUnsafeRead (MV_PackWords (VU.MV_Word (VPM.MVector (I# off) _ (MutableByteArray full_mba)))) (I# i) =
+    primitive $ \ s1 ->
+      case newByteArray# nbBytes s1 of
+        (# s2, elem_mba #) -> case copyMutableByteArray# full_mba (wordSize *# off +# nbBytes *# i) elem_mba 0# nbBytes s2 of
+          s3 -> case unsafeFreezeByteArray# elem_mba s3 of
+            (# s4, elem_ba #) -> (# s4, PackedWords (ByteArray elem_ba) #)
+    where
+      nbBytes, wordSize :: Int#
+      !(I# nbBytes) = bytesPerWord * wordLength @a
+      !(I# wordSize) = bytesPerWord
+  {-# INLINABLE basicUnsafeWrite #-}
+  basicUnsafeWrite (MV_PackWords (VU.MV_Word (VPM.MVector (I# off) _ (MutableByteArray full_mba)))) (I# i) (PackedWords (ByteArray val_ba)) =
+    primitive $ \ s1 -> case copyByteArray# val_ba 0# full_mba (wordSize *# off +# nbBytes *# i) nbBytes s1 of
+      s2 -> (# s2, () #)
+      where
+        nbBytes, wordSize :: Int#
+        !(I# nbBytes) = bytesPerWord * wordLength @a
+        !(I# wordSize) = bytesPerWord
 
 newtype instance VU.Vector (PackWords a) = V_PackWords (VU.Vector Word)
 
@@ -182,22 +257,26 @@   basicUnsafeFreeze = fmap V_PackWords . VG.basicUnsafeFreeze . op MV_PackWords
   {-# INLINE basicUnsafeThaw #-}
   basicUnsafeThaw = fmap MV_PackWords . VG.basicUnsafeThaw . op V_PackWords
-  {-# INLINE basicUnsafeSlice #-}
+  {-# INLINABLE 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
+  {-# INLINABLE basicUnsafeIndexM #-}
+  basicUnsafeIndexM (V_PackWords (VU.V_Word (VP.Vector (I# off) _ (ByteArray full_ba)))) (I# i) =
+    pure $ runRW# $ \ s1 ->
+      case newByteArray# nbBytes s1 of
+        (# s2, elem_mba #) -> case copyByteArray# full_ba (wordSize *# off +# nbBytes *# i) elem_mba 0# nbBytes s2 of
+          s3 -> case unsafeFreezeByteArray# elem_mba s3 of
+            (# _, elem_ba #) -> PackedWords (ByteArray elem_ba)
+    where
+      nbBytes, wordSize :: Int#
+      !(I# nbBytes) = bytesPerWord * wordLength @a
+      !(I# wordSize) = bytesPerWord
 
 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
+type WordLength a = NatWords (Cardinality a)
+type NatWords n = CLog (Cardinality Word) n
 
 {-# INLINE bytesPerWord #-}
 bytesPerWord :: forall (a :: Type) . 
@@ -209,8 +288,14 @@ wordLength :: forall (a :: Type) (b :: Type) . 
   (Finitary a, 1 <= Cardinality a, Num b) => 
   b
-wordLength = fromIntegral . natVal $ (Proxy :: Proxy (WordLength a))
+wordLength = fromIntegral $ natVal' @(WordLength a) proxy#
 
+{-# INLINE natWords #-}
+natWords :: forall (n :: Nat) (b :: Type) .
+  (KnownNat n, 1 <= n, Num b) =>
+  b
+natWords = fromIntegral $ natVal' @(NatWords n) proxy#
+
 {-# INLINE packWords #-}
 packWords :: forall (a :: Type) . 
   (Finitary a, 1 <= Cardinality a) => 
@@ -223,21 +308,58 @@   PackWords a -> a
 unpackWords = fromFinite . toFinite
 
-{-# INLINE intoWords #-}
+{-# INLINABLE 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)
+  Finite n -> ByteArray
+intoWords f = runRW# $ \ s1 ->
+  case newByteArray# nbBytes s1 of
+    (# s2, mba #) ->
+      case (
+        case i of
+          NatS# word
+            | 0## <- word
+            -> (# s2, 0# #)
+            | otherwise
+            -> case writeWordArray# mba 0# word s2 of
+                s3 -> (# s3, wordSize #)
+          NatJ# (BN# bigNatArray) ->
+            let
+              nbBytesWritten :: Int#
+#ifdef BIGNUM
+              nbBytesWritten = wordSize *# bigNatSize# bigNatArray
+#else
+              nbBytesWritten = wordSize *# sizeofBigNat# (BN# bigNatArray)
+#endif
+            in
+              case copyByteArray# bigNatArray 0# mba 0# nbBytesWritten s2 of
+                s3 -> (# s3, nbBytesWritten #)
+        ) of
+        (# s3, bytesWritten #) ->
+          case setByteArray# mba bytesWritten (nbBytes -# bytesWritten) 0# s3 of
+            s4 -> case unsafeFreezeByteArray# mba s4 of
+              (# _, ba #) -> ByteArray ba
 
-{-# INLINE outOfWords #-}
-outOfWords :: forall (n :: Nat) . 
+  where
+    wordSize :: Int#
+    !(I# wordSize) = bytesPerWord
+    nbBytes :: Int#
+    !(I# nbBytes) = I# wordSize * natWords @n
+    i :: Natural
+    i =
+#ifdef BIGNUM
+      integerToNaturalClamp ( getFinite f )
+#else
+      fromIntegral ( getFinite f )
+#endif
+
+{-# INLINABLE 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)
+  ByteArray -> Finite n
+outOfWords (ByteArray ba) =
+#ifdef BIGNUM
+  Finite $ integerFromBigNat# ba
+#else
+  Finite $ bigNatToInteger (BN# ba)
+#endif

@@ -15,59 +15,108 @@  - along with this program.  If not, see <http://www.gnu.org/licenses/>.
  -}
 
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE TypeInType #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeInType #-}
 
 module Main where
 
+-- base
 import Data.Kind (Type)
-import GHC.TypeNats
-import GHC.Generics (Generic)
 import Data.Word (Word8, Word16, Word64)
-import Hedgehog
-import Hedgehog.Classes
-import Data.Finitary (Finitary(..))
-import Data.Finite (Finite)
-import Data.Proxy (Proxy(..))
-import Control.DeepSeq (NFData)
-import Data.Hashable (Hashable(..))
-import Data.Binary (Binary)
 import Foreign.Storable (Storable)
+import GHC.Exts (proxy#)
+import GHC.Generics (Generic)
+import GHC.TypeNats (Nat, KnownNat, natVal')
 
-import qualified Hedgehog.Gen as G
-import qualified Hedgehog.Range as R
+-- binary
+import Data.Binary (Binary)
 
+-- deepseq
+import Control.DeepSeq (NFData)
+
+-- finitary
+import Data.Finitary (Finitary(..))
+
+-- finitary-derive
 import Data.Finitary.Finiteness (Finiteness(..))
 import Data.Finitary.PackBytes (PackBytes)
 import Data.Finitary.PackWords (PackWords)
 import Data.Finitary.PackInto (PackInto)
-
 import qualified Data.Finitary.PackBits as Safe
 import qualified Data.Finitary.PackBits.Unsafe as Unsafe
 import qualified Data.Finitary.PackBytes as PackBytes
 import qualified Data.Finitary.PackWords as PackWords
 
-data Foo = Bar | Baz Word8 Word8 | Quux Word16
+-- finite-typelits
+import Data.Finite (Finite)
+
+-- hashable
+import Data.Hashable (Hashable(..))
+
+-- hedgehog
+import Hedgehog
+import qualified Hedgehog.Gen as G
+import qualified Hedgehog.Range as R
+
+-- hedgehog-classes
+import Hedgehog.Classes
+
+-- vector
+import Data.Vector.Unboxed (Unbox)
+
+--------------------------------------------------------------------------------
+
+data Foo = Bar | Baz Word8 Word16 | Quux Word16
   deriving (Eq, Show, Generic, Finitary)
   deriving (Ord, Bounded, NFData, Hashable, Binary) via (Finiteness Foo)
 
-data Big = Big Word64 Word64
+data Big = Big Word64 Word64 | Mediums Foo Foo Foo Foo
   deriving (Eq, Show, Generic, Finitary)
   deriving (Ord, Bounded, NFData, Hashable, Binary) via (Finiteness Big)
 
+genFoo :: MonadGen m => m Foo
+genFoo = do
+  c <- G.element @_ @Word [ 0, 1, 2 ]
+  case c of
+    0 -> pure Bar
+    1 -> do
+      w1 <- G.word8  (R.linear 0 maxBound)
+      w2 <- G.word16 (R.linear 0 maxBound)
+      pure ( Baz w1 w2 )
+    _ -> do
+      w1 <- G.word16 (R.linear 0 maxBound)
+      pure ( Quux w1 )
+
+genBig :: MonadGen m => m Big
+genBig = do
+  c <- G.element @_ @Word [ 0, 1 ]
+  case c of
+    0 -> do
+      w1 <- G.word64 (R.linear 0 maxBound)
+      w2 <- G.word64 (R.linear 0 maxBound)
+      pure ( Big w1 w2 )
+    _ -> do
+      foo1 <- genFoo
+      foo2 <- genFoo
+      foo3 <- genFoo
+      foo4 <- genFoo
+      pure ( Mediums foo1 foo2 foo3 foo4 )
+
 -- Generators
 choose :: forall (a :: Type) m . (MonadGen m, Finitary a) => m a
 choose = fromFinite <$> chooseFinite
 
 chooseFinite :: forall (n :: Nat) m . (KnownNat n, MonadGen m) => m (Finite n)
 chooseFinite = fromIntegral <$> G.integral (R.linear 0 limit)
-  where limit = subtract @Integer 1 . fromIntegral . natVal @n $ Proxy
+  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]
@@ -75,6 +124,9 @@ packLaws :: (Eq a, Show a, Storable a) => Gen a -> [Laws]
 packLaws p = [storableLaws p]
 
+vectorLaws :: (Eq a, Show a, Unbox a) => Gen a -> [Laws]
+vectorLaws p = [muvectorLaws p]
+
 ordIsMonotonic :: forall (a :: Type) (t :: Type -> Type) . 
   (Finitary a, Show a, Ord a, Ord (t a)) => 
   (a -> t a) -> Property
@@ -82,25 +134,69 @@                                  y <- forAll $ choose @a
                                  (x < y) === (f x < f y)
 
-finitenessTests :: [(String, [Laws])]
-finitenessTests = [("Small Finiteness", finitenessLaws @Foo choose),
-                   ("Big Finiteness", finitenessLaws @Big choose)]
+roundTrips :: forall (a :: Type) (t :: Type -> Type) . 
+  (Finitary a, Show a, Ord a) => 
+  Gen a -> (a -> t a) -> (t a -> a) -> Property
+roundTrips gen pack unpack = property $ do
+  a <- forAll $ gen
+  case pack a of
+    !packed -> case unpack packed of
+      roundTripped -> a === roundTripped
 
-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)]
+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)
+  ]
+
+vectorTests :: [(String,[Laws])]
+vectorTests =
+  [ ("Small PackBits"       , vectorLaws @(Safe.PackBits   Foo) choose)
+  , ("Small unsafe PackBits", vectorLaws @(Unsafe.PackBits Foo) choose)
+  , ("Small PackBytes"      , vectorLaws @(PackBytes       Foo) choose)
+  , ("Small PackWords"      , vectorLaws @(PackWords       Foo) choose)
+  , ("Big PackBits"         , vectorLaws @(Safe.PackBits   Big) choose)
+  , ("Big unsafe PackBits"  , vectorLaws @(Unsafe.PackBits Big) choose)
+  , ("Big PackBytes"        , vectorLaws @(PackBytes       Big) choose)
+  , ("Big PackWords"        , vectorLaws @(PackWords       Big) choose)
+  ]
+
+monotonicTests :: Group
+monotonicTests = Group "Monotonicity" 
+  [ ("Small PackBits"       , ordIsMonotonic @Foo      Safe.Packed)
+  , ("Small unsafe PackBits", ordIsMonotonic @Foo    Unsafe.Packed)
+  , ("Small PackBytes"      , ordIsMonotonic @Foo PackBytes.Packed)
+  , ("Small PackWords"      , ordIsMonotonic @Foo PackWords.Packed)
+  , ("Big PackBits"         , ordIsMonotonic @Big      Safe.Packed)
+  , ("Big unsafe PackBits"  , ordIsMonotonic @Big    Unsafe.Packed)
+  , ("Big PackBytes"        , ordIsMonotonic @Big PackBytes.Packed)
+  , ("Big PackWords"        , ordIsMonotonic @Big PackWords.Packed)
+  ]
+
+roundTripTests :: Group
+roundTripTests = Group "Round-tripping" 
+  [ ("Small PackBits"       , roundTrips @Foo genFoo      Safe.Packed ( \ (      Safe.Packed x ) -> x ) )
+  , ("Small unsafe PackBits", roundTrips @Foo genFoo    Unsafe.Packed ( \ (    Unsafe.Packed x ) -> x ) )
+  , ("Small PackBytes"      , roundTrips @Foo genFoo PackBytes.Packed ( \ ( PackBytes.Packed x ) -> x ) )
+  , ("Small PackWords"      , roundTrips @Foo genFoo PackWords.Packed ( \ ( PackWords.Packed x ) -> x ) )
+  , ("Big PackBits"         , roundTrips @Big genBig      Safe.Packed ( \ (      Safe.Packed x ) -> x ) )
+  , ("Big unsafe PackBits"  , roundTrips @Big genBig    Unsafe.Packed ( \ (    Unsafe.Packed x ) -> x ) )
+  , ("Big PackBytes"        , roundTrips @Big genBig PackBytes.Packed ( \ ( PackBytes.Packed x ) -> x ) )
+  , ("Big PackWords"        , roundTrips @Big genBig PackWords.Packed ( \ ( PackWords.Packed x ) -> x ) )
+  ]
+
+checkTest :: Either [(String,[Laws])] Group -> IO Bool
+checkTest ( Left  laws  ) = lawsCheckMany laws
+checkTest ( Right group ) = checkParallel group
+
 main :: IO Bool
-main = (&&) <$> checkLaws <*> checkMonotonicity
-  where checkLaws = (&&) <$> lawsCheckMany finitenessTests <*> lawsCheckMany packTests
-        checkMonotonicity = checkParallel . Group "Monotonicity" $ [("Small PackBits", ordIsMonotonic @Foo Safe.Packed),
-                                                                    ("Small unsafe PackBits", ordIsMonotonic @Foo Unsafe.Packed),
-                                                                    ("Small PackBytes", ordIsMonotonic @Foo PackBytes.Packed),
-                                                                    ("Small PackWords", ordIsMonotonic @Foo PackWords.Packed),
-                                                                    ("Big PackBits", ordIsMonotonic @Big Safe.Packed),
-                                                                    ("Big unsafe PackBits", ordIsMonotonic @Big Unsafe.Packed),
-                                                                    ("Big PackBytes", ordIsMonotonic @Big PackBytes.Packed),
-                                                                    ("Big PackWords", ordIsMonotonic @Big PackWords.Packed)]
+main = and <$> traverse checkTest [ Left finitenessTests, Left packTests, Left vectorTests, Right monotonicTests, Right roundTripTests ]