isobmff-0.14.0.0: spec/BitRecordsSpec.hs
{-# LANGUAGE UndecidableInstances #-}
module BitRecordsSpec (spec) where
import Data.Bits
import Data.ByteString.Builder
import Data.Proxy
import Data.Type.BitRecords
import Data.Type.Equality ()
import Data.Kind.Extra
import GHC.TypeLits
import Prelude hiding ((.), id)
import Test.Hspec
import Test.QuickCheck (property, Arbitrary(..), choose)
import Test.TypeSpecCrazy
import Text.Printf
basicsSpec :: Spec
basicsSpec = do
describe "Maybe, Lists, Either, Bool, 'True, 'False, FlagJust, FlagNothing" $ do
let checkFlagJust ::
"Type Level Bool, 'True, 'False, FlagJust, FlagNothing Accessors"
##################################################################
"The record size works"
~~~~~~~~~~~~~~~~~~~~~~~~
1 `ShouldBe` FieldWidth (FlagJust 'Nothing)
-* 1 `ShouldBe` FieldWidth (FlagJust ('Just "Blah"))
-* 1 `ShouldBe` FieldWidth (FlagNothing ('Just "Blah"))
-- TODO reenable tests
-- -* 32 `ShouldBe` SizeInBits (ToBitRecord ('Just FieldU32))
-- -* 0 `ShouldBe` SizeInBits (ToBitRecord '[])
-- -* 10 `ShouldBe` SizeInBits (ToBitRecord '[Field 10])
-- -* 25 `ShouldBe` SizeInBits (ToBitRecord '[Field 10, Field 15])
-- -* 1 `ShouldBe` SizeInBits (ToBitRecord Bool)
-- -* 1 `ShouldBe` SizeInBits (ToBitRecord 'True)
-- -* 1 `ShouldBe` SizeInBits (ToBitRecord 'False)
checkFlagJust = Valid
runIO $ print checkFlagJust
describe "bitBuffer64Printer" $ do
describe "Just x" $ it "writes x" $
bitBuffer64Printer (Proxy :: Proxy (OptionalRecord ('Just ('BitRecordMember (Flag := 'True))))) `shouldBe` "<< 80 >>"
describe "Nothing" $ it "writes nothing" $
bitBuffer64Printer (Proxy :: Proxy (OptionalRecord ('Nothing))) `shouldBe` "<< >>"
-- describe "'[]" $ it "writes nothing" $
-- bitBuffer64Printer (Proxy :: Proxy (BitRecordOfList (Fun1 RecordField) ('[]))) `shouldBe` "<< >>"
-- describe "'[x1, x2]" $ it "writes x1 then x2" $
-- bitBuffer64Printer (Proxy :: Proxy (BitRecordOfList (Fun1 RecordField) ('[FieldU8 := 1, FieldU8 := 2]))) `shouldBe` "<< 01 02 >>"
describe "'True" $ it "writes a single bit with a 1" $
bitBuffer64Printer (Proxy :: Proxy (RecordField (Flag := 'True))) `shouldBe` "<< 80 >>"
describe "'False" $ it "writes a single bit with a 0" $
bitBuffer64Printer (Proxy :: Proxy (RecordField (Flag := 'False))) `shouldBe` "<< 00 >>"
describe "@: labelled fields" $ do
it "writes them ..." $
let fld = Proxy @(From (RecordField ( "foo" @: FlagJust 'Nothing )))
in bitBuffer64Printer fld `shouldBe` "<< 00 >>"
describe "FlagJust" $ do
it "writes a single bit '1' for a 'Just ...' parameter" $
bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagJust ('Just "test")))) `shouldBe` "<< 80 >>"
it "writes a single bit '0' for a 'Nothing' parameter" $
bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagJust 'Nothing))) `shouldBe` "<< 00 >>"
describe "FlagNothing" $ do
it "writes a single bit '0' for a 'Just ...' parameter" $
bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagNothing ('Just "test")))) `shouldBe` "<< 00 >>"
it "writes a single bit '1' for a 'Nothing' parameter" $
bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagNothing 'Nothing))) `shouldBe` "<< 80 >>"
-- TODO reenable showRecord tests
-- describe "showRecord" $ do
-- describe "Maybe" $ do
-- it "prints 'Just x'" $
-- showRecord (Proxy :: Proxy (ToBitRecord ('Just 'True))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
-- it "prints nothing for 'Nothing'" $
-- showRecord (Proxy :: Proxy (ToBitRecord ('Nothing))) `shouldBe` ""
-- describe "List" $ do
-- it "prints '[x]'" $
-- showRecord (Proxy :: Proxy (ToBitRecord ('[ 'True ]))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
-- it "prints '[x1, x2, x3]'" $
-- showRecord (Proxy :: Proxy (ToBitRecord ('[ Bool, Bool, Bool ]))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\nField:\n Demote Rep: Bool\n Bits: 1\nField:\n Demote Rep: Bool\n Bits: 1"
-- it "prints nothing for '[]'" $
-- showRecord (Proxy :: Proxy (ToBitRecord ('[]))) `shouldBe` ""
-- describe "Bool" $ do
-- it "prints 'True" $
-- showRecord (Proxy :: Proxy (ToBitRecord ('True))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
-- it "prints 'False" $
-- showRecord (Proxy :: Proxy (ToBitRecord ('False))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'False"
-- it "prints a Bool" $
-- showRecord (Proxy :: Proxy (ToBitRecord Bool)) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1"
-- describe "FlagJust" $ do
-- it "prints a 'FlagJust 'Just ..'" $
-- showRecord (Proxy :: Proxy (ToBitRecord (FlagJust ('Just "123")))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
-- it "prints a 'FlagJust 'Nothing'" $
-- showRecord (Proxy :: Proxy (ToBitRecord (FlagJust 'Nothing))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'False"
-- describe "FlagNothing" $ do
-- it "prints 'FlagNothing 'Just ..'" $
-- showRecord (Proxy :: Proxy (ToBitRecord (FlagNothing ('Just "123")))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'False"
-- it "prints a 'FlagNothing 'Nothing'" $
-- showRecord (Proxy :: Proxy (ToBitRecord (FlagNothing 'Nothing))) `shouldBe` "Field:\n Demote Rep: Bool\n Bits: 1\n Static Value: 'True"
#ifdef COMPLEXTESTS
arraySpec :: SpecWith ()
arraySpec =
describe "RecArray" $ do
describe "level record accessors" $ do
let checkArrayRec ::
"BitRecord accessors involving RecArray"
#######################################
"The record size works"
~~~~~~~~~~~~~~~~~~~~~~~~
1 `ShouldBe` SizeInBits (From (RecArray ('BitRecordMember Flag) 1))
-* 91 `ShouldBe` SizeInBits (From (("foo" @: Flag .+. FieldU8) ^^ 10) :+. Flag)
-* 91 `ShouldBe` SizeInBits (From (RecArray ("foo" @: Flag .+. FieldU8) 10) :+. Flag)
checkArrayRec = Valid
runIO $ print checkArrayRec
describe "showRecord" $
it "appends its body n times" $
let expected = "utf-8(40) := <<hello>> [5 Bytes]\nutf-8(40) := <<hello>> [5 Bytes]\nutf-8(40) := <<hello>> [5 Bytes]\nutf-8(40) := <<hello>> [5 Bytes]\nutf-8(40) := <<hello>> [5 Bytes]"
actual = showARecord (Proxy @ (('BitRecordMember [utf8|hello|] ^^ 5)))
in actual `shouldBe` expected
describe "bitBuffer64Printer" $
it "writes its contents n times to the builder" $
let actual = bitBuffer64Printer (Proxy :: Proxy (('BitRecordMember (Field 24 := 0x010203) ^^ 4)))
expected = "<< 01 02 03 01 02 03 01 02 03 01 02 03 >>"
in actual `shouldBe` expected
sizedSpec =
describe "Sized" $ do
describe "TypeChecks" $
let
checkSized ::
"Sized"
#########
"SizedString"
~~~~~~~~~~~~~~~
88 `ShouldBe` FieldWidth [utf8|Hello World|]
-* 104 `ShouldBe` SizeInBits (From (RecordField [utf8|Heλλo World|]))
-/-
"Sized BitRecord Members"
~~~~~~~~~~~~~~~~~~~~~~~~
8 `ShouldBe` SizeInBits (From (Sized8 'EmptyBitRecord))
-* 9 `ShouldBe` SizeInBits (From (Sized8 ('BitRecordMember Flag)))
-* 0 `ShouldBe` SizeInBytes 'EmptyBitRecord
-* 1 `ShouldBe` SizeInBytes ('BitRecordMember Flag)
-/-
"SizedField"
~~~~~~~~~~~~
9 `ShouldBe` SizeInBits (From (SizedField8 Flag))
-* 1 `ShouldBe` SizeInBytes Flag
-- TODO add more Sized tests, especially for SizedField
checkSized = Valid
in runIO $ print checkSized
describe "showRecord" $ do
describe "SizedString" $
it "renders a string containing wide utf-8 characters to a header containing the number of chars and the actual string" $
showARecord (Proxy :: Proxy (RecordField [utf8|Heλλo World!|])) `shouldBe` "utf-8(112) := <<He\955\955o World!>> [14 Bytes]"
describe "Sized SizeField16 SizedString" $
it "renders the number bytes not chars as the size field value" $
showARecord (Proxy :: Proxy (SizedField16 [utf8|Heλλo World!|])) `shouldBe` "size: U16 := hex: 000e (dec: 14)\nutf-8(112) := <<He\955\955o World!>> [14 Bytes]"
describe "bitBuffer64Printer" $ do
describe "no length prefix" $
it "renders no size prefix and the string as UTF-8 bytes" $
bitBuffer64Printer (Proxy :: Proxy (RecordField [utf8|ABC|]))
`shouldBe`
"<< 41 42 43 >>"
describe "8-bit length prefix" $
it "renders a single byte size prefix and the string as UTF-8 bytes" $
bitBuffer64Printer (Proxy :: Proxy (SizedField8 [utf8|ABC|]))
`shouldBe`
"<< 03 41 42 43 >>"
describe "16-bit length prefix" $
it "renders a big endian 16 bit size prefix and the string as UTF-8 bytes" $
bitBuffer64Printer (Proxy :: Proxy (SizedField16 [utf8|ABC|]))
`shouldBe`
"<< 00 03 41 42 43 >>"
describe "32-bit length prefix" $
it "renders a big endian 32 bit size prefix and the string as UTF-8 bytes" $
bitBuffer64Printer (Proxy :: Proxy (SizedField32 [utf82|ABC|]))
`shouldBe`
"<< 00 00 00 03 41 42 43 >>"
describe "64-bit length prefix" $
it "renders a big endian 64 bit size prefix and the string as UTF-8 bytes" $
bitBuffer64Printer (Proxy :: Proxy (SizedField64 [utf8|ABC|]))
`shouldBe`
"<< 00 00 00 00 00 00 00 03 41 42 43 >>"
type TestRecAligned =
"bar" @: Field 8 .+:
Field 8 := 0 .+:
"baz" @: Field 8 .+:
Field 32 := 0 .+:
"foo" @: Field 8 .+:
Field 8 := 0 .+:
"oof" @: Field 8 .+:
Field 8 := 0 .+.
"rab" @: Field 8
checkTestRecAligned
:: Expect '[ ShouldBe 96 (SizeInBits TestRecAligned) ]
checkTestRecAligned = Valid
type TestRecUnAligned =
"bar" @: Field 8 .+:
Field 8 := 0 .+:
"baz" @: Field 7 .+:
Field 32 := 0 .+:
"foo" @: Field 8 .+.
Field 8 := 0xfe
checkTestRecUnAligned
:: Expect '[ ShouldBe 71 (SizeInBits TestRecUnAligned) ]
checkTestRecUnAligned = Valid
testTakeLastN ::
"Taking the last n elements of a list" #######################################
TakeLastN 0 '[1,2,3] `ShouldBe` ('[] :: [Nat])
-* TakeLastN 1 '[1,2,3] `ShouldBe` '[3]
-* TakeLastN 2 '[1,2,3] `ShouldBe` '[2,3]
-* TakeLastN 5 '[1,2,3] `ShouldBe` '[1,2,3]
testTakeLastN = Valid
testRem
:: Expect '[ Mod 0 3 `ShouldBe` 0
, Mod 1 3 `ShouldBe` 1
, Mod 2 3 `ShouldBe` 2
, Mod 3 3 `ShouldBe` 0
, Mod 4 3 `ShouldBe` 1
, Mod 5 3 `ShouldBe` 2
, Mod 6 3 `ShouldBe` 0
]
testRem = Valid
testRemPow2
::
"ModPow2"
#########
"Remainder of '1'"
~~~~~~~~~~~~~~~~~~
It "1 `ModPow2` 1 is 1" (Is 1 (ModPow2 1 1))
-* It "1 `ModPow2` 8 is 1" (Is 1 (ModPow2 1 8))
-/-
"Remainder of '3916441'"
~~~~~~~~~~~~~~~~~~~~~~~~~~~
It " `ModPow2` 1 is 1" (Is 1 (ModPow2 3916441 1))
-* It " `ModPow2` 4 is 9" (Is 9 (ModPow2 3916441 4))
-* It " `ModPow2` 8 is 153" (Is 153 (ModPow2 3916441 8))
testRemPow2 = Valid
testDiv
:: Expect '[ Div 0 3 `ShouldBe` 0
, Div 1 3 `ShouldBe` 0
, Div 2 3 `ShouldBe` 0
, Div 3 3 `ShouldBe` 1
, Div 4 3 `ShouldBe` 1
, Div 5 3 `ShouldBe` 1
, Div 6 3 `ShouldBe` 2
, Div 144 13 `ShouldBe` 11
-- , Div 512 128 `ShouldBe` 11
]
testDiv = Valid
testNatBits
:: "Type Level bit operations"
###########################
"TestHighBit"
~~~~~~~~~~~~
ShouldBeFalse (TestHighBit 127 8)
-* ShouldBeFalse (TestHighBit 127 7)
-* ShouldBeTrue (TestHighBit 127 6)
-* ShouldBeFalse (TestHighBit 32 6)
-* ShouldBeTrue (TestHighBit 32 5)
-* ShouldBeFalse (TestHighBit 16 5)
-* ShouldBeTrue (TestHighBit 16 4)
-* ShouldBeFalse (TestHighBit 8 4)
-* ShouldBeTrue (TestHighBit 8 3)
-* ShouldBeFalse (TestHighBit 4 3)
-* ShouldBeTrue (TestHighBit 4 2)
-* ShouldBeFalse (TestHighBit 2 2)
-* ShouldBeTrue (TestHighBit 2 1)
-* ShouldBeFalse (TestHighBit 0 1)
-* ShouldBeTrue (TestHighBit 1 0)
-/-
"ToBits"
~~~~~~~~~
It "returns the empty list for a zero bit length"
(ToBits 1023 0 `ShouldBe` ('[] :: [Bool]) )
-* It "returns [] for a single unset bit"
(ShouldBe ('[] :: [Bool]) (ToBits 0 1))
-* It "returns [True] for a single set bit"
(ShouldBe '[ 'True] (ToBits 1 1))
-* It "returns [True, False] when getting two bits from 0x2"
(ShouldBe '[ 'True, 'False] (ToBits 0x2 2))
-* It "returns the list of bits in correct order"
(ShouldBe '[ 'True, 'True, 'True, 'True
, 'False, 'False, 'False, 'False]
(ToBits 0xf0 8))
-* It "returns no leading 'False (i.e. it omits leading zero bits)"
(ShouldBe '[ 'True, 'True, 'True, 'True]
(ToBits 0x0000000f 32))
-/-
"FromBits"
~~~~~~~~~
It "returns 0 for '[]"
(ShouldBe 0 (FromBits ('[] :: [Bool])))
-* It "returns 0 for [False]"
(ShouldBe 0 (FromBits '[ 'False]))
-* It "returns 1 for [True]"
(ShouldBe 1 (FromBits '[ 'True]))
-* It "returns 2 for [True, False]"
(ShouldBe 2 (FromBits '[ 'True, 'False]))
-* It "returns 4 for [True, False, False]"
(ShouldBe 4 (FromBits '[ 'True, 'False, 'False]))
-* It "returns 5 for [True, False, True]"
(ShouldBe 5 (FromBits '[ 'True, 'False, 'True]))
-/-
"ShiftBitsR"
~~~~~~~~~~~~
It "returns the input bits for n == 0"
(ShouldBe '[ 'True, 'False] (ShiftBitsR ['True, 'False] 0))
-* It "returns '[] when shifting [True] 1 bits"
(ShouldBe ('[] :: [Bool]) (ShiftBitsR '[ 'True ] 1))
-* It "returns '[True] when shifting [True, True] 1 bits"
(ShouldBe '[ 'True] (ShiftBitsR '[ 'True, 'True ] 1))
-* It "returns (ToBits 12 8) when shifting (ToBits 97 8) 3 bits to the right"
(ShouldBe (ToBits 12 8) (ShiftBitsR (ToBits 97 8) 3))
-/-
"GetMostSignificantBitIndex"
~~~~~~~~~~~~~~~
It "returns 1 for 0"
(ShouldBe 1 (GetMostSignificantBitIndex 64 0))
-* It "returns 1 for 1"
(ShouldBe 1 (GetMostSignificantBitIndex 64 1))
-* It "returns 1 for 2"
(ShouldBe 1 (GetMostSignificantBitIndex 64 2))
-* It "returns 1 for 3"
(ShouldBe 1 (GetMostSignificantBitIndex 64 3))
-* It "returns 2 for 4"
(ShouldBe 2 (GetMostSignificantBitIndex 64 4))
-* It "returns 2 for 5"
(ShouldBe 2 (GetMostSignificantBitIndex 64 4))
-* It "returns 8 for 511"
(ShouldBe 8 (GetMostSignificantBitIndex 64 511))
-* It "returns 63 for (2^64 - 1)"
(ShouldBe 63 (GetMostSignificantBitIndex 64 (2^64 - 1)))
-/-
"ShiftR"
~~~~~~~~~
It "returns '0' when shifting '42' 6 bits to the right"
(ShouldBe 0 (ShiftR 64 42 6))
-* It "returns 2 when shifting 512 8 bits to the right"
(ShouldBe 2 (ShiftR 64 512 8))
testNatBits = Valid
#endif
spec :: Spec
spec = do
basicsSpec
#ifdef COMPLEXTESTS
sizedSpec
arraySpec
describe "The Set of Type Functions" $
it "is sound" $ do
print (Valid :: Expect (SizeInBits (Flag .+. Field 7) `Is` 8))
print testTakeLastN
print testRem
print testRemPow2
print testDiv
print testNatBits
print checkTestRecAligned
print checkTestRecUnAligned
describe "showARecord" $ do
it "prints (Field 4 .+. (Field 4 := 0x96)) to \"<..>0110\"" $
let actual = showRecord (Proxy :: Proxy (Field 4 .+. Field 4 := 0x96))
in actual `shouldBe` "bits(4)\nbits(4) := 10010110 (hex: 96 dec: 150)"
describe "StaticLazybytestringbuilder" $ do
it "writes (and flushes) bits" $
let rec = Proxy
rec :: Proxy TestRecUnAligned
actualB :: Builder
actualB =
runBitBuilderHoley
(toFunctionBuilder rec)
1
3
7
actual = printBuilder actualB
in actual `shouldBe`
"<< 01 00 06 00 00 00 00 0f fc >>"
describe "Formatting sub-byte fields" $ do
it "only the addressed bits are copied to the output" $
property $ \value ->
let rec = Proxy
rec :: Proxy (Field 4 := 0 .+. "here" @: Field 4)
actualB :: Builder
actualB = runBitBuilderHoley (toFunctionBuilder rec) value
actual = printBuilder actualB
expected = printf "<< %.2x >>" (value .&. 0xf)
in actual `shouldBe` expected
it "renders (Flag := 0 .+. Field 7 := 130) to << 02 >>" $
let rec = Proxy
rec :: Proxy (Flag := 'False .+. Field 7 := 130)
actual = printBuilder b
where b = runBitBuilderHoley (toFunctionBuilder rec)
in actual `shouldBe` "<< 02 >>"
describe "ByteStringBuilder" $
describe "runBitBuilderHoley" $
it "0x01020304050607 to << 00 01 02 03 04 05 06 07 >>" $
let expected = "<< 00 01 02 03 04 05 06 07 >>"
actual =
printBuilder
(runBitBuilderHoley
(toFunctionBuilder
(bitBuffer64 64 0x01020304050607)))
in actual `shouldBe` expected
#endif
instance (KnownNat n, n <= 64) => Arbitrary (B n) where
arbitrary = do
let h = 2^(n'-1) - 1
n' = fromIntegral (natVal (Proxy @n)) :: Int
x <- choose (0, h + h + 1)
return (B x)