module Data.Type.BitRecords.Enum where
import Data.Type.BitRecords.Core
import Data.Type.BitRecords.Builder.BitBuffer
import Data.Type.BitRecords.Builder.Holey
import Data.Type.BitRecords.Builder.LazyByteStringBuilder
import Data.Proxy
import Data.Word
import Data.Kind (Type)
import GHC.TypeLits
import Data.Kind.Extra
import Data.Type.Pretty
data EnumOf enum where
MkEnumOf
:: IsAn (EnumField enum size)
-> IsA (FieldValue label enum)
-> BitRecord
-> EnumOf enum
type BitRecordOfEnum (e :: IsAn (EnumOf enum)) = (RenderEnumOf (Eval e) :: BitRecord)
type family RenderEnumOf (e :: EnumOf enum) :: BitRecord where
RenderEnumOf ('MkEnumOf mainField mainFieldVal extra) =
(BitRecordFieldOfEnumField mainField) :~ mainFieldVal .+: extra
data EnumField (enum :: Type) (size :: Nat)
type BitRecordFieldOfEnumField (x :: IsA (EnumField e s)) =
MkField ('MkFieldCustom :: BitField (EnumValue e) e s)
data FixedEnum (enum :: Type) (size :: Nat) :: IsAn (EnumField enum size)
data ExtEnum (enum :: Type)
(size :: Nat)
(extInd :: enum)
(extField :: IsA (BitRecordField (t :: BitField rt0 (st0 :: k0) len0)))
:: IsAn (EnumField enum size)
data SetEnum (l :: Symbol) (ef :: IsAn (EnumField enum size)) (v :: enum) :: IsAn (EnumOf enum)
type instance Eval (SetEnum (l :: Symbol) (ei :: IsAn (EnumField enum size)) value) =
'MkEnumOf
ei
(StaticFieldValue l value)
'EmptyBitRecord
data EnumParam
(label :: Symbol)
(ef :: IsAn (EnumField (enum :: Type) (size :: Nat)))
:: IsAn (EnumOf enum)
type instance Eval (EnumParam label (ei :: IsAn (EnumField enum size))) =
'MkEnumOf
ei
(RuntimeFieldValue label)
'EmptyBitRecord
data SetEnumAlt (l :: Symbol) (ef :: IsAn (EnumField (enum :: Type) (size :: Nat))) (v :: k)
:: IsAn (EnumOf enum)
type instance Eval (SetEnumAlt (l :: Symbol) (ExtEnum enum size extInd extField) value) =
'MkEnumOf
(ExtEnum enum size extInd extField)
(StaticFieldValue l extInd)
('BitRecordMember (extField := value))
type instance Eval (SetEnumAlt (l :: Symbol) (FixedEnum enum size) value) =
TypeError ('Text "Cannot assign an 'extended' value to the 'FixedEnum' "
':<>: 'ShowType enum)
data EnumParamAlt
(label :: Symbol)
(ef :: IsAn (EnumField (enum :: Type) (size :: Nat)))
:: IsAn (EnumOf enum)
type instance Eval (EnumParamAlt label (ExtEnum enum size extInd extField)) =
'MkEnumOf
(ExtEnum enum size extInd extField)
(StaticFieldValue label extInd)
('BitRecordMember (extField :~ RuntimeFieldValue label))
type instance Eval (EnumParamAlt label (FixedEnum enum size)) =
TypeError ('Text "Cannot assign an extension value to the FixedEnum "
':<>: 'ShowType enum)
type family FromEnum enum (entry :: enum) :: Nat
data EnumValue e where
MkEnumValue :: KnownNat (FromEnum e v) => Proxy (v :: e) -> EnumValue e
enumValueProxy :: KnownNat (FromEnum e v) => Proxy (v :: e) -> EnumValue e
enumValueProxy = MkEnumValue
fromEnumValue :: EnumValue e -> Word64
fromEnumValue (MkEnumValue p) = enumValue p
where
enumValue :: forall proxy (v :: enum) . KnownNat (FromEnum enum v) => proxy v -> Word64
enumValue _ = fromIntegral (natVal (Proxy @(FromEnum enum v)))
instance
forall (size :: Nat) r e (v :: e) (f :: IsA (BitRecordField ('MkFieldCustom :: BitField (EnumValue e) e size))) .
(KnownNat (FromEnum e v), KnownChunkSize size) =>
BitStringBuilderHoley (Proxy (f := v)) r where
bitStringBuilderHoley _ =
immediate (appendBitString
(bitStringProxyLength (Proxy @size)
(fromIntegral (natVal (Proxy @(FromEnum e v))))))
instance
forall (size :: Nat) r e .
(KnownChunkSize size) =>
BitStringBuilderHoley (Proxy (MkField ('MkFieldCustom :: BitField (EnumValue e) e size))) r
where
type ToBitStringBuilder (Proxy (MkField ('MkFieldCustom :: BitField (EnumValue e) e size))) r =
EnumValue e -> r
bitStringBuilderHoley _ =
indirect (appendBitString . bitStringProxyLength (Proxy @size) . fromEnumValue)
type instance ToPretty (EnumValue e) = PutStr "<<enum>>"
type instance PrettyCustomFieldValue (EnumValue e) e size (v :: e) =
PutNat (FromEnum e v) <+> ("hex" <:> PutHex (FromEnum e v)) <+> ("bin" <:> PutBits (FromEnum e v))