bitfield (empty) → 0.0.0.0
raw patch · 8 files changed
+639/−0 lines, 8 filesdep +QuickCheckdep +basedep +bitfield
Dependencies added: QuickCheck, base, bitfield, genvalidity, genvalidity-sydtest, sydtest, validity
Files
- CHANGELOG.md +9/−0
- LICENSE +21/−0
- README.md +83/−0
- bitfield.cabal +57/−0
- src/Data/Bitfield.hs +91/−0
- src/Data/Bitfield/Internal.hs +297/−0
- test/BitfieldSpec.hs +80/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,9 @@+# Changelog++`bitfield` uses [PVP Versioning][1].++## 0.1.0.0++* Initially created.++[1]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Jannis++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,83 @@+<h1 align="center"> bitfield </h1>++<p align="center">+<a href="https://github.com/1Jajen1/bitfield/actions">+ <img src="https://img.shields.io/github/actions/workflow/status/1Jajen1/bitfield/ci.yml?branch=main" alt="CI badge" />+</a>+<a href="https://haskell.org">+ <img src="https://img.shields.io/badge/Made%20in-Haskell-%235e5086?logo=haskell&style=flat-square" alt="made with Haskell"/>+</a>+<a href="https://hackage.haskell.org/package/bitfield">+ <img src="https://img.shields.io/hackage/v/bitfield?style=flat-square" alt="Hackage" />+</a>+</p>++## Description++Generic and easy to use bitfields. Pack and unpack records into compact representations.++## Example++```haskell+import Data.Bitfield++data Example = Example { one :: Word8, two :: Bool, three :: Bool } deriving (Show, Generic)+ +x :: Bitfield Word16 Example+x = pack $ Example 5 False True++>>> x+"Example { one = 5, two = False, three = True }"+>>> get @"two" x+"False"+-- Requires OverloadedRecordDot+>>> x.two+"False"+>>> set @"three" x False+"Example { one = 5, two = False, three = False }"+```++`x` is represented using `Word16` instead of the full heap object `Example` and thus takes far less memory.++## Custom fields++There are two important typeclasses for working with types in bitfields: `AsRep` and `HasFixedBitSize`.++The most common way to use them is to derive them via either an underlying `Enum` or `Integral` instance.++#### Via `Enum`++```haskell+data AEnum = A1 | A2 | A3+ deriving stock (Generic, Enum)+ deriving (HasFixedBitSize, AsRep rep) via (GenericEnum AEnum)+```++This still requires a `Generic` instance to count the constructors of `AEnum` for the `HasFixedBitSize` instance. The resulting field has a size of `Log2 NumConstructors` rounded up (`2` bits for `AEnum`). The actual value will be constructed using the `Enum` instance, so unless that is derived, the constructor order won't matter.++#### Via `Integral`++```haskell+newtype SmallInt = UnsafeSmallInt Int+ deriving (HasFixedBitSize, AsRep rep) via (ViaIntegral 5 Int)+```++This creates a `HasFixedBitSize` instance with a fixed bit size of `5` and a `AsRep` instance which reads and writes `5` bit values.++Note: The value is not truncated nor is it otherwise checked that the underlying value actually fits into the specified bit size. If it is too large it will write over other values!++## Type safety++Any operation on a `Bitfield` checks (on the type level) if that `Bitfield` is valid. Any field operation also requires a `HasField` instance, guaranteeing that such a field exists. The following examples will not compile:++```haskell+data Bad1 = Bad1 { a :: Bool, b :: Word8, c :: Bool }++x :: Bitfield Word8 Bad1+x = pack $ Bad1 True 1 True+-- Datatype Bad1 needs 10 bits, but the given representation Word8 has 8++y :: Bitfield Word16 Bad1 -> Word8+y b = get @"test" b+-- No instance HasField "test" Bad1 Word8+```
+ bitfield.cabal view
@@ -0,0 +1,57 @@+cabal-version: 2.4+name: bitfield+version: 0.0.0.0+synopsis: Generic and easy to use haskell bitfields+description: Generic and easy to use haskell bitfields. Allows packing and modifying datatypes in a compact representation. See `README.md` or 'Data.Bitfield' for documentation.+license: MIT+license-file: LICENSE+author: Jannis+maintainer: Jannis <overesch.jannis@gmail.com>+copyright: 2022 Jannis+category: Data, Bit+build-type: Simple+extra-source-files: README.md+ CHANGELOG.md+ LICENSE+tested-with: + GHC ==8.8.4 || ==8.10.7 || ==9.2.5 || ==9.4.3++source-repository head+ type: git+ location: https://github.com/1Jajen1/bitfield++common common-options+ build-depends: base >= 4 && < 5+ ghc-options: -Wall+ -Wcompat+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wredundant-constraints+ -fhide-source-paths+ -Wmissing-export-lists+ -Wpartial-fields+ -Wmissing-deriving-strategies+ -haddock+ default-language: Haskell2010+library+ import: common-options+ hs-source-dirs: src+ exposed-modules: Data.Bitfield+ , Data.Bitfield.Internal+test-suite bitfield-test+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-tool-depends: sydtest-discover:sydtest-discover+ build-depends: bitfield+ , sydtest >= 0.12 && < 0.14+ , validity >= 0.12 && < 0.13+ , genvalidity >= 1.0 && < 1.2+ , genvalidity-sydtest >= 1.0 && < 1.1+ , QuickCheck >= 2.13 && < 2.15+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N+ other-modules: BitfieldSpec
+ src/Data/Bitfield.hs view
@@ -0,0 +1,91 @@+-- |+-- Module : Data.Bitfield+-- Copyright : (c) Jannis Overesch 2022-2022+-- License : MIT+-- Maintainer : overesch.jannis@gmail.com+-- +-- Generic and easy to use bitfields. Pack and unpack records into compact representations.+-- The implementation is generic over the representation and the record, however it is+-- assumed that the representation is some integral type and that the record has an instance of+-- 'GHC.Generics.Generic'.+--+-- Due to possible overlap with the method names, it is recommended to use this module with a qualified import.+--+-- @+-- import Data.Bitfield+--+-- data Example = Example { one :: Bool, two :: Bool, three :: Bool, four :: Word8 } deriving (Show, Generic)+-- +-- x :: Bitfield Word16 Example+-- x = pack $ Example True False True 4+--+-- >>> x+-- Example { one = True, two = False, three = True, four = 4 }+-- >>> get \@"two" x+-- False+-- >>> set \@"three" x False+-- Example { one = True, two = False, three = False, four = 4 }+-- @+--+-- The values in the bitfield will be in whatever order the 'GHC.Generics.Generic' instance defines them in.+-- This is usually the order in which they are defined. +--+-- Access with @OverloadedRecordDot@ is also supported:+--+-- @+-- {-# LANGUAGE OverloadedRecordDot #-}+--+-- import Data.Bitfield+--+-- data Example = Example { one :: Bool, two :: Bool, three :: Bool } deriving (Show, Generic)+-- +-- x :: Bitfield Word8 Example+-- x = pack $ Example True False True+--+-- >>> x.one+-- True+-- @+-- +-- 'Bitfield' supports a variety of field types as long as those implement 'HasFixedBitSize' and 'AsRep'.+-- These instances are usually derived via 'GenericEnum' or 'ViaIntegral'.+--+-- @+-- data AEnum = A1 | A2 | A3+-- deriving stock (Generic, Enum)+-- deriving (HasFixedBitSize, AsRep r) via (GenericEnum AEnum)+--+-- newtype SmallInt = SmallInt Int+-- deriving (HasFixedBitSize, AsRep r) via (ViaIntegral 5 Int)+--+-- data Example = Example { a :: AEnum, b :: SmallInt }+--+-- x :: Bitfield Word8 Example+-- x = pack $ Example A2 (SmallInt 3)+-- @+--+-- It is also possible to nest 'Bitfield's, but they are not unpacked, the representation of the nested field is used directly.+--+-- @+-- data Nested = Nested { a :: Bool, b :: Bool }+-- data Example = Example { one :: Bitfield Word8 Nested, other :: Bool }+--+-- -- This bitfield requires at least 9 bits because the field "one" requires 8 bits.+-- x :: Bitfield Word16 Example+-- x = Pack $ Example (pack $ Nested True True) False+-- @++module Data.Bitfield (+-- * Bitfield+ Bitfield(Bitfield)+, unwrap+-- * General use+, get, set+, pack, unpack+-- * Custom fields+, HasFixedBitSize(..)+, AsRep(..)+, ViaIntegral(..)+, GenericEnum(..)+) where++import Data.Bitfield.Internal
+ src/Data/Bitfield/Internal.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE+ DerivingStrategies+, GeneralizedNewtypeDeriving+, KindSignatures+, DataKinds+, PolyKinds+, ScopedTypeVariables+, TypeApplications+, TypeFamilies+, UndecidableInstances+, MultiParamTypeClasses+, TypeSynonymInstances+, FlexibleInstances+, TypeOperators+, FlexibleContexts+, AllowAmbiguousTypes+, StandaloneDeriving+, DerivingVia+, CPP+, ConstraintKinds+, DefaultSignatures+#-}+{-# OPTIONS_GHC+ -Wno-unticked-promoted-constructors+ -Wno-redundant-constraints+#-}+{-# OPTIONS_HADDOCK not-home #-}+-- |+-- Module : Data.Bitfield.Internal+-- Copyright : (c) Jannis Overesch 2022-2022+-- License : MIT+-- Maintainer : overesch.jannis@gmail.com+module Data.Bitfield.Internal (+ Bitfield(..)+, unwrap+, get, set+, pack, unpack+, HasFixedBitSize(..)+, AsRep(..)+, ViaIntegral(..)+, GenericEnum(..)+, Fits+) where++#include "MachDeps.h"++import Data.Bits+import Data.Int+import Data.Kind+import Data.Proxy+import Data.Word++import GHC.Generics+import GHC.Records+import GHC.TypeLits as Nat+import Foreign.Storable++-- | A generic Bitfield+-- +-- Represents type @a@ with type @rep@.+--+-- Technically this allows any representation and any type to represent, however all methods+-- are written with the implicit assumption of a representation with an 'Integral' and 'Bits' instance.+-- The type to represent is also assumed to have a `Generic` instance and be a single constructor with named fields.+-- +-- @a@'s fields are also required to have an instance of 'AsRep' and 'FiniteBits'. This is provided for the most common+-- types ('Int'/'Word' (and variants) and 'Bool'). +newtype Bitfield (rep :: Type) (a :: Type) = Bitfield rep+ deriving newtype (Eq, Storable)++-- | Access the underlying representation of the 'Bitfield'+unwrap :: Bitfield rep a -> rep+unwrap (Bitfield rep) = rep+{-# INLINE unwrap #-}++-- | Access a single field+get :: forall name x rep a . (Fits rep a, HasField name (Bitfield rep a) x) => Bitfield rep a -> x+get = getField @name+{-# INLINE get #-}++-- | Change a single field +set :: forall name x rep a . (Fits rep a, HasField name (Bitfield rep a) x, GOffset name (Rep a), Bits rep, AsRep rep x) => Bitfield rep a -> x -> Bitfield rep a+set (Bitfield rep) x = Bitfield $ (toRep rep x off)+ where+ off = case offset (Proxy @name) (Proxy @(Rep a)) of+ Left _ -> error "Data.Bitfield.set:Failed to find offset"+ Right n -> n+{-# INLINE set #-}++-- | Unpack the 'Bitfield' and return the full datatype+unpack :: forall rep a . (Fits rep a, Generic a, GPackBitfield rep (Rep a)) => Bitfield rep a -> a+unpack (Bitfield b) = case unpackI (Proxy @(Rep a)) 0 b of (_, a) -> to a+{-# INLINE unpack #-}++-- | Pack a datatype into a bitfield+--+-- Beware that updates should be done with 'set', as 'pack' will recreate the entire 'Bitfield'+-- from scratch. The following will most likely *not* be optimised: @pack $ (unpack bitfield) { example = True }@+pack :: forall rep a . (Fits rep a, Generic a, Bits rep, GPackBitfield rep (Rep a)) => a -> Bitfield rep a+pack a = case packI (Proxy @(Rep a)) 0 zeroBits (from a) of (_, b) -> Bitfield b+{-# INLINE pack #-}++instance (Fits rep a, Generic a, GPackBitfield rep (Rep a), Show a) => Show (Bitfield rep a) where+ show = show . unpack++--+class GPackBitfield rep (f :: p -> Type) where+ unpackI :: forall x . Proxy f -> Int -> rep -> (Int, f x)+ packI :: forall x . Proxy f -> Int -> rep -> f x -> (Int, rep)++instance GPackBitfield r f => GPackBitfield r (M1 s m f) where+ unpackI _ off b = M1 <$> unpackI (Proxy @f) off b+ {-# INLINE unpackI #-}+ packI _ off r (M1 f) = packI (Proxy @f) off r f+ {-# INLINE packI #-}+instance (HasFixedBitSize a, AsRep rep a) => GPackBitfield rep (K1 c a) where+ unpackI _ off r = (fixedBitSize @a + off, K1 $ fromRep r off)+ {-# INLINE unpackI #-}+ packI _ off r (K1 a) = (fixedBitSize @a + off, toRep r a off)+ {-# INLINE packI #-}+instance (GPackBitfield r f, GPackBitfield r g) => GPackBitfield r (f :*: g) where+ unpackI _ off rep =+ case unpackI (Proxy @f) off rep of+ (off', l) -> case unpackI (Proxy @g) off' rep of+ (off'', r) -> (off'', l :*: r)+ {-# INLINE unpackI #-}+ packI _ off rep (l :*: r) =+ case packI (Proxy @f) off rep l of+ (off', rep') -> packI (Proxy @g) off' rep' r+ {-# INLINE packI #-}++class GOffset (name :: Symbol) (f :: p -> Type) where+ offset :: Proxy name -> Proxy f -> Either Int Int++instance GOffset name f => GOffset name (D1 m f) where+ offset pn _ = offset pn (Proxy @f)+ {-# INLINE offset #-}+instance GOffset name f => GOffset name (C1 m f) where+ offset pn _ = offset pn (Proxy @f)+ {-# INLINE offset #-}+instance (GOffset name f, GOffset name g) => GOffset name (f :*: g) where+ offset pn _ = case offset pn (Proxy @f) of+ Left i -> case offset pn (Proxy @g) of+ Left j -> Left $ i + j+ Right j -> Right $ i + j+ Right i -> Right i+ {-# INLINE offset #-}+instance GOffset name (S1 (MetaSel (Just name) su ss ds) (K1 c a)) where+ offset _ _ = Right 0+ {-# INLINE offset #-}+instance {-# OVERLAPS #-} HasFixedBitSize a => GOffset name (S1 m (K1 c a)) where+ offset _ _ = Left $ fixedBitSize @a+ {-# INLINE offset #-}++instance (HasField (name :: Symbol) a x, GOffset name (Rep a), AsRep rep x) => HasField name (Bitfield rep a) x where+ getField (Bitfield rep) = fromRep rep off+ where+ off = case offset (Proxy @name) (Proxy @(Rep a)) of+ Left _ -> error "Data.Bitfield.getField:Failed to find offset"+ Right n -> n+ {-# INLINE getField #-}++-- | Types with a fixed bitsize. This could be a type family as well, but having+-- it as a typeclass provides nicer error messages when one forgets to write an+-- instance for it.+class KnownNat (BitSize a) => HasFixedBitSize (a :: Type) where+ type BitSize a :: Nat++fixedBitSize :: forall a. HasFixedBitSize a => Int+fixedBitSize = fromIntegral $ natVal (Proxy @(BitSize a))++-- | Typeclass which converts @rep@ and @a@ into each other (at specified offsets).+class HasFixedBitSize a => AsRep rep a where+ fromRep :: rep -> Int -> a+ toRep :: rep -> a -> Int -> rep++-- Flatten nested bitfields+instance KnownNat (BitSize r2) => HasFixedBitSize (Bitfield r2 a) where+ type BitSize (Bitfield r2 a) = BitSize r2++instance AsRep r1 r2 => AsRep r1 (Bitfield r2 a) where+ fromRep r1 off = Bitfield $ fromRep r1 off+ {-# INLINE fromRep #-}+ toRep r1 (Bitfield r2) off = toRep r1 r2 off+ {-# INLINE toRep #-}++instance HasFixedBitSize Bool where+ type BitSize Bool = 1 ++instance Bits a => AsRep a Bool where+ fromRep r off = testBit r off+ {-# INLINE fromRep #-}+ toRep rep True off = setBit rep off+ toRep rep False off = clearBit rep off+ {-# INLINE toRep #-}++-- | Newtype wrapper with an 'AsRep' instance for 'Integral' representations and types.+--+-- The example below shows how to derive a 5 bit int field via a newtype:+-- +-- @+-- newtype SmallInt = SmallInt Int+-- deriving (HasFixedBitSize, AsRep r) via (ViaIntegral 5 Int)+-- @+newtype ViaIntegral (sz :: Nat) a = ViaIntegral a+ deriving newtype (Eq, Ord, Bits, Real, Enum, Num, Integral)++instance KnownNat sz => HasFixedBitSize (ViaIntegral sz n) where+ type BitSize (ViaIntegral sz n) = sz++instance (Bits a, Integral a, Integral n, KnownNat sz) => AsRep a (ViaIntegral sz n) where+ fromRep r off = fromIntegral $ mask .&. (unsafeShiftR r off)+ where+ mask = (unsafeShiftL (bit 0) (fixedBitSize @(ViaIntegral sz n))) - 1+ {-# INLINE fromRep #-}+ toRep rep n off = (mask .&. rep) .|. (unsafeShiftL (fromIntegral n) off)+ where+ mask = complement $ unsafeShiftL ((unsafeShiftL (bit 0) (fixedBitSize @(ViaIntegral sz n))) - 1) off+ {-# INLINE toRep #-}++instance HasFixedBitSize Int8 where type BitSize Int8 = 8+instance HasFixedBitSize Int16 where type BitSize Int16 = 16+instance HasFixedBitSize Int32 where type BitSize Int32 = 32+instance HasFixedBitSize Int64 where type BitSize Int64 = 64++instance HasFixedBitSize Int where type BitSize Int = SIZEOF_HSINT Nat.* 8++instance HasFixedBitSize Word8 where type BitSize Word8 = 8+instance HasFixedBitSize Word16 where type BitSize Word16 = 16+instance HasFixedBitSize Word32 where type BitSize Word32 = 32+instance HasFixedBitSize Word64 where type BitSize Word64 = 64++instance HasFixedBitSize Word where type BitSize Word = SIZEOF_HSINT Nat.* 8++deriving via (ViaIntegral 8 Int8 ) instance (Bits r, Integral r) => AsRep r Int8+deriving via (ViaIntegral 16 Int16) instance (Bits r, Integral r) => AsRep r Int16+deriving via (ViaIntegral 32 Int32) instance (Bits r, Integral r) => AsRep r Int32+deriving via (ViaIntegral 64 Int64) instance (Bits r, Integral r) => AsRep r Int64++deriving via (ViaIntegral (SIZEOF_HSINT Nat.* 8) Int) instance (Bits r, Integral r) => AsRep r Int++deriving via (ViaIntegral 8 Word8 ) instance (Bits r, Integral r) => AsRep r Word8+deriving via (ViaIntegral 16 Word16) instance (Bits r, Integral r) => AsRep r Word16+deriving via (ViaIntegral 32 Word32) instance (Bits r, Integral r) => AsRep r Word32+deriving via (ViaIntegral 64 Word64) instance (Bits r, Integral r) => AsRep r Word64++deriving via (ViaIntegral (SIZEOF_HSINT Nat.* 8) Word) instance (Bits r, Integral r) => AsRep r Word++-- | Deriving via helper for 'Enum' types. Requires that type to also have an instance of 'Generic'.+--+-- @+-- data AEnum = A1 | A2 | A3+-- deriving stock (Enum, Generic)+-- deriving (HasFixedBitSize, AsRep r) via (GenericEnum AEnum)+-- @+newtype GenericEnum a = GenericEnum a+ deriving newtype Eq++instance KnownNat (RoundUpLog2 (EnumSz (Rep a))) => HasFixedBitSize (GenericEnum a) where+ type BitSize (GenericEnum a) = RoundUpLog2 (EnumSz (Rep a))++instance (Generic a, Enum a, Bits rep, Integral rep, KnownNat (RoundUpLog2 (EnumSz (Rep a)))) => AsRep rep (GenericEnum a) where+ fromRep rep off =+ let ViaIntegral i = fromRep @rep @(ViaIntegral (BitSize (GenericEnum a)) Int) rep off+ in GenericEnum $ toEnum i+ {-# INLINE fromRep #-}+ toRep rep (GenericEnum x) off =+ let x' = ViaIntegral @(BitSize (GenericEnum a)) $ fromEnum x+ in toRep rep x' off+ {-# INLINE toRep #-}++-- Ugly way to check if we need to round up. Basically if he 2^log2(sz) /= sz then sz is not a power of two and was rounded down in log2.+type family RoundUpLog2 (sz :: Nat) :: Nat where+ RoundUpLog2 sz = RoundUpLog2' sz (2 ^ (Log2 sz)) (Log2 sz)++type family RoundUpLog2' (sz :: Nat) (sz' :: Nat) (log2 :: Nat) :: Nat where+ RoundUpLog2' sz sz log2 = log2+ RoundUpLog2' sz sz' log2 = log2 + 1++type family EnumSz (f :: p -> Type) :: Nat where+ EnumSz (M1 i s f) = EnumSz f+ EnumSz (f :+: g) = EnumSz f + EnumSz g+ EnumSz U1 = 1+ EnumSz (f :*: g) = TypeError (Text "Deriving a generic AsRep instance only supports sum types with empty constructors")+ EnumSz (K1 c a) = TypeError (Text "Deriving a generic AsRep instance only supports sum types with empty constructors")++type family ReqSz (f :: p -> Type) :: Nat where+ ReqSz (M1 i s f) = ReqSz f+ ReqSz (K1 c a) = BitSize a+ ReqSz (f :*: g) = ReqSz f + ReqSz g++-- | Constraint which checks if a datatype fits.+type Fits rep a = FitsPred (ReqSz (Rep a) <=? BitSize rep) rep a++type family FitsPred (b :: Bool) (rep :: Type) (a :: Type) :: Constraint where+ FitsPred True _ _ = ()+ FitsPred False rep a = TypeError (Text "Datatype " :<>: ShowType a :<>: Text " needs " :<>: ShowType (ReqSz (Rep a)) :<>: Text " bits, but the given representation " :<>: ShowType rep :<>: Text " has " :<>: ShowType (BitSize rep))
+ test/BitfieldSpec.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+#if __GLASGOW_HASKELL__ >= 902+{-# LANGUAGE OverloadedRecordDot #-}+#endif+module BitfieldSpec where++import Test.Syd+import Test.Syd.Validity++import Test.QuickCheck++import Data.Word++import Data.Bitfield as Bitfield+import GHC.Generics+import Data.Bits (unsafeShiftL)++data Example = Example { a :: Bool, b :: Word8, c :: Word16, d :: Bool } deriving stock (Eq, Show, Generic)++instance GenValid Example where+instance Validity Example where++spec :: Spec+spec = do+ it "pack should work on simple examples" $ do+ let t1 = pack @Word32 $ Example False 0 0 False+ let t2 = pack @Word32 $ Example True 0 0 False+ let t3 = pack @Word32 $ Example False 0 0 True+ let t4 = pack @Word32 $ Example True 12 0 False+ (Bitfield.unwrap t1) `shouldBe` 0+ (Bitfield.unwrap t2) `shouldBe` 1+ (Bitfield.unwrap t3) `shouldBe` (unsafeShiftL 1 25)+ (Bitfield.unwrap t4) `shouldBe` 25++ it "get @name b == name (unpack b)" $ forAllValid $ \(t :: Example) ->+ let bf = Bitfield.pack @Word32 t+ in get @"d" bf === d t++#if __GLASGOW_HASKELL__ >= 902+ it "get @name b == b.name" $ forAllValid $ \(t :: Example) ->+ let bf = Bitfield.pack @Word32 t+ in get @"d" bf === bf.d++ it "get @name b == (unpack b).name" $ forAllValid $ \(t :: Example) ->+ let bf = Bitfield.pack @Word32 t+ in (get @"b" bf === (unpack bf).b)+#endif+ + it "get @name (set @name b x) == x" $ forAllValid $ \(t :: Example, x :: Word16) ->+ x === Bitfield.get @"c" (Bitfield.set @"c" (Bitfield.pack @Word32 t) x)+ + it "unpack . pack = id" $ forAllValid $ \(t :: Example) ->+ t === (unpack $ pack @Word32 t)++data AEnum = A1 | A2 | A3 | A4+ deriving stock (Eq, Show, Enum, Generic)+ deriving (HasFixedBitSize, AsRep r) via GenericEnum AEnum++data ATest = ATest { a1 :: AEnum, b1 :: AEnum, c1 :: AEnum, d1 :: Bool, e1 :: Bool } deriving stock (Eq, Show, Generic)++-- AText fits into exactly 8 bits. This verifies that it compiles. Adding another constructor to AEnum changes its size and should not compile+compileTestAEnum :: Bitfield Word8 ATest+compileTestAEnum = pack $ ATest A1 A1 A1 True True++newtype SmallInt = SmallInt Int+ deriving newtype (Show, Eq)+ deriving (HasFixedBitSize, AsRep r) via (ViaIntegral 5 Int)++data AnotherTest = AnotherTest { a2 :: Bitfield Word8 ATest, b2 :: Bool, c2 :: SmallInt } deriving stock (Eq, Show, Generic)++compileAnotherTest :: Bitfield Word16 AnotherTest+compileAnotherTest = pack $ AnotherTest { a2 = pack $ ATest A1 A1 A1 True True, b2 = True, c2 = SmallInt 5 }
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}