isobmff 0.13.0.0 → 0.14.0.0

raw patch · 36 files changed

+2048/−871 lines, 36 filesdep ~function-builderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: function-builder

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• LICENSE +1/−1
• benchmarks/bit-records/Main.hs +27/−27
• isobmff.cabal +8/−3
• spec/BitRecordsSpec.hs +53/−53
• spec/EnumSpec.hs +2/−2
• spec/ExpandableSpec.hs +3/−3
• spec/Mp4AudioFileSpec.hs +6/−6
• spec/Mp4AudioSampleEntrySpec.hs +2/−2
• src/Data/ByteString/IsoBaseFileFormat/Box.hs +3/−3
• src/Data/ByteString/IsoBaseFileFormat/Boxes/HintSampleEntry.hs +1/−1
• src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackExtends.hs +7/−7
• src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackRun.hs +17/−16
• src/Data/ByteString/IsoBaseFileFormat/Util/BoxFields.hs +1/−1
• src/Data/ByteString/Mp4/Boxes/AudioSpecificConfig.hs +20/−20
• src/Data/ByteString/Mp4/Boxes/BaseDescriptor.hs +48/−48
• src/Data/ByteString/Mp4/Boxes/DecoderConfigDescriptor.hs +13/−13
• src/Data/ByteString/Mp4/Boxes/DecoderSpecificInfo.hs +2/−2
• src/Data/ByteString/Mp4/Boxes/ElementaryStreamDescriptor.hs +22/−22
• src/Data/ByteString/Mp4/Boxes/Expandable.hs +29/−22
• src/Data/ByteString/Mp4/Boxes/SyncLayerConfigDescriptor.hs +5/−5
• src/Data/Kind/Extra.hs +96/−97
• src/Data/Type/BitRecords.hs +2/−2
• src/Data/Type/BitRecords/BitBuffer64.hs +124/−0
• src/Data/Type/BitRecords/Builder/BitBuffer.hs +0/−161
• src/Data/Type/BitRecords/Builder/LazyByteStringBuilder.hs +319/−181
• src/Data/Type/BitRecords/Core.hs +189/−96
• src/Data/Type/BitRecords/Enum.hs +33/−33
• src/Data/Type/BitRecords/Sized.hs +24/−35
• src/Data/Type/BitRecords/SizedString.hs +35/−8
• src/Data/Type/BitRecords/Structure.hs +314/−0
• src/Data/Type/BitRecords/Structure/Constructor.hs +166/−0
• src/Data/Type/BitRecords/Structure/String.hs +68/−0
• src/Data/Type/BitRecords/Structure/TypeLits.hs +219/−0
• src/Data/Type/BitRecords/Writer/ByteStringBuilder.hs +181/−0
• stack.yaml +1/−1

@@ -1,3 +1,10 @@+# 0.14.0.0++Work-In-Progress intermediate release in preperation of splitting this package.++This compiles and the tests run, but the code really sucks!++ # 0.11.4.0  * Rename `AacMp4StreamConfig` to `AacInitSegment`

@@ -21,7 +21,7 @@ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, addParameter, INCIDENTAL,+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, deferred, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

@@ -64,12 +64,12 @@   "Test Types Sizes"   ######################## -        It's "64 bit long: Static64" (ShouldBe 64 (BitRecordSize Static64))-     -* It's "64 bit long: Static64WithParams" (ShouldBe 64 (BitRecordSize Static64WithParams))+        It's "64 bit long: Static64" (ShouldBe 64 (SizeInBits Static64))+     -* It's "64 bit long: Static64WithParams" (ShouldBe 64 (SizeInBits Static64WithParams)) #ifdef FULLBENCHMARKS-     -* It's "128 bit long" (ShouldBeTrue ((BitRecordSize Static128) == 128))-     -* It's "256 bit long" (ShouldBeTrue ((BitRecordSize Static256) == 256))-     -* It's "517 bit long" (ShouldBeTrue ((BitRecordSize Static517) == 517))+     -* It's "128 bit long" (ShouldBeTrue ((SizeInBits Static128) == 128))+     -* It's "256 bit long" (ShouldBeTrue ((SizeInBits Static256) == 256))+     -* It's "517 bit long" (ShouldBeTrue ((SizeInBits Static517) == 517)) #endif  aboutStatic64 =@@ -79,26 +79,26 @@ lumpUp m = L.unpack . L.toLazyByteString . mconcat . replicate (fromIntegral m)  static64 m = lumpUp m $-    runBitStringBuilderHoley $ bitStringBuilderHoley (Proxy :: Proxy Static64)+    runBitBuilderHoley $ toFunctionBuilder (Proxy :: Proxy Static64)  static64WithParam m = lumpUp m $-    runBitStringBuilderHoley (bitStringBuilderHoley (Proxy :: Proxy Static64WithParams))+    runBitBuilderHoley (toFunctionBuilder (Proxy :: Proxy Static64WithParams))                         (B m)                         (B m)  #ifdef FULLBENCHMARKS  static128 m =-  lumpUp m $ runBitStringBuilderHoley $ bitStringBuilderHoley (Proxy :: Proxy Static128)+  lumpUp m $ runBitBuilderHoley $ toFunctionBuilder (Proxy :: Proxy Static128)  static256 m =-  lumpUp m $ runBitStringBuilderHoley $ bitStringBuilderHoley (Proxy :: Proxy Static256)+  lumpUp m $ runBitBuilderHoley $ toFunctionBuilder (Proxy :: Proxy Static256)  static517 m =-  lumpUp m $ runBitStringBuilderHoley $ bitStringBuilderHoley (Proxy :: Proxy Static517)+  lumpUp m $ runBitBuilderHoley $ toFunctionBuilder (Proxy :: Proxy Static517)  staticPlain512bitBaseline m =-  lumpUp m $ runBitStringBuilderHoley $ bitStringBuilderHoley+  lumpUp m $ runBitBuilderHoley $ toFunctionBuilder     (Proxy :: Proxy (       Field 64 .+. Field 64 .+. Field 64 .+. Field 64 .+.       Field 64 .+. Field 64 .+. Field 64 .+. Field 64@@ -157,37 +157,37 @@                                       nf staticPlain512bitBaseline 1000                                   ] #endif-                         , bgroup "BitString Word64 direct"+                         , bgroup "BitBuffer64 Word64 direct"                                   [ bench "1" $-                                      nf bitStringWord64Direct 1+                                      nf bitBuffer64Word64Direct 1                                   , bench "100" $-                                      nf bitStringWord64Direct 5+                                      nf bitBuffer64Word64Direct 5                                   , bench "1000" $-                                      nf bitStringWord64Direct 1000+                                      nf bitBuffer64Word64Direct 1000                                   ]-                         , bgroup "BitString Word64 holey"+                         , bgroup "BitBuffer64 Word64 holey"                                   [ bench "1" $-                                      nf bitStringWord64Holey 1+                                      nf bitBuffer64Word64Holey 1                                   , bench "100" $-                                      nf bitStringWord64Holey 5+                                      nf bitBuffer64Word64Holey 5                                   , bench "1000" $-                                      nf bitStringWord64Holey 1000+                                      nf bitBuffer64Word64Holey 1000                                   ]                          ]                 ] -bitStringWord64Direct m =+bitBuffer64Word64Direct m =   lumpUp 1-    $ runBitStringBuilder+    $ runBitBuilder     $ mconcat     $ replicate m-    $ appendBitString-    $ bitString 64 0x01020304050607+    $ appendBitBuffer64+    $ bitBuffer64 64 0x01020304050607 -bitStringWord64Holey m =+bitBuffer64Word64Holey m =   lumpUp 1-    $ runBitStringBuilderHoley+    $ runBitBuilderHoley     $ mconcat     $ replicate m-    $ bitStringBuilderHoley-    $ bitString 64 0x01020304050607+    $ deferred+    $ bitBuffer64 64 0x01020304050607

@@ -1,5 +1,5 @@ name:                isobmff-version:             0.13.0.0+version:             0.14.0.0 synopsis:            A parser and generator for the ISO-14496-12/14 base media file format description:         Please see README.md homepage:            https://github.com/sheyll/isobmff#readme@@ -102,12 +102,17 @@                      , Data.Type.BitRecords                      , Data.Type.BitRecords.Arithmetic                      , Data.Type.BitRecords.Assert-                     , Data.Type.BitRecords.Builder.BitBuffer+                     , Data.Type.BitRecords.BitBuffer64                      , Data.Type.BitRecords.Builder.LazyByteStringBuilder+                     , Data.Type.BitRecords.Writer.ByteStringBuilder                      , Data.Type.BitRecords.Core                      , Data.Type.BitRecords.Enum                      , Data.Type.BitRecords.SizedString                      , Data.Type.BitRecords.Sized+                     , Data.Type.BitRecords.Structure+                     , Data.Type.BitRecords.Structure.Constructor+                     , Data.Type.BitRecords.Structure.String+                     , Data.Type.BitRecords.Structure.TypeLits   build-depends:       base >= 4.12 && < 5                      , bytestring                      -- , type-list@@ -116,7 +121,7 @@                      , singletons >= 2.5 && < 2.6                      , tagged                      , time-                     , function-builder >= 0.1 && < 0.2+                     , function-builder >= 0.3 && < 0.4                      , text                      , type-spec >= 0.3                      , mtl

@@ -23,46 +23,46 @@            "The record size works"           ~~~~~~~~~~~~~~~~~~~~~~~~-              1 `ShouldBe` BitRecordFieldSize (FlagJust 'Nothing)-          -*  1 `ShouldBe` BitRecordFieldSize (FlagJust ('Just "Blah"))-          -*  1 `ShouldBe` BitRecordFieldSize (FlagNothing ('Just "Blah"))+              1 `ShouldBe` FieldWidth (FlagJust 'Nothing)+          -*  1 `ShouldBe` FieldWidth (FlagJust ('Just "Blah"))+          -*  1 `ShouldBe` FieldWidth (FlagNothing ('Just "Blah"))           -- TODO reenable tests-          -- -*  32 `ShouldBe` BitRecordSize (ToBitRecord ('Just FieldU32))-          -- -*  0 `ShouldBe` BitRecordSize (ToBitRecord '[])-          -- -*  10 `ShouldBe` BitRecordSize (ToBitRecord '[Field 10])-          -- -*  25 `ShouldBe` BitRecordSize (ToBitRecord '[Field 10, Field 15])-          -- -*  1 `ShouldBe` BitRecordSize (ToBitRecord Bool)-          -- -*  1 `ShouldBe` BitRecordSize (ToBitRecord 'True)-          -- -*  1 `ShouldBe` BitRecordSize (ToBitRecord 'False)+          -- -*  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 "bitStringBuilder" $ do+  describe "bitBuffer64Printer" $ do     describe "Just x" $ it "writes x" $-      bitStringPrinter (Proxy :: Proxy (OptionalRecord ('Just ('BitRecordMember (Flag := 'True))))) `shouldBe` "<< 80 >>"+      bitBuffer64Printer (Proxy :: Proxy (OptionalRecord ('Just ('BitRecordMember (Flag := 'True))))) `shouldBe` "<< 80 >>"     describe "Nothing" $ it "writes nothing" $-      bitStringPrinter (Proxy :: Proxy (OptionalRecord ('Nothing))) `shouldBe` "<<  >>"+      bitBuffer64Printer (Proxy :: Proxy (OptionalRecord ('Nothing))) `shouldBe` "<<  >>"     -- describe "'[]" $ it "writes nothing" $-    --   bitStringPrinter (Proxy :: Proxy (BitRecordOfList (Fun1 RecordField)  ('[]))) `shouldBe` "<<  >>"+    --   bitBuffer64Printer (Proxy :: Proxy (BitRecordOfList (Fun1 RecordField)  ('[]))) `shouldBe` "<<  >>"     -- describe "'[x1, x2]" $ it "writes x1 then x2" $-    --   bitStringPrinter (Proxy :: Proxy (BitRecordOfList (Fun1 RecordField) ('[FieldU8 := 1, FieldU8 := 2]))) `shouldBe` "<< 01 02 >>"+    --   bitBuffer64Printer (Proxy :: Proxy (BitRecordOfList (Fun1 RecordField) ('[FieldU8 := 1, FieldU8 := 2]))) `shouldBe` "<< 01 02 >>"     describe "'True" $ it "writes a single bit with a 1" $-      bitStringPrinter (Proxy :: Proxy (RecordField (Flag := 'True))) `shouldBe` "<< 80 >>"+      bitBuffer64Printer (Proxy :: Proxy (RecordField (Flag := 'True))) `shouldBe` "<< 80 >>"     describe "'False" $ it "writes a single bit with a 0" $-      bitStringPrinter (Proxy :: Proxy (RecordField (Flag := 'False))) `shouldBe` "<< 00 >>"+      bitBuffer64Printer (Proxy :: Proxy (RecordField (Flag := 'False))) `shouldBe` "<< 00 >>"     describe "@: labelled fields"  $ do       it "writes them ..." $-        let fld = Proxy @(Eval (RecordField ( "foo" @: FlagJust 'Nothing  )))-        in bitStringPrinter fld `shouldBe` "<< 00 >>"+        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" $-        bitStringPrinter (Proxy :: Proxy (RecordField (FlagJust ('Just "test")))) `shouldBe` "<< 80 >>"+        bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagJust ('Just "test")))) `shouldBe` "<< 80 >>"       it "writes a single bit '0' for a 'Nothing' parameter" $-        bitStringPrinter (Proxy :: Proxy (RecordField (FlagJust 'Nothing))) `shouldBe` "<< 00 >>"+        bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagJust 'Nothing))) `shouldBe` "<< 00 >>"     describe "FlagNothing" $ do       it "writes a single bit '0' for a 'Just ...' parameter" $-        bitStringPrinter (Proxy :: Proxy (RecordField (FlagNothing ('Just "test")))) `shouldBe` "<< 00 >>"+        bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagNothing ('Just "test")))) `shouldBe` "<< 00 >>"       it "writes a single bit '1' for a 'Nothing' parameter" $-        bitStringPrinter (Proxy :: Proxy (RecordField (FlagNothing 'Nothing))) `shouldBe` "<< 80 >>"+        bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagNothing 'Nothing))) `shouldBe` "<< 80 >>"   -- TODO reenable showRecord tests   -- describe "showRecord" $ do   --   describe "Maybe" $ do@@ -106,9 +106,9 @@                "The record size works"               ~~~~~~~~~~~~~~~~~~~~~~~~-                  1 `ShouldBe` BitRecordSize (Eval (RecArray ('BitRecordMember Flag) 1))-              -* 91 `ShouldBe` BitRecordSize (Eval (("foo" @: Flag .+. FieldU8) ^^ 10) :+. Flag)-              -* 91 `ShouldBe` BitRecordSize (Eval (RecArray ("foo" @: Flag .+. FieldU8) 10) :+. Flag)+                  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" $@@ -116,9 +116,9 @@         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 "bitStringBuilder" $+      describe "bitBuffer64Printer" $         it "writes its contents n times to the builder" $-          let actual = bitStringPrinter (Proxy :: Proxy (('BitRecordMember (Field 24 := 0x010203) ^^ 4)))+          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 @@ -132,24 +132,24 @@              "SizedString"             ~~~~~~~~~~~~~~~-                88 `ShouldBe` BitRecordFieldSize [utf8|Hello World|]-            -* 104 `ShouldBe` BitRecordSize (Eval (RecordField [utf8|Heλλo World|]))+                88 `ShouldBe` FieldWidth [utf8|Hello World|]+            -* 104 `ShouldBe` SizeInBits (From (RecordField [utf8|Heλλo World|]))              -/-              "Sized BitRecord Members"             ~~~~~~~~~~~~~~~~~~~~~~~~-                8 `ShouldBe` BitRecordSize (Eval (Sized8 'EmptyBitRecord))-            -*  9 `ShouldBe` BitRecordSize (Eval (Sized8 ('BitRecordMember Flag)))-            -*  0 `ShouldBe` SizeFieldValue 'EmptyBitRecord-            -*  1 `ShouldBe` SizeFieldValue ('BitRecordMember Flag)+                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` BitRecordSize (Eval (SizedField8 Flag))-            -*  1 `ShouldBe` SizeFieldValue  Flag+                9 `ShouldBe` SizeInBits (From (SizedField8 Flag))+            -*  1 `ShouldBe` SizeInBytes  Flag              -- TODO add more Sized tests, especially for SizedField           checkSized = Valid@@ -161,30 +161,30 @@       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 "bitStringBuilder" $ do+    describe "bitBuffer64Printer" $ do       describe "no length prefix" $         it "renders no size prefix and the string as UTF-8 bytes" $-        bitStringPrinter (Proxy :: Proxy (RecordField [utf8|ABC|]))+        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" $-        bitStringPrinter (Proxy :: Proxy (SizedField8 [utf8|ABC|]))+        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" $-        bitStringPrinter (Proxy :: Proxy (SizedField16 [utf8|ABC|]))+        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" $-        bitStringPrinter (Proxy :: Proxy (SizedField32 [utf8|ABC|]))+        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" $-        bitStringPrinter (Proxy :: Proxy (SizedField64 [utf8|ABC|]))+        bitBuffer64Printer (Proxy :: Proxy (SizedField64 [utf8|ABC|]))         `shouldBe`         "<< 00 00 00 00 00 00 00 03 41 42 43 >>" @@ -200,7 +200,7 @@   "rab" @: Field 8  checkTestRecAligned-  :: Expect '[ ShouldBe 96        (BitRecordSize TestRecAligned)  ]+  :: Expect '[ ShouldBe 96        (SizeInBits TestRecAligned)  ] checkTestRecAligned = Valid  type TestRecUnAligned =@@ -212,7 +212,7 @@             Field 8  := 0xfe  checkTestRecUnAligned-  :: Expect '[ ShouldBe 71        (BitRecordSize TestRecUnAligned) ]+  :: Expect '[ ShouldBe 71        (SizeInBits TestRecUnAligned) ] checkTestRecUnAligned = Valid  testTakeLastN ::@@ -409,7 +409,7 @@   arraySpec   describe "The Set of Type Functions" $     it "is sound" $ do-      print (Valid :: Expect (BitRecordSize (Flag .+. Field 7) `Is` 8))+      print (Valid :: Expect (SizeInBits (Flag .+. Field 7) `Is` 8))       print testTakeLastN       print testRem       print testRemPow2@@ -427,8 +427,8 @@             rec :: Proxy TestRecUnAligned             actualB :: Builder             actualB =-                  runBitStringBuilderHoley-                  (bitStringBuilderHoley rec)+                  runBitBuilderHoley+                  (toFunctionBuilder rec)                           1                           3                           7@@ -441,7 +441,7 @@           let rec = Proxy               rec :: Proxy (Field 4 := 0 .+. "here" @: Field 4)               actualB :: Builder-              actualB = runBitStringBuilderHoley (bitStringBuilderHoley rec) value+              actualB = runBitBuilderHoley (toFunctionBuilder rec) value               actual = printBuilder actualB               expected = printf "<< %.2x >>" (value .&. 0xf)               in actual `shouldBe` expected@@ -449,17 +449,17 @@         let rec = Proxy             rec :: Proxy (Flag := 'False .+. Field 7 := 130)             actual = printBuilder b-              where b = runBitStringBuilderHoley (bitStringBuilderHoley rec)+              where b = runBitBuilderHoley (toFunctionBuilder rec)         in actual `shouldBe` "<< 02 >>"   describe "ByteStringBuilder" $-    describe "runBitStringBuilderHoley" $+    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-                (runBitStringBuilderHoley-                 (bitStringBuilderHoley-                     (bitString 64 0x01020304050607)))+                (runBitBuilderHoley+                 (toFunctionBuilder+                     (bitBuffer64 64 0x01020304050607)))             in actual `shouldBe` expected #endif 

@@ -12,9 +12,9 @@     it "renders as a record using showRecord" $       showRecord (Proxy @(BitRecordOfEnum (EnumParam "test" TestEnumExt)))       `shouldBe` "test: <<enum>>(2)"-  describe "BitStringBuilder" $ do+  describe "BitBuilder" $ do     it "produces binary output" $-     bitStringPrinter (Proxy  @(BitRecordOfEnum (EnumParam "test" TestEnumExt)))+     bitBuffer64Printer (Proxy  @(BitRecordOfEnum (EnumParam "test" TestEnumExt)))       (MkEnumValue (Proxy @'A))      `shouldBe` "<< 40 >>" 

@@ -16,13 +16,13 @@   describe "StaticExpandable" $ do     describe "ExpandableSizeLastChunk" $       it "renders both 2 and 130 as 00000010 " $ do-        let actual130 = bitStringPrinter (Proxy :: Proxy ((ExpandableSizeLastChunk 130)))-            actual2 = bitStringPrinter (Proxy :: Proxy (ExpandableSizeLastChunk 2))+        let actual130 = bitBuffer64Printer (Proxy :: Proxy ((ExpandableSizeLastChunk 130)))+            actual2 = bitBuffer64Printer (Proxy :: Proxy (ExpandableSizeLastChunk 2))         actual130 `shouldBe` actual2         actual2 `shouldBe` "<< 02 >>"     describe "ExpandableSize" $       it "creates a stdandard conform size representation for the size 130" $-        let actualStr = bitStringPrinter (Proxy :: Proxy (ExpandableSize 130))+        let actualStr = bitBuffer64Printer (Proxy :: Proxy (ExpandableSize 130))         in actualStr `shouldBe` "<< 81 02 >>"      -- TODO add new test

@@ -16,7 +16,7 @@      describe "Mp4AacAudioDecoderConfigDescriptor" $ do        it "can be pretty printed" $          showRecord (Proxy @(BitRecordOfDescriptor-                              $~ (Eval (Mp4AacAudioDecoderConfigDescriptor+                              $ (From (Mp4AacAudioDecoderConfigDescriptor                                         (AudioConfigAacLc                                          (EnumParam "samplingFreq" SamplingFreq)                                           (EnumParam "channelConfig" ChannelConfig))))))@@ -26,9 +26,9 @@ #ifdef COMPLEXTESTS        it "can be transformed to binary output" $          let actual =-              bitStringPrinter+              bitBuffer64Printer                 (Proxy @(BitRecordOfDescriptor-                               $~ Eval  (Mp4AacAudioDecoderConfigDescriptor+                               $ From  (Mp4AacAudioDecoderConfigDescriptor                                          (AudioConfigAacLc                                           (EnumParam "samplingFreq" SamplingFreq)                                            (EnumParam "channelConfig" ChannelConfig)))))@@ -42,18 +42,18 @@          in actual `shouldBe` expexted      describe "Mp4AacLcEsDescriptor" $        do it "can be transformed to binary output" $-            bitStringPrinter (Proxy @(BitRecordOfDescriptor $~ Eval Mp4AacLcEsDescriptor))+            bitBuffer64Printer (Proxy @(BitRecordOfDescriptor $ From Mp4AacLcEsDescriptor))                              False 0 0 0                              (MkEnumValue (Proxy @'SF48000))                              (MkEnumValue (Proxy @'SingleChannel))             `shouldBe`               "<< 03 19 00 01 00 04 11 40 15 00 00 00 00 00 00 00 00 00 00 00 05 02 11 88 06 01 02 >>"           it "can be pretty printed" $-            showRecord (Proxy @(BitRecordOfDescriptor $~ Eval Mp4AacLcEsDescriptor))+            showRecord (Proxy @(BitRecordOfDescriptor $ From Mp4AacLcEsDescriptor))             `shouldStartWith` "U8 := hex: 03 (dec: 3)\n"      describe "Mp4HeAacEsDescriptor" $        do it "can be transformed to binary output" $-            bitStringPrinter (Proxy @(BitRecordOfDescriptor $~ Eval Mp4HeAacEsDescriptor))+            bitBuffer64Printer (Proxy @(BitRecordOfDescriptor $ From Mp4HeAacEsDescriptor))                              False 0 0 0                              (MkEnumValue (Proxy @'SF48000))                              (MkEnumValue (Proxy @'SingleChannel))

@@ -17,8 +17,8 @@        "Small Audio Object Types"       ~~~~~~~~~~~~~~~~~~~~~~~~~~~-         5 `ShouldBe` BitRecordSize (AudioObjectTypeRec 'AoReserved5)  -/-+         5 `ShouldBe` SizeInBits (AudioObjectTypeRec 'AoReserved5)  -/-        "Big Audio Object Types"       ~~~~~~~~~~~~~~~~~~~~~~~~-        11 `ShouldBe` BitRecordSize (AudioObjectTypeRec 'AoCustom)+        11 `ShouldBe` SizeInBits (AudioObjectTypeRec 'AoCustom)

@@ -339,9 +339,9 @@  -- * Boxes of Bits -instance IsBoxContent BuilderBox where-  boxSize (MkBuilderBox !s _) = fromIntegral s-  boxBuilder (MkBuilderBox _ !b) = b+instance IsBoxContent BuilderWithSize where+  boxSize (MkBuilderWithSize !s _) = fromIntegral s+  boxBuilder (MkBuilderWithSize _ !b) = b  -- * Type Layout Rule Matchers 

@@ -6,7 +6,7 @@ import Data.ByteString.IsoBaseFileFormat.Boxes.Handler import Data.ByteString.IsoBaseFileFormat.Box --- | Protocol specific data. To create 'HintSampleEntry's a protocol specific+-- | Protocol specific data. Extends create 'HintSampleEntry's a protocol specific -- 'HintFields' instance must be provided newtype HintSampleEntry protocol where   HintSampleEntry :: protocol -> HintSampleEntry protocol

@@ -31,11 +31,11 @@   -> Word16 -- ^ sample degradation priority   -> Box (FullBox TrackExtends 0) trackExtends =-   wrapBitBuilderBox (fullBox 0 . MkTrackExtends) (Proxy @TrackExtendsBody)+   wrapBitBuilderWithSize (fullBox 0 . MkTrackExtends) (Proxy @TrackExtendsBody)   newtype TrackExtends where-  MkTrackExtends :: BuilderBox -> TrackExtends+  MkTrackExtends :: BuilderWithSize -> TrackExtends   deriving (IsBoxContent)  instance IsBox TrackExtends@@ -44,11 +44,11 @@  -- | Defaults for movie fragment - the content type TrackExtendsBody =-     "track_ID"                         @: FieldU32- .+: "default_sample_description_index" @: FieldU32- .+: "default_sample_duration"          @: FieldU32- .+: "default_sample_size"              @: FieldU32- .+: TrackExtendsDefaultSampleFlags+     'RecordField ("track_ID"                         @:: FieldU32)+ :+: 'RecordField ("default_sample_description_index" @:: FieldU32)+ :+: 'RecordField ("default_sample_duration"          @:: FieldU32)+ :+: 'RecordField ("default_sample_size"              @:: FieldU32)+ :+: TrackExtendsDefaultSampleFlags  type TrackExtendsDefaultSampleFlags =       "reserved"                    @: Field 4 := 0

@@ -24,26 +24,26 @@                                   + fromIntegral                                   ((headerStaticSize `div` 8)                                    + sampleCount * (sampleStaticSize `div` 8))-            !h                = bitBuilderBox (Proxy @(Header TrackRunFlagsIso5))-            !headerStaticSize = (natVal (Proxy @(BitRecordSize (Header TrackRunFlagsIso5))))-            !sampleStaticSize = (natVal (Proxy @(BitRecordSize (Sample TrackRunFlagsIso5))))+            !h                = bitBuilderWithSize (Proxy @(Header TrackRunFlagsIso5))+            !headerStaticSize = (natVal (Proxy @(SizeInBits (Header TrackRunFlagsIso5))))+            !sampleStaticSize = (natVal (Proxy @(SizeInBits (Sample TrackRunFlagsIso5))))             !sampleCount      = fromIntegral (length samples)          !body = mconcat $ s <$> samples           where-            s (!duration, !bs) = bitBuilderBox (Proxy @(Sample TrackRunFlagsIso5)) duration size+            s (!duration, !bs) = bitBuilderWithSize (Proxy @(Sample TrackRunFlagsIso5)) duration size               where                 !size = fromIntegral (BS.length bs)  newtype TrackRun where-  TrackRun :: BuilderBox -> TrackRun+  TrackRun :: BuilderWithSize -> TrackRun   deriving (IsBoxContent)  instance IsBox TrackRun type instance BoxTypeSymbol TrackRun = "trun" --- class MkTrackRunArgs (t :: IsA (TrackRunFlags sop fsp sdp ssp sfp sop)) where---   data TrRunArgs (t :: IsA (TrackRunFlags sop fsp sdp ssp sfp sop))+-- class MkTrackRunArgs (t :: Extends (TrackRunFlags sop fsp sdp ssp sfp sop)) where+--   data TrRunArgs (t :: Extends (TrackRunFlags sop fsp sdp ssp sfp sop))  data TrackRunFlags   (dataOffsetPresent :: Bool)@@ -54,9 +54,9 @@   (sampleCompositionTimeOffsetPresent :: Bool)  data TrackRunFlagsIso5-  :: IsA (TrackRunFlags 'True 'False 'True 'True 'True 'False)+  :: Extends (TrackRunFlags 'True 'False 'True 'True 'True 'False) -type Header (t :: IsA (TrackRunFlags dop fsp sdp ssp sfp sctop)) =+type Header (t :: Extends (TrackRunFlags dop fsp sdp ssp sfp sctop)) =       "version"                   @: FieldU8  := 0 -- TODO allow version 1   .+:                                Field 12 := 0   .+: "sample-scto-present"       @: Flag     := sctop@@ -67,14 +67,15 @@   .+: "first-sample-flag-present" @: Flag     := fsp   .+:                                Flag     := 'False   .+: "data-offset-preset"        @: Flag     := dop-  .+: "sample-count"              @: FieldU32-  .+: WhenR dop+  .+: 'RecordField ("sample-count"  @:: FieldU32)+  :+: WhenR dop         ('BitRecordMember ("data-offset"        @: FieldI32))   :+: WhenR fsp-        ('BitRecordMember ("first-sample-flags" @: FieldU32))+        ('RecordField ("first-sample-flags" @:: FieldU32))  -type Sample (t :: IsA (TrackRunFlags dop fsp sdp ssp sfp sctop)) =-      WhenR sdp ('BitRecordMember ("sample-duration" @: FieldU32))-  :+: WhenR ssp ('BitRecordMember ("sample-size"     @: FieldU32))-  :+: WhenR sfp ('BitRecordMember ("sample-flags"    @: FieldU32 := 0x02000000)) -- TODO allow flags as in TrackExtends +type Sample (t :: Extends (TrackRunFlags dop fsp sdp ssp sfp sctop)) =+      WhenR sdp ('RecordField ("sample-duration" @:: FieldU32))+  :+: WhenR ssp ('RecordField ("sample-size"     @:: FieldU32))+  :+: WhenR sfp ('RecordField ("sample-flags"    @:: FieldU32 :=. 0x02000000))+      -- TODO allow flags as in TrackExtends

@@ -198,7 +198,7 @@ -- * Constant fields  -- | Wrapper around a field, e.g. a 'Scalar' or 'ScalarArray', with a type level--- value. The wrapped content must implement 'FromTypeLit'. To get the value of+-- value. The wrapped content must implement 'FromTypeLit'. Extends get the value of -- a 'Constant'  use 'fromTypeLit'. data Constant o v where         Constant :: Constant o v

@@ -20,13 +20,13 @@ -- | A minimalistic audio config without sync and error protection data AudioConfigAacMinimal   :: AudioObjectTypeId-  -> IsAn AudioSubConfig-  -> IsAn (EnumOf SamplingFreqTable)-  -> IsAn (EnumOf ChannelConfigTable)-  -> IsA (DecoderSpecificInfo 'AudioIso14496_3 'AudioStream)+  -> Extends AudioSubConfig+  -> Extends (EnumOf SamplingFreqTable)+  -> Extends (EnumOf ChannelConfigTable)+  -> Extends (DecoderSpecificInfo 'AudioIso14496_3 'AudioStream)  type instance-  Eval (AudioConfigAacMinimal+  From (AudioConfigAacMinimal         aoId         subCfg         freq@@ -37,14 +37,14 @@ -- | A audio config with SBR signalled explicit and hierachical data AudioConfigSbrExplicitHierachical   :: AudioObjectTypeId-  -> IsAn AudioSubConfig-  -> IsAn (EnumOf SamplingFreqTable)-  -> IsAn (EnumOf ChannelConfigTable)-  -> IsAn (EnumOf SamplingFreqTable) -- extension SamplingFrequency-  -> IsA (DecoderSpecificInfo 'AudioIso14496_3 'AudioStream)+  -> Extends AudioSubConfig+  -> Extends (EnumOf SamplingFreqTable)+  -> Extends (EnumOf ChannelConfigTable)+  -> Extends (EnumOf SamplingFreqTable) -- extension SamplingFrequency+  -> Extends (DecoderSpecificInfo 'AudioIso14496_3 'AudioStream)  type instance-     Eval+     From        (AudioConfigSbrExplicitHierachical aoId subCfg freq channels           extFreq)      =@@ -142,7 +142,7 @@   .+: AudioObjectTypeField2 (FromEnum AudioObjectTypeId n)  type family AudioObjectTypeField1 (n :: Nat)-  :: IsA (BitRecordField ('MkFieldBits :: BitField (B 5) Nat 5)) where+  :: Extends (BitRecordField ('MkFieldBits :: BitField (B 5) Nat 5)) where   AudioObjectTypeField1 n =     If (n <=? 30) (Field 5 := n) (Field 5 := 31) @@ -270,18 +270,18 @@  data AudioSubConfig :: Type -type family BitRecordOfAudioSubConfig (x :: IsA AudioSubConfig) :: BitRecord+type family BitRecordOfAudioSubConfig (x :: Extends AudioSubConfig) :: BitRecord  data GASpecificConfig-  (frameLenFlag   :: IsA (FieldValue "frameLenFlag" Bool))-  (coreCoderDelay :: Maybe (IsA (FieldValue "coreCoderDelay" Nat)))-  (extension      :: IsA GASExtension)-  :: IsA AudioSubConfig+  (frameLenFlag   :: Extends (FieldValue "frameLenFlag" Bool))+  (coreCoderDelay :: Maybe (Extends (FieldValue "coreCoderDelay" Nat)))+  (extension      :: Extends GASExtension)+  :: Extends AudioSubConfig  type DefaultGASpecificConfig =   GASpecificConfig (StaticFieldValue "frameLenFlag" 'False) 'Nothing MkGASExtension -type instance Eval (GASpecificConfig fl cd ext)+type instance From (GASpecificConfig fl cd ext)   = TypeError ('Text "AudioSubConfig is abstract!")  @@ -295,7 +295,7 @@  -- | TODO implment that GAS extensions data GASExtension-data MkGASExtension :: IsA GASExtension+data MkGASExtension :: Extends GASExtension -type BitRecordOfGASExtension (x :: IsA GASExtension) =+type BitRecordOfGASExtension (x :: Extends GASExtension) =   'BitRecordMember ("has-gas-extension" @: Flag := 'False)

@@ -9,63 +9,63 @@ -- | Abstract class of /descriptors/ as recognized by ISO/IEC 14496-1 (Systems). -- A specifc descriptor is identified by the 'ClassTag'. data Descriptor :: ClassTag n -> Type where-  MkDescriptor :: BitRecord -> Descriptor tag+  MkDescriptor ::BitRecord -> Descriptor tag  -- TODO ok... this fixed the current problem in DecoderSpecificInfo .. but remove this instances ... or the above ... or ... I dunno -data BitRecordOfDescriptor :: IsA (Descriptor c :-> BitRecord)+data BitRecordOfDescriptor :: Extends (Descriptor c -> BitRecord)  type instance-  BitRecordOfDescriptor $~ ('MkDescriptor body :: Descriptor (tag :: ClassTag tagInd)) =+  Apply BitRecordOfDescriptor ('MkDescriptor body :: Descriptor (tag :: ClassTag tagInd)) =    FieldU8 := tagInd-   .+: Eval (StaticExpandableContent body)+   .+: From (StaticExpandableContent body)  type family GetClassTag (c :: ClassTag n) :: Nat where   GetClassTag (c :: ClassTag n) = n  -- | Base Descriptor Class Tags TODO rename to xxxTag data ClassTag (tag :: Nat) where-  ObjectDescr                      :: ClassTag 0x01-  InitialObjectDescr               :: ClassTag 0x02-  ES_Descr                         :: ClassTag 0x03-  DecoderConfigDescr               :: ClassTag 0x04-  DecSpecificInfo                  :: ClassTag 0x05-  SLConfigDescr                    :: ClassTag 0x06-  ContentIdentDescr                :: ClassTag 0x07-  SupplContentIdentDescr           :: ClassTag 0x08-  IPI_DescrPointer                 :: ClassTag 0x09-  IPMP_DescrPointer                :: ClassTag 0x0A-  IPMP_Descr                       :: ClassTag 0x0B-  QoS_Descr                        :: ClassTag 0x0C-  RegistrationDescr                :: ClassTag 0x0D-  ES_ID_Ref                        :: ClassTag 0x0F-  MP4_IOD_                         :: ClassTag 0x10-  MP4_OD_                          :: ClassTag 0x11-  IPL_DescrPointerRef              :: ClassTag 0x12-  ExtensionProfileLevelDescr       :: ClassTag 0x13-  ProfileLevelIndicationIndexDescr :: ClassTag 0x14-  ContentClassificationDescr       :: ClassTag 0x40-  KeyWordDescr                     :: ClassTag 0x41-  RatingDescr                      :: ClassTag 0x42-  LanguageDescr                    :: ClassTag 0x43-  ShortTextualDescr                :: ClassTag 0x44-  ExpandedTextualDescr             :: ClassTag 0x45-  ContentCreatorNameDescr          :: ClassTag 0x46-  ContentCreationDateDescr         :: ClassTag 0x47-  OCICreatorNameDescr              :: ClassTag 0x48-  OCICreationDateDescr             :: ClassTag 0x49-  SmpteCameraPositionDescr         :: ClassTag 0x4A-  SegmentDescr                     :: ClassTag 0x4B-  MediaTimeDescr                   :: ClassTag 0x4C-  IPMP_ToolsListDescr              :: ClassTag 0x60-  IPMP_Tool                        :: ClassTag 0x61-  M4MuxTimingDescr                 :: ClassTag 0x62-  M4MuxCodeTableDescr              :: ClassTag 0x63-  ExtSLConfigDescr                 :: ClassTag 0x64-  M4MuxBufferSizeDescr             :: ClassTag 0x65-  M4MuxIdentDescr                  :: ClassTag 0x66-  DependencyPointer                :: ClassTag 0x67-  DependencyMarker                 :: ClassTag 0x68-  M4MuxChannelDescr                :: ClassTag 0x69-  ExtDescrTag :: forall (n :: Nat) . (0x6A <= n, n <= 0xFE) =>  ClassTag n-  OCIDescrTag :: forall (n :: Nat) . (0x40 <= n, n <= 0x5F) =>  ClassTag n+  ObjectDescr                      ::ClassTag 0x01+  InitialObjectDescr               ::ClassTag 0x02+  ES_Descr                         ::ClassTag 0x03+  DecoderConfigDescr               ::ClassTag 0x04+  DecSpecificInfo                  ::ClassTag 0x05+  SLConfigDescr                    ::ClassTag 0x06+  ContentIdentDescr                ::ClassTag 0x07+  SupplContentIdentDescr           ::ClassTag 0x08+  IPI_DescrPointer                 ::ClassTag 0x09+  IPMP_DescrPointer                ::ClassTag 0x0A+  IPMP_Descr                       ::ClassTag 0x0B+  QoS_Descr                        ::ClassTag 0x0C+  RegistrationDescr                ::ClassTag 0x0D+  ES_ID_Ref                        ::ClassTag 0x0F+  MP4_IOD_                         ::ClassTag 0x10+  MP4_OD_                          ::ClassTag 0x11+  IPL_DescrPointerRef              ::ClassTag 0x12+  ExtensionProfileLevelDescr       ::ClassTag 0x13+  ProfileLevelIndicationIndexDescr ::ClassTag 0x14+  ContentClassificationDescr       ::ClassTag 0x40+  KeyWordDescr                     ::ClassTag 0x41+  RatingDescr                      ::ClassTag 0x42+  LanguageDescr                    ::ClassTag 0x43+  ShortTextualDescr                ::ClassTag 0x44+  ExpandedTextualDescr             ::ClassTag 0x45+  ContentCreatorNameDescr          ::ClassTag 0x46+  ContentCreationDateDescr         ::ClassTag 0x47+  OCICreatorNameDescr              ::ClassTag 0x48+  OCICreationDateDescr             ::ClassTag 0x49+  SmpteCameraPositionDescr         ::ClassTag 0x4A+  SegmentDescr                     ::ClassTag 0x4B+  MediaTimeDescr                   ::ClassTag 0x4C+  IPMP_ToolsListDescr              ::ClassTag 0x60+  IPMP_Tool                        ::ClassTag 0x61+  M4MuxTimingDescr                 ::ClassTag 0x62+  M4MuxCodeTableDescr              ::ClassTag 0x63+  ExtSLConfigDescr                 ::ClassTag 0x64+  M4MuxBufferSizeDescr             ::ClassTag 0x65+  M4MuxIdentDescr                  ::ClassTag 0x66+  DependencyPointer                ::ClassTag 0x67+  DependencyMarker                 ::ClassTag 0x68+  M4MuxChannelDescr                ::ClassTag 0x69+  ExtDescrTag :: (forall (n :: Nat) . (0x6A <= n, n <= 0xFE) =>  ClassTag n)+  OCIDescrTag :: (forall (n :: Nat) . (0x40 <= n, n <= 0x5F) =>  ClassTag n)

@@ -12,18 +12,18 @@ data DecoderConfigDescriptor        (ot :: ObjectTypeIndication)        (st :: StreamType)-          :: [IsA (DecoderSpecificInfo ot st)]-          -> [IsA (Descriptor 'ProfileLevelIndicationIndexDescr)]-          -> IsA (Descriptor 'DecoderConfigDescr)+          :: [Extends (DecoderSpecificInfo ot st)]+          -> [Extends (Descriptor 'ProfileLevelIndicationIndexDescr)]+          -> Extends (Descriptor 'DecoderConfigDescr) -type instance Eval (DecoderConfigDescriptor ot st di ps) =+type instance From (DecoderConfigDescriptor ot st di ps) =   'MkDescriptor (DecoderConfigDescriptorBody ot st di ps)  type family     DecoderConfigDescriptorBody       ot st-      (di :: [IsA (DecoderSpecificInfo ot st)])-      (ps :: [IsA (Descriptor 'ProfileLevelIndicationIndexDescr)])+      (di :: [Extends (DecoderSpecificInfo ot st)])+      (ps :: [Extends (Descriptor 'ProfileLevelIndicationIndexDescr)])         :: BitRecord   where     DecoderConfigDescriptorBody ot st di ps =@@ -32,22 +32,22 @@               :+: "upstream" @: Flag               .+: "reserved" @: Field 1        :=  1               .+: "bufferSizeDB" @: Field 24-              .+: "maxBitrate"   @: FieldU32-              .+: "avgBitrate"   @: FieldU32-              .+: Eval (BitRecordOfList+              .+: From ("maxBitrate" @:: Konst ('RecordField FieldU32))+              :+: From ("avgBitrate" @:: Konst ('RecordField FieldU32))+              :+: From (BitRecordOfList                         (DescriptorOfDecoderSpecificInfo                          :^>>>: BitRecordOfDescriptor)                         (di ?:: LengthIn 0 1))-              :+: Eval (BitRecordOfList+              :+: From (BitRecordOfList                         (Extract :>>>: BitRecordOfDescriptor)                         (ps ?:: LengthIn 0 255))  -- ** 'ProfileLevelIndicationIndexDescriptor'  data ProfileLevelIndicationIndexDescriptor-  :: IsA (FieldValue "profileLevelIndicationIndex" Nat)-  -> IsA (Descriptor 'ProfileLevelIndicationIndexDescr)+  :: Extends (FieldValue "profileLevelIndicationIndex" Nat)+  -> Extends (Descriptor 'ProfileLevelIndicationIndexDescr) -type instance Eval (ProfileLevelIndicationIndexDescriptor val) =+type instance From (ProfileLevelIndicationIndexDescriptor val) =   'MkDescriptor   ('BitRecordMember (FieldU8 :~ val))

@@ -14,9 +14,9 @@   MkDecoderSpecificInfo :: BitRecord -> DecoderSpecificInfo o s  data DescriptorOfDecoderSpecificInfo-  :: IsA (DecoderSpecificInfo ot st :-> Descriptor 'DecSpecificInfo)+  :: Extends (DecoderSpecificInfo ot st -> Descriptor 'DecSpecificInfo) -type instance DescriptorOfDecoderSpecificInfo $~ 'MkDecoderSpecificInfo body =+type instance Apply DescriptorOfDecoderSpecificInfo ('MkDecoderSpecificInfo body) =    'MkDescriptor body  type ObjectTypeIndicationEnum = FixedEnum ObjectTypeIndication 8

@@ -11,43 +11,43 @@ -- * Esd Box  type EsdBox = Box (FullBox Esd 0)-newtype Esd = Esd BuilderBox deriving (IsBoxContent)+newtype Esd = Esd BuilderWithSize deriving (IsBoxContent) instance IsBox Esd  type instance BoxTypeSymbol Esd = "esds" -esdBox :: forall (record :: IsA (Descriptor 'ES_Descr)) (rendered :: BitRecord) .-         ( BitStringBuilderHoley (Proxy rendered) EsdBox+esdBox :: forall (record :: Extends (Descriptor 'ES_Descr)) (rendered :: BitRecord) .+         ( HasFunctionBuilder BitBuilder (Proxy rendered)          , rendered ~ (RenderEsDescr record))-       => Proxy record -> ToBitStringBuilder (Proxy rendered) EsdBox+       => Proxy record -> ToFunction BitBuilder (Proxy rendered) EsdBox esdBox =   toFunction   . esdBoxHoley -esdBoxHoley :: forall (record :: IsA (Descriptor 'ES_Descr)) r (rendered :: BitRecord) .-               ( BitStringBuilderHoley (Proxy rendered) r+esdBoxHoley :: forall (record :: Extends (Descriptor 'ES_Descr)) r (rendered :: BitRecord) .+               ( HasFunctionBuilder BitBuilder (Proxy rendered)                , rendered ~ (RenderEsDescr record)                )-             => Proxy record -> FunctionBuilder EsdBox r (ToBitStringBuilder (Proxy rendered) r)+             => Proxy record -> FunctionBuilder EsdBox r (ToFunction BitBuilder (Proxy rendered) r) esdBoxHoley _p =   mapAccumulator (fullBox 0 . Esd) $-  bitBuilderBoxHoley (Proxy @rendered)+  builderBoxConstructor (Proxy @rendered) -type RenderEsDescr (d :: IsA (Descriptor 'ES_Descr)) =-  BitRecordOfDescriptor $~ (Eval d)+type RenderEsDescr (d :: Extends (Descriptor 'ES_Descr)) =+  BitRecordOfDescriptor $ (From d)  -- * Esd Record  data ESDescriptor-  :: IsA (FieldValue "esId" Nat)-  -> Maybe (IsA (FieldValue "depEsId" Nat))+  :: Extends (FieldValue "esId" Nat)+  -> Maybe (Extends (FieldValue "depEsId" Nat))     -- TODO Improve the custom field and also the sizedstring API-  -> Maybe (IsA (BitRecordField ('MkFieldCustom :: BitField ASizedString ASizedString (urlSize :: Nat))))-  -> Maybe (IsA (FieldValue "ocrEsId" Nat))-  -> IsA (FieldValue "streamPrio" Nat)-  -> IsA (Descriptor 'DecoderConfigDescr)-  -> IsA (Descriptor 'SLConfigDescr)-  -> IsA (Descriptor 'ES_Descr)+  -> Maybe (Extends (BitRecordField ('MkFieldCustom :: BitField ASizedString ASizedString (urlSize :: Nat))))+  -> Maybe (Extends (FieldValue "ocrEsId" Nat))+  -> Extends (FieldValue "streamPrio" Nat)+  -> Extends (Descriptor 'DecoderConfigDescr)+  -> Extends (Descriptor 'SLConfigDescr)+  -> Extends (Descriptor 'ES_Descr)  -- | ISO-14496-14 section 3.1.2 defines restrictions of the elementary stream -- descriptor.@@ -62,7 +62,7 @@ type DefaultStreamPrio = StaticFieldValue "streamPrio" 0  type instance-  Eval (ESDescriptor esId depEsId url ocrEsId streamPrio decConfig slConfig) =+  From (ESDescriptor esId depEsId url ocrEsId streamPrio decConfig slConfig) =   'MkDescriptor      ("esId" @: FieldU16 :~ esId       .+: "depEsIdFlag" @: FlagJust depEsId@@ -70,10 +70,10 @@       .+: "ocrEsIdFlag" @: FlagJust ocrEsId       .+: "streamPriority" @: Field 5 :~ streamPrio       .+: ("depEsId" @: FieldU16 :+? depEsId)-      :+: (Eval (OptionalRecordOf (Fun1 RecordField) url))+      :+: (From (OptionalRecordOf (Fun1 RecordField) url))       :+: ("ocrEsId" @: FieldU16 :+? ocrEsId)-      :+: (BitRecordOfDescriptor $~ Eval decConfig)-      :+: (BitRecordOfDescriptor $~ Eval slConfig)+      :+: (BitRecordOfDescriptor $ From decConfig)+      :+: (BitRecordOfDescriptor $ From slConfig)        -- TODO add the rest of the ESDescriptor      )

@@ -8,13 +8,13 @@  -- * Static Expandable -data StaticExpandableContent :: BitRecord -> IsA BitRecord+data StaticExpandableContent :: BitRecord -> Extends BitRecord  type StaticExpandableContentMaxBits = 32 -type instance Eval (StaticExpandableContent record) =+type instance From (StaticExpandableContent record) =      (ExpandableSize-        (ShiftR StaticExpandableContentMaxBits (BitRecordSize record) 3))+        (ShiftR StaticExpandableContentMaxBits (SizeInBits record) 3))        :+: record  type family ExpandableSize (s :: Nat) :: BitRecord where@@ -41,32 +41,39 @@ -- * Runtime-value Expandable -- TODO remove "runtime" Expandable? newtype Expandable t where-    Expandable :: t -> Expandable t+    Expandable ::t -> Expandable t  instance IsBoxContent t => IsBoxContent (Expandable t) where   boxSize (Expandable x) = expandableSizeSize (boxSize x) + boxSize x   boxBuilder (Expandable x) = expandableSizeBuilder (boxSize x) <> boxBuilder x  expandableSizeSize :: BoxSize -> BoxSize-expandableSizeSize UnlimitedSize = error "Unlimited size not supported by expandable"+expandableSizeSize UnlimitedSize =+  error "Unlimited size not supported by expandable" expandableSizeSize (BoxSize s)-  | s >= 2^(28 :: Int) = error "Expandable size >= 2^(28 :: Int)"-  | s >= 2^(21 :: Int) = 4-  | s >= 2^(14 :: Int) = 3-  | s >= 2^(7 :: Int) = 2-  | otherwise = 1+  | s >= 2 ^ (28 :: Int) = error "Expandable size >= 2^(28 :: Int)"+  | s >= 2 ^ (21 :: Int) = 4+  | s >= 2 ^ (14 :: Int) = 3+  | s >= 2 ^ (7 :: Int)  = 2+  | otherwise            = 1  expandableSizeBuilder :: BoxSize -> Builder-expandableSizeBuilder UnlimitedSize = error "Unlimited size not supported by expandable"+expandableSizeBuilder UnlimitedSize =+  error "Unlimited size not supported by expandable" expandableSizeBuilder (BoxSize s)-    | s >= 2 ^( 28 :: Int) = error "Expandable size >= 2^(28 :: Int)"-    | s >= 2 ^( 21 :: Int) = word8 (fromIntegral (0x80 .|. (s `unsafeShiftR` 21))) <>-          word8 (fromIntegral (0x80 .|. ((s `unsafeShiftR` 14) .&. 0x7F))) <>-          word8 (fromIntegral (0x80 .|. ((s `unsafeShiftR` 7) .&. 0x7F))) <>-          word8 (fromIntegral (s .&. 0x7F))-    | s >= 2 ^( 14 :: Int) = word8 (fromIntegral (0x80 .|. (s `unsafeShiftR` 14))) <>-          word8 (fromIntegral (0x80 .|. ((s `unsafeShiftR` 7) .&. 0x7F))) <>-          word8 (fromIntegral (s .&. 0x7F))-    | s >= 2 ^( 7 :: Int) = word8 (fromIntegral (0x80 .|. (s `unsafeShiftR` 7))) <>-          word8 (fromIntegral (s .&. 0x7F))-    | otherwise = word8 (fromIntegral s)+  | s >= 2 ^ (28 :: Int)+  = error "Expandable size >= 2^(28 :: Int)"+  | s >= 2 ^ (21 :: Int)+  = word8 (fromIntegral (0x80 .|. (s `unsafeShiftR` 21)))+    <> word8 (fromIntegral (0x80 .|. ((s `unsafeShiftR` 14) .&. 0x7F)))+    <> word8 (fromIntegral (0x80 .|. ((s `unsafeShiftR` 7) .&. 0x7F)))+    <> word8 (fromIntegral (s .&. 0x7F))+  | s >= 2 ^ (14 :: Int)+  = word8 (fromIntegral (0x80 .|. (s `unsafeShiftR` 14)))+    <> word8 (fromIntegral (0x80 .|. ((s `unsafeShiftR` 7) .&. 0x7F)))+    <> word8 (fromIntegral (s .&. 0x7F))+  | s >= 2 ^ (7 :: Int)+  = word8 (fromIntegral (0x80 .|. (s `unsafeShiftR` 7)))+    <> word8 (fromIntegral (s .&. 0x7F))+  | otherwise+  = word8 (fromIntegral s)

@@ -1,16 +1,16 @@ {-# LANGUAGE UndecidableInstances #-} module Data.ByteString.Mp4.Boxes.SyncLayerConfigDescriptor where -import Data.ByteString.IsoBaseFileFormat.ReExports-import Data.ByteString.Mp4.Boxes.BaseDescriptor+import           Data.ByteString.IsoBaseFileFormat.ReExports+import           Data.ByteString.Mp4.Boxes.BaseDescriptor -data Mp4SyncLayerDescriptor :: IsA (Descriptor 'SLConfigDescr)+data Mp4SyncLayerDescriptor :: Extends (Descriptor 'SLConfigDescr)  -- | In the holy scripture, ISO-14496-14 section 3.1.2, it is written that there -- shall be restrictions on the elementary stream descriptor, in there it says: -- Thou shall use only __two__ as the value for the __predefined__ field in the -- blessed __SLDescriptor__. Not one, this is a value not big enough, nor three, -- this value is too much. The righteous one ever only uses __two__. Only a fool--- will use __256__.-type instance Eval Mp4SyncLayerDescriptor =+-- will use __257__.+type instance From Mp4SyncLayerDescriptor =   'MkDescriptor ('BitRecordMember ("predefined" @: FieldU8 := 0x02))

@@ -1,22 +1,45 @@ {-# LANGUAGE UndecidableInstances #-}--- | Kind-level utilities to guide and simplify programming at the type level++-- / Utilities to provide better error messages+--+-- When dealing with type level programming in Haskell, especially when involving+-- undecidable instances, one is often confronted with irritating compiler+-- behaviour. This module shall mitigate the problems.+--+-- A group of types that all 'From' into the same type. This+-- is an /open/ and /extensible/ alternative to defining an algebraic data type+-- and using the promoted constructors. 'A' goes hand-in-hand with 'Extends' for+-- better readability.+--+-- For example:+--+-- @+-- data PrettyPrinter c where+--   RenderText :: Symbol -> PrettyPrinter Symbol+--   WithColor :: Color -> PrettyPrinter c -> PrettyPrinter c+--+-- data Color = Black | White+--+-- data ColoredText :: Color -> Symbol -> 'Extends' (PrettyPrinter Symbol)+--+-- type instance 'From' (ColoredText c txt) = 'WithColor c ('RenderText txt)+-- @ module Data.Kind.Extra-  ( type A(..)-  , type IsA-  , type IsAn-  , type Return-  , type Pure-  , type Eval-  , type (:->)-  , type Id+  ( type Extends+  , type Konst+  , (:~:)+  , type From   , type Apply-  , type (^*^)-  , type ($~)+  , Labelled+  , Named+  , Name+  , type (:#)+  , Anonymous+  , type ($)   , type (:>>=:)   , type (:>>>:)   , type (:^>>>:)   , type (:>>>^:)-  , type (:^>>>^:)   , type Extract   , type Optional   , type FoldMap@@ -27,108 +50,84 @@   ) where  import Data.Kind (type Type)+import Data.Type.Equality ((:~:))+import GHC.TypeLits (Symbol) --- * Open Promoted Types+-- | Indicates that a type constructs another.+type Extends a = (a -> Type :: Type) --- | A group of types that all 'Eval' into the same type. This--- is an /open/ and /extensible/ alternative to defining an algebraic data type--- and using the promoted constructors. 'A' goes hand-in-hand with 'IsA' for--- better readability.------ For example:------ @--- data PrettyPrinter c where---   RenderText :: Symbol -> PrettyPrinter Symbol---   WithColor :: Color -> PrettyPrinter c -> PrettyPrinter c------ data Color = Black | White------ data ColoredText :: Color -> Symbol -> 'IsA' (PrettyPrinter Symbol)------ type instance 'Eval' (ColoredText c txt) = 'WithColor c ('RenderText txt)--- @-data A :: forall foo . foo -> Type where-  MkA :: A foo+-- | An open type family to turn /symbolic/ type representations created with+-- 'A' or 'Extends' into the actual types.+type family From (t :: a -> Type) :: a --- | Type alias for 'A' such that @data Point2 x y :: A Vec2 -> Type@ becomes--- @data Point2 x y :: IsA Vec2@-type IsA (foo :: k) = (A foo -> Type :: Type)+-- | A @Konst a@, @'Extends' a@.+type Konst (a :: k) = ((:~:) a :: Extends k)+type instance From ((:~:) a) = a --- | An alias to 'IsA'-type IsAn (oo :: k) = (IsA oo :: Type)+-- | Phantom type for things that have a name+data Named s --- | An open type family to turn /symbolic/ type representations created with--- 'A' or 'IsA' into the actual types.-type family Eval (t :: A foo -> Type) :: foo+-- | Assign a name to something that has no name+data Name :: Symbol -> Extends s -> Extends (Named s) --- | A type @foo@, @'IsA' foo@.-data Pure (f :: o) :: IsAn o-type instance Eval (Pure f) = f-type Return f = Pure f+-- | Alias for 'Name'+type (name :: Symbol) :# (x :: Extends s) = Name name x --- | A symbolic type-level function.-data (:->) foo bar+infixr 7 :# --- | An open family of functions from @foo@ to @bar@-type family (f :: IsA (foo :-> bar)) $~ (x :: foo) :: bar-infixl 0 $~+-- | Remove tha name of a 'NamedStructure' to get to a 'Structure'+data Anonymous (x :: Extends (Named s)) :: Extends s --- | An alias for '$~'-type Apply f x = f $~ x+-- | Assign a symbol to any type in a group.+data Labelled (s :: Symbol) :: Extends a -> Extends a --- | Identity-data Id :: IsA (foo :-> foo)-type instance Id $~ x = x+type instance From (Labelled s t) = From t --- | Symbolic function application-type (^*^) (f :: IsA (foo :-> bar)) (x :: IsA foo) = f $~ (Eval x)-infixl 0 ^*^+-- | An open family of functions from @a@ to @b@+type family Apply (f :: Extends (a -> b)) (x :: a) :: b +-- | An alias for 'Apply'+type f $ x = Apply f x+ -- | Compose functions-data (:>>>:) :: IsA (good :-> better) -> IsA (better :-> best) -> IsA (good :-> best)+data (:>>>:) :: Extends (good -> better) -> Extends (better -> best) -> Extends (good -> best) infixl 1 :>>>:-type instance (f :>>>: g) $~ x = g $~ (f $~ x)+type instance Apply (f :>>>: g) x = g $ (f $ x) --- | Eval Input & Compose-data (:^>>>:) :: IsA (good :-> better) -> IsA (better :-> best) -> IsA (IsA good :-> best)+-- | From Input & Compose+data (:^>>>:) :: Extends (good -> better) -> Extends (better -> best) -> Extends (Extends good -> best) infixl 1 :^>>>:-type instance (f :^>>>: g) $~ x = g $~ (f $~ Eval x)+type instance Apply (f :^>>>: g) x = g $ (f $ From x) --- | Compose and 'Return'-data (:>>>^:) :: IsA (good :-> better) -> IsA (better :-> best) -> IsA (good :-> IsA best)+-- | Compose and 'Konst'+data (:>>>^:) :: Extends (good -> better) -> Extends (better -> best) -> Extends (good -> Extends best) infixl 1 :>>>^:-type instance (f :>>>^: g) $~ x = Return (g $~ (f $~ x))---- | Eval compose and return-data (:^>>>^:) :: IsA (good :-> better) -> IsA (better :-> best) -> IsA (IsA good :-> IsA best)-infixl 1 :^>>>^:-type instance (f :^>>>^: g) $~ x = Return (g $~ (f $~ Eval x))+type instance Apply (f :>>>^: g) x = Konst (g $ (f $ x)) --- | A function that applies 'Eval'-data Extract :: IsA (IsA x :-> x)-type instance Extract $~ x = Eval x+-- | A function that applies 'From'+data Extract :: Extends (Extends x -> x)+type instance Apply Extract x = From x --- | Eval and ApplyCompose functions-data (:>>=:) :: IsA foo -> IsA (foo :-> IsA bar) -> IsA bar+-- | From and ApplyCompose functions+data (:>>=:) :: Extends a -> Extends (a -> Extends b) -> Extends b infixl 1 :>>=:-type instance Eval (x :>>=: f) = Eval (f $~ Eval x)+type instance From (x :>>=: f) = From (f $ From x)  -- | Either use the value from @Just@ or return a fallback value(types(kinds))-data Optional :: IsA t -> IsA (s :-> IsA t) -> IsA (Maybe s :-> IsA t)+data Optional :: Extends t -> Extends (s -> Extends t) -> Extends (Maybe s -> Extends t) -type instance (Optional fallback f) $~ ('Just s) = f $~ s-type instance (Optional fallback f) $~ 'Nothing = fallback+type instance Apply (Optional fallback f) ('Just s) = f $ s+type instance Apply (Optional fallback f) 'Nothing = fallback  -- | Map over the elements of a list and fold the result. type family   FoldMap-          (append :: IsA (bar :-> IsA (bar :-> bar)))-          (zero :: bar)-          (f :: IsA (foo :-> bar))-          (xs :: [(foo :: Type)]) :: (bar :: Type) where+          (append :: Extends (b -> Extends (b -> b)))+          (zero :: b)+          (f :: Extends (a -> b))+          (xs :: [(a :: Type)]) :: (b :: Type) where   FoldMap append zero f '[]       = zero-  FoldMap append zero f (x ': xs) = append $~ (f $~ x) $~ FoldMap append zero f xs+  FoldMap append zero f (x ': xs) = append $ (f $ x) $ FoldMap append zero f xs  --  TODONT safe coercions (with undecidable instances) could be done only with a --  type-level equivilant of a type class dictionary, A good place for that@@ -137,18 +136,18 @@ --  missing.  -- | Like @TyCon1@ from Data.Singletons-data Fun1 :: (a -> IsA b)-            -> IsA (a :-> IsA b)-type instance (Fun1 f) $~ x = (f x)+data Fun1 :: (a -> Extends b)+            -> Extends (a -> Extends b)+type instance Apply (Fun1 f) x = (f x) -data Fun2 :: (a -> b -> IsA c)-            -> IsA (a :-> IsA (b :-> IsA c))-type instance (Fun2 f) $~ x = Fun1 (f x)+data Fun2 :: (a -> b -> Extends c)+            -> Extends (a -> Extends (b -> Extends c))+type instance Apply (Fun2 f) x = Fun1 (f x) -data Fun3 :: (a -> b -> c -> IsA d)-            -> IsA (a :-> IsA (b :-> IsA (c :-> IsA d)))-type instance (Fun3 f) $~ x = Fun2 (f x)+data Fun3 :: (a -> b -> c -> Extends d)+            -> Extends (a -> Extends (b -> Extends (c -> Extends d)))+type instance Apply (Fun3 f) x = Fun2 (f x) -data Fun4 :: (a -> b -> c -> d -> IsAn e)-            -> IsA (a :-> IsA (b :-> IsA (c :-> IsA (d :-> IsAn e))))-type instance (Fun4 f) $~ x = Fun3 (f x)+data Fun4 :: (a -> b -> c -> d -> Extends e)+            -> Extends (a -> Extends (b -> Extends (c -> Extends (d -> Extends e))))+type instance Apply (Fun4 f) x = Fun3 (f x)

@@ -1,7 +1,7 @@ module Data.Type.BitRecords   ( module Data.Type.BitRecords.Arithmetic   , module Data.Type.BitRecords.Assert-  , module Data.Type.BitRecords.Builder.BitBuffer+  , module Data.Type.BitRecords.BitBuffer64   , module Data.FunctionBuilder   , module Data.Type.BitRecords.Builder.LazyByteStringBuilder   , module Data.Type.BitRecords.Core@@ -13,7 +13,7 @@  import           Data.Type.BitRecords.Arithmetic import           Data.Type.BitRecords.Assert-import           Data.Type.BitRecords.Builder.BitBuffer+import           Data.Type.BitRecords.BitBuffer64 import           Data.FunctionBuilder import           Data.Type.BitRecords.Builder.LazyByteStringBuilder import           Data.Type.BitRecords.Core

@@ -0,0 +1,124 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+module Data.Type.BitRecords.BitBuffer64+    ( type BitBuffer64MaxLength+    , bitBuffer64MaxLength+    , bitBuffer64MaxLengthBytes+    , BitBuffer64()+    , bitBuffer64Content+    , bitBuffer64Length+    , isBitBuffer64Empty+    , bitBuffer64SpaceLeft+    , bitBuffer64+    , emptyBitBuffer64+    , bitBuffer64ProxyLength+    , bufferBits+    , type KnownChunkSize+    ) where++import           Data.Proxy+import           Data.Bits+import           Data.Word+import           Data.Kind ( Constraint )+import           GHC.TypeLits++-- | The maximum number of bits a 'BitBuffer' can hold.+type BitBuffer64MaxLength = 64++-- | The maximum number of bits a 'BitBuffer' can hold.+bitBuffer64MaxLength :: Int+bitBuffer64MaxLength = 64 -- fromInteger (natVal (Proxy :: Proxy BitBuffer64MaxLength))++-- | The maximum number of bytes a 'BitBuffer' can hold.+bitBuffer64MaxLengthBytes :: Word64+bitBuffer64MaxLengthBytes = 8++-- | A buffer for 64 bits, such that the bits are written MSB to LSB.+--+-- > type TwoFields = "f0" @: Field m .+. "f1" @: Field n+--+-- Writes:+-- @       MSB                                             LSB+--    Bit: |k  ..  k-(m+1)|k-m  ..  k-(m+n+1)|k-(m+n)  ..  0|+--  Value: |------f0------|--------f1--------|XXXXXXXXXXXXXX|+-- @+--+-- Where @k@ is the current bit offset.+-- The input values are expected to be in the order of the fields, i.e.:+--+-- @+-- toFunction $ bitBuffer64Builder (Proxy :: Proxy TwoFields) 1 2+-- @+--+-- Will result in:+-- @       MSB                                             LSB+--    Bit: |k  ..  k-(m+1)|k-m  ..  k-(m+n+1)| k-(m+n)  ..  0|+--  Value: |0     ..     1|0       ..      10| X    ..      X|+-- @+--+-- The string of bits with a given length (but always @<= 'bitBuffer64MaxLength'@.+-- The number of bits must be smaller that 'bitBuffer64MaxLength'.+data BitBuffer64 = BitBuffer64 !Word64 !Int++bitBuffer64Content :: BitBuffer64 -> Word64+bitBuffer64Content (BitBuffer64 !c _) =+    c++bitBuffer64Length :: BitBuffer64 -> Int+bitBuffer64Length (BitBuffer64 _ !len) =+    len++isBitBuffer64Empty :: BitBuffer64 -> Bool+isBitBuffer64Empty (BitBuffer64 _ !len) =+    len == 0++bitBuffer64SpaceLeft :: BitBuffer64 -> Int+bitBuffer64SpaceLeft (BitBuffer64 _ !len) =+    bitBuffer64MaxLength - len++-- | Create a 'BitBuffer64' containing @len@ bits from LSB to MSB, properly+-- masked, such that only @len@ least significant bits are kept..+bitBuffer64 :: Int -> Word64 -> BitBuffer64+bitBuffer64 !len !b =+    BitBuffer64 (let !s = bitBuffer64MaxLength - len in ((b `unsafeShiftL` s) `unsafeShiftR` s)) len++-- | Create an empty 'BitBuffer64'.+emptyBitBuffer64 :: BitBuffer64+emptyBitBuffer64 = BitBuffer64 0 0++-- | Create a 'BitBuffer64' with a length given by a 'Proxy' to a type level+-- 'Nat'.+bitBuffer64ProxyLength :: (KnownChunkSize n) => Proxy n -> Word64 -> BitBuffer64+bitBuffer64ProxyLength !plen !v = bitBuffer64 fieldLen v+    where+      !fieldLen = fromIntegral (natVal plen)+++-- | Copy bits starting at a specific offset from one @a@ the the other.+-- Set bits starting from the most significant bit to the least.+--   For example @writeBits m 1 <> writeBits n 2@ would result in:+--+-- @+--         MSB                                             LSB+--    Bit: |k  ..  k-(m+1)|k-m  ..  k-(m+n+1)| k-(m+n)  ..  0|+--  Value: |0     ..     1|0        ..     10|  ...          |+--          ->             ->                 ->     (direction of writing)+-- @+--+bufferBits :: BitBuffer64 -- ^ The value to write (in the lower @length@ bits).+           -> BitBuffer64 -- ^ The input to write to (starting from length)+           -> (BitBuffer64, BitBuffer64) -- ^ The remaining bits that did not fit+                                         -- in the buffer and the output buffer.+bufferBits (BitBuffer64 !bits !len) (BitBuffer64 !buff !offset) =+    let !spaceAvailable = bitBuffer64MaxLength - offset+        !writeLen = min spaceAvailable len+        !writeOffset = spaceAvailable - writeLen+        !restLen = len - writeLen+        !restBits = bits .&. (1 `unsafeShiftL` restLen - 1)+        !buff' = buff .|.+            (bits `unsafeShiftR` restLen `unsafeShiftL` writeOffset)+    in+        (BitBuffer64 restBits restLen, BitBuffer64 buff' (offset + writeLen))++type family KnownChunkSize (s :: Nat) :: Constraint where+        KnownChunkSize size = (KnownNat size, size <= BitBuffer64MaxLength)

@@ -1,161 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-module Data.Type.BitRecords.Builder.BitBuffer-    ( type BitStringMaxLength-    , type ModuloBitStringMaxLength-    , bitStringMaxLength-    , bitStringMaxLengthBytes-    , BitString()-    , bitStringContent-    , bitStringLength-    , isBitStringEmpty-    , bitStringSpaceLeft-    , bitString-    , emptyBitString-    , bitStringProxyLength-    , BitStringBuilderChunk()-    , bitStringBuilderChunkContent-    , bitStringBuilderChunkLength-    , isBitStringBuilderChunkEmpty-    , bitStringBuilderChunkSpaceLeft-    , bitStringBuilderChunk-    , emptyBitStringBuilderChunk-    , bufferBits-    , type KnownChunkSize-    ) where--import           Data.Proxy-import           Data.Bits-import           Data.Word-import           Data.Kind ( Constraint )-import           GHC.TypeLits---- | The maximum number of bits a 'BitBuffer' can hold.-type BitStringMaxLength = 64---- | Calculate the modulus of a number and the 'BitStringMaxLength'.-type family ModuloBitStringMaxLength (len :: Nat) :: Nat where-        ModuloBitStringMaxLength len = len `Mod` BitStringMaxLength---- | The maximum number of bits a 'BitBuffer' can hold.-bitStringMaxLength :: Num a => a-bitStringMaxLength = 64---- | The maximum number of bytes a 'BitBuffer' can hold.-bitStringMaxLengthBytes :: Word64-bitStringMaxLengthBytes = 8---- | A string of bits with a given length (but always @<= 'bitStringMaxLength'@.--- The number of bits must be smaller that 'bitStringMaxLength'.-data BitString = BitString !Word64 !Int--bitStringContent :: BitString -> Word64-bitStringContent (BitString !c _) =-    c--bitStringLength :: BitString -> Int-bitStringLength (BitString _ !len) =-    len--isBitStringEmpty :: BitString -> Bool-isBitStringEmpty (BitString _ !len) =-    len == 0--bitStringSpaceLeft :: BitString -> Int-bitStringSpaceLeft (BitString _ !len) =-    bitStringMaxLength - len---- | Create a 'BitString' containing @len@ bits from LSB to MSB, properly--- masked, such that only @len@ least significant bits are kept..-bitString :: Int -> Word64 -> BitString-bitString !len !b = BitString (let !s = bitStringMaxLength - len in ((b `unsafeShiftL` s) `unsafeShiftR` s)) len---- | Create an empty 'BitString'.-emptyBitString :: BitString-emptyBitString = BitString 0 0---- | A buffer for 64 bits, such that the bits are written MSB to LSB.------ > type TwoFields = "f0" @: Field m .+. "f1" @: Field n------ Writes:--- @       MSB                                             LSB---    Bit: |k  ..  k-(m+1)|k-m  ..  k-(m+n+1)|k-(m+n)  ..  0|---  Value: |------f0------|--------f1--------|XXXXXXXXXXXXXX|--- @------ Where @k@ is the current bit offset.--- The input values are expected to be in the order of the fields, i.e.:------ @--- toFunction $ bitStringBuilderHoley (Proxy :: Proxy TwoFields) 1 2--- @------ Will result in:--- @       MSB                                             LSB---    Bit: |k  ..  k-(m+1)|k-m  ..  k-(m+n+1)| k-(m+n)  ..  0|---  Value: |0     ..     1|0       ..      10| X    ..      X|--- @-data BitStringBuilderChunk = BitStringBuilderChunk !Word64 !Int--bitStringBuilderChunkContent :: BitStringBuilderChunk -> Word64-bitStringBuilderChunkContent (BitStringBuilderChunk !c _) =-    c--bitStringBuilderChunkLength :: BitStringBuilderChunk -> Int-bitStringBuilderChunkLength (BitStringBuilderChunk _ !len) =-    len--isBitStringBuilderChunkEmpty :: BitStringBuilderChunk -> Bool-isBitStringBuilderChunkEmpty (BitStringBuilderChunk _ !len) =-    len == 0--bitStringBuilderChunkSpaceLeft :: BitStringBuilderChunk -> Int-bitStringBuilderChunkSpaceLeft (BitStringBuilderChunk _ !len) =-    bitStringMaxLength - len---- | Create a 'BitStringBuilderChunk' containing @len@ bits from LSB to MSB, properly--- masked, such that only @len@ least significant bits are kept..-bitStringBuilderChunk :: Word64 -> Int -> BitStringBuilderChunk-bitStringBuilderChunk !b !len = BitStringBuilderChunk b len---- | Create an empty 'BitStringBuilderChunk'.-emptyBitStringBuilderChunk :: BitStringBuilderChunk-emptyBitStringBuilderChunk = BitStringBuilderChunk 0 0---- | Create a 'BitStringBuilderChunk' with a length given by a 'Proxy' to a type level--- 'Nat'.-bitStringProxyLength :: (KnownChunkSize n) => Proxy n -> Word64 -> BitString-bitStringProxyLength !plen !v = bitString fieldLen v-    where-      !fieldLen = fromIntegral (natVal plen)----- | Copy bits starting at a specific offset from one @a@ the the other.--- Set bits starting from the most significant bit to the least.---   For example @writeBits m 1 <> writeBits n 2@ would result in:------ @---         MSB                                             LSB---    Bit: |k  ..  k-(m+1)|k-m  ..  k-(m+n+1)| k-(m+n)  ..  0|---  Value: |0     ..     1|0        ..     10|  ...          |---          ->             ->                 ->     (direction of writing)--- @----bufferBits :: BitString -- ^ The value to write (in the lower @length@ bits).-           -> BitStringBuilderChunk -- ^ The input to write to-           -> (BitString, BitStringBuilderChunk) -- ^ The remaining bits that did not fit-                                        -- in the buffer and the output buffer.-bufferBits (BitString !bits !len) (BitStringBuilderChunk !buff !offset) =-    let !spaceAvailable = bitStringMaxLength - offset-        !writeLen = min spaceAvailable len-        !writeOffset = spaceAvailable - writeLen-        !restLen = len - writeLen-        !restBits = bits .&. (1 `unsafeShiftL` restLen - 1)-        !buff' = buff .|.-            (bits `unsafeShiftR` restLen `unsafeShiftL` writeOffset)-    in-        (BitString restBits restLen, BitStringBuilderChunk buff' (offset + writeLen))--type family KnownChunkSize (s :: Nat) :: Constraint where-        KnownChunkSize size = (KnownNat size, size <= BitStringMaxLength)

@@ -1,9 +1,11 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints  #-} module Data.Type.BitRecords.Builder.LazyByteStringBuilder where -import Data.Type.BitRecords.Builder.BitBuffer+import Data.Type.BitRecords.BitBuffer64 import Data.FunctionBuilder import Data.Type.BitRecords.Core import Data.Word@@ -19,86 +21,86 @@ import qualified Data.ByteString.Lazy as B import qualified Data.ByteString as SB import Text.Printf+import Type.Reflection --- | A wrapper around a builder derived from a 'BitStringBuilderState'-data BuilderBox where-  MkBuilderBox :: !Word64 -> !SB.Builder -> BuilderBox+-- | A wrapper around a builder derived from a 'BitBuilderState'+data BuilderWithSize where+  MkBuilderWithSize :: !Word64 -> !SB.Builder -> BuilderWithSize -instance Semigroup BuilderBox where-  (MkBuilderBox !ls !lb) <> (MkBuilderBox !rs !rb) =-    MkBuilderBox (ls + rs) (lb <> rb)+instance Semigroup BuilderWithSize where+  (MkBuilderWithSize !ls !lb) <> (MkBuilderWithSize !rs !rb) =+    MkBuilderWithSize (ls + rs) (lb <> rb) -instance Monoid BuilderBox where-  mempty = MkBuilderBox 0 mempty+instance Monoid BuilderWithSize where+  mempty = MkBuilderWithSize 0 mempty --- | Create a 'SB.Builder' from a 'BitRecord' and store it in a 'BuilderBox'-bitBuilderBox ::-  forall (record :: BitRecord) .-  BitStringBuilderHoley (Proxy record) BuilderBox+-- | Create a 'SB.Builder' from a 'BitRecord' and store it in a 'BuilderWithSize'+bitBuilderWithSize ::+  forall (record :: BitRecord) . HasFunctionBuilder BitBuilder (Proxy record)   =>  Proxy record-  -> ToBitStringBuilder (Proxy record) BuilderBox-bitBuilderBox = toFunction . bitBuilderBoxHoley+  -> ToFunction BitBuilder (Proxy record) BuilderWithSize+bitBuilderWithSize = toFunction . builderBoxConstructor --- | Like 'bitBuilderBox', but 'toFunction' the result and accept as an additional--- parameter a wrapper function to wrap the final result (the 'BuilderBox') and+-- | Like 'bitBuilderWithSize', but 'toFunction' the result and accept as an additional+-- parameter a wrapper function to wrap the final result (the 'BuilderWithSize') and -- 'toFunction' the whole machiner.-wrapBitBuilderBox ::+wrapBitBuilderWithSize ::   forall (record :: BitRecord) wrapped .-    BitStringBuilderHoley (Proxy record) wrapped-  => (BuilderBox -> wrapped)+    HasFunctionBuilder BitBuilder (Proxy record)+  => (BuilderWithSize -> wrapped)   -> Proxy record-  -> ToBitStringBuilder (Proxy record) wrapped-wrapBitBuilderBox !f !p = toFunction (mapAccumulator f (bitBuilderBoxHoley p))+  -> ToFunction BitBuilder (Proxy record) wrapped+wrapBitBuilderWithSize !f !p = toFunction (mapAccumulator f (builderBoxConstructor p)) --- | Create a 'SB.Builder' from a 'BitRecord' and store it in a 'BuilderBox';+-- | Create a 'SB.Builder' from a 'BitRecord' and store it in a 'BuilderWithSize'; -- return a 'FunctionBuilder' monoid that does that on 'toFunction'-bitBuilderBoxHoley ::+builderBoxConstructor ::   forall (record :: BitRecord) r .-  BitStringBuilderHoley (Proxy record) r+  HasFunctionBuilder BitBuilder (Proxy record)   =>  Proxy record-  -> FunctionBuilder BuilderBox r (ToBitStringBuilder (Proxy record) r)-bitBuilderBoxHoley !p =-  let fromBitStringBuilder !h =-        let (BitStringBuilderState !builder _ !wsize) =-              flushBitStringBuilder-              $ appBitStringBuilder h initialBitStringBuilderState-            !out = MkBuilderBox wsize builder+  -> FunctionBuilder BuilderWithSize r (ToFunction BitBuilder (Proxy record) r)+builderBoxConstructor !p =+  let fromBitBuilder !h =+        let (BitBuilderState !builder _ !wsize) =+              flushBitBuilder+              $ appBitBuilder h initialBitBuilderState+            !out = MkBuilderWithSize wsize builder         in out-  in mapAccumulator fromBitStringBuilder (bitStringBuilderHoley p)+  in mapAccumulator fromBitBuilder (toFunctionBuilder p)  -- * Low-level interface to building 'BitRecord's and other things -newtype BitStringBuilder =-  BitStringBuilder {unBitStringBuilder :: Dual (Endo BitStringBuilderState)}+newtype BitBuilder =+  BitBuilder {unBitBuilder :: Dual (Endo BitBuilderState)}   deriving (Monoid, Semigroup) -runBitStringBuilder-  :: BitStringBuilder -> SB.Builder-runBitStringBuilder !w =-  getBitStringBuilderStateBuilder $-  flushBitStringBuilder $ appBitStringBuilder w initialBitStringBuilderState+runBitBuilder+  :: BitBuilder -> SB.Builder+runBitBuilder !w =+  getBitBuilderStateBuilder $+  flushBitBuilder $ appBitBuilder w initialBitBuilderState -bitStringBuilder :: (BitStringBuilderState -> BitStringBuilderState)-                 -> BitStringBuilder-bitStringBuilder = BitStringBuilder . Dual . Endo+bitBuffer64Builder :: (BitBuilderState -> BitBuilderState)+                 -> BitBuilder+bitBuffer64Builder = BitBuilder . Dual . Endo -appBitStringBuilder :: BitStringBuilder-                    -> BitStringBuilderState-                    -> BitStringBuilderState-appBitStringBuilder !w = appEndo (getDual (unBitStringBuilder w))+appBitBuilder :: BitBuilder+                    -> BitBuilderState+                    -> BitBuilderState+appBitBuilder !w = appEndo (getDual (unBitBuilder w)) -data BitStringBuilderState where-        BitStringBuilderState ::-          !SB.Builder -> !BitStringBuilderChunk -> !Word64 -> BitStringBuilderState+data BitBuilderState where+        BitBuilderState ::+          !SB.Builder -> !BitBuffer64 -> !Word64 -> BitBuilderState -getBitStringBuilderStateBuilder-  :: BitStringBuilderState -> SB.Builder-getBitStringBuilderStateBuilder (BitStringBuilderState !builder _ _) = builder+getBitBuilderStateBuilder+  :: BitBuilderState -> SB.Builder+getBitBuilderStateBuilder (BitBuilderState !builder _ _) = builder -initialBitStringBuilderState-  :: BitStringBuilderState-initialBitStringBuilderState =-  BitStringBuilderState mempty emptyBitStringBuilderChunk 0+initialBitBuilderState+  :: BitBuilderState+initialBitBuilderState =+  BitBuilderState mempty emptyBitBuffer64 0  -- | Write the partial buffer contents using any number of 'word8' The unwritten --   parts of the bittr buffer are at the top.  If the@@ -107,16 +109,16 @@ -- >     ^^^^^^^^^^^^^^^^^^^ -- > Relevant bits start to the top! ---flushBitStringBuilder-  :: BitStringBuilderState -> BitStringBuilderState-flushBitStringBuilder (BitStringBuilderState !bldr !buff !totalSize) =-  BitStringBuilderState (writeRestBytes bldr 0)-                        emptyBitStringBuilderChunk+flushBitBuilder+  :: BitBuilderState -> BitBuilderState+flushBitBuilder (BitBuilderState !bldr !buff !totalSize) =+  BitBuilderState (writeRestBytes bldr 0)+                        emptyBitBuffer64                         totalSize'-  where !off = bitStringBuilderChunkLength buff+  where !off = bitBuffer64Length buff         !off_ = (fromIntegral off :: Word64)         !totalSize' = totalSize + signum (off_ `rem` 8) + (off_ `div` 8)-        !part = bitStringBuilderChunkContent buff+        !part = bitBuffer64Content buff         -- write bytes from msb to lsb until the offset is reached         -- >  63  ...  (63-off-1)(63-off)  ...  0         -- >  ^^^^^^^^^^^^^^^^^^^@@ -130,47 +132,40 @@                         bldr' <>                         SB.word8 (fromIntegral                                  ((part `unsafeShiftR`-                                   (bitStringMaxLength - flushOffset')) .&.+                                   (bitBuffer64MaxLength - flushOffset')) .&.                                   0xFF))                   in writeRestBytes bldr'' flushOffset' --- | Write all the bits, in chunks, filling and writing the 'BitString'--- in the 'BitStringBuilderState' as often as necessary.-appendBitString :: BitString -> BitStringBuilder-appendBitString !x' =-  bitStringBuilder $-  \(BitStringBuilderState !builder !buff !totalSizeIn) -> go x' builder buff totalSizeIn+-- | Write all the bits, in chunks, filling and writing the 'BitBuffer64'+-- in the 'BitBuilderState' as often as necessary.+appendBitBuffer64 :: BitBuffer64 -> BitBuilder+appendBitBuffer64 !x' =+  bitBuffer64Builder $+  \(BitBuilderState !builder !buff !totalSizeIn) -> go x' builder buff totalSizeIn   where go !x !builder !buff !totalSize-          | bitStringLength x == 0 = BitStringBuilderState builder buff totalSize+          | bitBuffer64Length x == 0 = BitBuilderState builder buff totalSize           | otherwise =             let (!rest, !buff') = bufferBits x buff-            in if bitStringBuilderChunkSpaceLeft buff' > 0-                  then BitStringBuilderState builder buff' totalSize+            in if bitBuffer64SpaceLeft buff' > 0+                  then BitBuilderState builder buff' totalSize                   else let !nextBuilder =                              builder <>-                             SB.word64BE (bitStringBuilderChunkContent buff')-                           !totalSize' = totalSize + bitStringMaxLengthBytes-                       in go rest nextBuilder emptyBitStringBuilderChunk totalSize'+                             SB.word64BE (bitBuffer64Content buff')+                           !totalSize' = totalSize + bitBuffer64MaxLengthBytes+                       in go rest nextBuilder emptyBitBuffer64 totalSize' --- | Write all the b*y*tes, into the 'BitStringBuilderState' this allows general+-- | Write all the b*y*tes, into the 'BitBuilderState' this allows general -- purposes non-byte aligned builders.-appendStrictByteString :: SB.ByteString -> BitStringBuilder+appendStrictByteString :: SB.ByteString -> BitBuilder appendStrictByteString !sb =-  foldMap (appendBitString . bitString 8 . fromIntegral) (SB.unpack sb)--runBitStringBuilderHoley-  :: FunctionBuilder BitStringBuilder SB.Builder a -> a-runBitStringBuilderHoley (FB !x) = x runBitStringBuilder---- * 'BitString' construction from 'BitRecord's+  foldMap (appendBitBuffer64 . bitBuffer64 8 . fromIntegral) (SB.unpack sb) -class BitStringBuilderHoley a r where-  type ToBitStringBuilder a r-  type ToBitStringBuilder a r = r-  bitStringBuilderHoley :: a -> FunctionBuilder BitStringBuilder r (ToBitStringBuilder a r)+runBitBuilderHoley+  :: FunctionBuilder BitBuilder SB.Builder a -> a+runBitBuilderHoley (FB !x) = x runBitBuilder -instance BitStringBuilderHoley BitString r where-  bitStringBuilderHoley = immediate . appendBitString+instance HasFunctionBuilder BitBuilder BitBuffer64 where+  toFunctionBuilder = immediate . appendBitBuffer64  -- ** 'BitRecordField' instances @@ -180,125 +175,270 @@   UnsignedDemoteRep Int32 = Word32   UnsignedDemoteRep Int64 = Word64 --- *** Labbeled Fields+-- *** BitFields  instance-  forall nested l a .-   ( BitStringBuilderHoley (Proxy nested) a )-  => BitStringBuilderHoley (Proxy (LabelF l nested)) a where-  type ToBitStringBuilder (Proxy (LabelF l nested)) a =-    ToBitStringBuilder (Proxy nested) a-  bitStringBuilderHoley _ = bitStringBuilderHoley (Proxy @nested)+  forall (nested :: BitField rt st s)  .+   ( HasFunctionBuilder BitBuilder (Proxy nested) )+  => HasFunctionBuilder BitBuilder (Proxy (Konst nested)) where+  type ToFunction BitBuilder (Proxy (Konst nested)) a =+    ToFunction BitBuilder (Proxy nested) a+  toFunctionBuilder _ = toFunctionBuilder (Proxy @nested) --- **** Bool -instance forall f a . (BitRecordFieldSize f ~ 1) =>-  BitStringBuilderHoley (Proxy (f := 'True)) a where-  bitStringBuilderHoley _ = immediate (appendBitString (bitString 1 1))+instance+  forall rt (nested :: BitField rt st s) .+   ( DynamicContent BitBuilder (Proxy nested) rt )+  => DynamicContent BitBuilder (Proxy (Konst nested)) rt where+  addParameter _ = addParameter (Proxy @nested) -instance forall f a . (BitRecordFieldSize f ~ 1) =>-  BitStringBuilderHoley (Proxy (f := 'False)) a where-  bitStringBuilderHoley _ = immediate (appendBitString (bitString 1 0))+-- -- *** Labbeled Fields -instance forall a .-  BitStringBuilderHoley (Proxy (MkField 'MkFieldFlag)) a where-  type ToBitStringBuilder (Proxy (MkField 'MkFieldFlag)) a = Bool -> a-  bitStringBuilderHoley _ =-    addParameter (appendBitString . bitString 1 . (\ !t -> if t then 1 else 0))+instance+  forall nested l .+   ( HasFunctionBuilder BitBuilder (Proxy nested) )+  => HasFunctionBuilder BitBuilder (Proxy (LabelF l nested)) where+  type ToFunction BitBuilder (Proxy (LabelF l nested)) a =+    ToFunction BitBuilder (Proxy nested) a+  toFunctionBuilder _ = toFunctionBuilder (Proxy @nested) --- **** Bits+instance ( DynamicContent BitBuilder (Proxy nested) b )+  => DynamicContent BitBuilder (Proxy (LabelF l nested)) b where+  addParameter _ = addParameter (Proxy @nested) -instance forall (s :: Nat) a . (KnownChunkSize s) =>-  BitStringBuilderHoley (Proxy (MkField ('MkFieldBits :: BitField (B s) Nat s))) a where-  type ToBitStringBuilder (Proxy (MkField ('MkFieldBits :: BitField (B s) Nat s))) a = B s -> a-  bitStringBuilderHoley _ = addParameter (appendBitString . bitStringProxyLength (Proxy @s) . unB)+instance+  forall (nested :: Extends (BitField rt st s)) l .+   ( HasFunctionBuilder BitBuilder (Proxy nested) )+  => HasFunctionBuilder BitBuilder (Proxy (Labelled l nested)) where+  type ToFunction BitBuilder (Proxy (Labelled l nested)) a =+    ToFunction BitBuilder (Proxy nested) a+  toFunctionBuilder _ = toFunctionBuilder (Proxy @nested) --- **** Naturals+instance+  forall rt st s (nested :: Extends (BitField rt st s)) (l :: Symbol) out .+   ( DynamicContent BitBuilder (Proxy nested) rt )+  => DynamicContent BitBuilder (Proxy (Labelled l nested)) rt where+  addParameter _ = addParameter (Proxy @nested) -instance forall a .-  BitStringBuilderHoley (Proxy (MkField 'MkFieldU64)) a where-  type ToBitStringBuilder (Proxy (MkField 'MkFieldU64)) a = Word64 -> a-  bitStringBuilderHoley _ = addParameter (appendBitString . bitString 64)+-- -- **** Bool -instance forall a .-  BitStringBuilderHoley (Proxy (MkField 'MkFieldU32)) a where-  type ToBitStringBuilder (Proxy (MkField 'MkFieldU32)) a = Word32 -> a-  bitStringBuilderHoley _ = addParameter (appendBitString . bitString 32 . fromIntegral)+instance forall f . (FieldWidth f ~ 1) =>+  HasFunctionBuilder BitBuilder (Proxy (f := 'True)) where+  toFunctionBuilder _ = immediate (appendBitBuffer64 (bitBuffer64 1 1)) -instance forall a .-  BitStringBuilderHoley (Proxy (MkField 'MkFieldU16)) a where-  type ToBitStringBuilder (Proxy (MkField 'MkFieldU16)) a = Word16 -> a-  bitStringBuilderHoley _ = addParameter (appendBitString . bitString 16 . fromIntegral)+instance forall f . (FieldWidth f ~ 1) =>+  HasFunctionBuilder BitBuilder (Proxy (f := 'False)) where+  toFunctionBuilder _ = immediate (appendBitBuffer64 (bitBuffer64 1 0)) -instance forall a .-  BitStringBuilderHoley (Proxy (MkField 'MkFieldU8)) a where-  type ToBitStringBuilder (Proxy (MkField 'MkFieldU8)) a = Word8 -> a-  bitStringBuilderHoley _ = addParameter (appendBitString . bitString 8 . fromIntegral)+instance HasFunctionBuilder BitBuilder (Proxy (MkField 'MkFieldFlag)) where+  type ToFunction BitBuilder (Proxy (MkField 'MkFieldFlag)) a = Bool -> a+  toFunctionBuilder _ =+    deferred (appendBitBuffer64 . bitBuffer64 1 . (\ !t -> if t then 1 else 0)) --- **** Signed+-- -- new: -instance forall a .-  BitStringBuilderHoley (Proxy (MkField 'MkFieldI64)) a where-  type ToBitStringBuilder (Proxy (MkField 'MkFieldI64)) a = Int64 -> a-  bitStringBuilderHoley _ = addParameter (appendBitString . bitString 64 . fromIntegral @Int64 @Word64)+instance forall f . (BitFieldSize (From f) ~ 1) =>+  HasFunctionBuilder BitBuilder (Proxy (f :=. 'True)) where+  toFunctionBuilder _ = immediate (appendBitBuffer64 (bitBuffer64 1 1)) -instance forall a .-  BitStringBuilderHoley (Proxy (MkField 'MkFieldI32)) a where-  type ToBitStringBuilder (Proxy (MkField 'MkFieldI32)) a = Int32 -> a-  bitStringBuilderHoley _ = addParameter (appendBitString . bitString 32 . fromIntegral . fromIntegral @Int32 @Word32)+instance forall f . (BitFieldSize (From f) ~ 1) =>+  HasFunctionBuilder BitBuilder (Proxy (f :=. 'False)) where+  toFunctionBuilder _ = immediate (appendBitBuffer64 (bitBuffer64 1 0)) -instance forall a .-  BitStringBuilderHoley (Proxy (MkField 'MkFieldI16)) a where-  type ToBitStringBuilder (Proxy (MkField 'MkFieldI16)) a = Int16 -> a-  bitStringBuilderHoley _ = addParameter (appendBitString . bitString 16 . fromIntegral . fromIntegral @Int16 @Word16)+instance HasFunctionBuilder BitBuilder (Proxy 'MkFieldFlag) where+  type ToFunction BitBuilder (Proxy 'MkFieldFlag) a = Bool -> a+  toFunctionBuilder _ =+    deferred (appendBitBuffer64 . bitBuffer64 1 . (\ !t -> if t then 1 else 0)) -instance forall a .-  BitStringBuilderHoley (Proxy (MkField 'MkFieldI8)) a where-  type ToBitStringBuilder (Proxy (MkField 'MkFieldI8)) a = Int8 -> a-  bitStringBuilderHoley _ = addParameter (appendBitString . bitString 8 . fromIntegral . fromIntegral @Int8 @Word8)+instance DynamicContent BitBuilder (Proxy 'MkFieldFlag) Bool where+  addParameter = toFunctionBuilder +-- -- **** Bits -instance forall (f :: IsA (BitRecordField (t :: BitField rt Nat len))) (v :: Nat) a . (KnownNat v, BitStringBuilderHoley (Proxy f) a, ToBitStringBuilder (Proxy f) a ~ (rt -> a), Num rt) =>-  BitStringBuilderHoley (Proxy (f := v)) a where-  bitStringBuilderHoley _ = fillParameter (bitStringBuilderHoley (Proxy @f)) (fromIntegral (natVal (Proxy @v)))+instance forall (s :: Nat) . (KnownChunkSize s) =>+  HasFunctionBuilder BitBuilder (Proxy (MkField ('MkFieldBits :: BitField (B s) Nat s))) where+  type ToFunction BitBuilder (Proxy (MkField ('MkFieldBits :: BitField (B s) Nat s))) a = B s -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64ProxyLength (Proxy @s) . unB) -instance forall v f a x . (KnownNat v, BitStringBuilderHoley (Proxy f) a, ToBitStringBuilder (Proxy f) a ~ (x -> a), Num x) =>-  BitStringBuilderHoley (Proxy (f := ('PositiveNat v))) a where-  bitStringBuilderHoley _ =  fillParameter (bitStringBuilderHoley (Proxy @f)) (fromIntegral (natVal (Proxy @v))) +instance forall (s :: Nat) r . (KnownChunkSize s) =>+  DynamicContent BitBuilder (Proxy (MkField ('MkFieldBits :: BitField (B s) Nat s))) (B s) where+  addParameter = toFunctionBuilder -instance forall v f a x . (KnownNat v, BitStringBuilderHoley (Proxy f) a, ToBitStringBuilder (Proxy f) a ~ (x -> a), Num x) =>-  BitStringBuilderHoley (Proxy (f := ('NegativeNat v))) a where-  bitStringBuilderHoley _ = fillParameter (bitStringBuilderHoley (Proxy @f)) (fromIntegral (-1 * (natVal (Proxy @v))))+-- -- **** Naturals +instance+  HasFunctionBuilder BitBuilder (Proxy (MkField 'MkFieldU64)) where+  type ToFunction BitBuilder (Proxy (MkField 'MkFieldU64)) a = Word64 -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64 64)++instance+  DynamicContent BitBuilder (Proxy (MkField 'MkFieldU64)) Word64 where+  addParameter = toFunctionBuilder++instance+  HasFunctionBuilder BitBuilder (Proxy (MkField 'MkFieldU32)) where+  type ToFunction BitBuilder (Proxy (MkField 'MkFieldU32)) a = Word32 -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64 32 . fromIntegral)++instance+  DynamicContent BitBuilder (Proxy (MkField ('MkFieldU32:: BitField Word32 Nat 32))) Word32 where+  addParameter = toFunctionBuilder++instance+  HasFunctionBuilder BitBuilder (Proxy 'MkFieldU32) where+  type ToFunction BitBuilder (Proxy 'MkFieldU32) a = Word32 -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64 32 . fromIntegral)++instance+  DynamicContent BitBuilder (Proxy 'MkFieldU32) Word32 where+  addParameter = toFunctionBuilder++instance+  HasFunctionBuilder BitBuilder (Proxy (MkField 'MkFieldU16)) where+  type ToFunction BitBuilder (Proxy (MkField 'MkFieldU16)) a = Word16 -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64 16 . fromIntegral)++instance+  DynamicContent BitBuilder (Proxy (MkField 'MkFieldU16)) Word16 where+  addParameter = toFunctionBuilder++instance+  HasFunctionBuilder BitBuilder (Proxy (MkField 'MkFieldU8)) where+  type ToFunction BitBuilder (Proxy (MkField 'MkFieldU8)) a = Word8 -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64 8 . fromIntegral)++instance+  DynamicContent BitBuilder (Proxy (MkField 'MkFieldU8)) Word8 where+  addParameter = toFunctionBuilder++-- -- **** Signed++instance+  HasFunctionBuilder BitBuilder (Proxy (MkField 'MkFieldI64)) where+  type ToFunction BitBuilder (Proxy (MkField 'MkFieldI64)) a = Int64 -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64 64 . fromIntegral @Int64 @Word64)++instance+  DynamicContent BitBuilder (Proxy (MkField 'MkFieldI64)) Int64 where+  addParameter = toFunctionBuilder++instance+  HasFunctionBuilder BitBuilder (Proxy (MkField 'MkFieldI32)) where+  type ToFunction BitBuilder (Proxy (MkField 'MkFieldI32)) a = Int32 -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64 32 . fromIntegral . fromIntegral @Int32 @Word32)++instance+  DynamicContent BitBuilder (Proxy (MkField 'MkFieldI32)) Int32 where+  addParameter = toFunctionBuilder++instance+  HasFunctionBuilder BitBuilder (Proxy (MkField 'MkFieldI16)) where+  type ToFunction BitBuilder (Proxy (MkField 'MkFieldI16)) a = Int16 -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64 16 . fromIntegral . fromIntegral @Int16 @Word16)++instance+  DynamicContent BitBuilder (Proxy (MkField 'MkFieldI16)) Int16 where+  addParameter = toFunctionBuilder++instance+  HasFunctionBuilder BitBuilder (Proxy (MkField 'MkFieldI8)) where+  type ToFunction BitBuilder (Proxy (MkField 'MkFieldI8)) a = Int8 -> a+  toFunctionBuilder _ = deferred (appendBitBuffer64 . bitBuffer64 8 . fromIntegral . fromIntegral @Int8 @Word8)++instance+  DynamicContent BitBuilder (Proxy (MkField 'MkFieldI8)) Int8 where+  addParameter = toFunctionBuilder++-- *** Assign static values++instance+  forall+    rt+    (len :: Nat)+    (t :: BitField rt Nat len)+    (f :: Extends (BitRecordField t))+    (v :: Nat)+    .+      ( KnownNat v+      , DynamicContent BitBuilder (Proxy f) rt+      , Num rt+      )+      =>  HasFunctionBuilder BitBuilder (Proxy (f := v)) where+  toFunctionBuilder _ =+    fillParameter (addParameter (Proxy @f)) (fromIntegral (natVal (Proxy @v)))++instance forall v f x . (KnownNat v, DynamicContent BitBuilder (Proxy f) x, Num x) =>+  HasFunctionBuilder BitBuilder (Proxy (f := ('PositiveNat v))) where+  toFunctionBuilder _ =+    fillParameter (addParameter (Proxy @f)) (fromIntegral (natVal (Proxy @v)))+++instance forall v f x . (KnownNat v, DynamicContent BitBuilder (Proxy f) x, Num x) =>+  HasFunctionBuilder BitBuilder (Proxy (f := ('NegativeNat v))) where+  toFunctionBuilder _ = fillParameter (addParameter (Proxy @f)) (fromIntegral (-1 * (natVal (Proxy @v))))++-- new:++instance+  forall (f :: Extends (BitField rt Nat len)) (v :: Nat) .+  ( KnownNat v+  , DynamicContent BitBuilder (Proxy f) rt+  , Num rt)+  =>+  HasFunctionBuilder BitBuilder (Proxy (f :=. v)) where+  toFunctionBuilder _ =+    fillParameter+      (addParameter (Proxy @f))+      (fromIntegral (natVal (Proxy @v)))++-- -- instance forall v f a x . (KnownNat v, HasFunctionBuilder BitBuilder (Proxy f) a, ToFunction BitBuilder (Proxy f) a ~ (x -> a), Num x) =>+-- --   HasFunctionBuilder BitBuilder (Proxy (f := ('PositiveNat v))) a where+-- --   toFunctionBuilder _ =  fillParameter (toFunctionBuilder (Proxy @f)) (fromIntegral (natVal (Proxy @v)))+--+--+-- -- instance forall v f a x . (KnownNat v, HasFunctionBuilder BitBuilder (Proxy f) a, ToFunction BitBuilder (Proxy f) a ~ (x -> a), Num x) =>+-- --   HasFunctionBuilder BitBuilder (Proxy (f := ('NegativeNat v))) a where+-- --   toFunctionBuilder _ = fillParameter (toFunctionBuilder (Proxy @f)) (fromIntegral (-1 * (natVal (Proxy @v))))++ -- ** 'BitRecord' instances -instance forall (r :: IsA BitRecord) a . BitStringBuilderHoley (Proxy (Eval r)) a =>-  BitStringBuilderHoley (Proxy r) a where-  type ToBitStringBuilder (Proxy r) a =-    ToBitStringBuilder (Proxy (Eval r)) a-  bitStringBuilderHoley _ = bitStringBuilderHoley (Proxy @(Eval r))+instance forall (r :: Extends BitRecord) . HasFunctionBuilder BitBuilder (Proxy (From r)) =>+  HasFunctionBuilder BitBuilder (Proxy r) where+  type ToFunction BitBuilder (Proxy r) a =+    ToFunction BitBuilder (Proxy (From r)) a+  toFunctionBuilder _ = toFunctionBuilder (Proxy @(From r))  -- *** 'BitRecordMember' -instance forall f a . BitStringBuilderHoley (Proxy f) a => BitStringBuilderHoley (Proxy ('BitRecordMember f)) a where-  type ToBitStringBuilder (Proxy ('BitRecordMember f)) a = ToBitStringBuilder (Proxy f) a-  bitStringBuilderHoley _ = bitStringBuilderHoley (Proxy @f)+instance forall f . HasFunctionBuilder BitBuilder (Proxy f) => HasFunctionBuilder BitBuilder (Proxy ('BitRecordMember f)) where+  type ToFunction BitBuilder (Proxy ('BitRecordMember f)) a = ToFunction BitBuilder (Proxy f) a+  toFunctionBuilder _ = toFunctionBuilder (Proxy @f) +-- *** 'RecordField'+++instance forall f . HasFunctionBuilder BitBuilder (Proxy f)+  => HasFunctionBuilder BitBuilder (Proxy ('RecordField f)) where+  type ToFunction BitBuilder (Proxy ('RecordField f)) a =+        ToFunction BitBuilder (Proxy f) a+  toFunctionBuilder _ = toFunctionBuilder (Proxy @f)++ -- *** 'AppendedBitRecords' -instance forall l r a .-  (BitStringBuilderHoley (Proxy l) (ToBitStringBuilder (Proxy r) a)-  , BitStringBuilderHoley (Proxy r) a)-   => BitStringBuilderHoley (Proxy ('BitRecordAppend l r)) a where-  type ToBitStringBuilder (Proxy ('BitRecordAppend l r)) a =-    ToBitStringBuilder (Proxy l) (ToBitStringBuilder (Proxy r) a)-  bitStringBuilderHoley _ = bitStringBuilderHoley (Proxy @l) . bitStringBuilderHoley (Proxy @r)+instance forall l r .+  (HasFunctionBuilder BitBuilder (Proxy l), HasFunctionBuilder BitBuilder (Proxy r))+   => HasFunctionBuilder BitBuilder (Proxy ('BitRecordAppend l r)) where+  type ToFunction BitBuilder (Proxy ('BitRecordAppend l r)) a =+    ToFunction BitBuilder (Proxy l) (ToFunction BitBuilder (Proxy r) a)+  toFunctionBuilder _ = toFunctionBuilder (Proxy @l) . toFunctionBuilder (Proxy @r)  -- *** 'EmptyBitRecord' and '...Pretty' -instance BitStringBuilderHoley (Proxy 'EmptyBitRecord) a where-  bitStringBuilderHoley _ = id+instance HasFunctionBuilder BitBuilder (Proxy 'EmptyBitRecord) where+  toFunctionBuilder _ = id  -- ** Tracing/Debug Printing @@ -308,8 +448,6 @@   ("<< " ++) $   (++ " >>") $ unwords $ printf "%0.2x" <$> B.unpack (SB.toLazyByteString b) -bitStringPrinter-  :: BitStringBuilderHoley a String-  => a -> ToBitStringBuilder a String-bitStringPrinter =-  toFunction . mapAccumulator (printBuilder . runBitStringBuilder) . bitStringBuilderHoley+bitBuffer64Printer :: HasFunctionBuilder BitBuilder a => a -> ToFunction BitBuilder a String+bitBuffer64Printer =+  toFunction . mapAccumulator (printBuilder . runBitBuilder) . toFunctionBuilder

@@ -1,27 +1,60 @@ {-# LANGUAGE UndecidableInstances #-}+-- | NamedStructure definition for sequences of bits.+--+-- This module provides the core data types and functions for+-- conversion of finite bit sequences from an to conventional (Haskell) data types.+--+-- Non-compressed, non-random finite bit sequences generated by programs are+-- usually compositions of bytes and multi byte words, and a ton of Haskell libraries+-- exist for the serialization and deserialization of ByteStrings.+--+-- This module allows the definition of a __structure__ i.e. a very simple grammar,+-- which allows functions in this library to read and write single bytes, words and bits.+--+-- Also complete bit sequence may be constructed or destructed from and to Haskell types.+--+-- Further more, the structures may contain dependent sub-sequences, for example to+-- express structures that precede a /length/ field before a repetitive block data.+--+-- Antother example for dependent sequences is /fields/ whose presence depends on+-- /flags/ preceding them.+--+-- This library is also designed with /zero copying/ in mind.+--+-- It should be emphasized that binary deserialization __is not__+-- to be confused with binary destructuring. While the former usually involves copying+-- all regular sub sequences from the input to a value of a certain type, the later+-- merely requires to peek into the sequeuence at a certain position and deserializing+-- a sub sequence. The starting position and the interpretation are governed by the+-- strucuture applied to the sequence.+ module Data.Type.BitRecords.Core where -import Data.Int-import Data.Kind (Type)-import Data.Kind.Extra-import Data.Proxy-import Data.Type.Pretty-import Data.Word-import Data.Bits-import GHC.TypeLits-import Text.Printf+import           Data.Int+import           Data.Kind                      ( Type )+import           Data.Kind.Extra+import           Data.Proxy+import           Data.Type.Pretty+import           Data.Word+import           Data.Bits+import           GHC.TypeLits+import           Text.Printf  -- * Bit-Records  -- ** Bit-Record Type + -- | 'BitRecordField's assembly data BitRecord where   EmptyBitRecord     :: BitRecord-  BitRecordMember    :: IsA (BitRecordField t) -> BitRecord+  BitRecordMember    :: Extends (BitRecordField t) -> BitRecord+  RecordField        :: Extends (BitField rt st size) -> BitRecord   BitRecordAppend    :: BitRecord -> BitRecord -> BitRecord   -- TODO  MissingBitRecord          :: ErrorMessage     -> BitRecord ++ -- | A conditional 'BitRecord' type family WhenR (b :: Bool) (x :: BitRecord) :: BitRecord where   WhenR 'False r = 'EmptyBitRecord@@ -30,39 +63,67 @@ -- *** Basic Accessor  -- | Get the number of bits in a 'BitRecord'-type family BitRecordSize (x :: BitRecord) :: Nat where-  BitRecordSize 'EmptyBitRecord           = 0-  BitRecordSize ('BitRecordMember f)      = BitRecordFieldSize f-  BitRecordSize ('BitRecordAppend l r)    = BitRecordSize l + BitRecordSize r+type family SizeInBits (x :: k) :: Nat where+  SizeInBits 'EmptyBitRecord           = 0+  SizeInBits ('BitRecordMember f)      = FieldWidth f+  SizeInBits ('RecordField f) = BitFieldSize (From f)+  SizeInBits ('BitRecordAppend l r)    = SizeInBits l + SizeInBits r ++-- | For something to be augmented by a size field there must be an instance of+-- this family to generate the value of the size field, e.g. by counting the+-- elements.+type family SizeInBytes (c :: k) :: Nat++type instance SizeInBytes (f := v) = SizeInBytes v+type instance SizeInBytes (LabelF l f) = SizeInBytes f+type instance SizeInBytes (MkField (t :: BitField (rt:: Type) (st::k) (size::Nat))) = SizeInBytes t++type instance SizeInBytes (b :: BitRecord) = Bits2Bytes (SizeInBits b)++type Bits2Bytes (bitSize :: Nat) =+  Bits2Bytes2 (Div bitSize 8) (Mod bitSize 8)++type family Bits2Bytes2 (bitSizeDiv8 :: Nat) (bitSizeMod8 :: Nat) :: Nat where+  Bits2Bytes2 bytes 0 = bytes+  Bits2Bytes2 bytes n = bytes + 1++type instance SizeInBytes (f :=. v) = SizeInBytes v+type instance SizeInBytes (Labelled l f) = SizeInBytes f+type instance SizeInBytes (t :: BitField (rt:: Type) (st::k) (size::Nat)) = size+ -- | Get the total number of members in a record. type family BitRecordMemberCount (b :: BitRecord) :: Nat where   BitRecordMemberCount 'EmptyBitRecord           = 0   BitRecordMemberCount ('BitRecordMember f)      = 1+  BitRecordMemberCount ('RecordField f) = 1   BitRecordMemberCount ('BitRecordAppend l r)    = BitRecordMemberCount l + BitRecordMemberCount r  -- | Get the size of the record. getRecordSizeFromProxy-  :: forall px (rec :: BitRecord) . KnownNat (BitRecordSize rec) => px rec -> Integer-getRecordSizeFromProxy _ = natVal (Proxy :: Proxy (BitRecordSize rec))+  :: forall px (rec :: BitRecord)+   . KnownNat (SizeInBits rec)+  => px rec+  -> Integer+getRecordSizeFromProxy _ = natVal (Proxy :: Proxy (SizeInBits rec))  -- | Either use the value from @Just@ or return a 'EmptyBitRecord' value(types(kinds))-type OptionalRecordOf (f :: IsA (s :-> IsA BitRecord)) (x :: Maybe s) =-  (Optional (Pure 'EmptyBitRecord) f $~ x :: IsA BitRecord)+type OptionalRecordOf (f :: Extends (s -> Extends BitRecord)) (x :: Maybe s)+  = (Optional (Konst 'EmptyBitRecord) f $ x :: Extends BitRecord)  -- ** Record composition  -- | Combine two 'BitRecord's to form a new 'BitRecord'. If the parameters are -- not of type 'BitRecord' they will be converted.-data (:+^) (l :: BitRecord) (r :: IsA BitRecord) :: IsA BitRecord+data (:+^) (l :: BitRecord) (r :: Extends BitRecord) :: Extends BitRecord infixl 3 :+^-type instance Eval (l :+^ r) = l `Append` Eval r+type instance From (l :+^ r) = l `Append` From r  -- | Combine two 'BitRecord's to form a new 'BitRecord'. If the parameters are -- not of type 'BitRecord' they will be converted.-data (:^+) (l :: IsA BitRecord) (r :: BitRecord) :: IsA BitRecord+data (:^+) (l :: Extends BitRecord) (r :: BitRecord) :: Extends BitRecord infixl 3 :^+-type instance Eval (l :^+ r) = Eval l `Append` r+type instance From (l :^+ r) = From l `Append` r  -- | Combine two 'BitRecord's to form a new 'BitRecord'. If the parameters are -- not of type 'BitRecord' they will be converted.@@ -75,48 +136,46 @@   Append l r = 'BitRecordAppend l r  -- | Append a 'BitRecord' and a 'BitRecordField'-type (:+.) (r :: BitRecord)-           (f :: IsA (BitRecordField t1))-           = Append r ('BitRecordMember f)+type (:+.) (r :: BitRecord) (f :: Extends (BitRecordField t1))+  = Append r ( 'BitRecordMember f) infixl 6 :+.  -- | Append a 'BitRecordField' and a 'BitRecord'-type (.+:) (f :: IsA (BitRecordField t1))-           (r :: BitRecord)-  = Append ('BitRecordMember f) r+type (.+:) (f :: Extends (BitRecordField t1)) (r :: BitRecord)+  = Append ( 'BitRecordMember f) r infixr 6 .+:  -- | Append a 'BitRecordField' and a 'BitRecordField' forming a 'BitRecord' with -- two members.-type (.+.) (l :: IsA (BitRecordField t1))-           (r :: IsA (BitRecordField t2))-           = Append ('BitRecordMember l) ('BitRecordMember r)+type (.+.) (l :: Extends (BitRecordField t1)) (r :: Extends (BitRecordField t2))+  = Append ( 'BitRecordMember l) ( 'BitRecordMember r) infixr 6 .+.  -- | Set a field to either a static, compile time, value or a dynamic, runtime value. type family (:~)-  (field :: IsA (BitRecordField (t :: BitField (rt :: Type) (st :: k) (len :: Nat))))-  (value :: IsA (FieldValue (label :: Symbol) st))-  :: IsA (BitRecordField t) where+  (field :: Extends (BitRecordField (t :: BitField (rt :: Type) (st :: k) (len :: Nat))))+  (value :: Extends (FieldValue (label :: Symbol) st))+  :: Extends (BitRecordField t) where   fld :~ StaticFieldValue l v  = (l @: fld) := v   fld :~ RuntimeFieldValue l = l @: fld infixl 7 :~ + -- | Like ':~' but for a 'Maybe' parameter. In case of 'Just' it behaves like ':~' -- in case of 'Nothing' it return an 'EmptyBitRecord'. type family (:~?)-  (fld :: IsA (BitRecordField (t :: BitField (rt :: Type) (st :: k) (len :: Nat))))-  (value :: Maybe (IsA (FieldValue (label :: Symbol) st)))-  :: IsA BitRecord where+  (fld :: Extends (BitRecordField (t :: BitField (rt :: Type) (st :: k) (len :: Nat))))+  (value :: Maybe (Extends (FieldValue (label :: Symbol) st)))+  :: Extends BitRecord where   fld :~? ('Just v) = RecordField (fld :~ v)-  fld :~? 'Nothing  = Pure 'EmptyBitRecord+  fld :~? 'Nothing  = Konst 'EmptyBitRecord infixl 7 :~?  -- | Like ':~' but for a 'Maybe' parameter. In case of 'Just' it behaves like ':~' -- in case of 'Nothing' it return an 'EmptyBitRecord'. type family (:+?)-  (fld :: IsA (BitRecordField (t :: BitField (rt :: Type) (st :: k) (len :: Nat))))-  (value :: Maybe (IsA (FieldValue (label :: Symbol) st)))+  (fld :: Extends (BitRecordField (t :: BitField (rt :: Type) (st :: k) (len :: Nat))))+  (value :: Maybe (Extends (FieldValue (label :: Symbol) st)))   :: BitRecord where   fld :+? ('Just v) = 'BitRecordMember (fld :~ v)   fld :+? 'Nothing  = 'EmptyBitRecord@@ -125,20 +184,23 @@ -- | The field value parameter for ':~', either a static, compile time, value or -- a dynamic, runtime value. data FieldValue :: Symbol -> staticRep -> Type-data StaticFieldValue (label :: Symbol) :: staticRep -> IsA (FieldValue label staticRep)-data RuntimeFieldValue (label :: Symbol) :: IsA (FieldValue label staticRep)+data StaticFieldValue (label :: Symbol) :: staticRep -> Extends (FieldValue label staticRep)+data RuntimeFieldValue (label :: Symbol) :: Extends (FieldValue label staticRep)  -- *** Record Arrays and Repitition +++ -- | An array of records with a fixed number of elements, NOTE: this type is -- actually not really necessary since 'ReplicateRecord' exists, but this allows -- to have a different 'showRecord' output.-data RecArray :: BitRecord -> Nat -> IsA BitRecord+data RecArray :: BitRecord -> Nat -> Extends BitRecord  type r ^^ n = RecArray r n infixl 5 ^^ -type instance Eval (RecArray (r :: BitRecord) n ) = RecArrayToBitRecord r n+type instance From (RecArray (r :: BitRecord) n ) = RecArrayToBitRecord r n  -- | Repeat a bit record @n@ times. type family RecArrayToBitRecord (r :: BitRecord) (n :: Nat) :: BitRecord where@@ -151,23 +213,23 @@ -- | Let type level lists also be records data     BitRecordOfList-      (f  :: IsA (foo :-> BitRecord))+      (f  :: Extends (foo -> BitRecord))       (xs :: [foo])-      :: IsA BitRecord+      :: Extends BitRecord -type instance Eval (BitRecordOfList f xs) =+type instance From (BitRecordOfList f xs) =   FoldMap BitRecordAppendFun 'EmptyBitRecord f xs  type BitRecordAppendFun = Fun1 BitRecordAppendFun_-data BitRecordAppendFun_ :: BitRecord -> IsA (BitRecord :-> BitRecord)-type instance (BitRecordAppendFun_ l) $~ r = Append l r+data BitRecordAppendFun_ :: BitRecord -> Extends (BitRecord -> BitRecord)+type instance Apply (BitRecordAppendFun_ l) r = Append l r  -- *** Maybe Record  -- | Either use the value from @Just@ or return a 'EmptyBitRecord' value(types(kinds))-data OptionalRecord :: Maybe BitRecord -> IsA BitRecord-type instance Eval (OptionalRecord ('Just t)) = t-type instance Eval (OptionalRecord 'Nothing)  = 'EmptyBitRecord+data OptionalRecord :: Maybe BitRecord -> Extends BitRecord+type instance From (OptionalRecord ('Just t)) = t+type instance From (OptionalRecord 'Nothing)  = 'EmptyBitRecord  -- ** Field ADT @@ -179,28 +241,39 @@ data BitRecordField :: BitField rt st len -> Type  -- | A bit record field with a number of bits-data MkField t :: IsA (BitRecordField t)+data MkField t :: BitRecordField t -> Type  -- **** Setting a Label  -- | A bit record field with a number of bits-data LabelF :: Symbol -> IsA (BitRecordField t) -> IsA (BitRecordField t)+data LabelF :: Symbol -> Extends (BitRecordField t) -> Extends (BitRecordField t) + -- | A field with a label assigned to it.-type-  (l :: Symbol) @:(f :: IsA (BitRecordField (t :: BitField rt (st :: stk) size)))-  = (LabelF l f :: IsA (BitRecordField t))+type (l :: Symbol) @: (f :: Extends+  (BitRecordField (t :: BitField rt (st :: stk) size)))+  = (LabelF l f :: Extends (BitRecordField t)) infixr 8 @: +-- | A field with a label assigned to it.+type (l :: Symbol) @:: (f :: Extends a) = Labelled l f+infixr 8 @::+ -- **** Assignment  -- | A field with a value set at compile time. data (:=) :: forall st (t :: BitField rt st size) .-            IsA (BitRecordField t)+            Extends (BitRecordField t)           -> st-          -> IsA (BitRecordField t)+          -> Extends (BitRecordField t) infixl 7 := +-- | A field with a value set at compile time.+data (:=.) :: Extends (BitField rt st size)+           -> st+           -> Extends (BitField rt st size)+infixl 7 :=.+ -- | Types of this kind define the basic type of a 'BitRecordField'. Sure, this -- could have been an open type, but really, how many actual useful field types -- exist? Well, from a global perspective, uncountable infinite, but the focus@@ -213,27 +286,30 @@      (staticRep :: k)      (bitCount :: Nat)   where-    MkFieldFlag    :: BitField Bool Bool 1-    MkFieldBits    :: forall (n :: Nat) . BitField (B n) Nat n-    MkFieldBitsXXL :: forall (n :: Nat) . BitField Integer Nat n-    MkFieldU8      :: BitField Word8 Nat 8-    MkFieldU16     :: BitField Word16 Nat 16-    MkFieldU32     :: BitField Word32 Nat 32-    MkFieldU64     :: BitField Word64 Nat 64-    MkFieldI8      :: BitField Int8  SignedNat 8-    MkFieldI16     :: BitField Int16 SignedNat 16-    MkFieldI32     :: BitField Int32 SignedNat 32-    MkFieldI64     :: BitField Int64 SignedNat 64+    MkFieldFlag    ::BitField Bool Bool 1+    MkFieldBits    :: (forall (n :: Nat) . BitField (B n) Nat n)+    MkFieldBitsXXL :: (forall (n :: Nat) . BitField Integer Nat n)+    MkFieldU8      ::BitField Word8 Nat 8+    MkFieldU16     ::BitField Word16 Nat 16+    MkFieldU32     ::BitField Word32 Nat 32+    MkFieldU64     ::BitField Word64 Nat 64+    MkFieldI8      ::BitField Int8  SignedNat 8+    MkFieldI16     ::BitField Int16 SignedNat 16+    MkFieldI32     ::BitField Int32 SignedNat 32+    MkFieldI64     ::BitField Int64 SignedNat 64     -- TODO refactor this MkFieldCustom, it caused a lot of trouble!-    MkFieldCustom  :: BitField rt st n+    MkFieldCustom  ::BitField rt st n -type Flag     = MkField 'MkFieldFlag-type Field n  = MkField ('MkFieldBits :: BitField (B n) Nat n)-type FieldU8  = MkField 'MkFieldU8+type family BitFieldSize (b :: BitField rt st size) :: Nat where+  BitFieldSize (b :: BitField rt st size) = size++type Flag = MkField 'MkFieldFlag+type Field n = MkField ( 'MkFieldBits :: BitField (B n) Nat n)+type FieldU8 = MkField 'MkFieldU8 type FieldU16 = MkField 'MkFieldU16-type FieldU32 = MkField 'MkFieldU32+type FieldU32 =  Konst 'MkFieldU32 type FieldU64 = MkField 'MkFieldU64-type FieldI8  = MkField 'MkFieldI8+type FieldI8 = MkField 'MkFieldI8 type FieldI16 = MkField 'MkFieldI16 type FieldI32 = MkField 'MkFieldI32 type FieldI64 = MkField 'MkFieldI64@@ -249,63 +325,73 @@  -- | A signed field value. data SignedNat where-  PositiveNat :: Nat -> SignedNat-  NegativeNat :: Nat -> SignedNat+  PositiveNat ::Nat -> SignedNat+  NegativeNat ::Nat -> SignedNat  -- *** Composed Fields  -- | A Flag (1-bit) that is true if the type level maybe is 'Just'.-type family FlagJust (a :: Maybe (v :: Type)) :: IsA (BitRecordField 'MkFieldFlag) where+type family FlagJust (a :: Maybe (v :: Type)) :: Extends (BitRecordField 'MkFieldFlag) where   FlagJust ('Just x) = Flag := 'True   FlagJust 'Nothing  = Flag := 'False  -- | A Flag (1-bit) that is true if the type level maybe is 'Nothing'.-type family FlagNothing  (a :: Maybe (v :: Type)) :: IsA (BitRecordField 'MkFieldFlag) where+type family FlagNothing  (a :: Maybe (v :: Type)) :: Extends (BitRecordField 'MkFieldFlag) where   FlagNothing ('Just x) = Flag := 'False   FlagNothing 'Nothing  = Flag := 'True  -- | An optional field in a bit record-data MaybeField :: Maybe (IsA (BitRecordField t)) -> IsA BitRecord-type instance Eval (MaybeField ('Just  fld)) = 'BitRecordMember fld-type instance Eval (MaybeField 'Nothing) = 'EmptyBitRecord+data MaybeField :: Maybe (Extends (BitRecordField t)) -> Extends BitRecord+type instance From (MaybeField ('Just  fld)) = 'BitRecordMember fld+type instance From (MaybeField 'Nothing) = 'EmptyBitRecord  -- | A 'BitRecordField' can be used as 'BitRecordMember'-data RecordField :: IsA (BitRecordField t) -> IsA BitRecord-type instance Eval (RecordField f) = 'BitRecordMember f+data RecordField :: Extends (BitRecordField t) -> Extends BitRecord+type instance From (RecordField f) = 'BitRecordMember f  -- | Calculate the size as a number of bits from a 'BitRecordField'-type family BitRecordFieldSize (x :: IsA (BitRecordField t)) where-  BitRecordFieldSize (x :: IsA (BitRecordField (t :: BitField rt st size))) = size-+type family FieldWidth (x :: Extends (BitRecordField t)) where+  FieldWidth (x :: Extends (BitRecordField (t :: BitField rt st size))) = size  -- * Field and Record PrettyType Instances  -- | Render @rec@ to a pretty, human readable form. Internally this is a wrapper -- around 'ptShow' using 'PrettyRecord'. showARecord-  :: forall proxy (rec :: IsA BitRecord) . PrettyTypeShow (PrettyRecord (Eval rec))-  => proxy rec -> String-showARecord _ = showPretty (Proxy :: Proxy (PrettyRecord (Eval rec)))+  :: forall proxy (rec :: Extends BitRecord)+   . PrettyTypeShow (PrettyRecord (From rec))+  => proxy rec+  -> String+showARecord _ = showPretty (Proxy :: Proxy (PrettyRecord (From rec)))  -- | Render @rec@ to a pretty, human readable form. Internally this is a wrapper -- around 'ptShow' using 'PrettyRecord'. showRecord-  :: forall proxy (rec :: BitRecord) . PrettyTypeShow (PrettyRecord rec)-  => proxy rec -> String+  :: forall proxy (rec :: BitRecord)+   . PrettyTypeShow (PrettyRecord rec)+  => proxy rec+  -> String showRecord _ = showPretty (Proxy :: Proxy (PrettyRecord rec))  type instance ToPretty (rec :: BitRecord) = PrettyRecord rec  type family PrettyRecord (rec :: BitRecord) :: PrettyType where    PrettyRecord ('BitRecordMember m) = PrettyField m+   PrettyRecord ('RecordField m) = PrettyRecordField m    PrettyRecord ' EmptyBitRecord = 'PrettyNewline    PrettyRecord ('BitRecordAppend l r) = PrettyRecord l <$$> PrettyRecord r -type instance ToPretty (f :: IsA (BitRecordField t)) = PrettyField f+type instance ToPretty (f :: Extends (BitRecordField t)) = PrettyField f -type family PrettyField (f :: IsA (BitRecordField (t :: BitField (rt :: Type) (st :: Type) (size :: Nat)))) :: PrettyType where+type family PrettyRecordField (f :: Extends (BitField (rt :: Type) (st :: Type) (size :: Nat))) :: PrettyType where+  PrettyRecordField (Konst t) = PrettyFieldType t+  PrettyRecordField (f :=. v) =+    PrettyRecordField f <+> PutStr ":=" <+> PrettyFieldValue (From f) v+  PrettyRecordField (Labelled l f) = l <:> PrettyRecordField f++type family PrettyField (f :: Extends (BitRecordField (t :: BitField (rt :: Type) (st :: Type) (size :: Nat)))) :: PrettyType where   PrettyField (MkField t) = PrettyFieldType t-  PrettyField ((f :: IsA (BitRecordField t)) := v) =+  PrettyField ((f :: Extends (BitRecordField t)) := v) =     PrettyField f <+> PutStr ":=" <+> PrettyFieldValue t v   PrettyField (LabelF l f) = l <:> PrettyField f @@ -343,3 +429,10 @@   PrettyFieldValue ('MkFieldCustom :: BitField rt ct size) v = PrettyCustomFieldValue rt ct size v  type family PrettyCustomFieldValue (rt :: Type) (st :: Type) (size :: Nat) (v :: st) :: PrettyType++type family PrintHexIfPossible t (s :: Nat) :: PrettyType where+  PrintHexIfPossible Word64 s = PutHex64 s+  PrintHexIfPossible Word32 s = PutHex32 s+  PrintHexIfPossible Word16 s = PutHex16 s+  PrintHexIfPossible Word8 s = PutHex8 s+  PrintHexIfPossible x s = TypeError ('Text "Invalid size field type: " ':<>: 'ShowType x)

@@ -2,7 +2,7 @@ module Data.Type.BitRecords.Enum where  import           Data.Type.BitRecords.Core-import           Data.Type.BitRecords.Builder.BitBuffer+import           Data.Type.BitRecords.BitBuffer64 import           Data.FunctionBuilder import           Data.Type.BitRecords.Builder.LazyByteStringBuilder import           Data.Proxy@@ -18,13 +18,13 @@ -- the clauses of the (sum) type. data EnumOf enum where   MkEnumOf-    ::IsAn (EnumField enum size)-    -> IsA (FieldValue label enum)+    ::Extends (EnumField enum size)+    -> Extends (FieldValue label enum)     -> BitRecord     -> EnumOf enum -type BitRecordOfEnum (e :: IsAn (EnumOf enum))-  = (RenderEnumOf (Eval e) :: BitRecord)+type BitRecordOfEnum (e :: Extends (EnumOf enum))+  = (RenderEnumOf (From e) :: BitRecord)  type family RenderEnumOf (e :: EnumOf enum) :: BitRecord where   RenderEnumOf ('MkEnumOf mainField mainFieldVal extra) =@@ -33,11 +33,11 @@ -- | Physical representation of an 'EnumOf', this is an abstract type data EnumField (enum :: Type) (size :: Nat) -type BitRecordFieldOfEnumField (x :: IsA (EnumField e s))+type BitRecordFieldOfEnumField (x :: Extends (EnumField e s))   = MkField ( 'MkFieldCustom :: BitField (EnumValue e) e s)  -- | A fixed size 'EnumField'-data FixedEnum (enum :: Type) (size :: Nat) :: IsAn (EnumField enum size)+data FixedEnum (enum :: Type) (size :: Nat) :: Extends (EnumField enum size)  -- | An enum that can be extended with an additional 'BitRecordField', following -- the  regular enum field; the extension is optional, i.e. only if the@@ -45,13 +45,13 @@ data ExtEnum (enum :: Type)              (size :: Nat)              (extInd :: enum)-             (extField :: IsA (BitRecordField (t :: BitField rt0 (st0 :: k0) len0)))-             :: IsAn (EnumField enum size)+             (extField :: Extends (BitRecordField (t :: BitField rt0 (st0 :: k0) len0)))+             :: Extends (EnumField enum size)  -- | Create an 'EnumOf' that sets an enum to a static value.-data SetEnum (l :: Symbol) (ef :: IsAn (EnumField enum size)) (v :: enum) :: IsAn (EnumOf enum)+data SetEnum (l :: Symbol) (ef :: Extends (EnumField enum size)) (v :: enum) :: Extends (EnumOf enum) -type instance Eval (SetEnum (l :: Symbol) (ei :: IsAn (EnumField enum size)) value) =+type instance From (SetEnum (l :: Symbol) (ei :: Extends (EnumField enum size)) value) =   'MkEnumOf      ei      (StaticFieldValue l value)@@ -60,42 +60,42 @@ -- | Create an 'EnumOf' that sets the enum to a runtime value. data EnumParam      (label :: Symbol)-     (ef :: IsAn (EnumField (enum :: Type) (size :: Nat)))-     :: IsAn (EnumOf enum)-type instance Eval (EnumParam label (ei :: IsAn (EnumField enum size))) =+     (ef :: Extends (EnumField (enum :: Type) (size :: Nat)))+     :: Extends (EnumOf enum)+type instance From (EnumParam label (ei :: Extends (EnumField enum size))) =   'MkEnumOf      ei      (RuntimeFieldValue label)      'EmptyBitRecord  -- | Create an 'EnumOf' that sets an extended enum to an extended static value.-data SetEnumAlt (l :: Symbol) (ef :: IsAn (EnumField (enum :: Type) (size :: Nat))) (v :: k)-  :: IsAn (EnumOf enum)+data SetEnumAlt (l :: Symbol) (ef :: Extends (EnumField (enum :: Type) (size :: Nat))) (v :: k)+  :: Extends (EnumOf enum) -type instance Eval (SetEnumAlt (l :: Symbol) (ExtEnum enum size extInd extField) value) =+type instance From (SetEnumAlt (l :: Symbol) (ExtEnum enum size extInd extField) value) =   -- TODO maybe enrich the demoteRep type of 'MkField??   'MkEnumOf      (ExtEnum enum size extInd extField)      (StaticFieldValue l extInd)      ('BitRecordMember (extField := value)) -type instance Eval (SetEnumAlt (l :: Symbol) (FixedEnum enum size) value) =+type instance From (SetEnumAlt (l :: Symbol) (FixedEnum enum size) value) =   TypeError ('Text "Cannot assign an 'extended' value to the 'FixedEnum' "              ':<>: 'ShowType enum)  -- | Create an 'EnumOf' that sets the extended enum to a runtime value. data EnumParamAlt   (label :: Symbol)-  (ef :: IsAn (EnumField (enum :: Type) (size :: Nat)))-  :: IsAn (EnumOf enum)+  (ef :: Extends (EnumField (enum :: Type) (size :: Nat)))+  :: Extends (EnumOf enum) -type instance Eval (EnumParamAlt label (ExtEnum enum size extInd extField)) =+type instance From (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)) =+type instance From (EnumParamAlt label (FixedEnum enum size)) =   TypeError ('Text "Cannot assign an extension value to the FixedEnum "              ':<>: 'ShowType enum) @@ -123,25 +123,25 @@   enumValue _ = fromIntegral (natVal (Proxy @(FromEnum enum v)))  instance-  forall (size :: Nat) r e (v :: e) (f :: IsA (BitRecordField ('MkFieldCustom :: BitField (EnumValue e) e size))) .+  forall (size :: Nat) e (v :: e) (f :: Extends (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))))+  HasFunctionBuilder BitBuilder (Proxy (f := v))  where+  toFunctionBuilder _ = immediate+    (appendBitBuffer64+      (bitBuffer64ProxyLength (Proxy @size)+                              (fromIntegral (natVal (Proxy @(FromEnum e v))))       )     )  instance-  forall (size :: Nat) r e  .+  forall (size :: Nat)  e  .   (KnownChunkSize size) =>-  BitStringBuilderHoley (Proxy (MkField ('MkFieldCustom :: BitField (EnumValue e) e size))) r+  HasFunctionBuilder BitBuilder (Proxy (MkField ('MkFieldCustom :: BitField (EnumValue e) e size)))   where-  type ToBitStringBuilder (Proxy (MkField ('MkFieldCustom :: BitField (EnumValue e) e size))) r =+  type ToFunction BitBuilder (Proxy (MkField ('MkFieldCustom :: BitField (EnumValue e) e size))) r =     EnumValue e -> r-  bitStringBuilderHoley _ = addParameter-    (appendBitString . bitStringProxyLength (Proxy @size) . fromEnumValue)+  toFunctionBuilder _ = deferred+    (appendBitBuffer64 . bitBuffer64ProxyLength (Proxy @size) . fromEnumValue)  type instance ToPretty (EnumValue e) = PutStr "<<enum>>" type instance PrettyCustomFieldValue (EnumValue e) e size (v :: e) =

@@ -1,26 +1,23 @@ -- | Size Fields {-# LANGUAGE UndecidableInstances #-} module Data.Type.BitRecords.Sized-  ( type Sized, type Sized8, type Sized16, type Sized32, type Sized64-  , type SizedField, type SizedField8, type SizedField16, type SizedField32, type SizedField64-  , type SizeFieldValue)+  ( type Sized, type Sized8, type Sized16, Sized32, type Sized64+  , type SizedField, type SizedField8, type SizedField16, type SizedField32, type SizedField64)   where -import Data.Type.Pretty import Data.Type.BitRecords.Core-import Data.Word import GHC.TypeLits import Data.Kind.Extra import Data.Kind (type Type)  -- | A record with a /size/ member, and a nested record that can be counted--- using 'SizeFieldValue'.+-- using 'SizeInBytes'. data Sized-  (sf :: IsA (BitRecordField (t :: BitField (rt :: Type) Nat (size :: Nat))))+  (sf :: Extends (BitRecordField (t :: BitField (rt :: Type) Nat (size :: Nat))))   (r :: BitRecord)-  :: IsA BitRecord-type instance Eval (Sized sf r) =-   "size" @: sf := SizeFieldValue r .+: r+  :: Extends BitRecord+type instance From (Sized sf r) =+   "size" @: sf := SizeInBytes r .+: r  -- | A convenient alias for a 'Sized' with an 'FieldU8' size field. type Sized8 t = Sized FieldU8 t@@ -29,19 +26,28 @@ type Sized16 t = Sized FieldU16 t  -- | A convenient alias for a 'Sized' with an 'FieldU32' size field.-type Sized32 t = Sized FieldU32 t+type Sized32 t = Sized2 FieldU32 t +-- | A convenient alias for a 'Sized' with an 'FieldU32' size field.+data Sized2 ::Extends (BitField rt Nat sz) -> Extends a -> Extends BitRecord++type instance From (Sized2 sizeField (r :: Extends BitRecord)) =+  'RecordField ("size" @:: sizeField :=. SizeInBytes (From r)) :+: From r++type instance From (Sized2 sizeField (r :: Extends (BitField sr st sz))) =+  'RecordField ("size" @:: sizeField :=. SizeInBytes (From r)) :+: 'RecordField r+ -- | A convenient alias for a 'Sized' with an 'FieldU64' size field. type Sized64 t = Sized FieldU64 t  -- | A record with a /size/ member, and a nested field that can be counted--- using 'SizeFieldValue'.+-- using 'SizeInBytes'. data SizedField-  (sf :: IsA (BitRecordField (t :: BitField (rt :: Type) Nat (size :: Nat))))-  (r :: IsA (BitRecordField (u :: BitField (rt' :: Type) (st' :: k0) (len0 :: Nat))))-  :: IsA BitRecord-type instance Eval (SizedField sf r) =-   "size" @: sf := SizeFieldValue r .+. r+  (sf :: Extends (BitRecordField (t :: BitField (rt :: Type) Nat (size :: Nat))))+  (r :: Extends (BitRecordField (u :: BitField (rt' :: Type) (st' :: k0) (len0 :: Nat))))+  :: Extends BitRecord+type instance From (SizedField sf r) =+   "size" @: sf := SizeInBytes r .+. r  -- | A convenient alias for a 'SizedField' with an 'FieldU8' size field. type SizedField8 t = SizedField FieldU8 t@@ -50,24 +56,7 @@ type SizedField16 t = SizedField FieldU16 t  -- | A convenient alias for a 'SizedField' with an 'FieldU32' size field.-type SizedField32 t = SizedField FieldU32 t+type SizedField32 t = Sized32 (Konst ('RecordField t))  -- | A convenient alias for a 'SizedField' with an 'FieldU64' size field. type SizedField64 t = SizedField FieldU64 t---- | For something to be augmented by a size field there must be an instance of--- this family to generate the value of the size field, e.g. by counting the--- elements.-type family SizeFieldValue (c :: k) :: Nat--type instance SizeFieldValue (b :: BitRecord) = BitRecordMemberCount b-type instance SizeFieldValue (f := v) = SizeFieldValue v-type instance SizeFieldValue (LabelF l f) = SizeFieldValue f-type instance SizeFieldValue (MkField (t :: BitField (rt:: Type) (st::k) (size::Nat))) = size--type family PrintHexIfPossible t (s :: Nat) :: PrettyType where-  PrintHexIfPossible Word64 s = PutHex64 s-  PrintHexIfPossible Word32 s = PutHex32 s-  PrintHexIfPossible Word16 s = PutHex16 s-  PrintHexIfPossible Word8 s = PutHex8 s-  PrintHexIfPossible x s = TypeError ('Text "Invalid size field type: " ':<>: 'ShowType x)

@@ -3,11 +3,12 @@ module Data.Type.BitRecords.SizedString   (SizedString()   ,ASizedString()-  ,utf8)+  ,utf8+  ,utf82+  ,SizedString2())   where  import Data.Type.BitRecords.Core-import Data.Type.BitRecords.Sized import Data.FunctionBuilder import Data.Type.BitRecords.Builder.LazyByteStringBuilder import qualified Language.Haskell.TH as TH@@ -18,7 +19,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Proxy-import Data.Kind (type Type) import Data.Kind.Extra  -- TODO Refactor@@ -31,11 +31,14 @@ type SizedString str bytes =   MkField ('MkFieldCustom :: BitField ASizedString ASizedString (8 * bytes)) := 'MkASizedString str bytes +type SizedString2 str bytes =+  Konst ('MkFieldCustom :: BitField ASizedString ASizedString (8 * bytes)) :=. 'MkASizedString str bytes+ data ASizedString where   MkASizedString :: Symbol -> Nat -> ASizedString  type instance-     SizeFieldValue ('MkASizedString str byteCount) = byteCount+     SizeInBytes ('MkASizedString str byteCount) = byteCount  type instance      ToPretty ASizedString = PutStr "utf-8"@@ -60,15 +63,39 @@              return $                TH.PromotedT ''SizedString `TH.AppT` strT `TH.AppT` byteCountT +-- | Create a 'SizedString' from a utf-8 string+utf82 :: TH.QuasiQuoter+utf82 = TH.QuasiQuoter undefined undefined mkSizedStr undefined+  where mkSizedStr :: String -> TH.Q TH.Type+        mkSizedStr str =+          do let strT = TH.LitT (TH.StrTyLit str)+                 byteCount =+                   fromIntegral (B.length (E.encodeUtf8 (T.pack str)))+                 byteCountT = TH.LitT (TH.NumTyLit byteCount)+             return $+               TH.PromotedT ''SizedString2 `TH.AppT` strT `TH.AppT` byteCountT++ instance   forall (size :: Nat)     (str :: Symbol)     (bytes :: Nat)-    (r :: Type)-    (f :: IsA (BitRecordField ('MkFieldCustom :: BitField ASizedString ASizedString size))) .+    (f :: Extends (BitRecordField ('MkFieldCustom :: BitField ASizedString ASizedString size))) .       (KnownSymbol str)-    => BitStringBuilderHoley (Proxy (f := 'MkASizedString str bytes)) r+    => HasFunctionBuilder BitBuilder (Proxy (f := 'MkASizedString str bytes))   where-    bitStringBuilderHoley _ =+    toFunctionBuilder _ =+      immediate (appendStrictByteString+                 (E.encodeUtf8 (T.pack (symbolVal (Proxy @str)))))++instance+  forall (size :: Nat)+    (str :: Symbol)+    (bytes :: Nat)+    (f :: Extends (BitField ASizedString ASizedString size)) .+      (KnownSymbol str)+    => HasFunctionBuilder BitBuilder (Proxy (f :=. 'MkASizedString str bytes))+  where+    toFunctionBuilder _ =       immediate (appendStrictByteString                  (E.encodeUtf8 (T.pack (symbolVal (Proxy @str)))))

@@ -0,0 +1,314 @@+{-# LANGUAGE UndecidableInstances #-}+-- | NamedStructure definition for sequences of bits.+--+-- This module provides the core data types and functions for+-- conversion of finite bit sequences from an to conventional (Haskell) data types.+--+-- Non-compressed, non-random finite bit sequences generated by programs are+-- usually compositions of bytes and multi byte words, and a ton of Haskell libraries+-- exist for the serialization and deserialization of ByteStrings.+--+-- This module allows the definition of a __structure__ i.e. a very simple grammar,+-- which allows functions in this library to read and write single bytes, words and bits.+--+-- Also complete bit sequence may be constructed or destructed from and to Haskell types.+--+-- Further more, the Record may contain dependent sub-sequences, for example to+-- express Record that precede a /length/ field before a repetitive block data.+--+-- Antother example for dependent sequences is /fields/ whose presence depends on+-- /flags/ preceding them.+--+-- This library is also designed with /zero copying/ in mind.+--+-- It should be emphasized that binary deserialization __is not__+-- to be confused with binary destructuring. While the former usually involves copying+-- all regular sub sequences from the input to a value of a certain type, the later+-- merely requires to peek into the sequeuence at a certain position and deserializing+-- a sub sequence. The starting position and the interpretation are governed by the+-- strucuture applied to the sequence.++module Data.Type.BitRecords.Structure where++import           Data.Int+import           Data.Kind                      ( Type )+import           Data.Kind.Extra+import           Data.Proxy+import           Data.Type.Pretty+import           Data.Word+import           GHC.TypeLits+import           Data.Type.Bool+import           Data.Type.Equality             (type (==))+import           Test.TypeSpec+import qualified Data.Type.BitRecords.Structure.TypeLits as Literal++-- | Phantom type for structures+data Structure (sizeType :: StructureSizeType) where+  MkVariableStructure :: Structure 'VarSize+  MkFixStructure :: Structure 'FixSize++-- | 'Structure's that have statically known fixed size.+type FixStructure = Structure 'FixSize++-- | 'Structure's that have __no__ statically known fixed size.+type VariableStructure = Structure 'VarSize++-- | Phantom type indicating that if a 'Structure' has a statically known size.+data StructureSizeType = VarSize | FixSize++-- | The number of bits that a structure with a predetermined fixed size requires.+type family GetStructureSize (t :: Extends (Structure 'FixSize)) :: Nat++-- | Support for Pretty Printing 'Structure' Types+type family PrettyStructure (struct :: Extends (Structure sizeType)) :: PrettyType+type instance ToPretty (struct :: Extends (Structure sizeType)) = PrettyStructure struct++-- | Empty Structure+data EmptyStructure :: Extends (Structure 'FixSize)++type instance GetStructureSize EmptyStructure = 0+type instance PrettyStructure EmptyStructure = 'PrettyEmpty+type instance GetStructureSize (Anonymous (Name name struct)) = GetStructureSize struct+type instance PrettyStructure (Anonymous (Name name struct)) = name <:> PrettyStructure struct++-- | A record is a list of fields, 'Name' 'Structure' composed of a list of other Record in natural order.+data Record :: [Extends (Named (Structure sizeType))] -> Extends (Structure sizeType)++type instance GetStructureSize (Record '[]) = 0+type instance GetStructureSize (Record (x ': xs)) = GetStructureSize (Anonymous x) + GetStructureSize (Record xs)+type instance PrettyStructure (Record xs) = "Record" <:$$--> PrettyRecord xs++-- | Compose 'Named' 'Structure's to a 'Record'.+type family (<>) (a :: Extends (Named (Structure sizeType))) (b :: k) :: Extends (Structure sizeType) where+  a <> (b :: Extends (Named (Structure sizeType))) = Record '[a, b]+  a <> (Record xs) = Record (a ': xs)++infixr 6 <>++-- | Internal function to render 'Record's+type family PrettyRecord (xs :: [Extends (Named (Structure sizeType))]) :: PrettyType where+  PrettyRecord '[] = 'PrettyEmpty+  PrettyRecord (x ': xs) =+    (PutStr "-" <+> PrettyStructure (Anonymous x)) <$$> PrettyRecord xs++-- | A fixed length sequence of bits.+data BitSequence (length :: Nat) :: Extends (Structure 'FixSize)++-- | Internal function to validate that a 'BitSequence' has a valid length.+type family WithValidBitSequenceLength (length :: Nat) (out :: k) :: k where+  WithValidBitSequenceLength length out =+    If (length <=? 64 && 1 <=? length )+      out+      (TypeError ('Text "invalid bit sequence length: " ':<>: 'ShowType length))++-- | An alias to construct a 'Name'd 'BitSequence' with the given number of bits+type family (//) (name :: Symbol) (length :: Nat) :: Extends (Named (Structure 'FixSize)) where+  name // length =+    WithValidBitSequenceLength length (Name name (BitSequence length))++infixr 7 //++type instance GetStructureSize (BitSequence length) =+  WithValidBitSequenceLength length length+type instance PrettyStructure (BitSequence length) =+  WithValidBitSequenceLength length (PutStr "BitSequence " <+> PutNat length)++-- | A constant, fixed length sequence of bits, generated by a type level 'LiteralFamily'.+data LiteralStructure a :: Extends (Structure 'FixSize)++type instance GetStructureSize (LiteralStructure (Literal.Value s k (x :: k))) = Literal.SizeOf s x+type instance PrettyStructure (LiteralStructure (Literal.Value s k (x :: k))) = "LiteralStructure" <:> Literal.Pretty s x+++-- | Pad a 'Structure' to a structure with a length being a multiple of the length of the literal.+data Padded (literal :: Either j j) (struct :: Extends (Structure 'FixSize)) :: Extends (Structure 'FixSize)++-- | Type function calculating the number of padding bits requred to pad @struct@ to a multiple of+-- literal size.+type family GetPaddingSize literal (struct :: Extends (Structure 'FixSize)) :: Nat where+  GetPaddingSize (Literal.Value s k (x :: k)) y =+    ((Literal.SizeOf s x) - ((GetStructureSize y) `Mod` (Literal.SizeOf s x))) `Mod` (Literal.SizeOf s x)++-- | Type function to validate that both arguments to 'Alias' have a valid length. The lengths are valid+-- iff the right hand side requires the same amount of bits as the left hand side.+-- If necessary, one can always pad the right hand side to match the left hand side using 'Padded'.+type family PaddedStructureValidateSize literal (rhs :: Extends (Structure 'FixSize)) (out :: k) :: k where+  PaddedStructureValidateSize (Literal.Value s k (x :: k)) rhs out =+    If (Literal.SizeOf s x == 0)+      (TypeError ('Text "Cannot use a literal of size 0: "+                  ':<>: 'ShowType (Literal.Value s k (x :: k))+                  ':<>: 'Text " to pad the structure: "+                  ':<>: 'ShowType rhs))+      out++type instance GetStructureSize (Padded (either literal) struct) =+  PaddedStructureValidateSize literal struct (GetPaddingSize literal struct + GetStructureSize struct)++type instance PrettyStructure (Padded (either literal) struct) =+  PrettyParens (PrettyStructure struct) <+> ("padded with" <:> PutNat (GetPaddingSize literal struct) <+> PutStr "bits.")++-- | Alias structures, the size of the an alias structure is equal to the size of both elements.+data Alias :: Extends (Structure 'FixSize) -> Extends (Structure 'FixSize)  -> Extends (Structure 'FixSize)++-- | Internal function to validate that both arguments to 'Alias' have a valid length. The lengths are valid+-- iff the right hand side requires the same amount of bits as the left hand side.+-- If necessary, one can always pad the right hand side to match the left hand side using 'Padded'.+type family AliasStructureValidateSize (lhs :: Extends (Structure 'FixSize)) (rhs :: Extends (Structure 'FixSize)) (out :: k) :: k where+  AliasStructureValidateSize lhs rhs out =+    If (GetStructureSize rhs == GetStructureSize lhs)+      out+      (TypeError ('Text "Cannot alias structures of different size " ':<>: 'ShowType rhs+                  ':<>: 'Text " requires " ':<>: 'ShowType (GetStructureSize rhs)+                  ':<>: 'Text " bits, but "  ':<>: 'ShowType lhs+                  ':<>: 'Text " requires " ':<>: 'ShowType (GetStructureSize lhs)+                  ':<>: 'Text " bits."))++type instance GetStructureSize (Alias lhs rhs) = AliasStructureValidateSize lhs rhs (GetStructureSize lhs)++type instance PrettyStructure (Alias lhs rhs) =+  AliasStructureValidateSize lhs rhs+    ("Alias" <:$$--> (PrettyStructure lhs <$$> PrettyStructure rhs))+++-- ** Integer Sequences++-- | A Wrapper for Haskell types. Users should implement the 'GetStructureSize' and 'Constructor' instances.+data TypeStructure :: Type -> Extends (Structure 'FixSize)++-- | An usigned 8-bit integer+type U8 = TypeStructure Word8+type instance GetStructureSize (TypeStructure Word8) = 8+type instance PrettyStructure (TypeStructure Word8) = ToPretty Word8++-- | A signed 8-bit integer+type S8 = TypeStructure Int8+type instance GetStructureSize (TypeStructure Int8) = 8+type instance PrettyStructure (TypeStructure Int8) = ToPretty Int8++-- | A single bit structure+type FlagStructure = TypeStructure Bool+type instance GetStructureSize (TypeStructure Bool) = 1+type instance PrettyStructure (TypeStructure Bool) = ToPretty Bool++-- | (Structure 'FixSize) holding integral numbers+data IntegerStructure :: Nat -> Sign -> Endianess -> Extends (Structure 'FixSize) where+  S16LE :: Int16 -> IntegerStructure 16 'Signed 'LE 'MkFixStructure+  S16BE :: Int16 -> IntegerStructure 16 'Signed 'BE 'MkFixStructure+  U16LE :: Word16 -> IntegerStructure 16 'Unsigned 'LE 'MkFixStructure+  U16BE :: Word16 -> IntegerStructure 16 'Unsigned 'BE 'MkFixStructure+  S32LE :: Int32 -> IntegerStructure 32 'Signed 'LE 'MkFixStructure+  S32BE :: Int32 -> IntegerStructure 32 'Signed 'BE 'MkFixStructure+  U32LE :: Word32 -> IntegerStructure 32 'Unsigned 'LE 'MkFixStructure+  U32BE :: Word32 -> IntegerStructure 32 'Unsigned 'BE 'MkFixStructure+  S64LE :: Int64 -> IntegerStructure 64 'Signed 'LE 'MkFixStructure+  S64BE :: Int64 -> IntegerStructure 64 'Signed 'BE 'MkFixStructure+  U64LE :: Word64 -> IntegerStructure 64 'Unsigned 'LE 'MkFixStructure+  U64BE :: Word64 -> IntegerStructure 64 'Unsigned 'BE 'MkFixStructure++-- | Endianess of an 'IntegerStructure'+data Endianess = LE | BE++-- | Integer sign of an 'IntegerStructure'+data Sign = Signed | Unsigned++-- | Internal function to ensure that the length of an 'IntegerStructure' is 16,32 or 64+type family IntegerStructureValidateLength (n :: Nat) (out :: k) where+  IntegerStructureValidateLength n out =+    If (n == 16) out (If (n == 32) out (If (n == 64) out+      (TypeError ('Text "Invalid IntegerStructure size: " ':<>: 'ShowType n))))++type instance GetStructureSize (IntegerStructure n s e) = IntegerStructureValidateLength n n+type instance PrettyStructure (IntegerStructure n s e) =+  IntegerStructureValidateLength n+    (PutStr "IntegerStructure"+    <+> PutNat n+    <+> If (s == 'Signed) (PutStr "Signed") (PutStr "Unsigned")+    <+> If (e == 'BE) (PutStr "BE") (PutStr "LE"))++-- | An unsigned integer structure+type U n e = IntegerStructure n 'Unsigned e++-- / A signed integer structure+type S n e = IntegerStructure n 'Signed e++-- | Conditional structure, since this is equivalent to 'If' this might be removed (TODO)+data ConditionalStructure (condition :: Bool) (ifStruct :: Extends (Structure 'FixSize)) (elseStruct :: Extends (Structure 'FixSize)) :: Extends (Structure 'FixSize)++type instance GetStructureSize (ConditionalStructure 'True l r) = GetStructureSize l+type instance GetStructureSize (ConditionalStructure 'False l r) = GetStructureSize r+type instance PrettyStructure (ConditionalStructure 'True l r) = PrettyStructure l+type instance PrettyStructure (ConditionalStructure 'False l r) = PrettyStructure r++-- * Structure PrettyType Printing++-- | Render @struct@ to a pretty, human readable form. Internally this is a wrapper+-- around 'ptShow' using 'PrettyStructure'.+showStructure+  :: forall proxy (struct :: Extends (Structure 'FixSize))+   . PrettyTypeShow (PrettyStructure struct)+  => proxy struct+  -> String+showStructure _ = showPretty (Proxy :: Proxy (PrettyStructure struct))++-- -------------------------------------------+-- Tests+-- -------------------------------------------++-- | Internal type used for unit tests+data BoolProxy (t :: Bool) where+  TrueProxy :: BoolProxy 'True+  FalseProxy :: BoolProxy 'False++_typeSpecGetStructureSize+  :: BoolProxy (testBool :: Bool)+  -> Expect [ GetStructureSize U8 `ShouldBe` 8+            , GetStructureSize EmptyStructure `ShouldBe` 0+            , GetStructureSize (Record [Name "x" U8, Name "y" U8]) `ShouldBe` 16+            , GetStructureSize (S 16 'BE) `ShouldBe` 16+            , GetStructureSize (ConditionalStructure testBool (U 32 'LE) S8) `ShouldBe` (If testBool 32 8)+            , GetStructureSize ("field 1"//3 <> "field 2"//2 <> "field 3"//5 <>+                          Name "field 4" ("field 4.1"//3 <> "field 4.2"//6))+                         `ShouldBe` 19+            , GetStructureSize (Alias (BitSequence 4) (LiteralStructure (Literal.Bits '[1,0,0,1]))) `ShouldBe` 4+            , GetStructureSize (Padded ('Left  (Literal.Bits '[1,0,1,0,1,0,1,0])) ("x"//1 <> "y"//2)) `ShouldBe` 8+            , GetStructureSize (Padded ('Right (Literal.Bits '[1,0,1,0,1,0,1,0])) (Anonymous ("x"//9))) `ShouldBe` 16+            , GetStructureSize (Padded ('Left  (Literal.Bits '[1,0,1,0,1,0,1,0])) (Anonymous ("x"//22))) `ShouldBe` 24+            , GetStructureSize (Padded ('Right (Literal.Bits '[1,0,1,0,1,0,1,0])) (Anonymous ("x"//33))) `ShouldBe` 40+            , GetStructureSize (Padded ('Right (Literal.To (Literal.Sequence Word8 Nat) '[0,255,0,255])) (Anonymous ("x"//10))) `ShouldBe` 32+            ]+_typeSpecGetStructureSize TrueProxy = Valid+_typeSpecGetStructureSize FalseProxy = Valid++_prettySpec :: String+_prettySpec =+  showPretty (Proxy @(+      PrettyHigh '[+         PrettyStructure EmptyStructure+       , PrettyStructure (Anonymous (Name "foo" U8))+       , PrettyStructure U8+       , PrettyStructure S8+       , PrettyStructure FlagStructure+       , PrettyStructure (S 16 'LE)+       , PrettyStructure (S 32 'LE)+       , PrettyStructure (S 64 'LE)+       , PrettyStructure (U 16 'LE)+       , PrettyStructure (U 32 'LE)+       , PrettyStructure (U 64 'LE)+       , PrettyStructure (S 16 'BE)+       , PrettyStructure (S 32 'BE)+       , PrettyStructure (S 64 'BE)+       , PrettyStructure (U 16 'BE)+       , PrettyStructure (U 32 'BE)+       , PrettyStructure (Padded ('Left (Literal.Bits '[1,0,1,0,1,0,1,0])) ("x"//2 <> "y"//7 <> "z"//5))+       , PrettyStructure (U 64 'BE)+       , PrettyStructure ("x"//32 <> "y"//32 <> "z"//8)+       , PrettyStructure (ConditionalStructure 'False S8 U8)+       , PrettyStructure (ConditionalStructure 'True S8 U8)+       , PrettyStructure (Alias S8 (Padded ('Left (Literal.To Word8 0)) (LiteralStructure (Literal.To Nat 123))))+       , PrettyStructure (Alias S8 (LiteralStructure (Literal.To Word8 123)))+       , PrettyStructure (Alias FlagStructure (LiteralStructure (Literal.To Literal.Bit 1)))+       , PrettyStructure (LiteralStructure (Literal.Bits '[1,0,1,0]))+       , PrettyStructure (Anonymous ("foo" :# U 64 'BE))+       ]+      )+    )

@@ -0,0 +1,166 @@+{-# LANGUAGE UndecidableInstances, TypeFamilyDependencies #-}+module Data.Type.BitRecords.Structure.Constructor+        ()+where++import           Data.Int+import           Data.Kind.Extra+import           Data.Kind+import           Data.Word+import           Data.Type.BitRecords.Structure+import           GHC.TypeLits+import qualified Data.Type.BitRecords.Structure.TypeLits+                                               as Literal++-- | The class accompanying 'Structure' derivatives that can be constructed via a function with corresponding+-- arguments, to some output (e.g. a ByteString).+--type family HasConstructor (t :: Extends (Structure sizeType))++-- | The type signature of a constructor (function) for a structure+type family Constructor (t :: Extends (Structure sizeType)) next :: k++type instance Constructor EmptyStructure next = next+type instance Constructor (Anonymous (Name name struct)) next = Constructor struct next+type instance Constructor (Record ('[] :: [Extends (Named (Structure sizeType))])) next = next+type instance Constructor (Record (x ': xs)) next = Constructor (Anonymous x) (Constructor (Record xs) next)+type instance Constructor (BitSequence length) next = WithValidBitSequenceLength length (Word64 -> next)+type instance Constructor (TypeStructure Bool) next = Bool -> next+type instance Constructor (TypeStructure Int8) next = Int8 -> next+type instance Constructor (LiteralStructure r) next = next+type instance Constructor (TypeStructure Word8) next = Word8 -> next+type instance Constructor (IntegerStructure n s e) next   =+  IntegerStructureValidateLength n (IntegerStructure n s e 'MkFixStructure -> next)+type instance Constructor (Alias s a) next = AliasStructureValidateSize s a next+type instance Constructor (ConditionalStructure 'True l r) next = Constructor l next+type instance Constructor (ConditionalStructure 'False l r) next = Constructor r next++_constructorSpec :: ()+_constructorSpec =+        (undefined :: Constructor U8 ()) (undefined :: Word8)+                <> (undefined :: Constructor S8 ()) (undefined :: Int8)+                <> (undefined :: Constructor FlagStructure ())+                           (undefined :: Bool)+                <> (undefined :: Constructor (S 16 'BE) ())+                           (undefined :: IntegerStructure+                                     16+                                     'Signed+                                     'BE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (U 16 'BE) ())+                           (undefined :: IntegerStructure+                                     16+                                     'Unsigned+                                     'BE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (S 16 'LE) ())+                           (undefined :: IntegerStructure+                                     16+                                     'Signed+                                     'LE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (U 16 'LE) ())+                           (undefined :: IntegerStructure+                                     16+                                     'Unsigned+                                     'LE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (S 32 'BE) ())+                           (undefined :: IntegerStructure+                                     32+                                     'Signed+                                     'BE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (U 32 'BE) ())+                           (undefined :: IntegerStructure+                                     32+                                     'Unsigned+                                     'BE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (S 32 'LE) ())+                           (undefined :: IntegerStructure+                                     32+                                     'Signed+                                     'LE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (U 32 'LE) ())+                           (undefined :: IntegerStructure+                                     32+                                     'Unsigned+                                     'LE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (S 64 'BE) ())+                           (undefined :: IntegerStructure+                                     64+                                     'Signed+                                     'BE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (U 64 'BE) ())+                           (undefined :: IntegerStructure+                                     64+                                     'Unsigned+                                     'BE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (S 64 'LE) ())+                           (undefined :: IntegerStructure+                                     64+                                     'Signed+                                     'LE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (U 64 'LE) ())+                           (undefined :: IntegerStructure+                                     64+                                     'Unsigned+                                     'LE+                                     'MkFixStructure+                           )+                <> (undefined :: Constructor (Anonymous (Name "foo" U8)) ())+                           (undefined :: Word8)+                <> (undefined :: Constructor+                             ( Alias+                                       ( Name "foo" U8 <> Name "bar" FlagStructure+                                       )+                                       (LiteralStructure (Literal.To Nat 256))+                             )+                             ()+                   )+                <> (undefined :: Constructor (Record '[]) ())+                <> (undefined :: Constructor EmptyStructure ())+                <> (undefined :: Constructor (BitSequence 15) ())+                           (undefined :: Word64)+                <> (undefined :: Constructor+                             (ConditionalStructure 'True (Record '[]) U8)+                             ()+                   )+                <> (undefined :: Constructor+                             (ConditionalStructure 'False (Record '[]) U8)+                             ()+                   )+                           (undefined :: Word8)+                <> (undefined :: Constructor+                             (Record '[Name "x" U8, Name "y" S8])+                             ()+                   )+                           (undefined :: Word8)+                           (undefined :: Int8)+                <> (undefined :: Constructor+                             (Name "x" U8 <> Name "y" S8 <> Name "z" S8)+                             ()+                   )+                           (undefined :: Word8)+                           (undefined :: Int8)+                           (undefined :: Int8)+                <> (undefined :: Constructor+                             (LiteralStructure (Literal.Bits '[1, 0, 1, 0]))+                             ()+                   )

@@ -0,0 +1,68 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.BitRecords.Structure.String+  ( FixSizeStringStructure+  , utf8Bits+  )+where++import qualified Language.Haskell.TH           as TH+import qualified Language.Haskell.TH.Quote     as TH+import           GHC.TypeLits+import           Data.Type.Pretty+import qualified Data.ByteString               as B+import qualified Data.Text                     as T+import qualified Data.Text.Encoding            as E+import           Data.Proxy+import           Data.Kind.Extra+import           Data.Type.BitRecords.Structure++-- TODO Refactor++-- * String Fields++-- | A type level symbol paired with a type level length, that determines how+-- many bits the representation will use.+-- The resulting structure has __exactly__ that size.+-- Note: That currently multibyte character support is missing.+data FixSizeStringStructure :: Nat -> Extends (Structure 'FixSize)++type instance GetStructureSize (FixSizeStringStructure size) = size++type instance PrettyStructure (FixSizeStringStructure size) =+     "FixSizeStringStructure"  <:> PutNat size <++> PutStr "bits"+++-- | Create a 'FixSizeStringStructure' from a utf-8 string+utf8Bits :: TH.QuasiQuoter+utf8Bits = TH.QuasiQuoter undefined undefined mkSizedStr undefined+ where+  mkSizedStr :: String -> TH.Q TH.Type+  mkSizedStr str = do+    let strT       = TH.LitT (TH.StrTyLit str)+        byteCount  = fromIntegral (B.length (E.encodeUtf8 (T.pack str)))+        byteCountT = TH.LitT (TH.NumTyLit byteCount)+    return $ TH.PromotedT ''FixSizeStringStructure `TH.AppT` strT `TH.AppT` byteCountT+++-- instance+--   forall (size :: Nat)+--     (str :: Symbol)+--     (bytes :: Nat)+--     (f :: Extends (BitRecordField ('MkFieldCustom :: BitField ASizedString ASizedString size))) .+--       (KnownSymbol str)+--     => HasFunctionBuilder BitBuilder (Proxy (f := 'MkASizedString str bytes))+--   where+--   toFunctionBuilder _ = immediate+--     (appendStrictByteString (E.encodeUtf8 (T.pack (symbolVal (Proxy @str)))))++-- instance+--   forall (size :: Nat)+--     (str :: Symbol)+--     (bytes :: Nat)+--     (f :: Extends (BitField ASizedString ASizedString size)) .+--       (KnownSymbol str)+--     => HasFunctionBuilder BitBuilder (Proxy (f :=. 'MkASizedString str bytes))+--   where+--   toFunctionBuilder _ = immediate+--     (appendStrictByteString (E.encodeUtf8 (T.pack (symbolVal (Proxy @str)))))

@@ -0,0 +1,219 @@+{-# LANGUAGE UndecidableInstances #-}+module Data.Type.BitRecords.Structure.TypeLits+  ( PositiveInt+  , NegativeInt+  , Bits+  , LiteralFamily(..)+  , To+  , Value+  , Empty+  , Bit+  , Byte+  , Signed(..)+  , SignedByte+  , SignedInteger+  , Sequence+  )+where++import           Data.Type.Bool+import           Data.Type.Equality+import           Data.Type.Pretty+import           Data.Kind+import           Data.Word+import           GHC.TypeLits+++-- * Type Level Literals++-- | A 'Positive' 'Signed' 'Nat'+type family PositiveInt (n :: Nat) where+  PositiveInt n = To (Signed Nat Nat) ('Positive n :: Signed Nat Nat)++-- | A 'Negative' 'Signed' 'Nat'+type family NegativeInt (n :: Nat) where+  NegativeInt n = To (Signed Nat Nat) ('Negative n :: Signed Nat Nat)++-- | A literal bit sequence. The sequence is validated, only+-- zeros and ones are allowed.+type family Bits (xs :: [Nat]) where+    Bits xs = To (Sequence Bit Nat) xs++-- * Type Family Supporting Type Level Literals++--+-- | A /kind/ class for /kinds/, that are /inhabited/ on  __type-level__ by a certain kind of literal.+--+-- [@a@] This parameter identifies the whole family; a type level literal kind of the family is determined by+-- that parameter. No two instances for the same family but with different type level literal kinds are+-- allowed.+--+-- [@typeLitKind@] This is the kind of __type level literals__ /representing/ the static values inhabiting+-- this family.+--+class LiteralFamily a typeLitKind | a -> typeLitKind where++  -- | A __predicate__ that is applied to a type-level-literal and is satisfied /iff/ the given literal+  -- is __in the range of valid type-level-literals__ of kind @typeLitKind@.+  --+  -- This is by 'SequenceLiteral' for example.+  type InRange a (typeLit :: typeLitKind) :: Bool+  type InRange a typeLit = 'True++  -- | Convert a type level representation to a 'PrettyType'+  type Pretty a (typeLit :: typeLitKind) :: PrettyType+  type Pretty a (typeLit :: typeLitKind) = ToPretty typeLit+    -- TODO decide to use or ditch this default: "TypeLiteral" <:$$--> ToPretty a <++> PutStr " " <++> ToPretty typeLit <++> PutStr "::" <++> ToPretty typeLitKind++  -- | Seperator to use when rendering a list of literals of this family.+  type PrettySeperator a (typeLit :: typeLitKind) :: PrettyType+  type PrettySeperator a d = 'PrettySpace++  -- | Return the number of bits that the literal value will occupy+  type SizeOf a (typeLit :: typeLitKind) :: Nat++-- | Make a valid 'Value' by checking the parameters using 'InRange' and return a 'Value'+type family To s (x :: k) where+  To s (x :: k) = If (InRange s x) (Value s k x)+    (TypeError ('Text "Cannot make a " ':<>: 'ShowType s ':<>: 'Text " from: " ':<>: 'ShowType x ))++-- | The representation of a /value/ belonging to a 'LiteralFamily'+data Value s k (x :: k) :: Type++type instance ToPretty (Value s k x) = Pretty s x++-- | An empty type literal+data Empty = Empty++type instance ToPretty Empty = PutStr "Empty"+type instance ToPretty 'Empty = PutStr "Empty"++instance LiteralFamily Empty Empty where+  type InRange Empty 'Empty = 'True+  type Pretty Empty 'Empty = 'PrettyEmpty+  type SizeOf Empty 'Empty = 0++instance LiteralFamily () () where+  type InRange () '() = 'True+  type Pretty () '() = 'PrettyEmpty+  type SizeOf () '() = 1++-- | A bit literal+data Bit++type instance ToPretty Bit = PutStr "Bit"++instance LiteralFamily Bit Nat where+  type InRange Bit n = ( n == 0 || n == 1 )+  type Pretty Bit n = PutNat n+  type SizeOf Bit _ = 1+  type PrettySeperator Bit _ = 'PrettyEmpty++-- | An unsigned byte literal+data Byte++type instance ToPretty Byte = PutStr "Byte"++instance LiteralFamily Byte Nat where+  type InRange Byte n = ( n <=? 255 )+  type Pretty Byte n = PutHex n+  type SizeOf Byte _ = 8++instance LiteralFamily Word8 Nat where+  type InRange Word8 n = ( n <=? 255 )+  type Pretty Word8 n = PutNat n+  type SizeOf Word8 _ = 8++instance LiteralFamily Word16 Nat where+  type InRange Word16 n = ( n <=? 65535 )+  type Pretty Word16 n = PutNat n+  type SizeOf Word16 _ = 16++instance LiteralFamily Nat Nat where+  type InRange Nat n = 'True+  type Pretty Nat n = PutNat n+  type SizeOf Nat x = NatSize x++instance LiteralFamily Bool Bool where+  type InRange Bool n = 'True+  type Pretty Bool n = ToPretty n+  type SizeOf Bool x = 1++instance (LiteralFamily as ak, LiteralFamily bs bk) => LiteralFamily (as, bs) (ak, bk) where+  type InRange (as, bs) '(a, b) = InRange as a && InRange bs b+  type Pretty (as, bs) '(a, b) = PrettyParens (PrettyWide '[Pretty as a, Pretty bs b])+  type SizeOf (as, bs) '(a, b) = SizeOf as a + SizeOf bs b++instance (LiteralFamily s k) => LiteralFamily (Maybe s) (Maybe k) where+  type InRange (Maybe s) 'Nothing = 'True+  type InRange (Maybe s) ('Just x) = InRange s x+  type Pretty (Maybe s) 'Nothing = ToPretty s <++> PutStr ":" <+> PutStr "n/a"+  type Pretty (Maybe s) ('Just x) = ToPretty s <++> PutStr ":" <+> Pretty s x+  type SizeOf (Maybe s) 'Nothing = 0+  type SizeOf (Maybe s) ('Just x) = SizeOf s x+++-- | The minimum  number of bits to represent the value+type family NatSize (value :: Nat) :: Nat where+  NatSize 0 = 1+  NatSize n = Log2 n + 1++-- | A signed type literal for family @t@ over GHC type literal @v@+data Signed t v = Positive v | Negative v++type instance ToPretty (Signed t v) = "Signed" <:> ToPretty t <+> ToPretty v+type instance ToPretty ('Positive v) = PutStr "+" <++> ToPretty v+type instance ToPretty ('Negative v) = PutStr "-" <++> ToPretty v+++instance LiteralFamily t v => LiteralFamily (Signed t v) (Signed t v) where+  type instance InRange (Signed t v) ( 'Positive x) = InRange t x+  type instance InRange (Signed t v) ( 'Negative x) = InRange t x+  type instance Pretty (Signed t v) ( 'Positive x) = PutStr "+" <+> Pretty t x+  type instance Pretty (Signed t v) ( 'Negative x) = PutStr "-" <+> Pretty t x+  type instance SizeOf (Signed t v) ( 'Positive x) = SizeOf t x + 1+  type instance SizeOf (Signed t v) ( 'Negative x) = SizeOf t x + 1++-- | A signed 'Byte'+type SignedByte = Signed Byte Nat++-- | A signed 'Nat'+type SignedInteger = Signed Nat Nat++-- ** Composite Literals++-- | A sequence of literals.+data Sequence s k++type instance ToPretty (Sequence t v) = "Sequence of" <:> ToPretty t++instance LiteralFamily s k => LiteralFamily (Sequence s k) [k] where+  type instance InRange (Sequence s k) xs = ValidateSequenceLiterals s xs xs++  type instance Pretty (Sequence s k) (bs :: [k]) =+    ToPretty (Sequence s k) <$$--> ToPrettySequenceLiterals s bs++  type instance PrettySeperator (Sequence s k) (     '[]  :: [k]) = 'PrettySpace+  type instance PrettySeperator (Sequence s k) ((x ': xs) :: [k]) = 'PrettyNewline++  type instance SizeOf (Sequence s k) (     '[]  :: [k]) = 0+  type instance SizeOf (Sequence s k) ((x ': xs) :: [k]) = SizeOf s x + SizeOf (Sequence s k) xs++-- | Validate recursivly all sequence members+type family ValidateSequenceLiterals s (all :: [k]) (x :: [k]) :: Bool+  where+    ValidateSequenceLiterals s ls '[] = 'True+    ValidateSequenceLiterals s ls (e ': xs) =+      If (InRange s e)+         (ValidateSequenceLiterals s ls xs)+         (TypeError ('Text "Error while validating the literal sequence of type: "+                     ':<>: 'ShowType s+                     ':<>: 'Text " with contents: "+                     ':<>: 'ShowType ls+                     ':<>: 'Text ", have an invalid element: "+                     ':<>: 'ShowType e))++-- | Prettify recursivly all sequence members+type family ToPrettySequenceLiterals s (x :: [k]) :: PrettyType where+  ToPrettySequenceLiterals s '[] = 'PrettyEmpty+  ToPrettySequenceLiterals s (x ': xs) = Pretty s x <++> PrettySeperator s x <++> ToPrettySequenceLiterals s xs

@@ -0,0 +1,181 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints  #-}+module Data.Type.BitRecords.Writer.ByteStringBuilder where++import Data.Type.BitRecords.BitBuffer64+import Data.FunctionBuilder+import Data.Type.BitRecords.Structure+import Data.Word+import Data.Bits+import Data.Kind.Extra+import Data.Proxy+import Data.Monoid+import Control.Category+import Prelude hiding ((.), id)+import qualified Data.ByteString.Builder as SB+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString as SB+import Text.Printf++import           Data.FunctionBuilder           ( FunctionBuilder )+import qualified Data.FunctionBuilder          as FunctionBuilder+++-- * 'BitBuffer64' construction from 'Extends (Structure sizeType's)++instance HasFunctionBuilder BitBuilder BitBuffer64 where+  toFunctionBuilder = immediate . appendBitBuffer64++newtype BitBuilder =+  BitBuilder {unBitBuilder :: Dual (Endo BitBuilderState)}+  deriving (Monoid, Semigroup)++data BitBuilderState where+        BitBuilderState ::+          !SB.Builder -> !BitBuffer64 -> !Word64 -> BitBuilderState++-- | A wrapper around a builder derived from a 'BitBuilderState'+data BuilderWithSize where+  MkBuilderWithSize :: !Word64 -> !SB.Builder -> BuilderWithSize++instance Semigroup BuilderWithSize where+  (MkBuilderWithSize !ls !lb) <> (MkBuilderWithSize !rs !rb) =+    MkBuilderWithSize (ls + rs) (lb <> rb)++instance Monoid BuilderWithSize where+  mempty = MkBuilderWithSize 0 mempty++-- | Create a 'SB.Builder' from a ('Structur sizeTypee') and store it in a 'BuilderWithSize'+bitBuilderWithSize ::+  forall (struct :: Extends (Structure sizeType)) .+  HasFunctionBuilder BitBuilder (Proxy struct)+  => Proxy struct+  -> ToFunction BitBuilder (Proxy struct) BuilderWithSize+bitBuilderWithSize = toFunction . builderBoxConstructor++-- | Like 'bitBuilderWithSize', but 'toFunction' the result and accept as an additional+-- parameter a wrapper function to wrap the final result (the 'BuilderWithSize') and+-- 'toFunction' the whole machiner.+wrapBitBuilderWithSize ::+  forall (struct :: Extends (Structure sizeType)) wrapped .+    HasFunctionBuilder BitBuilder (Proxy struct)+  => (BuilderWithSize -> wrapped)+  -> Proxy struct+  -> ToFunction BitBuilder (Proxy struct) wrapped+wrapBitBuilderWithSize !f !p = toFunction (mapAccumulator f (builderBoxConstructor p))++-- | Create a 'SB.Builder' from a 'Extends (Structure sizeType') and store it in a 'BuilderWithSize';+-- return a 'FunctionBuilder' monoid that does that on 'toFunction'+builderBoxConstructor ::+  forall (struct :: Extends (Structure sizeType)) r .+  HasFunctionBuilder BitBuilder (Proxy struct)+  => Proxy struct+  -> FunctionBuilder BuilderWithSize r (ToFunction BitBuilder (Proxy struct) r)+builderBoxConstructor !p =+  let fromBitBuilder !h =+        let (BitBuilderState !builder _ !wsize) =+              flushBitBuilder+              $ appBitBuilder h initialBitBuilderState+            !out = MkBuilderWithSize wsize builder+        in out+  in mapAccumulator fromBitBuilder (toFunctionBuilder p)++-- * Low-level interface to building 'Extends (Structure sizeType's) and other things+runBitBuilder+  :: BitBuilder -> SB.Builder+runBitBuilder !w =+  getBitBuilderStateBuilder $+  flushBitBuilder $ appBitBuilder w initialBitBuilderState++bitBuffer64Builder :: (BitBuilderState -> BitBuilderState)+                    -> BitBuilder+bitBuffer64Builder = BitBuilder . Dual . Endo++appBitBuilder :: BitBuilder+                    -> BitBuilderState+                    -> BitBuilderState+appBitBuilder !w = appEndo (getDual (unBitBuilder w))++getBitBuilderStateBuilder+  :: BitBuilderState -> SB.Builder+getBitBuilderStateBuilder (BitBuilderState !builder _ _) = builder++initialBitBuilderState+  :: BitBuilderState+initialBitBuilderState =+  BitBuilderState mempty emptyBitBuffer64 0++-- | Write the partial buffer contents using any number of 'word8' The unwritten+--   parts of the bittr buffer are at the top.  If the+--+-- >     63  ...  (63-off-1)(63-off)  ...  0+-- >     ^^^^^^^^^^^^^^^^^^^+-- > Relevant bits start to the top!+--+flushBitBuilder+  :: BitBuilderState -> BitBuilderState+flushBitBuilder (BitBuilderState !bldr !buff !totalSize) =+  BitBuilderState (writeRestBytes bldr 0)+                        emptyBitBuffer64+                        totalSize'+  where !off = bitBuffer64Length buff+        !off_ = (fromIntegral off :: Word64)+        !totalSize' = totalSize + signum (off_ `rem` 8) + (off_ `div` 8)+        !part = bitBuffer64Content buff+        -- write bytes from msb to lsb until the offset is reached+        -- >  63  ...  (63-off-1)(63-off)  ...  0+        -- >  ^^^^^^^^^^^^^^^^^^^+        -- >  AAAAAAAABBBBBBBBCCC00000+        -- >  |byte A| byte B| byte C|+        writeRestBytes !bldr' !flushOffset =+          if off <= flushOffset+             then bldr'+             else let !flushOffset' = flushOffset + 8+                      !bldr'' =+                        bldr' <>+                        SB.word8 (fromIntegral+                                 ((part `unsafeShiftR`+                                   (bitBuffer64MaxLength - flushOffset')) .&.+                                  0xFF))+                  in writeRestBytes bldr'' flushOffset'++-- | Write all the bits, in chunks, filling and writing the 'BitBuffer64'+-- in the 'BitBuilderState' as often as necessary.+appendBitBuffer64 :: BitBuffer64 -> BitBuilder+appendBitBuffer64 !x' =+  bitBuffer64Builder $+  \(BitBuilderState !builder !buff !totalSizeIn) -> go x' builder buff totalSizeIn+  where go !x !builder !buff !totalSize+          | bitBuffer64Length x == 0 = BitBuilderState builder buff totalSize+          | otherwise =+            let (!rest, !buff') = bufferBits x buff+            in if bitBuffer64SpaceLeft buff' > 0+                  then BitBuilderState builder buff' totalSize+                  else let !nextBuilder =+                             builder <>+                             SB.word64BE (bitBuffer64Content buff')+                           !totalSize' = totalSize + bitBuffer64MaxLengthBytes+                       in go rest nextBuilder emptyBitBuffer64 totalSize'++-- | Write all the b__y__tes, into the 'BitBuilderState' this allows general+-- purposes non-byte aligned builders.+appendStrictByteString :: SB.ByteString -> BitBuilder+appendStrictByteString !sb =+  foldMap (appendBitBuffer64 . bitBuffer64 8 . fromIntegral) (SB.unpack sb)++runBitBuilderHoley+  :: FunctionBuilder BitBuilder SB.Builder a -> a+runBitBuilderHoley (FB !x) = x runBitBuilder+++-- ** Tracing/Debug Printing++-- | Print a 'SB.Builder' to a space seperated series of hexa-decimal bytes.+printBuilder :: SB.Builder -> String+printBuilder b =+  ("<< " ++) $+  (++ " >>") $ unwords $ printf "%0.2x" <$> B.unpack (SB.toLazyByteString b)++bitBuffer64Printer :: HasFunctionBuilder BitBuilder a => a -> ToFunction BitBuilder a String+bitBuffer64Printer =+  toFunction . mapAccumulator (printBuilder . runBitBuilder) . toFunctionBuilder

@@ -6,7 +6,7 @@ extra-deps: - pretty-types-0.3.0.1 - type-spec-0.4.0.0-- function-builder-0.1.0.1+- function-builder-0.3.0.1  flags: {}