Bits.hs

{-# 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 { unBitProd :: r }
  deriving (Eq, Ord, Enum, Bounded, Ix, Generic, Hashable, Storable)

instance (Forall (Instance1 Show h) xs, BitFields r xs h) => Show (BitProd r xs h) where
  showsPrec d x = showParen (d > 10)
    $ showString "toBitProd " . showsPrec 11 (fromBitProd 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 _ = ()
  toBits _ = zeroBits

instance Bits r => FromBits r (Proxy a) where
  type BitWidth (Proxy a) = 0
  fromBits _ = Proxy
  toBits _ = zeroBits

instance FromBits Word64 Word64 where
  type BitWidth Word64 = 64
  fromBits = id
  toBits = id

instance FromBits Word64 Bool where
  type BitWidth Bool = 1
  fromBits = flip testBit 0
  toBits False = 0
  toBits True = 1

instance FromBits Word64 Word8 where
  type BitWidth Word8 = 8
  fromBits = fromIntegral
  toBits = fromIntegral

instance FromBits Word64 Word16 where
  type BitWidth Word16 = 16
  fromBits = fromIntegral
  toBits = fromIntegral

instance FromBits Word64 Word32 where
  type BitWidth Word32 = 32
  fromBits = fromIntegral
  toBits = fromIntegral

instance FromBits Word64 Int8 where
  type BitWidth Int8 = 8
  fromBits = fromIntegral
  toBits = fromIntegral . (fromIntegral :: Int8 -> Word8)

instance FromBits Word64 Int16 where
  type BitWidth Int16 = 16
  fromBits = fromIntegral
  toBits = fromIntegral . (fromIntegral :: Int16 -> Word16)

instance FromBits Word64 Int32 where
  type BitWidth Int32 = 32
  fromBits = fromIntegral
  toBits = fromIntegral . (fromIntegral :: Int32 -> Word32)

instance FromBits r a => FromBits r (Identity a) where
  type BitWidth (Identity a) = BitWidth a
  fromBits = Identity . fromBits
  toBits = toBits . 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 = (fromBits (unsafeShiftR r width), fromBits r) where
    width = fromInteger $ natVal (Proxy :: Proxy (BitWidth b))
  toBits (a, b) = unsafeShiftL (toBits a) width .|. toBits b where
    width = fromInteger $ natVal (Proxy :: Proxy (BitWidth b))

instance FromBits r a => FromBits r (Const a b) where
  type BitWidth (Const a b) = BitWidth a
  fromBits = Const . fromBits
  toBits = toBits . getConst

instance (Bits r, KnownNat (BitWidth (h (TargetOf x))), FromBits r (h (TargetOf x))) => FromBits r (Field h x) where
  type BitWidth (Field h x) = BitWidth (h (TargetOf x))
  fromBits = Field . fromBits
  toBits = toBits . 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 = BitProd
  toBits = 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 p = hfoldrWithIndexFor (Proxy :: Proxy (Instance1 (FromBits r) h))
  (\i v f r -> f $! bupdate i r v) id p (BitProd 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 p = htabulateFor (Proxy :: Proxy (Instance1 (FromBits r) h))
  $ flip blookup 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 i (BitProd r) = fromBits $ unsafeShiftR r
  $ bitOffsetAt (Proxy :: Proxy r) (Proxy :: Proxy h) (Proxy :: Proxy xs)
  $ getMemberId 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 i (BitProd r) a = BitProd $ r .&. mask
  .|. unsafeShiftL (toBits a) offset
  where
    mask = unsafeShiftL (complement zeroBits) width `rotateL` offset
    width = fromInteger $ natVal (Proxy :: Proxy (BitWidth (h x)))
    offset = bitOffsetAt (Proxy :: Proxy r) (Proxy :: Proxy h) (Proxy :: Proxy xs) $ getMemberId 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 _ ph _ = henumerateFor
  (Proxy :: Proxy (Instance1 (FromBits r) h))
  (Proxy :: Proxy xs)
  (\m r o i -> if i == 0
    then o
    else r (fromInteger (natVal (proxyBitWidth ph m)) + o) (i - 1))
  (error "Impossible") 0
{-# INLINE bitOffsetAt #-}

proxyBitWidth :: Proxy h -> proxy x -> Proxy (BitWidth (h x))
proxyBitWidth _ _ = 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 i pafb = cotabulate $ \ws -> bupdate i (extract ws) <$> cosieve pafb (blookup i <$> ws)
  {-# INLINE pieceAt #-}