{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Ivory.Language.BitData.BitData where
import Ivory.Language.Bits
import Ivory.Language.Proxy
import Ivory.Language.Cast
import Ivory.Language.IBool
import Ivory.Language.BitData.Bits
class (ANat (BitSize (BitType a)),
IvoryRep (BitDataRep a),
BitType a ~ Bits (BitSize (BitType a))) => BitData a where
type BitType a :: *
toBits :: a -> BitType a
fromBits :: BitType a -> a
type BitDataRep a = BitRep (BitSize (BitType a))
fromRep :: BitData a => BitDataRep a -> a
fromRep = fromBits . repToBits
unsafeFromRep :: BitData a => BitDataRep a -> a
unsafeFromRep = fromBits . unsafeRepToBits
toRep :: BitData a => a -> BitDataRep a
toRep = unBits . toBits
instance (ANat n, IvoryRep (BitRep n)) => BitData (Bits n) where
type BitType (Bits n) = Bits n
toBits = id
fromBits = id
data BitDataField a b = BitDataField
{ bitDataFieldPos :: Int
, bitDataFieldLen :: Int
, bitDataFieldName :: String
} deriving Show
(#>) :: BitDataField a b -> BitDataField b c -> BitDataField a c
(BitDataField p1 _ n1) #> (BitDataField p2 l2 n2) = BitDataField pos len name
where
name = n1 ++ "." ++ n2
pos = p1 + p2
len = l2
getBitDataField :: (BitData a, BitData b,
BitCast (BitDataRep a) (BitDataRep b))
=> BitDataField a b -> a -> b
getBitDataField f x = unsafeFromRep (bitCast ((toRep x `iShiftR` pos) .& mask))
where pos = fromIntegral (bitDataFieldPos f)
mask = fromIntegral ((2 ^ bitDataFieldLen f) - 1 :: Integer)
(#.) :: (BitData a, BitData b,
BitCast (BitDataRep a) (BitDataRep b))
=> a -> BitDataField a b -> b
(#.) = flip getBitDataField
setBitDataField :: (BitData a, BitData b,
SafeCast (BitDataRep b) (BitDataRep a))
=> BitDataField a b -> a -> b -> a
setBitDataField f x y = unsafeFromRep ((toRep x .& mask) .| val)
where val = safeCast (toRep y) `iShiftL` pos
pos = fromIntegral (bitDataFieldPos f)
fmax = fromIntegral ((2 ^ bitDataFieldLen f) - 1 :: Integer)
mask = iComplement (fmax `iShiftL` pos)
setBitDataBit :: BitData a => BitDataField a Bit -> a -> a
setBitDataBit f x = unsafeFromRep (toRep x .| (1 `iShiftL` pos))
where pos = fromIntegral (bitDataFieldPos f)
clearBitDataBit :: BitData a => BitDataField a Bit -> a -> a
clearBitDataBit f x = unsafeFromRep (toRep x .& (iComplement (1 `iShiftL` pos)))
where pos = fromIntegral (bitDataFieldPos f)
bitToBool :: Bit -> IBool
bitToBool b = (toRep b ==? 0) ? (false, true)
boolToBit :: IBool -> Bit
boolToBit b = b ? (fromRep 1, fromRep 0)