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

-- | An opaque wrapper around @a@, representing each value as a byte string.
newtype PackBytes (a :: Type) = PackBytes (VU.Vector Word8)
  deriving (PackBytes a -> PackBytes a -> Bool
(PackBytes a -> PackBytes a -> Bool)
-> (PackBytes a -> PackBytes a -> Bool) -> Eq (PackBytes a)
forall a. PackBytes a -> PackBytes a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackBytes a -> PackBytes a -> Bool
$c/= :: forall a. PackBytes a -> PackBytes a -> Bool
== :: PackBytes a -> PackBytes a -> Bool
$c== :: forall a. PackBytes a -> PackBytes a -> Bool
Eq, Int -> PackBytes a -> ShowS
[PackBytes a] -> ShowS
PackBytes a -> String
(Int -> PackBytes a -> ShowS)
-> (PackBytes a -> String)
-> ([PackBytes a] -> ShowS)
-> Show (PackBytes a)
forall a. Int -> PackBytes a -> ShowS
forall a. [PackBytes a] -> ShowS
forall a. PackBytes a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackBytes a] -> ShowS
$cshowList :: forall a. [PackBytes a] -> ShowS
show :: PackBytes a -> String
$cshow :: forall a. PackBytes a -> String
showsPrec :: Int -> PackBytes a -> ShowS
$cshowsPrec :: forall a. Int -> PackBytes a -> ShowS
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) => 
  a -> PackBytes a
pattern $bPacked :: a -> PackBytes a
$mPacked :: forall r a.
(Finitary a, 1 <= Cardinality a) =>
PackBytes a -> (a -> r) -> (Void# -> r) -> r
Packed x <- (unpackBytes -> x)
  where Packed x :: a
x = a -> PackBytes a
forall a. (Finitary a, 1 <= Cardinality a) => a -> PackBytes a
packBytes a
x

instance Ord (PackBytes a) where
  compare :: PackBytes a -> PackBytes a -> Ordering
compare (PackBytes v1 :: Vector Word8
v1) (PackBytes v2 :: Vector Word8
v2) = Dual Ordering -> Ordering
forall a. Dual a -> a
getDual (Dual Ordering -> Ordering)
-> (Vector Word8 -> Dual Ordering) -> Vector Word8 -> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word8, Word8) -> Dual Ordering -> Dual Ordering)
-> Dual Ordering -> Vector (Word8, Word8) -> Dual Ordering
forall a b. Unbox a => (a -> b -> b) -> b -> Vector a -> b
VU.foldr (Word8, Word8) -> Dual Ordering -> Dual Ordering
forall a. Ord a => (a, a) -> Dual Ordering -> Dual Ordering
go (Ordering -> Dual Ordering
forall a. a -> Dual a
Dual Ordering
EQ) (Vector (Word8, Word8) -> Dual Ordering)
-> (Vector Word8 -> Vector (Word8, Word8))
-> Vector Word8
-> Dual Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8 -> (Word8, Word8))
-> Vector Word8 -> Vector Word8 -> Vector (Word8, Word8)
forall a b c.
(Unbox a, Unbox b, Unbox c) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
VU.zipWith (,) Vector Word8
v1 (Vector Word8 -> Ordering) -> Vector Word8 -> Ordering
forall a b. (a -> b) -> a -> b
$ Vector Word8
v2
    where go :: (a, a) -> Dual Ordering -> Dual Ordering
go input :: (a, a)
input order :: Dual Ordering
order = (Dual Ordering
order Dual Ordering -> Dual Ordering -> Dual Ordering
forall a. Semigroup a => a -> a -> a
<>) (Dual Ordering -> Dual Ordering)
-> ((a, a) -> Dual Ordering) -> (a, a) -> Dual Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ordering -> Dual Ordering
forall a. a -> Dual a
Dual (Ordering -> Dual Ordering)
-> ((a, a) -> Ordering) -> (a, a) -> Dual Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Ordering) -> (a, a) -> Ordering
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((a, a) -> Dual Ordering) -> (a, a) -> Dual Ordering
forall a b. (a -> b) -> a -> b
$ (a, a)
input

instance Bin.Binary (PackBytes a) where
  {-# INLINE put #-}
  put :: PackBytes a -> Put
put = Vector Word8 -> Put
forall t. Binary t => t -> Put
Bin.put (Vector Word8 -> Put)
-> (PackBytes a -> Vector Word8) -> PackBytes a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Word8 -> PackBytes a) -> PackBytes a -> Vector Word8
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Word8 -> PackBytes a
forall a. Vector Word8 -> PackBytes a
PackBytes
  {-# INLINE get #-}
  get :: Get (PackBytes a)
get = Vector Word8 -> PackBytes a
forall a. Vector Word8 -> PackBytes a
PackBytes (Vector Word8 -> PackBytes a)
-> Get (Vector Word8) -> Get (PackBytes a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Vector Word8)
forall t. Binary t => Get t
Bin.get

instance Hashable (PackBytes a) where
  {-# INLINE hashWithSalt #-}
  hashWithSalt :: Int -> PackBytes a -> Int
hashWithSalt salt :: Int
salt = Int -> Vector Word8 -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (Vector Word8 -> Int)
-> (PackBytes a -> Vector Word8) -> PackBytes a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Word8 -> PackBytes a) -> PackBytes a -> Vector Word8
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Word8 -> PackBytes a
forall a. Vector Word8 -> PackBytes a
PackBytes

instance NFData (PackBytes a) where
  {-# INLINE rnf #-}
  rnf :: PackBytes a -> ()
rnf = Vector Word8 -> ()
forall a. NFData a => a -> ()
rnf (Vector Word8 -> ())
-> (PackBytes a -> Vector Word8) -> PackBytes a -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Word8 -> PackBytes a) -> PackBytes a -> Vector Word8
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Word8 -> PackBytes a
forall a. Vector Word8 -> PackBytes a
PackBytes

instance (Finitary a, 1 <= Cardinality a) => Finitary (PackBytes a) where
  type Cardinality (PackBytes a) = Cardinality a
  {-# INLINE fromFinite #-}
  fromFinite :: Finite (Cardinality (PackBytes a)) -> PackBytes a
fromFinite = Vector Word8 -> PackBytes a
forall a. Vector Word8 -> PackBytes a
PackBytes (Vector Word8 -> PackBytes a)
-> (Finite (Cardinality a) -> Vector Word8)
-> Finite (Cardinality a)
-> PackBytes a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Finite (Cardinality a) -> Vector Word8
forall (n :: Nat). (KnownNat n, 1 <= n) => Finite n -> Vector Word8
intoBytes
  {-# INLINE toFinite #-}
  toFinite :: PackBytes a -> Finite (Cardinality (PackBytes a))
toFinite = Vector Word8 -> Finite (Cardinality a)
forall (n :: Nat). KnownNat n => Vector Word8 -> Finite n
outOfBytes (Vector Word8 -> Finite (Cardinality a))
-> (PackBytes a -> Vector Word8)
-> PackBytes a
-> Finite (Cardinality a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Word8 -> PackBytes a) -> PackBytes a -> Vector Word8
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Word8 -> PackBytes a
forall a. Vector Word8 -> PackBytes a
PackBytes

instance (Finitary a, 1 <= Cardinality a) => Bounded (PackBytes a) where
  {-# INLINE minBound #-}
  minBound :: PackBytes a
minBound = PackBytes a
forall a. (Finitary a, 1 <= Cardinality a) => a
start
  {-# INLINE maxBound #-}
  maxBound :: PackBytes a
maxBound = PackBytes a
forall a. (Finitary a, 1 <= Cardinality a) => a
end

instance (Finitary a, 1 <= Cardinality a) => Storable (PackBytes a) where
  {-# INLINE sizeOf #-}
  sizeOf :: PackBytes a -> Int
sizeOf _ = forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a
  {-# INLINE alignment #-}
  alignment :: PackBytes a -> Int
alignment _ = Word8 -> Int
forall a. Storable a => a -> Int
alignment (Word8
forall a. HasCallStack => a
undefined :: Word8)
  {-# INLINE peek #-}
  peek :: Ptr (PackBytes a) -> IO (PackBytes a)
peek ptr :: Ptr (PackBytes a)
ptr = do let bytePtr :: Ptr Any
bytePtr = Ptr (PackBytes a) -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr (PackBytes a)
ptr
                Vector Word8 -> PackBytes a
forall a. Vector Word8 -> PackBytes a
PackBytes (Vector Word8 -> PackBytes a)
-> IO (Vector Word8) -> IO (PackBytes a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> (Int -> IO Word8) -> IO (Vector Word8)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> (Int -> m a) -> m (Vector a)
VU.generateM (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word8 -> IO Word8) -> (Int -> Ptr Word8) -> Int -> IO Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Any -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Any
bytePtr)
  {-# INLINE poke #-}
  poke :: Ptr (PackBytes a) -> PackBytes a -> IO ()
poke ptr :: Ptr (PackBytes a)
ptr (PackBytes v :: Vector Word8
v) = do let bytePtr :: Ptr Word8
bytePtr = Ptr (PackBytes a) -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr (PackBytes a)
ptr
                              (Ptr Word8 -> Word8 -> IO (Ptr Word8))
-> Ptr Word8 -> Vector Word8 -> IO ()
forall (m :: * -> *) b a.
(Monad m, Unbox b) =>
(a -> b -> m a) -> a -> Vector b -> m ()
VU.foldM'_ Ptr Word8 -> Word8 -> IO (Ptr Word8)
forall a b. Storable a => Ptr a -> a -> IO (Ptr b)
go Ptr Word8
bytePtr Vector Word8
v
    where go :: Ptr a -> a -> IO (Ptr b)
go p :: Ptr a
p e :: a
e = Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
p a
e IO () -> IO (Ptr b) -> IO (Ptr b)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> IO (Ptr b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr a -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
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 :: MVector s (PackBytes a) -> Int
basicLength = (MVector s Word8 -> MVector s (PackBytes a))
-> (MVector s Word8 -> Int) -> MVector s (PackBytes a) -> Int
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over MVector s Word8 -> MVector s (PackBytes a)
forall s a. MVector s Word8 -> MVector s (PackBytes a)
MV_PackBytes ((Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (Int -> Int) -> (MVector s Word8 -> Int) -> MVector s Word8 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector s Word8 -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
VGM.basicLength)
  {-# INLINE basicOverlaps #-}
  basicOverlaps :: MVector s (PackBytes a) -> MVector s (PackBytes a) -> Bool
basicOverlaps = (MVector s Word8 -> MVector s (PackBytes a))
-> (MVector s Word8 -> MVector s Word8 -> Bool)
-> MVector s (PackBytes a)
-> MVector s (PackBytes a)
-> Bool
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a -> a') -> b -> b -> b'
over2 MVector s Word8 -> MVector s (PackBytes a)
forall s a. MVector s Word8 -> MVector s (PackBytes a)
MV_PackBytes MVector s Word8 -> MVector s Word8 -> Bool
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> Bool
VGM.basicOverlaps
  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeSlice :: Int -> Int -> MVector s (PackBytes a) -> MVector s (PackBytes a)
basicUnsafeSlice i :: Int
i len :: Int
len = (MVector s Word8 -> MVector s (PackBytes a))
-> (MVector s Word8 -> MVector s Word8)
-> MVector s (PackBytes a)
-> MVector s (PackBytes a)
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over MVector s Word8 -> MVector s (PackBytes a)
forall s a. MVector s Word8 -> MVector s (PackBytes a)
MV_PackBytes (Int -> Int -> MVector s Word8 -> MVector s Word8
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
VGM.basicUnsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a))
  {-# INLINE basicUnsafeNew #-}
  basicUnsafeNew :: Int -> m (MVector (PrimState m) (PackBytes a))
basicUnsafeNew len :: Int
len = MVector (PrimState m) Word8 -> MVector (PrimState m) (PackBytes a)
forall s a. MVector s Word8 -> MVector s (PackBytes a)
MV_PackBytes (MVector (PrimState m) Word8
 -> MVector (PrimState m) (PackBytes a))
-> m (MVector (PrimState m) Word8)
-> m (MVector (PrimState m) (PackBytes a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (MVector (PrimState m) Word8)
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
Int -> m (v (PrimState m) a)
VGM.basicUnsafeNew (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a)
  {-# INLINE basicInitialize #-}
  basicInitialize :: MVector (PrimState m) (PackBytes a) -> m ()
basicInitialize = MVector (PrimState m) Word8 -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> m ()
VGM.basicInitialize (MVector (PrimState m) Word8 -> m ())
-> (MVector (PrimState m) (PackBytes a)
    -> MVector (PrimState m) Word8)
-> MVector (PrimState m) (PackBytes a)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVector (PrimState m) Word8
 -> MVector (PrimState m) (PackBytes a))
-> MVector (PrimState m) (PackBytes a)
-> MVector (PrimState m) Word8
forall a b. Coercible a b => (a -> b) -> b -> a
op MVector (PrimState m) Word8 -> MVector (PrimState m) (PackBytes a)
forall s a. MVector s Word8 -> MVector s (PackBytes a)
MV_PackBytes
  {-# INLINE basicUnsafeRead #-}
  basicUnsafeRead :: MVector (PrimState m) (PackBytes a) -> Int -> m (PackBytes a)
basicUnsafeRead (MV_PackBytes v) i :: Int
i = (Vector Word8 -> PackBytes a)
-> m (Vector Word8) -> m (PackBytes a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector Word8 -> PackBytes a
forall a. Vector Word8 -> PackBytes a
PackBytes (m (Vector Word8) -> m (PackBytes a))
-> (MVector (PrimState m) Word8 -> m (Vector Word8))
-> MVector (PrimState m) Word8
-> m (PackBytes a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector (PrimState m) Word8 -> m (Vector Word8)
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> m (v a)
VG.freeze (MVector (PrimState m) Word8 -> m (Vector Word8))
-> (MVector (PrimState m) Word8 -> MVector (PrimState m) Word8)
-> MVector (PrimState m) Word8
-> m (Vector Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Int
-> MVector (PrimState m) Word8
-> MVector (PrimState m) Word8
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
VGM.unsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (MVector (PrimState m) Word8 -> m (PackBytes a))
-> MVector (PrimState m) Word8 -> m (PackBytes a)
forall a b. (a -> b) -> a -> b
$ MVector (PrimState m) Word8
v
  {-# INLINE basicUnsafeWrite #-}
  basicUnsafeWrite :: MVector (PrimState m) (PackBytes a) -> Int -> PackBytes a -> m ()
basicUnsafeWrite (MV_PackBytes v) i :: Int
i (PackBytes x :: Vector Word8
x) = let slice :: MVector (PrimState m) Word8
slice = Int
-> Int
-> MVector (PrimState m) Word8
-> MVector (PrimState m) Word8
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
VGM.unsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) MVector (PrimState m) Word8
v in
                                                        Mutable Vector (PrimState m) Word8 -> Vector Word8 -> m ()
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> v a -> m ()
VG.unsafeCopy MVector (PrimState m) Word8
Mutable Vector (PrimState m) Word8
slice Vector Word8
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 :: Vector (PackBytes a) -> Int
basicLength = (Vector Word8 -> Vector (PackBytes a))
-> (Vector Word8 -> Int) -> Vector (PackBytes a) -> Int
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over Vector Word8 -> Vector (PackBytes a)
forall a. Vector Word8 -> Vector (PackBytes a)
V_PackBytes ((Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (Int -> Int) -> (Vector Word8 -> Int) -> Vector Word8 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word8 -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
VG.basicLength)
  {-# INLINE basicUnsafeFreeze #-}
  basicUnsafeFreeze :: Mutable Vector (PrimState m) (PackBytes a)
-> m (Vector (PackBytes a))
basicUnsafeFreeze = (Vector Word8 -> Vector (PackBytes a))
-> m (Vector Word8) -> m (Vector (PackBytes a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector Word8 -> Vector (PackBytes a)
forall a. Vector Word8 -> Vector (PackBytes a)
V_PackBytes (m (Vector Word8) -> m (Vector (PackBytes a)))
-> (MVector (PrimState m) (PackBytes a) -> m (Vector Word8))
-> MVector (PrimState m) (PackBytes a)
-> m (Vector (PackBytes a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVector (PrimState m) Word8 -> m (Vector Word8)
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> m (v a)
VG.basicUnsafeFreeze (MVector (PrimState m) Word8 -> m (Vector Word8))
-> (MVector (PrimState m) (PackBytes a)
    -> MVector (PrimState m) Word8)
-> MVector (PrimState m) (PackBytes a)
-> m (Vector Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVector (PrimState m) Word8
 -> MVector (PrimState m) (PackBytes a))
-> MVector (PrimState m) (PackBytes a)
-> MVector (PrimState m) Word8
forall a b. Coercible a b => (a -> b) -> b -> a
op MVector (PrimState m) Word8 -> MVector (PrimState m) (PackBytes a)
forall s a. MVector s Word8 -> MVector s (PackBytes a)
MV_PackBytes
  {-# INLINE basicUnsafeThaw #-} 
  basicUnsafeThaw :: Vector (PackBytes a)
-> m (Mutable Vector (PrimState m) (PackBytes a))
basicUnsafeThaw = (MVector (PrimState m) Word8
 -> MVector (PrimState m) (PackBytes a))
-> m (MVector (PrimState m) Word8)
-> m (MVector (PrimState m) (PackBytes a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVector (PrimState m) Word8 -> MVector (PrimState m) (PackBytes a)
forall s a. MVector s Word8 -> MVector s (PackBytes a)
MV_PackBytes (m (MVector (PrimState m) Word8)
 -> m (MVector (PrimState m) (PackBytes a)))
-> (Vector (PackBytes a) -> m (MVector (PrimState m) Word8))
-> Vector (PackBytes a)
-> m (MVector (PrimState m) (PackBytes a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word8 -> m (MVector (PrimState m) Word8)
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
v a -> m (Mutable v (PrimState m) a)
VG.basicUnsafeThaw (Vector Word8 -> m (MVector (PrimState m) Word8))
-> (Vector (PackBytes a) -> Vector Word8)
-> Vector (PackBytes a)
-> m (MVector (PrimState m) Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Word8 -> Vector (PackBytes a))
-> Vector (PackBytes a) -> Vector Word8
forall a b. Coercible a b => (a -> b) -> b -> a
op Vector Word8 -> Vector (PackBytes a)
forall a. Vector Word8 -> Vector (PackBytes a)
V_PackBytes
  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeSlice :: Int -> Int -> Vector (PackBytes a) -> Vector (PackBytes a)
basicUnsafeSlice i :: Int
i len :: Int
len = (Vector Word8 -> Vector (PackBytes a))
-> (Vector Word8 -> Vector Word8)
-> Vector (PackBytes a)
-> Vector (PackBytes a)
forall a b a' b'.
(Coercible a b, Coercible a' b') =>
(a -> b) -> (a -> a') -> b -> b'
over Vector Word8 -> Vector (PackBytes a)
forall a. Vector Word8 -> Vector (PackBytes a)
V_PackBytes (Int -> Int -> Vector Word8 -> Vector Word8
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
VG.basicUnsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a))
  {-# INLINE basicUnsafeIndexM #-}
  basicUnsafeIndexM :: Vector (PackBytes a) -> Int -> m (PackBytes a)
basicUnsafeIndexM (V_PackBytes v) i :: Int
i = PackBytes a -> m (PackBytes a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackBytes a -> m (PackBytes a))
-> (Vector Word8 -> PackBytes a) -> Vector Word8 -> m (PackBytes a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word8 -> PackBytes a
forall a. Vector Word8 -> PackBytes a
PackBytes (Vector Word8 -> PackBytes a)
-> (Vector Word8 -> Vector Word8) -> Vector Word8 -> PackBytes a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Vector Word8 -> Vector Word8
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
VG.unsafeSlice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (forall b. (Finitary a, 1 <= Cardinality a, Num b) => b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @a) (Vector Word8 -> m (PackBytes a))
-> Vector Word8 -> m (PackBytes a)
forall a b. (a -> b) -> a -> b
$ Vector Word8
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 :: b
byteLength = Natural -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> b)
-> (Proxy (CLog 256 (Cardinality a)) -> Natural)
-> Proxy (CLog 256 (Cardinality a))
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (CLog 256 (Cardinality a)) -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy (CLog 256 (Cardinality a)) -> b)
-> Proxy (CLog 256 (Cardinality a)) -> b
forall a b. (a -> b) -> a -> b
$ (Proxy (ByteLength a)
forall k (t :: k). Proxy t
Proxy :: Proxy (ByteLength a)) 

{-# INLINE packBytes #-}
packBytes :: forall (a :: Type) . 
  (Finitary a, 1 <= Cardinality a) => 
  a -> PackBytes a
packBytes :: a -> PackBytes a
packBytes = Finite (Cardinality a) -> PackBytes a
forall a. Finitary a => Finite (Cardinality a) -> a
fromFinite (Finite (Cardinality a) -> PackBytes a)
-> (a -> Finite (Cardinality a)) -> a -> PackBytes a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Finite (Cardinality a)
forall a. Finitary a => a -> Finite (Cardinality a)
toFinite

{-# INLINE unpackBytes #-}
unpackBytes :: forall (a :: Type) . 
  (Finitary a, 1 <= Cardinality a) => 
  PackBytes a -> a
unpackBytes :: PackBytes a -> a
unpackBytes = Finite (Cardinality a) -> a
forall a. Finitary a => Finite (Cardinality a) -> a
fromFinite (Finite (Cardinality a) -> a)
-> (PackBytes a -> Finite (Cardinality a)) -> PackBytes a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackBytes a -> Finite (Cardinality a)
forall a. Finitary a => a -> Finite (Cardinality a)
toFinite

{-# INLINE intoBytes #-}
intoBytes :: forall (n :: Nat) . 
  (KnownNat n, 1 <= n) => 
  Finite n -> VU.Vector Word8
intoBytes :: Finite n -> Vector Word8
intoBytes = State Natural (Vector Word8) -> Natural -> Vector Word8
forall s a. State s a -> s -> a
evalState (Int
-> StateT Natural Identity Word8 -> State Natural (Vector Word8)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
VU.replicateM (forall b.
(Finitary (Finite n), 1 <= Cardinality (Finite n), Num b) =>
b
forall a b. (Finitary a, 1 <= Cardinality a, Num b) => b
byteLength @(Finite n)) StateT Natural Identity Word8
go) (Natural -> Vector Word8)
-> (Finite n -> Natural) -> Finite n -> Vector Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integral (Finite n), Num Natural) => Finite n -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @Natural
  where go :: StateT Natural Identity Word8
go = do Natural
remaining <- StateT Natural Identity Natural
forall (m :: * -> *) s. Monad m => StateT s m s
get
                let (d :: Natural
d, r :: Natural
r) = Natural -> Natural -> (Natural, Natural)
forall a. Integral a => a -> a -> (a, a)
quotRem Natural
remaining 256
                Natural -> StateT Natural Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Natural
d StateT Natural Identity ()
-> StateT Natural Identity Word8 -> StateT Natural Identity Word8
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> StateT Natural Identity Word8
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
r)

{-# INLINE outOfBytes #-}
outOfBytes :: forall (n :: Nat) . 
  (KnownNat n) =>
  VU.Vector Word8 -> Finite n
outOfBytes :: Vector Word8 -> Finite n
outOfBytes v :: Vector Word8
v = State (Finite n) (Finite n) -> Finite n -> Finite n
forall s a. State s a -> s -> a
evalState ((Finite n -> Word8 -> State (Finite n) (Finite n))
-> Finite n -> Vector Word8 -> State (Finite n) (Finite n)
forall (m :: * -> *) b a.
(Monad m, Unbox b) =>
(a -> b -> m a) -> a -> Vector b -> m a
VU.foldM' Finite n -> Word8 -> State (Finite n) (Finite n)
forall (m :: * -> *) a b.
(Monad m, Integral a, Num b) =>
b -> a -> StateT b m b
go 0 Vector Word8
v) 1
  where go :: b -> a -> StateT b m b
go old :: b
old w :: a
w = do b
power <- StateT b m b
forall (m :: * -> *) s. Monad m => StateT s m s
get
                      let placeValue :: b
placeValue = b
power b -> b -> b
forall a. Num a => a -> a -> a
* a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w
                      (b -> b) -> StateT b m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (b -> b -> b
forall a. Num a => a -> a -> a
* 256)
                      b -> StateT b m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b
old b -> b -> b
forall a. Num a => a -> a -> a
+ b
placeValue)