{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses, TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}
#if __GLASGOW_HASKELL__ < 806
{-# LANGUAGE TypeInType #-}
#endif
-----------------------------------------------------------------------
-- |
-- Module      :  Data.Extensible.Bits
-- Copyright   :  (c) Fumiaki Kinoshita 2018
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- Bit-packed records
-----------------------------------------------------------------------
module Data.Extensible.Bits (BitProd(..)
  , FromBits(..)
  , TotalBits
  , BitFields
  , blookup
  , bupdate
  , toBitProd
  , fromBitProd
  , BitRecordOf
  , BitRecord) where

import Control.Applicative
import Control.Comonad
import Data.Bits
import Data.Extensible.Class
import Data.Extensible.Dictionary
import Data.Extensible.Product
import Data.Extensible.Field
import Data.Functor.Identity
import Data.Hashable
import Data.Ix
import Data.Kind (Type)
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
import Data.Proxy
import Data.Word
import Data.Int
import Foreign.Storable (Storable)
import GHC.Generics (Generic)
import GHC.TypeLits

-- | Bit-vector product. It has similar interface as @(:*)@ but fields are packed into @r@.
newtype BitProd r (xs :: [k]) (h :: k -> Type) = BitProd { forall k r (xs :: [k]) (h :: k -> Type). BitProd r xs h -> r
unBitProd :: r }
  deriving (BitProd r xs h -> BitProd r xs h -> Bool
(BitProd r xs h -> BitProd r xs h -> Bool)
-> (BitProd r xs h -> BitProd r xs h -> Bool)
-> Eq (BitProd r xs h)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall r k (xs :: [k]) (h :: k -> Type).
Eq r =>
BitProd r xs h -> BitProd r xs h -> Bool
$c== :: forall r k (xs :: [k]) (h :: k -> Type).
Eq r =>
BitProd r xs h -> BitProd r xs h -> Bool
== :: BitProd r xs h -> BitProd r xs h -> Bool
$c/= :: forall r k (xs :: [k]) (h :: k -> Type).
Eq r =>
BitProd r xs h -> BitProd r xs h -> Bool
/= :: BitProd r xs h -> BitProd r xs h -> Bool
Eq, Eq (BitProd r xs h)
Eq (BitProd r xs h) =>
(BitProd r xs h -> BitProd r xs h -> Ordering)
-> (BitProd r xs h -> BitProd r xs h -> Bool)
-> (BitProd r xs h -> BitProd r xs h -> Bool)
-> (BitProd r xs h -> BitProd r xs h -> Bool)
-> (BitProd r xs h -> BitProd r xs h -> Bool)
-> (BitProd r xs h -> BitProd r xs h -> BitProd r xs h)
-> (BitProd r xs h -> BitProd r xs h -> BitProd r xs h)
-> Ord (BitProd r xs h)
BitProd r xs h -> BitProd r xs h -> Bool
BitProd r xs h -> BitProd r xs h -> Ordering
BitProd r xs h -> BitProd r xs h -> BitProd r xs h
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
Eq (BitProd r xs h)
forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> Bool
forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> Ordering
forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> BitProd r xs h
$ccompare :: forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> Ordering
compare :: BitProd r xs h -> BitProd r xs h -> Ordering
$c< :: forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> Bool
< :: BitProd r xs h -> BitProd r xs h -> Bool
$c<= :: forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> Bool
<= :: BitProd r xs h -> BitProd r xs h -> Bool
$c> :: forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> Bool
> :: BitProd r xs h -> BitProd r xs h -> Bool
$c>= :: forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> Bool
>= :: BitProd r xs h -> BitProd r xs h -> Bool
$cmax :: forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> BitProd r xs h
max :: BitProd r xs h -> BitProd r xs h -> BitProd r xs h
$cmin :: forall r k (xs :: [k]) (h :: k -> Type).
Ord r =>
BitProd r xs h -> BitProd r xs h -> BitProd r xs h
min :: BitProd r xs h -> BitProd r xs h -> BitProd r xs h
Ord, Int -> BitProd r xs h
BitProd r xs h -> Int
BitProd r xs h -> [BitProd r xs h]
BitProd r xs h -> BitProd r xs h
BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
BitProd r xs h
-> BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
(BitProd r xs h -> BitProd r xs h)
-> (BitProd r xs h -> BitProd r xs h)
-> (Int -> BitProd r xs h)
-> (BitProd r xs h -> Int)
-> (BitProd r xs h -> [BitProd r xs h])
-> (BitProd r xs h -> BitProd r xs h -> [BitProd r xs h])
-> (BitProd r xs h -> BitProd r xs h -> [BitProd r xs h])
-> (BitProd r xs h
    -> BitProd r xs h -> BitProd r xs h -> [BitProd r xs h])
-> Enum (BitProd r xs h)
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
Int -> BitProd r xs h
forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> Int
forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> [BitProd r xs h]
forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> BitProd r xs h
forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h
-> BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
$csucc :: forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> BitProd r xs h
succ :: BitProd r xs h -> BitProd r xs h
$cpred :: forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> BitProd r xs h
pred :: BitProd r xs h -> BitProd r xs h
$ctoEnum :: forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
Int -> BitProd r xs h
toEnum :: Int -> BitProd r xs h
$cfromEnum :: forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> Int
fromEnum :: BitProd r xs h -> Int
$cenumFrom :: forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> [BitProd r xs h]
enumFrom :: BitProd r xs h -> [BitProd r xs h]
$cenumFromThen :: forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
enumFromThen :: BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
$cenumFromTo :: forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
enumFromTo :: BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
$cenumFromThenTo :: forall r k (xs :: [k]) (h :: k -> Type).
Enum r =>
BitProd r xs h
-> BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
enumFromThenTo :: BitProd r xs h
-> BitProd r xs h -> BitProd r xs h -> [BitProd r xs h]
Enum, BitProd r xs h
BitProd r xs h -> BitProd r xs h -> Bounded (BitProd r xs h)
forall a. a -> a -> Bounded a
forall r k (xs :: [k]) (h :: k -> Type).
Bounded r =>
BitProd r xs h
$cminBound :: forall r k (xs :: [k]) (h :: k -> Type).
Bounded r =>
BitProd r xs h
minBound :: BitProd r xs h
$cmaxBound :: forall r k (xs :: [k]) (h :: k -> Type).
Bounded r =>
BitProd r xs h
maxBound :: BitProd r xs h
Bounded, Ord (BitProd r xs h)
Ord (BitProd r xs h) =>
((BitProd r xs h, BitProd r xs h) -> [BitProd r xs h])
-> ((BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Int)
-> ((BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Int)
-> ((BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Bool)
-> ((BitProd r xs h, BitProd r xs h) -> Int)
-> ((BitProd r xs h, BitProd r xs h) -> Int)
-> Ix (BitProd r xs h)
(BitProd r xs h, BitProd r xs h) -> Int
(BitProd r xs h, BitProd r xs h) -> [BitProd r xs h]
(BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Bool
(BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Int
forall a.
Ord a =>
((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
Ord (BitProd r xs h)
forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> Int
forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> [BitProd r xs h]
forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Bool
forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Int
$crange :: forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> [BitProd r xs h]
range :: (BitProd r xs h, BitProd r xs h) -> [BitProd r xs h]
$cindex :: forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Int
index :: (BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Int
$cunsafeIndex :: forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Int
unsafeIndex :: (BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Int
$cinRange :: forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Bool
inRange :: (BitProd r xs h, BitProd r xs h) -> BitProd r xs h -> Bool
$crangeSize :: forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> Int
rangeSize :: (BitProd r xs h, BitProd r xs h) -> Int
$cunsafeRangeSize :: forall r k (xs :: [k]) (h :: k -> Type).
Ix r =>
(BitProd r xs h, BitProd r xs h) -> Int
unsafeRangeSize :: (BitProd r xs h, BitProd r xs h) -> Int
Ix, (forall x. BitProd r xs h -> Rep (BitProd r xs h) x)
-> (forall x. Rep (BitProd r xs h) x -> BitProd r xs h)
-> Generic (BitProd r xs h)
forall x. Rep (BitProd r xs h) x -> BitProd r xs h
forall x. BitProd r xs h -> Rep (BitProd r xs h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall r k (xs :: [k]) (h :: k -> Type) x.
Rep (BitProd r xs h) x -> BitProd r xs h
forall r k (xs :: [k]) (h :: k -> Type) x.
BitProd r xs h -> Rep (BitProd r xs h) x
$cfrom :: forall r k (xs :: [k]) (h :: k -> Type) x.
BitProd r xs h -> Rep (BitProd r xs h) x
from :: forall x. BitProd r xs h -> Rep (BitProd r xs h) x
$cto :: forall r k (xs :: [k]) (h :: k -> Type) x.
Rep (BitProd r xs h) x -> BitProd r xs h
to :: forall x. Rep (BitProd r xs h) x -> BitProd r xs h
Generic, Eq (BitProd r xs h)
Eq (BitProd r xs h) =>
(Int -> BitProd r xs h -> Int)
-> (BitProd r xs h -> Int) -> Hashable (BitProd r xs h)
Int -> BitProd r xs h -> Int
BitProd r xs h -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall r k (xs :: [k]) (h :: k -> Type).
Hashable r =>
Eq (BitProd r xs h)
forall r k (xs :: [k]) (h :: k -> Type).
Hashable r =>
Int -> BitProd r xs h -> Int
forall r k (xs :: [k]) (h :: k -> Type).
Hashable r =>
BitProd r xs h -> Int
$chashWithSalt :: forall r k (xs :: [k]) (h :: k -> Type).
Hashable r =>
Int -> BitProd r xs h -> Int
hashWithSalt :: Int -> BitProd r xs h -> Int
$chash :: forall r k (xs :: [k]) (h :: k -> Type).
Hashable r =>
BitProd r xs h -> Int
hash :: BitProd r xs h -> Int
Hashable, Ptr (BitProd r xs h) -> IO (BitProd r xs h)
Ptr (BitProd r xs h) -> Int -> IO (BitProd r xs h)
Ptr (BitProd r xs h) -> Int -> BitProd r xs h -> IO ()
Ptr (BitProd r xs h) -> BitProd r xs h -> IO ()
BitProd r xs h -> Int
(BitProd r xs h -> Int)
-> (BitProd r xs h -> Int)
-> (Ptr (BitProd r xs h) -> Int -> IO (BitProd r xs h))
-> (Ptr (BitProd r xs h) -> Int -> BitProd r xs h -> IO ())
-> (forall b. Ptr b -> Int -> IO (BitProd r xs h))
-> (forall b. Ptr b -> Int -> BitProd r xs h -> IO ())
-> (Ptr (BitProd r xs h) -> IO (BitProd r xs h))
-> (Ptr (BitProd r xs h) -> BitProd r xs h -> IO ())
-> Storable (BitProd r xs h)
forall b. Ptr b -> Int -> IO (BitProd r xs h)
forall b. Ptr b -> Int -> BitProd r xs h -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
Ptr (BitProd r xs h) -> IO (BitProd r xs h)
forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
Ptr (BitProd r xs h) -> Int -> IO (BitProd r xs h)
forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
Ptr (BitProd r xs h) -> Int -> BitProd r xs h -> IO ()
forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
Ptr (BitProd r xs h) -> BitProd r xs h -> IO ()
forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
BitProd r xs h -> Int
forall r k (xs :: [k]) (h :: k -> Type) b.
Storable r =>
Ptr b -> Int -> IO (BitProd r xs h)
forall r k (xs :: [k]) (h :: k -> Type) b.
Storable r =>
Ptr b -> Int -> BitProd r xs h -> IO ()
$csizeOf :: forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
BitProd r xs h -> Int
sizeOf :: BitProd r xs h -> Int
$calignment :: forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
BitProd r xs h -> Int
alignment :: BitProd r xs h -> Int
$cpeekElemOff :: forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
Ptr (BitProd r xs h) -> Int -> IO (BitProd r xs h)
peekElemOff :: Ptr (BitProd r xs h) -> Int -> IO (BitProd r xs h)
$cpokeElemOff :: forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
Ptr (BitProd r xs h) -> Int -> BitProd r xs h -> IO ()
pokeElemOff :: Ptr (BitProd r xs h) -> Int -> BitProd r xs h -> IO ()
$cpeekByteOff :: forall r k (xs :: [k]) (h :: k -> Type) b.
Storable r =>
Ptr b -> Int -> IO (BitProd r xs h)
peekByteOff :: forall b. Ptr b -> Int -> IO (BitProd r xs h)
$cpokeByteOff :: forall r k (xs :: [k]) (h :: k -> Type) b.
Storable r =>
Ptr b -> Int -> BitProd r xs h -> IO ()
pokeByteOff :: forall b. Ptr b -> Int -> BitProd r xs h -> IO ()
$cpeek :: forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
Ptr (BitProd r xs h) -> IO (BitProd r xs h)
peek :: Ptr (BitProd r xs h) -> IO (BitProd r xs h)
$cpoke :: forall r k (xs :: [k]) (h :: k -> Type).
Storable r =>
Ptr (BitProd r xs h) -> BitProd r xs h -> IO ()
poke :: Ptr (BitProd r xs h) -> BitProd r xs h -> IO ()
Storable)

instance (Forall (Instance1 Show h) xs, BitFields r xs h) => Show (BitProd r xs h) where
  showsPrec :: Int -> BitProd r xs h -> ShowS
showsPrec Int
d BitProd r xs h
x = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"toBitProd " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (xs :& h) -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (BitProd r xs h -> xs :& h
forall {k} r (xs :: [k]) (h :: k -> Type).
BitFields r xs h =>
BitProd r xs h -> xs :& h
fromBitProd BitProd r xs h
x)

-- | Total 'BitWidth'
type family TotalBits h xs where
  TotalBits h '[] = 0
  TotalBits h (x ': xs) = BitWidth (h x) + TotalBits h xs

-- | Conversion between a value and a bit representation.
--
-- Instances of `FromBits` must satisfy the following laws:
--
-- > fromBits (x `shiftL` W .|. toBits a) ≡ a
-- > toBits a `shiftR` W == zeroBits
--
-- where W is the 'BitWidth'.
class (Bits r, KnownNat (BitWidth a)) => FromBits r a where
  type BitWidth a :: Nat
  fromBits :: r -> a
  toBits :: a -> r

instance Bits r => FromBits r () where
  type BitWidth () = 0
  fromBits :: r -> ()
fromBits r
_ = ()
  toBits :: () -> r
toBits ()
_ = r
forall a. Bits a => a
zeroBits

instance Bits r => FromBits r (Proxy a) where
  type BitWidth (Proxy a) = 0
  fromBits :: r -> Proxy a
fromBits r
_ = Proxy a
forall {k} (t :: k). Proxy t
Proxy
  toBits :: Proxy a -> r
toBits Proxy a
_ = r
forall a. Bits a => a
zeroBits

instance FromBits Word64 Word64 where
  type BitWidth Word64 = 64
  fromBits :: Word64 -> Word64
fromBits = Word64 -> Word64
forall a. a -> a
id
  toBits :: Word64 -> Word64
toBits = Word64 -> Word64
forall a. a -> a
id

instance FromBits Word64 Bool where
  type BitWidth Bool = 1
  fromBits :: Word64 -> Bool
fromBits = (Word64 -> Int -> Bool) -> Int -> Word64 -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int
0
  toBits :: Bool -> Word64
toBits Bool
False = Word64
0
  toBits Bool
True = Word64
1

instance FromBits Word64 Word8 where
  type BitWidth Word8 = 8
  fromBits :: Word64 -> Word8
fromBits = Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  toBits :: Word8 -> Word64
toBits = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance FromBits Word64 Word16 where
  type BitWidth Word16 = 16
  fromBits :: Word64 -> Word16
fromBits = Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  toBits :: Word16 -> Word64
toBits = Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance FromBits Word64 Word32 where
  type BitWidth Word32 = 32
  fromBits :: Word64 -> Word32
fromBits = Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  toBits :: Word32 -> Word64
toBits = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance FromBits Word64 Int8 where
  type BitWidth Int8 = 8
  fromBits :: Word64 -> Int8
fromBits = Word64 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  toBits :: Int8 -> Word64
toBits = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> (Int8 -> Word8) -> Int8 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int8 -> Word8)

instance FromBits Word64 Int16 where
  type BitWidth Int16 = 16
  fromBits :: Word64 -> Int16
fromBits = Word64 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  toBits :: Int16 -> Word64
toBits = Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word64) -> (Int16 -> Word16) -> Int16 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int16 -> Word16)

instance FromBits Word64 Int32 where
  type BitWidth Int32 = 32
  fromBits :: Word64 -> Int32
fromBits = Word64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  toBits :: Int32 -> Word64
toBits = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> (Int32 -> Word32) -> Int32 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int32 -> Word32)

instance FromBits r a => FromBits r (Identity a) where
  type BitWidth (Identity a) = BitWidth a
  fromBits :: r -> Identity a
fromBits = a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> (r -> a) -> r -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> a
forall r a. FromBits r a => r -> a
fromBits
  toBits :: Identity a -> r
toBits = a -> r
forall r a. FromBits r a => a -> r
toBits (a -> r) -> (Identity a -> a) -> Identity a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity

instance (FromBits r a, FromBits r b, n ~ (BitWidth a + BitWidth b), n <= BitWidth r, KnownNat n) => FromBits r (a, b) where
  type BitWidth (a, b) = BitWidth a + BitWidth b
  fromBits :: r -> (a, b)
fromBits r
r = (r -> a
forall r a. FromBits r a => r -> a
fromBits (r -> Int -> r
forall a. Bits a => a -> Int -> a
unsafeShiftR r
r Int
width), r -> b
forall r a. FromBits r a => r -> a
fromBits r
r) where
    width :: Int
width = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy (BitWidth b) -> Integer
forall (n :: Natural) (proxy :: Natural -> Type).
KnownNat n =>
proxy n -> Integer
natVal (Proxy (BitWidth b)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (BitWidth b))
  toBits :: (a, b) -> r
toBits (a
a, b
b) = r -> Int -> r
forall a. Bits a => a -> Int -> a
unsafeShiftL (a -> r
forall r a. FromBits r a => a -> r
toBits a
a) Int
width r -> r -> r
forall a. Bits a => a -> a -> a
.|. b -> r
forall r a. FromBits r a => a -> r
toBits b
b where
    width :: Int
width = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy (BitWidth b) -> Integer
forall (n :: Natural) (proxy :: Natural -> Type).
KnownNat n =>
proxy n -> Integer
natVal (Proxy (BitWidth b)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (BitWidth b))

instance FromBits r a => FromBits r (Const a b) where
  type BitWidth (Const a b) = BitWidth a
  fromBits :: r -> Const a b
fromBits = a -> Const a b
forall {k} a (b :: k). a -> Const a b
Const (a -> Const a b) -> (r -> a) -> r -> Const a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> a
forall r a. FromBits r a => r -> a
fromBits
  toBits :: Const a b -> r
toBits = a -> r
forall r a. FromBits r a => a -> r
toBits (a -> r) -> (Const a b -> a) -> Const a b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const a b -> a
forall {k} a (b :: k). Const a b -> a
getConst

instance (Bits r, FromBits r (h (TargetOf x))) => FromBits r (Field h x) where
  type BitWidth (Field h x) = BitWidth (h (TargetOf x))
  fromBits :: r -> Field h x
fromBits = h (TargetOf x) -> Field h x
forall v k (h :: v -> Type) (kv :: Assoc k v).
h (TargetOf kv) -> Field h kv
Field (h (TargetOf x) -> Field h x)
-> (r -> h (TargetOf x)) -> r -> Field h x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> h (TargetOf x)
forall r a. FromBits r a => r -> a
fromBits
  toBits :: Field h x -> r
toBits = h (TargetOf x) -> r
forall r a. FromBits r a => a -> r
toBits (h (TargetOf x) -> r)
-> (Field h x -> h (TargetOf x)) -> Field h x -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field h x -> h (TargetOf x)
forall v k (h :: v -> Type) (kv :: Assoc k v).
Field h kv -> h (TargetOf kv)
getField

instance (Bits r, KnownNat (TotalBits h xs)) => FromBits r (BitProd r xs h) where
  type BitWidth (BitProd r xs h) = TotalBits h xs
  fromBits :: r -> BitProd r xs h
fromBits = r -> BitProd r xs h
forall k r (xs :: [k]) (h :: k -> Type). r -> BitProd r xs h
BitProd
  toBits :: BitProd r xs h -> r
toBits = BitProd r xs h -> r
forall k r (xs :: [k]) (h :: k -> Type). BitProd r xs h -> r
unBitProd

-- | Fields are instances of 'FromBits' and fit in the representation.
type BitFields r xs h = (FromBits r r
  , TotalBits h xs <= BitWidth r
  , Forall (Instance1 (FromBits r) h) xs)

-- | Convert a normal extensible record into a bit record.
toBitProd :: forall r xs h. BitFields r xs h => xs :& h -> BitProd r xs h
toBitProd :: forall {k} r (xs :: [k]) (h :: k -> Type).
BitFields r xs h =>
(xs :& h) -> BitProd r xs h
toBitProd xs :& h
p = Proxy (Instance1 (FromBits r) h)
-> (forall (x :: k).
    Instance1 (FromBits r) h x =>
    Membership xs x
    -> h x
    -> (BitProd r xs h -> BitProd r xs h)
    -> BitProd r xs h
    -> BitProd r xs h)
-> (BitProd r xs h -> BitProd r xs h)
-> (xs :& h)
-> BitProd r xs h
-> BitProd r xs h
forall {k} (c :: k -> Constraint) (xs :: [k]) (h :: k -> Type) r
       (proxy :: (k -> Constraint) -> Type).
Forall c xs =>
proxy c
-> (forall (x :: k). c x => Membership xs x -> h x -> r -> r)
-> r
-> (xs :& h)
-> r
hfoldrWithIndexFor (Proxy (Instance1 (FromBits r) h)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Instance1 (FromBits r) h))
  (\Membership xs x
i h x
v BitProd r xs h -> BitProd r xs h
f BitProd r xs h
r -> BitProd r xs h -> BitProd r xs h
f (BitProd r xs h -> BitProd r xs h)
-> BitProd r xs h -> BitProd r xs h
forall a b. (a -> b) -> a -> b
$! Membership xs x -> BitProd r xs h -> h x -> BitProd r xs h
forall {k} (x :: k) r (xs :: [k]) (h :: k -> Type).
(BitFields r xs h, FromBits r (h x)) =>
Membership xs x -> BitProd r xs h -> h x -> BitProd r xs h
bupdate Membership xs x
i BitProd r xs h
r h x
v) BitProd r xs h -> BitProd r xs h
forall a. a -> a
id xs :& h
p (r -> BitProd r xs h
forall k r (xs :: [k]) (h :: k -> Type). r -> BitProd r xs h
BitProd r
forall a. Bits a => a
zeroBits)
{-# INLINE toBitProd #-}

-- | Convert a normal extensible record into a bit record.
fromBitProd :: forall r xs h. BitFields r xs h => BitProd r xs h -> xs :& h
fromBitProd :: forall {k} r (xs :: [k]) (h :: k -> Type).
BitFields r xs h =>
BitProd r xs h -> xs :& h
fromBitProd BitProd r xs h
p = Proxy (Instance1 (FromBits r) h)
-> (forall {x :: k}.
    Instance1 (FromBits r) h x =>
    Membership xs x -> h x)
-> xs :& h
forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> Type) (h :: k -> Type).
Forall c xs =>
proxy c
-> (forall (x :: k). c x => Membership xs x -> h x) -> xs :& h
htabulateFor (Proxy (Instance1 (FromBits r) h)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Instance1 (FromBits r) h))
  ((forall {x :: k}.
  Instance1 (FromBits r) h x =>
  Membership xs x -> h x)
 -> xs :& h)
-> (forall {x :: k}.
    Instance1 (FromBits r) h x =>
    Membership xs x -> h x)
-> xs :& h
forall a b. (a -> b) -> a -> b
$ (Membership xs x -> BitProd r xs h -> h x)
-> BitProd r xs h -> Membership xs x -> h x
forall a b c. (a -> b -> c) -> b -> a -> c
flip Membership xs x -> BitProd r xs h -> h x
forall {k} (x :: k) r (xs :: [k]) (h :: k -> Type).
(BitFields r xs h, FromBits r (h x)) =>
Membership xs x -> BitProd r xs h -> h x
blookup BitProd r xs h
p
{-# INLINE fromBitProd #-}

-- | 'hlookup' for 'BitProd'
blookup :: forall x r xs h.
  (BitFields r xs h, FromBits r (h x))
  => Membership xs x -> BitProd r xs h -> h x
blookup :: forall {k} (x :: k) r (xs :: [k]) (h :: k -> Type).
(BitFields r xs h, FromBits r (h x)) =>
Membership xs x -> BitProd r xs h -> h x
blookup Membership xs x
i (BitProd r
r) = r -> h x
forall r a. FromBits r a => r -> a
fromBits (r -> h x) -> r -> h x
forall a b. (a -> b) -> a -> b
$ r -> Int -> r
forall a. Bits a => a -> Int -> a
unsafeShiftR r
r
  (Int -> r) -> Int -> r
forall a b. (a -> b) -> a -> b
$ Proxy r -> Proxy h -> Proxy xs -> Int -> Int
forall k r (h :: k -> Type) (xs :: [k]).
Forall (Instance1 (FromBits r) h) xs =>
Proxy r -> Proxy h -> Proxy xs -> Int -> Int
bitOffsetAt (Proxy r
forall {k} (t :: k). Proxy t
Proxy :: Proxy r) (Proxy h
forall {k} (t :: k). Proxy t
Proxy :: Proxy h) (Proxy xs
forall {k} (t :: k). Proxy t
Proxy :: Proxy xs)
  (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Membership xs x -> Int
forall k (xs :: [k]) (x :: k). Membership xs x -> Int
getMemberId Membership xs x
i
{-# INLINE blookup #-}

-- | Update a field of a 'BitProd'.
bupdate :: forall x r xs h.
  (BitFields r xs h, FromBits r (h x))
  => Membership xs x -> BitProd r xs h -> h x -> BitProd r xs h
bupdate :: forall {k} (x :: k) r (xs :: [k]) (h :: k -> Type).
(BitFields r xs h, FromBits r (h x)) =>
Membership xs x -> BitProd r xs h -> h x -> BitProd r xs h
bupdate Membership xs x
i (BitProd r
r) h x
a = r -> BitProd r xs h
forall k r (xs :: [k]) (h :: k -> Type). r -> BitProd r xs h
BitProd (r -> BitProd r xs h) -> r -> BitProd r xs h
forall a b. (a -> b) -> a -> b
$ r
r r -> r -> r
forall a. Bits a => a -> a -> a
.&. r
mask
  r -> r -> r
forall a. Bits a => a -> a -> a
.|. r -> Int -> r
forall a. Bits a => a -> Int -> a
unsafeShiftL (h x -> r
forall r a. FromBits r a => a -> r
toBits h x
a) Int
offset
  where
    mask :: r
mask = r -> Int -> r
forall a. Bits a => a -> Int -> a
unsafeShiftL (r -> r
forall a. Bits a => a -> a
complement r
forall a. Bits a => a
zeroBits) Int
width r -> Int -> r
forall a. Bits a => a -> Int -> a
`rotateL` Int
offset
    width :: Int
width = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy (BitWidth (h x)) -> Integer
forall (n :: Natural) (proxy :: Natural -> Type).
KnownNat n =>
proxy n -> Integer
natVal (Proxy (BitWidth (h x))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (BitWidth (h x)))
    offset :: Int
offset = Proxy r -> Proxy h -> Proxy xs -> Int -> Int
forall k r (h :: k -> Type) (xs :: [k]).
Forall (Instance1 (FromBits r) h) xs =>
Proxy r -> Proxy h -> Proxy xs -> Int -> Int
bitOffsetAt (Proxy r
forall {k} (t :: k). Proxy t
Proxy :: Proxy r) (Proxy h
forall {k} (t :: k). Proxy t
Proxy :: Proxy h) (Proxy xs
forall {k} (t :: k). Proxy t
Proxy :: Proxy xs) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Membership xs x -> Int
forall k (xs :: [k]) (x :: k). Membership xs x -> Int
getMemberId Membership xs x
i
{-# INLINE bupdate #-}

bitOffsetAt :: forall k r h xs. Forall (Instance1 (FromBits r) h) xs
  => Proxy (r :: Type) -> Proxy (h :: k -> Type) -> Proxy (xs :: [k]) -> Int -> Int
bitOffsetAt :: forall k r (h :: k -> Type) (xs :: [k]).
Forall (Instance1 (FromBits r) h) xs =>
Proxy r -> Proxy h -> Proxy xs -> Int -> Int
bitOffsetAt Proxy r
_ Proxy h
ph Proxy xs
_ = Proxy (Instance1 (FromBits r) h)
-> Proxy xs
-> (forall (x :: k).
    Instance1 (FromBits r) h x =>
    Membership xs x -> (Int -> Int -> Int) -> Int -> Int -> Int)
-> (Int -> Int -> Int)
-> Int
-> Int
-> Int
forall k (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> Type) (proxy' :: [k] -> Type) r.
Forall c xs =>
proxy c
-> proxy' xs
-> (forall (x :: k). c x => Membership xs x -> r -> r)
-> r
-> r
forall (proxy :: (k -> Constraint) -> Type) (proxy' :: [k] -> Type)
       r.
proxy (Instance1 (FromBits r) h)
-> proxy' xs
-> (forall (x :: k).
    Instance1 (FromBits r) h x =>
    Membership xs x -> r -> r)
-> r
-> r
henumerateFor
  (Proxy (Instance1 (FromBits r) h)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Instance1 (FromBits r) h))
  (Proxy xs
forall {k} (t :: k). Proxy t
Proxy :: Proxy xs)
  (\Membership xs x
m Int -> Int -> Int
r Int
o Int
i -> if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    then Int
o
    else Int -> Int -> Int
r (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy (BitWidth (h x)) -> Integer
forall (n :: Natural) (proxy :: Natural -> Type).
KnownNat n =>
proxy n -> Integer
natVal (Proxy h -> Membership xs x -> Proxy (BitWidth (h x))
forall {k} (h :: k -> Type) (proxy :: k -> Type) (x :: k).
Proxy h -> proxy x -> Proxy (BitWidth (h x))
proxyBitWidth Proxy h
ph Membership xs x
m)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
o) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  (String -> Int -> Int -> Int
forall a. HasCallStack => String -> a
error String
"Impossible") Int
0
{-# INLINE bitOffsetAt #-}

proxyBitWidth :: Proxy h -> proxy x -> Proxy (BitWidth (h x))
proxyBitWidth :: forall {k} (h :: k -> Type) (proxy :: k -> Type) (x :: k).
Proxy h -> proxy x -> Proxy (BitWidth (h x))
proxyBitWidth Proxy h
_ proxy x
_ = Proxy (BitWidth (h x))
forall {k} (t :: k). Proxy t
Proxy

-- | Bit-packed record
type BitRecordOf r h xs = BitProd r xs (Field h)

-- | Bit-packed record
type BitRecord r xs = BitRecordOf r Identity xs

instance (Corepresentable p, Comonad (Corep p), Functor f) => Extensible f p (BitProd r) where
  type ExtensibleConstr (BitProd r) xs h x
    = (BitFields r xs h, FromBits r (h x))
  pieceAt :: forall (xs :: [k]) (h :: k -> Type) (x :: k).
ExtensibleConstr (BitProd r) xs h x =>
Membership xs x -> Optic' p f (BitProd r xs h) (h x)
pieceAt Membership xs x
i p (h x) (f (h x))
pafb = (Corep p (BitProd r xs h) -> f (BitProd r xs h))
-> p (BitProd r xs h) (f (BitProd r xs h))
forall d c. (Corep p d -> c) -> p d c
forall (p :: Type -> Type -> Type) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate ((Corep p (BitProd r xs h) -> f (BitProd r xs h))
 -> p (BitProd r xs h) (f (BitProd r xs h)))
-> (Corep p (BitProd r xs h) -> f (BitProd r xs h))
-> p (BitProd r xs h) (f (BitProd r xs h))
forall a b. (a -> b) -> a -> b
$ \Corep p (BitProd r xs h)
ws -> Membership xs x -> BitProd r xs h -> h x -> BitProd r xs h
forall {k} (x :: k) r (xs :: [k]) (h :: k -> Type).
(BitFields r xs h, FromBits r (h x)) =>
Membership xs x -> BitProd r xs h -> h x -> BitProd r xs h
bupdate Membership xs x
i (Corep p (BitProd r xs h) -> BitProd r xs h
forall a. Corep p a -> a
forall (w :: Type -> Type) a. Comonad w => w a -> a
extract Corep p (BitProd r xs h)
ws) (h x -> BitProd r xs h) -> f (h x) -> f (BitProd r xs h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> p (h x) (f (h x)) -> Corep p (h x) -> f (h x)
forall a b. p a b -> Corep p a -> b
forall (p :: Type -> Type -> Type) (f :: Type -> Type) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve p (h x) (f (h x))
pafb (Membership xs x -> BitProd r xs h -> h x
forall {k} (x :: k) r (xs :: [k]) (h :: k -> Type).
(BitFields r xs h, FromBits r (h x)) =>
Membership xs x -> BitProd r xs h -> h x
blookup Membership xs x
i (BitProd r xs h -> h x)
-> Corep p (BitProd r xs h) -> Corep p (h x)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Corep p (BitProd r xs h)
ws)
  {-# INLINE pieceAt #-}