haskus-binary 1.4 → 1.5

raw patch · 99 files changed

+9134/−7865 lines, 99 filesdep −primitivePVP ok

version bump matches the API change (PVP)

Dependencies removed: primitive

API changes (from Hackage documentation)

Files

• haskus-binary.cabal +53/−44
• src/bench/BitReverse.hs +2/−2
• src/lib/Haskus/Binary/BitField.hs +369/−0
• src/lib/Haskus/Binary/BitSet.hs +296/−0
• src/lib/Haskus/Binary/Bits.hs +161/−0
• src/lib/Haskus/Binary/Bits/Bitwise.hs +85/−0
• src/lib/Haskus/Binary/Bits/Finite.hs +136/−0
• src/lib/Haskus/Binary/Bits/Get.hs +237/−0
• src/lib/Haskus/Binary/Bits/Helper.hs +21/−0
• src/lib/Haskus/Binary/Bits/Index.hs +100/−0
• src/lib/Haskus/Binary/Bits/Mask.hs +94/−0
• src/lib/Haskus/Binary/Bits/Order.hs +29/−0
• src/lib/Haskus/Binary/Bits/Put.hs +175/−0
• src/lib/Haskus/Binary/Bits/Reverse.hs +340/−0
• src/lib/Haskus/Binary/Bits/Rotate.hs +90/−0
• src/lib/Haskus/Binary/Bits/Shift.hs +324/−0
• src/lib/Haskus/Binary/Buffer.hs +353/−0
• src/lib/Haskus/Binary/BufferBuilder.hs +47/−0
• src/lib/Haskus/Binary/BufferList.hs +29/−0
• src/lib/Haskus/Binary/CTypes.hs +13/−0
• src/lib/Haskus/Binary/Char.hs +15/−0
• src/lib/Haskus/Binary/Endianness.hs +222/−0
• src/lib/Haskus/Binary/Enum.hs +144/−0
• src/lib/Haskus/Binary/Get.hs +237/−0
• src/lib/Haskus/Binary/Put.hs +89/−0
• src/lib/Haskus/Binary/Record.hs +208/−0
• src/lib/Haskus/Binary/Serialize.hs +135/−0
• src/lib/Haskus/Binary/Serialize/Buffer.hs +368/−0
• src/lib/Haskus/Binary/Serialize/File.hs +75/−0
• src/lib/Haskus/Binary/Serialize/Get.hs +142/−0
• src/lib/Haskus/Binary/Serialize/Put.hs +138/−0
• src/lib/Haskus/Binary/Serialize/Size.hs +35/−0
• src/lib/Haskus/Binary/Storable.hs +544/−0
• src/lib/Haskus/Binary/Union.hs +186/−0
• src/lib/Haskus/Binary/Unum.hs +737/−0
• src/lib/Haskus/Binary/Vector.hs +354/−0
• src/lib/Haskus/Format/Binary/BitField.hs +0/−365
• src/lib/Haskus/Format/Binary/BitSet.hs +0/−296
• src/lib/Haskus/Format/Binary/Bits.hs +0/−113
• src/lib/Haskus/Format/Binary/Bits/Bitwise.hs +0/−84
• src/lib/Haskus/Format/Binary/Bits/Finite.hs +0/−135
• src/lib/Haskus/Format/Binary/Bits/Get.hs +0/−236
• src/lib/Haskus/Format/Binary/Bits/Helper.hs +0/−21
• src/lib/Haskus/Format/Binary/Bits/Index.hs +0/−82
• src/lib/Haskus/Format/Binary/Bits/Mask.hs +0/−93
• src/lib/Haskus/Format/Binary/Bits/Order.hs +0/−29
• src/lib/Haskus/Format/Binary/Bits/Put.hs +0/−175
• src/lib/Haskus/Format/Binary/Bits/Reverse.hs +0/−339
• src/lib/Haskus/Format/Binary/Bits/Rotate.hs +0/−89
• src/lib/Haskus/Format/Binary/Bits/Shift.hs +0/−323
• src/lib/Haskus/Format/Binary/Buffer.hs +0/−350
• src/lib/Haskus/Format/Binary/BufferBuilder.hs +0/−47
• src/lib/Haskus/Format/Binary/BufferList.hs +0/−29
• src/lib/Haskus/Format/Binary/Char.hs +0/−15
• src/lib/Haskus/Format/Binary/Endianness.hs +0/−222
• src/lib/Haskus/Format/Binary/Enum.hs +0/−144
• src/lib/Haskus/Format/Binary/FixedPoint.hs +0/−81
• src/lib/Haskus/Format/Binary/Get.hs +0/−237
• src/lib/Haskus/Format/Binary/Layout.hs +0/−57
• src/lib/Haskus/Format/Binary/Posit.hs +0/−423
• src/lib/Haskus/Format/Binary/Ptr.hs +0/−186
• src/lib/Haskus/Format/Binary/Put.hs +0/−78
• src/lib/Haskus/Format/Binary/Record.hs +0/−207
• src/lib/Haskus/Format/Binary/Serialize.hs +0/−320
• src/lib/Haskus/Format/Binary/Serialize/Buffer.hs +0/−142
• src/lib/Haskus/Format/Binary/Storable.hs +0/−538
• src/lib/Haskus/Format/Binary/Union.hs +0/−185
• src/lib/Haskus/Format/Binary/Unum.hs +0/−737
• src/lib/Haskus/Format/Binary/VariableLength.hs +0/−94
• src/lib/Haskus/Format/Binary/Vector.hs +0/−352
• src/lib/Haskus/Format/Binary/Word.hs +0/−88
• src/lib/Haskus/Format/Number.hs +0/−8
• src/lib/Haskus/Format/Number/BitNat.hs +0/−342
• src/lib/Haskus/Format/Number/NaturalRange.hs +0/−195
• src/lib/Haskus/Memory/Allocator/Malloc.hs +1/−3
• src/lib/Haskus/Memory/Buffer.hs +266/−267
• src/lib/Haskus/Memory/Embed.hs +3/−3
• src/lib/Haskus/Memory/Layout.hs +166/−0
• src/lib/Haskus/Memory/Property.hs +37/−0
• src/lib/Haskus/Memory/Ptr.hs +187/−0
• src/lib/Haskus/Memory/Typed.hs +26/−0
• src/lib/Haskus/Memory/Utils.hs +80/−0
• src/lib/Haskus/Memory/View.hs +1/−1
• src/lib/Haskus/Number.hs +8/−0
• src/lib/Haskus/Number/BitNat.hs +389/−0
• src/lib/Haskus/Number/FixedPoint.hs +148/−0
• src/lib/Haskus/Number/Float.hs +58/−0
• src/lib/Haskus/Number/Int.hs +48/−0
• src/lib/Haskus/Number/NaturalRange.hs +195/−0
• src/lib/Haskus/Number/Posit.hs +423/−0
• src/lib/Haskus/Number/Signed.hs +166/−0
• src/lib/Haskus/Number/SignedSafe.hs +162/−0
• src/lib/Haskus/Number/VariableLength.hs +123/−0
• src/lib/Haskus/Number/Word.hs +47/−0
• src/lib/Haskus/Utils/Memory.hs +0/−72
• src/tests/Haskus/Tests/Common.hs +1/−1
• src/tests/Haskus/Tests/Format/Binary/Bits.hs +11/−10
• src/tests/Haskus/Tests/Format/Binary/GetPut.hs +2/−2
• src/tests/Haskus/Tests/Format/Binary/Vector.hs +3/−3

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                haskus-binary-version:             1.4+version:             1.5 synopsis:            Haskus binary format manipulation license:             BSD-3-Clause license-file:        LICENSE@@ -18,57 +18,68 @@  source-repository head   type: git-  location: git://github.com/haskus/haskus-packages.git+  location: git://github.com/haskus/packages.git  library   exposed-modules: -    Haskus.Format.Binary.Bits-    Haskus.Format.Binary.Bits.Finite-    Haskus.Format.Binary.Bits.Index-    Haskus.Format.Binary.Bits.Bitwise-    Haskus.Format.Binary.Bits.Reverse-    Haskus.Format.Binary.Bits.Rotate-    Haskus.Format.Binary.Bits.Shift-    Haskus.Format.Binary.Bits.Order-    Haskus.Format.Binary.Bits.Get-    Haskus.Format.Binary.Bits.Put-    Haskus.Format.Binary.Bits.Mask-    Haskus.Format.Binary.Bits.Helper+    Haskus.Binary.Bits+    Haskus.Binary.Bits.Finite+    Haskus.Binary.Bits.Index+    Haskus.Binary.Bits.Bitwise+    Haskus.Binary.Bits.Reverse+    Haskus.Binary.Bits.Rotate+    Haskus.Binary.Bits.Shift+    Haskus.Binary.Bits.Order+    Haskus.Binary.Bits.Get+    Haskus.Binary.Bits.Put+    Haskus.Binary.Bits.Mask+    Haskus.Binary.Bits.Helper -    Haskus.Format.Binary.BitSet-    Haskus.Format.Binary.BitField-    Haskus.Format.Binary.Buffer-    Haskus.Format.Binary.BufferList-    Haskus.Format.Binary.BufferBuilder-    Haskus.Format.Binary.Char-    Haskus.Format.Binary.Enum-    Haskus.Format.Binary.Endianness-    Haskus.Format.Binary.FixedPoint-    Haskus.Format.Binary.Get-    Haskus.Format.Binary.Put-    Haskus.Format.Binary.VariableLength-    Haskus.Format.Binary.Vector-    Haskus.Format.Binary.Union-    Haskus.Format.Binary.Unum-    Haskus.Format.Binary.Posit-    Haskus.Format.Binary.Record-    Haskus.Format.Binary.Storable-    Haskus.Format.Binary.Word-    Haskus.Format.Binary.Ptr-    Haskus.Format.Binary.Serialize-    Haskus.Format.Binary.Serialize.Buffer-    Haskus.Format.Binary.Layout+    Haskus.Binary.BitSet+    Haskus.Binary.BitField+    Haskus.Binary.Buffer+    Haskus.Binary.BufferList+    Haskus.Binary.BufferBuilder+    Haskus.Binary.Char+    Haskus.Binary.Enum+    Haskus.Binary.Endianness+    Haskus.Binary.Get+    Haskus.Binary.Put+    Haskus.Binary.Vector+    Haskus.Binary.Union+    Haskus.Binary.Unum+    Haskus.Binary.Record+    Haskus.Binary.Storable+    Haskus.Binary.Serialize+    Haskus.Binary.Serialize.Size+    Haskus.Binary.Serialize.Put+    Haskus.Binary.Serialize.Get+    Haskus.Binary.Serialize.Buffer+    Haskus.Binary.Serialize.File+    Haskus.Binary.CTypes -    Haskus.Format.Number-    Haskus.Format.Number.BitNat-    Haskus.Format.Number.NaturalRange+    Haskus.Number+    Haskus.Number.Word+    Haskus.Number.Int+    Haskus.Number.Float+    Haskus.Number.VariableLength+    Haskus.Number.Posit+    Haskus.Number.FixedPoint+    Haskus.Number.BitNat+    Haskus.Number.Signed+    Haskus.Number.SignedSafe+    Haskus.Number.NaturalRange -    Haskus.Utils.Memory+    Haskus.Memory.Utils     Haskus.Memory.Buffer     Haskus.Memory.Allocator.Malloc     Haskus.Memory.Embed+    Haskus.Memory.Layout     Haskus.Memory.View+    Haskus.Memory.Ptr+    Haskus.Memory.Property+    Haskus.Memory.Typed    other-modules: @@ -81,15 +92,13 @@       ,  cereal                    >= 0.5       ,  bytestring                >= 0.10       ,  mtl                       >= 2.2-      ,  primitive       ,  megaparsec       ,  template-haskell       ,  transformers       ,  directory       ,  filepath -  build-tools: -  ghc-options:          -Wall+  ghc-options:          -Wall -Wno-unticked-promoted-constructors   default-language:     Haskell2010   hs-source-dirs:       src/lib 

@@ -1,7 +1,7 @@  import Criterion.Main-import Haskus.Format.Binary.Bits.Reverse-import Haskus.Format.Binary.Word+import Haskus.Binary.Bits.Reverse+import Haskus.Number.Word  main :: IO () main = do

@@ -0,0 +1,369 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Bit fields (as in C)+--+-- This module allows you to define bit fields over words. For instance, you can+-- have a Word16 split into 3 fields X, Y and Z composed of 5, 9 and 2 bits+-- respectively.+--+-- @                  X             Y          Z   @+-- @ w :: Word16 |0 0 0 0 0|0 0 0 0 0 0 0 0 0|0 0| @+-- +-- You define it as follows:+--+-- @+-- {-# LANGUAGE DataKinds #-}+--+-- w :: BitFields Word16 '[ BitField 5 "X" Word8 +--                        , BitField 9 "Y" Word16+--                        , BitField 2 "Z" Word8+--                        ]+-- w = BitFields 0x0102+-- @+--+-- Note that each field has its own associated type (e.g. Word8 for X and Z)+-- that must be large enough to hold the number of bits for the field.+--+-- Operations on BitFields expect that the cumulated size of the fields is equal+-- to the whole word size: use a padding field if necessary. Otherwise you can+-- use unsafe versions of the functions: extractField', updateField',+-- withField'.+-- +-- You can extract and update the value of a field by its name:+--+-- @+-- x = extractField @"X" w+-- z = extractField @"Z" w+-- w' = updateField @"Y" 0x16 w+-- @+--+-- Fields can also be 'BitSet' or 'EnumField':+--+-- @+-- {-# LANGUAGE DataKinds #-}+--+-- data A = A0 | A1 | A2 | A3 deriving (Enum,CEnum)+--+-- data B = B0 | B1 deriving (Enum,BitOffset)+--+-- w :: BitFields Word16 '[ BitField 5 "X" (EnumField Word8 A)+--                        , BitField 9 "Y" Word16+--                        , BitField 2 "Z" (BitSet Word8 B)+--                        ]+-- w = BitFields 0x0102+-- @+--+module Haskus.Binary.BitField+   ( BitFields (..)+   , bitFieldsBits+   , BitField (..)+   , extractField+   , extractField'+   , updateField+   , updateField'+   , withField+   , withField'+   , matchFields+   , matchNamedFields+   , Field+   )+where++import Haskus.Binary.BitSet as BitSet+import Haskus.Binary.Enum+import Haskus.Number.Word+import Haskus.Number.Int+import Haskus.Binary.Bits+import Haskus.Binary.Storable+import Haskus.Utils.HList+import Haskus.Utils.Types+import Haskus.Utils.Tuple++-- | Bit fields on a base type b+newtype BitFields b (f :: [*]) = BitFields b deriving (Storable)++-- | Get backing word+bitFieldsBits :: BitFields b f -> b+{-# INLINABLE bitFieldsBits #-}+bitFieldsBits (BitFields b) = b+++-- | A field of n bits+newtype BitField (n :: Nat) (name :: Symbol) s = BitField s deriving (Storable)++-- | Get the bit offset of a field from its name+type family Offset (name :: Symbol) fs :: Nat where+   Offset name (BitField n name  s ': xs) = AddOffset xs+   Offset name (BitField n name2 s ': xs) = Offset name xs++type family AddOffset fs :: Nat where+   AddOffset '[]                        = 0+   AddOffset (BitField n name s ': xs)  = n + AddOffset xs++-- | Get the type of a field from its name+type family Output (name :: Symbol) fs :: * where+   Output name (BitField n name  s ': xs) = s+   Output name (BitField n name2 s ': xs) = Output name xs++-- | Get the size of a field from it name+type family Size (name :: Symbol) fs :: Nat where+   Size name (BitField n name  s ': xs) = n+   Size name (BitField n name2 s ': xs) = Size name xs++-- | Get the whole size of a BitFields+type family WholeSize fs :: Nat where+   WholeSize '[]                        = 0+   WholeSize (BitField n name s ': xs)  = n + WholeSize xs++type family BitFieldTypes xs where+   BitFieldTypes '[]                       = '[]+   BitFieldTypes (BitField n name s ': xs) = s ': BitFieldTypes xs++class Field f where+   fromField :: Integral b => f -> b+   toField   :: Integral b => b -> f++instance Field Bool where+   fromField True  = 1+   fromField False = 0+   toField 0  = False+   toField _  = True++instance Field Word where+   fromField = fromIntegral+   toField   = fromIntegral++instance Field Word8 where+   fromField = fromIntegral+   toField   = fromIntegral++instance Field Word16 where+   fromField = fromIntegral+   toField   = fromIntegral++instance Field Word32 where+   fromField = fromIntegral+   toField   = fromIntegral++instance Field Word64 where+   fromField = fromIntegral+   toField   = fromIntegral++instance Field Int where+   fromField = fromIntegral+   toField   = fromIntegral++instance Field Int8 where+   fromField = fromIntegral+   toField   = fromIntegral++instance Field Int16 where+   fromField = fromIntegral+   toField   = fromIntegral++instance Field Int32 where+   fromField = fromIntegral+   toField   = fromIntegral++instance Field Int64 where+   fromField = fromIntegral+   toField   = fromIntegral++instance (FiniteBits b, Integral b, BitOffset a) => Field (BitSet b a) where+   fromField = fromIntegral . BitSet.toBits+   toField   = BitSet.fromBits . fromIntegral++instance (Integral b, CEnum a) => Field (EnumField b a) where+   fromField = fromCEnum . fromEnumField+   toField   = toEnumField . toCEnum++-- | Get the value of a field+extractField :: forall (name :: Symbol) fields b .+   ( KnownNat (Offset name fields)+   , KnownNat (Size name fields)+   , WholeSize fields ~ BitSize b+   , Bits b, Integral b+   , Field (Output name fields)+   ) => BitFields b fields -> Output name fields+{-# INLINABLE extractField #-}+extractField = extractField' @name++-- | Get the value of a field (without checking sizes)+extractField' :: forall (name :: Symbol) fields b .+   ( KnownNat (Offset name fields)+   , KnownNat (Size name fields)+   , Bits b, Integral b+   , Field (Output name fields)+   ) => BitFields b fields -> Output name fields+{-# INLINABLE extractField' #-}+extractField' (BitFields w) = toField ((w `shiftR` off) .&. ((1 `shiftL` sz) - 1))+   where+      off = natValue @(Offset name fields)+      sz  = natValue @(Size name fields)+++-- | Set the value of a field+updateField :: forall name fields b .+   ( KnownNat (Offset name fields)+   , KnownNat (Size name fields)+   , WholeSize fields ~ BitSize b+   , Bits b, Integral b+   , Field (Output name fields)+   ) => Output name fields -> BitFields b fields -> BitFields b fields+{-# INLINABLE updateField #-}+updateField = updateField' @name++-- | Set the value of a field (without checking sizes)+updateField' :: forall name fields b .+   ( KnownNat (Offset name fields)+   , KnownNat (Size name fields)+   , Bits b, Integral b+   , Field (Output name fields)+   ) => Output name fields -> BitFields b fields -> BitFields b fields+{-# INLINABLE updateField' #-}+updateField' value (BitFields w) = BitFields $ ((fromField value `shiftL` off) .&. mask') .|. (w .&. complement mask')+   where+      off   = natValue @(Offset name fields)+      sz    = natValue @(Size name fields)+      mask' = ((1 `shiftL` sz) - 1) `shiftL` off+++-- | Modify the value of a field+withField :: forall name fields b f .+   ( KnownNat (Offset name fields)+   , KnownNat (Size name fields)+   , WholeSize fields ~ BitSize b+   , Bits b, Integral b+   , f ~ Output name fields+   , Field f+   ) => (f -> f) -> BitFields b fields -> BitFields b fields+{-# INLINABLE withField #-}+withField = withField' @name++-- | Modify the value of a field (without checking sizes)+withField' :: forall (name :: Symbol) fields b f .+   ( KnownNat (Offset name fields)+   , KnownNat (Size name fields)+   , Bits b, Integral b+   , f ~ Output name fields+   , Field f+   ) => (f -> f) -> BitFields b fields -> BitFields b fields+{-# INLINABLE withField' #-}+withField' f bs = updateField' @name (f v) bs+   where+      v = extractField' @name bs+++-------------------------------------------------------------------------------------+-- We use HFoldr' to extract each component and create a HList from it. Then we+-- convert it into a Tuple+-------------------------------------------------------------------------------------+data Extract = Extract+data Name    = Name++instance forall name bs b l l2 i (n :: Nat) s r w .+   ( bs ~ BitFields w l                    -- the bitfields+   , b ~ BitField n name s                 -- the current field+   , i ~ (bs, HList l2)                    -- input type+   , r ~ (bs, HList (Output name l ': l2)) -- result type+   , BitSize w ~ WholeSize l+   , Integral w, Bits w+   , KnownNat (Offset name l)+   , KnownNat (Size name l)+   , Field (Output name l)+   ) => Apply Extract (b, i) r where+      apply _ (_, (bs,xs)) =+         (bs, HCons (extractField @name bs) xs)++instance forall name bs b l l2 i (n :: Nat) s r w .+   ( bs ~ BitFields w l       -- the bitfields+   , b ~ BitField n name s    -- the current field+   , i ~ HList l2             -- input type+   , r ~ HList (String ': l2) -- result type+   , KnownSymbol name+   ) => Apply Name (b, i) r where+      apply _ (_, xs) = HCons (symbolValue @name) xs++fieldValues :: forall l l2 w bs .+   ( bs ~ BitFields w l+   , HFoldr' Extract (bs, HList '[]) l (bs, HList l2)+   ) => bs -> HList l2+fieldValues bs = snd res+   where+      res :: (bs, HList l2)+      res = hFoldr' Extract ((bs, HNil) :: (bs, HList '[])) (undefined :: HList l)++fieldNames :: forall l l2 w bs .+   ( bs ~ BitFields w l+   , HFoldr' Name (HList '[]) l (HList l2)+   ) => bs -> HList l2+fieldNames _ = hFoldr' Name (HNil :: HList '[]) (undefined :: HList l)++-- | Get values in a tuple+matchFields :: forall l l2 w bs t .+   ( bs ~ BitFields w l+   , HFoldr' Extract (bs, HList '[]) l (bs, HList l2)+   , HTuple l2+   , t ~ Tuple l2+   ) => bs -> t+matchFields = hToTuple @l2 . fieldValues+++-- | Get field names and values in a tuple+matchNamedFields ::forall lt lv ln lnv w bs t .+   ( bs ~ BitFields w lt+   , HFoldr' Extract (bs, HList '[]) lt (bs, HList lv)+   , HFoldr' Name (HList '[]) lt (HList ln)+   , HZipList ln lv lnv+   , HTuple lnv+   , t ~ Tuple lnv+   ) => bs -> t+matchNamedFields = hToTuple @lnv . matchNamedFields'++-- | Get field names and values in a tuple+matchNamedFields' ::forall lt lv ln lnv w bs .+   ( bs ~ BitFields w lt+   , HFoldr' Extract (bs, HList '[]) lt (bs, HList lv)+   , HFoldr' Name (HList '[]) lt (HList ln)+   , HZipList ln lv lnv+   ) => bs -> HList lnv+matchNamedFields' bs = hZipList names values+   where+      names  = fieldNames bs+      values = fieldValues bs++-- | Get field names and values in a tuple+instance forall lt ln lnv w bs.+   ( bs ~ BitFields w lt+   , ln ~ Replicate (Length lt) String+   , HFoldr' Extract (bs, HList '[]) lt (bs, HList (BitFieldTypes lt))+   , HFoldr' Name (HList '[]) lt (HList ln)+   , HZipList ln (BitFieldTypes lt) lnv+   , Show (HList lnv)+   ) => Show (BitFields w lt) where+      show bs = show (matchNamedFields' bs :: HList lnv)+++instance forall lt lt2 w bs.+   ( bs ~ BitFields w lt+   , HFoldr' Extract (bs, HList '[]) lt (bs, HList lt2)+   , Eq (HList lt2)+   , lt2 ~ BitFieldTypes lt+   ) => Eq (BitFields w lt) where+   (==) x y = x' == y'+      where+         x' :: HList lt2+         x' = fieldValues x+         y' :: HList lt2+         y' = fieldValues y

@@ -0,0 +1,296 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}++-- | A bit set based on Enum to name the bits. Use bitwise operations and+-- minimal storage in a safer way.+--+-- Similar to Data.Bitset.Generic from bitset package, but+--+--     * We don't have the Num constraint+--     * We dont use the deprecated bitSize function+--     * We use countTrailingZeros instead of iterating on the+--     number of bits+--     * We add a typeclass BitOffset+--+-- Example:+--+-- @+-- {-# LANGUAGE DeriveAnyClass #-}+-- data Flag+--    = FlagXXX+--    | FlagYYY+--    | FlagWWW+--    deriving (Show,Eq,Enum,BitOffset)+--+-- -- Adapt the backing type, here we choose Word16+-- type Flags = 'BitSet' Word16 Flag+-- @+--+-- Then you can convert (for free) a Word16 into Flags with 'fromBits' and+-- convert back with 'toBits'.+--+-- You can check if a flag is set or not with 'member' and 'notMember' and get+-- a list of set flags with 'toList'. You can 'insert' or 'delete' flags. You+-- can also perform set operations such as 'union' and 'intersection'.+--+module Haskus.Binary.BitSet+   ( BitSet+   , BitOffset (..)+   , null+   , empty+   , singleton+   , insert+   , delete+   , toBits+   , fromBits+   , member+   , elem+   , notMember+   , elems+   , intersection+   , union+   , unions+   , fromListToBits+   , toListFromBits+   , enumerateSetBits+   , fromList+   , toList+   )+where++import Prelude hiding (null,elem)++import qualified GHC.Exts as Ext++import Data.Foldable (foldl')++import Haskus.Binary.Bits+import Haskus.Binary.Storable++-- | A bit set: use bitwise operations (fast!) and minimal storage (sizeOf+-- basetype)+--+-- * b is the base type (Bits b)+-- * a is the element type (Enum a)+--+-- The elements in the Enum a are flags corresponding to each bit of b starting+-- from the least-significant bit.+newtype BitSet b a = BitSet b deriving (Eq,Ord,Storable)++instance+   ( Show a+   , BitOffset a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   ) => Show (BitSet b a)+   where+      show b = "fromList " ++ show (toList b)++-- | Indicate if the set is empty+null ::+   ( FiniteBits b+   , Eq b+   ) => BitSet b a -> Bool+{-# INLINABLE null #-}+null (BitSet b) = b == zeroBits+++-- | Empty bitset+empty :: (FiniteBits b) => BitSet b a+{-# INLINABLE empty #-}+empty = BitSet zeroBits+++-- | Create a BitSet from a single element+singleton :: (IndexableBits b, BitOffset a) => a -> BitSet b a+{-# INLINABLE singleton #-}+singleton e = BitSet $ bit (toBitOffset e)+++-- | Insert an element in the set+insert :: (IndexableBits b, BitOffset a) => BitSet b a -> a -> BitSet b a+{-# INLINABLE insert #-}+insert (BitSet b) e = BitSet $ setBit b (toBitOffset e)+++-- | Remove an element from the set+delete :: (IndexableBits b, BitOffset a) => BitSet b a -> a -> BitSet b a+{-# INLINABLE delete #-}+delete (BitSet b) e = BitSet $ clearBit b (toBitOffset e)+++-- | Unwrap the bitset+toBits :: BitSet b a -> b+toBits (BitSet b) = b++-- | Wrap a bitset+fromBits :: (BitOffset a, FiniteBits b) => b -> BitSet b a+fromBits = BitSet++-- | Test if an element is in the set+member ::+   ( BitOffset a+   , FiniteBits b+   , IndexableBits b+   ) => BitSet b a -> a -> Bool+{-# INLINABLE member #-}+member (BitSet b) e = testBit b (toBitOffset e)+++-- | Test if an element is in the set+elem ::+   ( BitOffset a+   , FiniteBits b+   , IndexableBits b+   ) => a -> BitSet b a -> Bool+{-# INLINABLE elem #-}+elem e (BitSet b) = testBit b (toBitOffset e)+++-- | Test if an element is not in the set+notMember ::+   ( BitOffset a+   , FiniteBits b+   , IndexableBits b+   ) => BitSet b a -> a -> Bool+{-# INLINABLE notMember #-}+notMember b e = not (member b e)+++-- | Retrieve elements in the set+elems ::+   ( BitOffset a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   ) => BitSet b a -> [a]+elems (BitSet b) = go b+   where+      go !c+         | c == zeroBits = []+         | otherwise     = let e = countTrailingZeros c in fromBitOffset e : go (clearBit c e)++-- | Intersection of two sets+intersection ::+   ( FiniteBits b+   , Bitwise b+   ) => BitSet b a -> BitSet b a -> BitSet b a+{-# INLINABLE intersection #-}+intersection (BitSet b1) (BitSet b2) = BitSet (b1 .&. b2)+++-- | Intersection of two sets+union ::+   ( FiniteBits b+   , Bitwise b+   ) => BitSet b a -> BitSet b a -> BitSet b a+{-# INLINABLE union #-}+union (BitSet b1) (BitSet b2) = BitSet (b1 .|. b2)+++-- | Intersection of several sets+unions ::+   ( FiniteBits b+   , Bitwise b+   ) => [BitSet b a] -> BitSet b a+{-# INLINABLE unions #-}+unions = foldl' union empty+++-- | Bit set indexed with a+class BitOffset a where+   -- | Return the bit offset of an element+   toBitOffset         :: a -> Word+   default toBitOffset :: Enum a => a -> Word+   toBitOffset         = fromIntegral . fromEnum++   -- | Return the value associated with a bit offset+   fromBitOffset         :: Word -> a+   default fromBitOffset :: Enum a => Word -> a+   fromBitOffset         = toEnum . fromIntegral++-- | It can be useful to get the indexes of the set bits+instance BitOffset Int where+   toBitOffset   = fromIntegral+   fromBitOffset = fromIntegral++-- | It can be useful to get the indexes of the set bits+instance BitOffset Word where+   toBitOffset   = id+   fromBitOffset = id+   +++-- | Convert a list of enum elements into a bitset Warning: b+-- must have enough bits to store the given elements! (we don't+-- perform any check, for performance reason)+fromListToBits ::+   ( BitOffset a+   , FiniteBits b+   , IndexableBits b+   , Foldable m+   ) => m a -> b+fromListToBits = toBits . fromList++-- | Convert a bitset into a list of Enum elements+toListFromBits ::+   ( BitOffset a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   ) => b -> [a]+toListFromBits = toList . BitSet++-- | Convert a bitset into a list of Enum elements by testing the Enum values+-- successively.+--+-- The difference with `toListFromBits` is that extra values in the BitSet will+-- be ignored.+enumerateSetBits ::+   ( BitOffset a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   , Bounded a+   , Enum a+   ) => b -> [a]+enumerateSetBits b = go [] [minBound..]+   where+      go rs []     = rs+      go rs (x:xs)+         | member (BitSet b) x = go (x:rs) xs+         | otherwise           = go rs xs++-- | Convert a set into a list+toList ::+   ( BitOffset a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   ) => BitSet b a -> [a]+toList = elems++-- | Convert a Foldable into a set+fromList ::+   ( BitOffset a+   , IndexableBits b+   , FiniteBits b+   , Foldable m+   ) => m a -> BitSet b a+fromList = foldl' insert (BitSet zeroBits)+++instance+   ( FiniteBits b+   , IndexableBits b+   , BitOffset a+   , Eq b+   ) => Ext.IsList (BitSet b a)+   where+      type Item (BitSet b a) = a+      fromList = fromList+      toList   = toList

@@ -0,0 +1,161 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}++-- | Operations on bits+module Haskus.Binary.Bits+   ( Bits+   , FiniteBits (..)+   , IndexableBits (..)+   , ShiftableBits (..)+   , SignedShiftableBits (..)+   , RotatableBits (..)+   , Bitwise (..)+   -- * Bit reversal+   , ReversableBits (..)+   , reverseBitsGeneric+   , reverseLeastBits+   -- * Mask+   , MaskBits (..)+   , Maskable+   , maskDyn+   , mask+   -- * String conversion+   , bitsToString+   , bitsToStringN+   , bitsFromString+   -- * Shift+   , getBitRange+   -- * Various+   , bitOffset+   , byteOffset+   , isPowerOfTwo+   , isPowerOfFour+   , getPowerOfTwo+   , getPowerOfFour+   )+where++import Haskus.Utils.List (foldl')+import Haskus.Utils.Types+import Haskus.Utils.Maybe+import Haskus.Binary.Bits.Finite+import Haskus.Binary.Bits.Index+import Haskus.Binary.Bits.Reverse+import Haskus.Binary.Bits.Rotate+import Haskus.Binary.Bits.Shift+import Haskus.Binary.Bits.Bitwise+import Haskus.Binary.Bits.Order+import Haskus.Binary.Bits.Mask+import Haskus.Binary.Bits.Helper++type Bits a =+   ( Eq a+   , FiniteBits a+   , IndexableBits a+   , ShiftableBits a+   , Bitwise a+   , RotatableBits a+   , KnownNat (BitSize a)+   , MaskBits a+   )++-- | Check if a number is a power of two (2^n)+--+-- >>> isPowerOfTwo (10 :: Word)+-- False+-- >>> isPowerOfTwo (16 :: Word)+-- True+isPowerOfTwo :: IndexableBits a => a -> Bool+isPowerOfTwo x = popCount x == 1++-- | Check if a number is a power of two (2^n) and return `n`+--+-- >>> getPowerOfTwo (10 :: Word)+-- Nothing+-- >>> getPowerOfTwo (16 :: Word)+-- Just 4+getPowerOfTwo :: (IndexableBits a, FiniteBits a) => a -> Maybe Word+getPowerOfTwo x+   | isPowerOfTwo x = Just (countTrailingZeros x)+   | otherwise      = Nothing++-- | Check if a number is a power of four (4^n)+--+-- >>> isPowerOfFour (10 :: Word)+-- False+-- >>> isPowerOfFour (16 :: Word)+-- True+isPowerOfFour :: (IndexableBits a, FiniteBits a) => a -> Bool+isPowerOfFour x = isJust (getPowerOfFour x)++-- | Check if a number is a power of four (4^n) and return `n`+--+-- >>> getPowerOfFour (10 :: Word)+-- Nothing+-- >>> getPowerOfFour (16 :: Word)+-- Just 2+getPowerOfFour :: (IndexableBits a, FiniteBits a) => a -> Maybe Word+getPowerOfFour x+   | popCount x == 1                -- test that a single bit is set to 1+   , let c = countTrailingZeros x   -- and that it is followed by an even+   , testBit c 0 == False           -- number of zeros+   = Just (c `shiftR` 1)+   | otherwise       = Nothing++-- | Reverse the @n@ least important bits of the given value. The higher bits+-- are set to 0.+reverseLeastBits ::+   ( ShiftableBits a+   , FiniteBits a+   , ReversableBits a+   , KnownNat (BitSize a)+   ) => Word -> a -> a+reverseLeastBits n value = reverseBits value `uncheckedShiftR` ((bitSize value) - n)++-- | Convert bits into a string composed of '0' and '1' chars+bitsToString :: forall a.+   ( FiniteBits a+   , IndexableBits a+   , KnownNat (BitSize a)+   ) => a -> String+bitsToString = bitsToStringN (natValue @(BitSize a))++-- | Convert a specified amount of bits into a string composed of '0' and '1' chars+bitsToStringN :: forall a.+   ( IndexableBits a+   ) => Word -> a -> String+bitsToStringN n x = fmap b [n-1, n-2 .. 0]+   where+      b v = if testBit x v then '1' else '0'++-- | Convert a string of '0' and '1' chars into a word+bitsFromString :: Bits a => String -> a+bitsFromString xs = foldl' b zeroBits (reverse xs `zip` [0..])+   where+      b x ('0',i) = clearBit x i+      b x ('1',i) = setBit x i+      b _ (c,_)   = error $ "Invalid character in the string: " ++ [c]+++-- | `getBitRange bo offset n c` takes n bits at offset in c and put them in the+-- least-significant bits of the result+getBitRange :: forall b.+   ( ShiftableBits b+   , ReversableBits b+   , FiniteBits b+   , KnownNat (BitSize b)+   , Bitwise b+   , MaskBits b+   ) => BitOrder -> Word -> Word -> b -> b+{-# INLINABLE getBitRange #-}+getBitRange bo o n c = case bo of+      BB -> maskDyn n $ c             `uncheckedShiftR` d+      BL -> maskDyn n $ reverseBits c `uncheckedShiftR` o+      LB -> maskDyn n $ reverseBits c `uncheckedShiftR` d+      LL -> maskDyn n $ c             `uncheckedShiftR` o+   where +      d  = bitSize c - n - o+

@@ -0,0 +1,85 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}++-- | Bitwise bit operations+module Haskus.Binary.Bits.Bitwise+   ( Bitwise (..)+   )+where++import Haskus.Number.Word+import Haskus.Number.Int+import GHC.Exts+import GHC.Num++-- | Bitwise bit operations+class Bitwise a where+   -- | Bitwise "and"+   (.&.) :: a -> a -> a++   -- | Bitwise "or"+   (.|.) :: a -> a -> a++   -- | Bitwise "xor"+   xor :: a -> a -> a+++instance Bitwise Word where+   (W# x#) .&.   (W# y#) = W# (x# `and#` y#)+   (W# x#) .|.   (W# y#) = W# (x# `or#` y#)+   (W# x#) `xor` (W# y#) = W# (x# `xor#` y#)++instance Bitwise Word8 where+   (W8# x#) .&.   (W8# y#) = W8# (x# `and#` y#)+   (W8# x#) .|.   (W8# y#) = W8# (x# `or#` y#)+   (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#)++instance Bitwise Word16 where+   (W16# x#) .&.   (W16# y#) = W16# (x# `and#` y#)+   (W16# x#) .|.   (W16# y#) = W16# (x# `or#` y#)+   (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#)++instance Bitwise Word32 where+   (W32# x#) .&.   (W32# y#) = W32# (x# `and#` y#)+   (W32# x#) .|.   (W32# y#) = W32# (x# `or#` y#)+   (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#)++instance Bitwise Word64 where+   (W64# x#) .&.   (W64# y#) = W64# (x# `and#` y#)+   (W64# x#) .|.   (W64# y#) = W64# (x# `or#` y#)+   (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#)++instance Bitwise Int where+   (I# x#) .&.   (I# y#) = I# (x# `andI#` y#)+   (I# x#) .|.   (I# y#) = I# (x# `orI#` y#)+   (I# x#) `xor` (I# y#) = I# (x# `xorI#` y#)++instance Bitwise Int8 where+   (I8# x#) .&.   (I8# y#) = I8# (word2Int# (int2Word# x# `and#` int2Word# y#))+   (I8# x#) .|.   (I8# y#) = I8# (word2Int# (int2Word# x# `or#`  int2Word# y#))+   (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#))++instance Bitwise Int16 where+   (I16# x#) .&.   (I16# y#) = I16# (word2Int# (int2Word# x# `and#` int2Word# y#))+   (I16# x#) .|.   (I16# y#) = I16# (word2Int# (int2Word# x# `or#`  int2Word# y#))+   (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#))++instance Bitwise Int32 where+   (I32# x#) .&.   (I32# y#) = I32# (word2Int# (int2Word# x# `and#` int2Word# y#))+   (I32# x#) .|.   (I32# y#) = I32# (word2Int# (int2Word# x# `or#`  int2Word# y#))+   (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#))++instance Bitwise Int64 where+   (I64# x#) .&.   (I64# y#) = I64# (word2Int# (int2Word# x# `and#` int2Word# y#))+   (I64# x#) .|.   (I64# y#) = I64# (word2Int# (int2Word# x# `or#`  int2Word# y#))+   (I64# x#) `xor` (I64# y#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#))++instance Bitwise Integer where+   (.&.)      = andInteger+   (.|.)      = orInteger+   xor        = xorInteger++instance Bitwise Natural where+   (.&.)      = andNatural+   (.|.)      = orNatural+   xor        = xorNatural

@@ -0,0 +1,136 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Types with finite bit count+module Haskus.Binary.Bits.Finite+   ( FiniteBits (..)+   )+where++import Haskus.Utils.Types+import Haskus.Number.Word+import Haskus.Number.Int+import GHC.Exts++#include "MachDeps.h"++-- | Type representable by a fixed amount of bits+class FiniteBits a where++   -- | Number of bits+   type BitSize a :: Nat++   -- | Number of bits (the value is ignored)+   bitSize :: (Integral i, KnownNat (BitSize a)) => a -> i+   bitSize _ = natValue @(BitSize a)+   +   -- | All bits set to 0+   zeroBits :: a++   -- | All bits set to 1+   oneBits :: a+   oneBits = complement zeroBits++   -- | Count number of zero bits preceding the most significant set bit+   countLeadingZeros :: a -> Word++   -- | Count number of zero bits following the least significant set bit+   countTrailingZeros :: a -> Word++   -- | Complement+   complement :: a -> a+++instance FiniteBits Word where+   type BitSize Word          = WORD_SIZE_IN_BITS+   zeroBits                   = 0+   oneBits                    = maxBound+   countLeadingZeros  (W# x#) = W# (clz# x#)+   countTrailingZeros (W# x#) = W# (ctz# x#)+   complement (W# x#)         = W# (x# `xor#` mb#)+      where !(W# mb#) = maxBound++instance FiniteBits Word8 where+   type BitSize Word8          = 8+   zeroBits                    = 0+   oneBits                     = maxBound+   countLeadingZeros  (W8# x#) = W# (clz8# x#)+   countTrailingZeros (W8# x#) = W# (ctz8# x#)+   complement (W8# x#)         = W8# (x# `xor#` mb#)+      where !(W8# mb#) = maxBound++instance FiniteBits Word16 where+   type BitSize Word16          = 16+   zeroBits                     = 0+   oneBits                      = maxBound+   countLeadingZeros  (W16# x#) = W# (clz16# x#)+   countTrailingZeros (W16# x#) = W# (ctz16# x#)+   complement (W16# x#)         = W16# (x# `xor#` mb#)+      where !(W16# mb#) = maxBound++instance FiniteBits Word32 where+   type BitSize Word32          = 32+   zeroBits                     = 0+   oneBits                      = maxBound+   countLeadingZeros  (W32# x#) = W# (clz32# x#)+   countTrailingZeros (W32# x#) = W# (ctz32# x#)+   complement (W32# x#)         = W32# (x# `xor#` mb#)+      where !(W32# mb#) = maxBound++instance FiniteBits Word64 where+   type BitSize Word64          = 64+   zeroBits                     = 0+   oneBits                      = maxBound+   countLeadingZeros  (W64# x#) = W# (clz64# x#)+   countTrailingZeros (W64# x#) = W# (ctz64# x#)+   complement (W64# x#)         = W64# (x# `xor#` mb#)+      where !(W64# mb#) = maxBound+++instance FiniteBits Int where+   type BitSize Int           = WORD_SIZE_IN_BITS+   zeroBits                   = 0+   oneBits                    = (-1)+   countLeadingZeros  (I# x#) = W# (clz# (int2Word# x#))+   countTrailingZeros (I# x#) = W# (ctz# (int2Word# x#))+   complement (I# x#)         = I# (notI# x#)++instance FiniteBits Int8 where+   type BitSize Int8           = 8+   zeroBits                    = 0+   oneBits                     = (-1)+   countLeadingZeros  (I8# x#) = W# (clz8# (int2Word# x#))+   countTrailingZeros (I8# x#) = W# (ctz8# (int2Word# x#))+   complement (I8# x#)         = I8# (word2Int# (not# (int2Word# x#)))++instance FiniteBits Int16 where+   type BitSize Int16           = 16+   zeroBits                     = 0+   oneBits                      = (-1)+   countLeadingZeros  (I16# x#) = W# (clz16# (int2Word# x#))+   countTrailingZeros (I16# x#) = W# (ctz16# (int2Word# x#))+   complement (I16# x#)         = I16# (word2Int# (not# (int2Word# x#)))++instance FiniteBits Int32 where+   type BitSize Int32           = 32+   zeroBits                     = 0+   oneBits                      = (-1)+   countLeadingZeros  (I32# x#) = W# (clz32# (int2Word# x#))+   countTrailingZeros (I32# x#) = W# (ctz32# (int2Word# x#))+   complement (I32# x#)         = I32# (word2Int# (not# (int2Word# x#)))++instance FiniteBits Int64 where+   type BitSize Int64           = 64+   zeroBits                     = 0+   oneBits                      = (-1)+   countLeadingZeros  (I64# x#) = W# (clz64# (int2Word# x#))+   countTrailingZeros (I64# x#) = W# (ctz64# (int2Word# x#))+   complement (I64# x#)         = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))

@@ -0,0 +1,237 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Bit getter+module Haskus.Binary.Bits.Get+   ( BitGetState(..)+   , newBitGetState+   , isEmpty+   , skipBits+   , skipBitsToAlignOnWord8+   , getBits+   , getBitsChecked+   , getBitsBuffer+   -- * Monadic+   , BitGet+   , BitGetT+   , runBitGet+   , runBitGetT+   , runBitGetPartialT+   , runBitGetPartial+   , resumeBitGetPartialT+   , resumeBitGetPartial+   , isEmptyM+   , skipBitsM+   , skipBitsToAlignOnWord8M+   , getBitsM+   , getBitsCheckedM+   , getBitBoolM+   , getBitsBSM+   , changeBitGetOrder+   , withBitGetOrder+   )+where++import System.IO.Unsafe (unsafePerformIO)+import Control.Monad.State+import Control.Monad.Identity+import Foreign.Marshal.Alloc (mallocBytes)+import Foreign.Ptr++import Haskus.Binary.Buffer+import Haskus.Binary.Bits.Order+import Haskus.Binary.Bits+import Haskus.Binary.Storable (poke)++-- | BitGet state+data BitGetState = BitGetState+   { bitGetStateInput      :: {-# UNPACK #-} !Buffer     -- ^ Input+   , bitGetStateBitOffset  :: {-# UNPACK #-} !Word       -- ^ Bit offset (0-7)+   , bitGetStateBitOrder   ::                !BitOrder   -- ^ Bit order+   } deriving (Show)++-- | Create a new BitGetState+newBitGetState :: BitOrder -> Buffer -> BitGetState+newBitGetState bo bs = BitGetState bs 0 bo++-- | Indicate that the source is empty+isEmpty :: BitGetState -> Bool+isEmpty (BitGetState bs o _) = o == 0 && isBufferEmpty bs++-- | Skip the given number of bits from the input+skipBits :: Word -> BitGetState -> BitGetState+skipBits o (BitGetState bs n bo) = BitGetState (bufferUnsafeDrop d bs) n' bo+   where+      !o' = n+o+      !d  = fromIntegral $ byteOffset o'+      !n' = bitOffset o'++-- | Skip the required number of bits to be aligned on 8-bits+skipBitsToAlignOnWord8 :: BitGetState -> BitGetState+skipBitsToAlignOnWord8 s = case bitGetStateBitOffset s of+   0 -> s+   n -> skipBits (8-n) s++-- | Read the given number of bits and put the result in a word+getBits :: (Integral a, Bits a) => Word -> BitGetState -> a+getBits nbits (BitGetState bs off bo) = rec zeroBits 0 bs off nbits+   where+      -- w   = current result+      -- n   = number of valid bits in w+      -- i   = input bytestring+      -- o   = bit offset in input bytestring+      -- r   = number of remaining bits to read+      rec w _ _ _ 0 = w+      rec w n i o r = rec nw (n+nb) (bufferTail i) o' (r-nb)+         where +            -- current Word8+            c  = bufferHead i+            -- number of bits to take from the current Word8+            nb = min (8-o) r+            -- bits taken from the current Word8 and put in correct order in least-significant bits+            tc = fromIntegral $ getBitRange bo o nb c+            -- mix new bits with the current result+            nw = case bo of+                  BB -> (w `shiftL` fromIntegral nb) .|. tc+                  LB -> (w `shiftL` fromIntegral nb) .|. tc+                  BL -> (tc `shiftL` fromIntegral n) .|. w+                  LL -> (tc `shiftL` fromIntegral n) .|. w+            -- new offset ((o + nb) `mod` 8)+            o' = bitOffset (o + nb)++-- | Perform some checks before calling getBits+--+-- Check that the number of bits to read is not greater than the first parameter+getBitsChecked :: (Integral a, Bits a, ReversableBits a) => Word -> Word -> BitGetState -> a+{-# INLINABLE getBitsChecked #-}+getBitsChecked m n s+   | n > m     = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")"+   | otherwise = getBits n s++-- | Read the given number of Word8 and return them in a Buffer+--+-- Examples:+-- @  BB: xxxABCDE FGHIJKLM NOPxxxxx -> ABCDEFGH IJKLMNOP @+-- @  LL: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP @+-- @  BL: xxxPONML KJIHGFED CBAxxxxx -> ABCDEFGH IJKLMNOP @+-- @  LB: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP @+getBitsBuffer :: Word -> BitGetState -> Buffer+getBitsBuffer n (BitGetState bs o bo) =+   if n == 0+      then emptyBuffer+      else+         let +            bs'  = bufferUnsafeTake (n+1) bs+            bs'' = bufferUnsafeTake n     bs+            rev  = bufferMap reverseBits+         in case (o,bo) of+            (0,BB) ->                     bs''+            (0,LL) ->       bufferReverse bs''+            (0,LB) -> rev                 bs''+            (0,BL) -> rev $ bufferReverse bs''+            (_,LL) ->                     getBitsBuffer n (BitGetState (bufferReverse bs') (8-o)  BB)+            (_,BL) -> rev . bufferReverse $ getBitsBuffer n (BitGetState bs'               o     BB)+            (_,LB) -> rev . bufferReverse $ getBitsBuffer n (BitGetState bs'               o     LL)+            (_,BB) -> unsafePerformIO $ do+               let len = n+1+               ptr <- mallocBytes (fromIntegral len)+               let f r i = do+                     let+                        w  = bufferUnsafeIndex bs (len-i)+                        w' = (w `shiftL` fromIntegral o) .|. r+                        r' = w `shiftR` (8-fromIntegral o)+                     poke (castPtr ptr `plusPtr` fromIntegral (len-i)) w'+                     return r'+               foldM_ f 0 [1..len]+               bufferUnsafeInit <$> bufferPackPtr len ptr++++-- | BitGet monad transformer+type BitGetT m a = StateT BitGetState m a++-- | BitGet monad+type BitGet a    = BitGetT Identity a++-- | Evaluate a BitGet monad+runBitGetT :: Monad m => BitOrder -> BitGetT m a -> Buffer -> m a+runBitGetT bo m bs = evalStateT m (newBitGetState bo bs)++-- | Evaluate a BitGet monad+runBitGet :: BitOrder -> BitGet a -> Buffer -> a+runBitGet bo m bs = runIdentity (runBitGetT bo m bs)++-- | Evaluate a BitGet monad, return the remaining state+runBitGetPartialT :: BitOrder -> BitGetT m a -> Buffer -> m (a, BitGetState)+runBitGetPartialT bo m bs = runStateT m (newBitGetState bo bs)++-- | Evaluate a BitGet monad, return the remaining state+runBitGetPartial :: BitOrder -> BitGet a -> Buffer -> (a, BitGetState)+runBitGetPartial bo m bs = runIdentity (runBitGetPartialT bo m bs)++-- | Resume a BitGet evaluation+resumeBitGetPartialT :: BitGetT m a -> BitGetState -> m (a, BitGetState)+resumeBitGetPartialT = runStateT ++-- | Resume a BitGet evaluation+resumeBitGetPartial :: BitGet a -> BitGetState -> (a,BitGetState)+resumeBitGetPartial m s = runIdentity (resumeBitGetPartialT m s)++-- | Indicate if all bits have been read+isEmptyM :: Monad m => BitGetT m Bool+isEmptyM = gets isEmpty++-- | Skip the given number of bits from the input (monadic version)+skipBitsM :: Monad m => Word -> BitGetT m ()+skipBitsM = modify . skipBits+++-- | Skip the required number of bits to be aligned on 8-bits (monadic version)+skipBitsToAlignOnWord8M :: Monad m =>  BitGetT m ()+skipBitsToAlignOnWord8M = modify skipBitsToAlignOnWord8++-- | Read the given number of bits and put the result in a word+getBitsM :: (Integral a, Bits a, Monad m) => Word -> BitGetT m a+getBitsM n = do+   v <- gets (getBits n)+   skipBitsM n+   return v++-- | Perform some checks before calling getBitsM+getBitsCheckedM :: (Integral a, Bits a, ReversableBits a, Monad m) => Word -> Word -> BitGetT m a+getBitsCheckedM m n = do+   v <- gets (getBitsChecked m n)+   skipBitsM n+   return v++-- | Get a bit and convert it into a Bool+getBitBoolM :: (Monad m) => BitGetT m Bool+getBitBoolM = do+   v <- getBitsM 1+   return ((v :: Word) == 1)++-- | Get the given number of Word8+getBitsBSM :: (Monad m) => Word -> BitGetT m Buffer+getBitsBSM n = do+   bs <- gets (getBitsBuffer n)+   skipBitsM (8*n)+   return bs++-- | Change the current bit ordering+--+-- Be careful to change the outer bit ordering (B* to L* or the inverse) only+-- on bytes boundaries! Otherwise, you will read the same bits more than once.+changeBitGetOrder :: Monad m => BitOrder -> BitGetT m ()+changeBitGetOrder bo = modify (\s -> s { bitGetStateBitOrder = bo })++-- | Change the bit ordering for the wrapped BitGet+--+-- Be careful, this function uses changeBitGetOrder internally.+withBitGetOrder :: Monad m => BitOrder -> BitGetT m a -> BitGetT m a+withBitGetOrder bo m = do+   bo' <- gets bitGetStateBitOrder+   changeBitGetOrder bo+   v <- m+   changeBitGetOrder bo'+   return v+

@@ -0,0 +1,21 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}++module Haskus.Binary.Bits.Helper+   ( bitOffset+   , byteOffset+   )+where++import Haskus.Binary.Bits.Shift+import Haskus.Binary.Bits.Mask++-- | Compute bit offset (equivalent to x `mod` 8 but faster)+bitOffset :: Word -> Word+{-# INLINABLE bitOffset #-}+bitOffset n = mask @3 n++-- | Compute byte offset (equivalent to x `div` 8 but faster)+byteOffset :: Word -> Word+{-# INLINABLE byteOffset #-}+byteOffset n = n `uncheckedShiftR` 3

@@ -0,0 +1,100 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}++-- | Bit indexable types+module Haskus.Binary.Bits.Index+   ( IndexableBits (..)+   )+where++import Haskus.Binary.Bits.Shift+import Haskus.Binary.Bits.Bitwise+import Haskus.Binary.Bits.Finite+import Haskus.Number.Word+import Haskus.Number.Int++import GHC.Exts+import qualified Data.Bits as BaseBits+import Numeric.Natural++-- | Type whose bits are indexable+class IndexableBits a where+   -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear.+   bit :: Word -> a+   default bit :: (Num a, ShiftableBits a) => Word -> a+   bit i = 1 `shiftL` i++   -- | @x \`setBit\` i@ is the same as @x .|. bit i@+   setBit :: a -> Word -> a+   default setBit :: (Bitwise a) => a -> Word -> a+   setBit a i = a .|. bit i++   -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@+   clearBit :: a -> Word -> a+   default clearBit :: (FiniteBits a,Bitwise a) => a -> Word -> a+   clearBit a i = a .&. complement (bit i)++   -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@+   complementBit :: a -> Word -> a+   default complementBit :: (Bitwise a) => a -> Word -> a+   complementBit a i = a `xor` bit i++   -- | Return 'True' if the @n@th bit of the argument is 1+   testBit :: a -> Word -> Bool+   default testBit :: (Bitwise a, Num a, Eq a) => a -> Word -> Bool+   testBit a i = (a .&. bit i) /= 0++   -- | Return the number of set bits+   popCount :: a -> Word+   default popCount :: (Bitwise a, Num a, Eq a) => a -> Word+   popCount = go 0+      where+         go !c 0 = c+         go c  w = go (c+1) (w .&. (w-1))+++instance IndexableBits Word where+   popCount (W# x#) = W# (popCnt# x#)++instance IndexableBits Word8 where+   popCount (W8# x#) = W# (popCnt8# x#)++instance IndexableBits Word16 where+   popCount (W16# x#) = W# (popCnt16# x#)++instance IndexableBits Word32 where+   popCount (W32# x#) = W# (popCnt32# x#)++instance IndexableBits Word64 where+   popCount (W64# x#) = W# (popCnt64# x#)++instance IndexableBits Int where+   popCount (I# x#) = W# (popCnt# (int2Word# x#))++instance IndexableBits Int8 where+   popCount (I8# x#) = W# (popCnt8# (int2Word# x#))++instance IndexableBits Int16 where+   popCount (I16# x#) = W# (popCnt16# (int2Word# x#))++instance IndexableBits Int32 where+   popCount (I32# x#) = W# (popCnt32# (int2Word# x#))++instance IndexableBits Int64 where+   popCount (I64# x#) = W# (popCnt64# (int2Word# x#))++instance IndexableBits Integer where+   -- we don't have access to Integer primitive (we would have to conditionally+   -- import integer-gmp or integer-simple like `base` does) so we use Data.Bits+   -- from `base` instead.+   testBit x i  = BaseBits.testBit x (fromIntegral i)+   bit i        = BaseBits.bit (fromIntegral i)+   popCount x   = fromIntegral (BaseBits.popCount x)+   clearBit x i = BaseBits.clearBit x (fromIntegral i)++instance IndexableBits Natural where+   testBit x i  = BaseBits.testBit x (fromIntegral i)+   bit i        = BaseBits.bit (fromIntegral i)+   popCount x   = fromIntegral (BaseBits.popCount x)+   clearBit x i = BaseBits.clearBit x (fromIntegral i)

@@ -0,0 +1,94 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}++module Haskus.Binary.Bits.Mask+   ( MaskBits (..)+   , makeMaskFinite+   , makeMask+   , maskDyn+   , Maskable+   , mask+   )+where++import Haskus.Binary.Bits.Finite+import Haskus.Binary.Bits.Shift+import Haskus.Binary.Bits.Bitwise+import Haskus.Number.Word+import Haskus.Number.Int+import Haskus.Utils.Types+import GHC.Natural++-- | makeMaskFinite 3 = 00000111+makeMaskFinite :: forall a.+   ( ShiftableBits a+   , FiniteBits a+   , KnownNat (BitSize a)+   , Bitwise a+   ) => Word -> a+{-# INLINABLE makeMaskFinite #-}+makeMaskFinite n = complement zeroBits `shiftR` off+   where+      off = natValue' @(BitSize a) - n++{-# SPECIALIZE makeMaskFinite :: Word -> Int #-}+{-# SPECIALIZE makeMaskFinite :: Word -> Int8 #-}+{-# SPECIALIZE makeMaskFinite :: Word -> Int16 #-}+{-# SPECIALIZE makeMaskFinite :: Word -> Int32 #-}+{-# SPECIALIZE makeMaskFinite :: Word -> Int64 #-}+{-# SPECIALIZE makeMaskFinite :: Word -> Word #-}+{-# SPECIALIZE makeMaskFinite :: Word -> Word8 #-}+{-# SPECIALIZE makeMaskFinite :: Word -> Word16 #-}+{-# SPECIALIZE makeMaskFinite :: Word -> Word32 #-}+{-# SPECIALIZE makeMaskFinite :: Word -> Word64 #-}++class MaskBits a where+   -- | Make a mask dynamically+   makeMaskDyn :: Word -> a++instance MaskBits Natural where+   makeMaskDyn n = mkNatural (replicate (fromIntegral q) c ++ [makeMaskFinite r])+      where+         c = complement zeroBits+         (q,r) = n `quotRem` 32++instance MaskBits Word   where makeMaskDyn = makeMaskFinite+instance MaskBits Word8  where makeMaskDyn = makeMaskFinite+instance MaskBits Word16 where makeMaskDyn = makeMaskFinite+instance MaskBits Word32 where makeMaskDyn = makeMaskFinite+instance MaskBits Word64 where makeMaskDyn = makeMaskFinite+instance MaskBits Int    where makeMaskDyn = makeMaskFinite+instance MaskBits Int8   where makeMaskDyn = makeMaskFinite+instance MaskBits Int16  where makeMaskDyn = makeMaskFinite+instance MaskBits Int32  where makeMaskDyn = makeMaskFinite+instance MaskBits Int64  where makeMaskDyn = makeMaskFinite++-- | Make a mask statically+makeMask :: forall n a.+   ( KnownNat n+   , MaskBits a+   ) => a+{-# INLINABLE makeMask #-}+makeMask = makeMaskDyn (natValue' @n)++-- | Keep only the n least-significant bits of the given value+maskDyn ::+   ( MaskBits a+   , Bitwise a+   ) => Word -> a -> a+{-# INLINABLE maskDyn #-}+maskDyn n v = v .&. makeMaskDyn n++-- | Keep only the n least-significant bits of the given value+mask :: forall n a. Maskable n a => a -> a+{-# INLINABLE mask #-}+mask v = v .&. makeMask @n++type Maskable n a =+   ( MaskBits a+   , Bitwise a+   , KnownNat n+   )

@@ -0,0 +1,29 @@+-- | Bit orderings+module Haskus.Binary.Bits.Order+   ( BitOrder(..)+   )+where++-- | Bit order+--+-- The first letter indicates the outer bit ordering, i.e. how bytes are filled:+--  +--  * B?: from left to right (B is for BigEndian)+--  * L?: from right to left (L is for LittleEndian)+--+-- The second letter indicates the inner bit ordering, i.e. how words are stored:+--   +--  * ?B: the most significant bit is stored first (in the outer bit order!)+--  * ?L: the least-significant bit is stored first (in the outer bit order!)+--+-- E.g. two successive words of 5 bits: ABCDE, VWXYZ+-- @ BB: ABCDEVWX YZxxxxxx @  +-- @ BL: EDCBAZYX WVxxxxxx @+-- @ LB: XWVEDCBA xxxxxxZY @+-- @ LL: XYZABCDE xxxxxxVW @+data BitOrder+   = BB+   | LB+   | BL+   | LL+   deriving (Show,Eq)

@@ -0,0 +1,175 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Bit putter+module Haskus.Binary.Bits.Put+   ( BitPutState(..)+   , newBitPutState+   , putBits+   , putBitsBuffer+   , getBitPutBuffer+   , getBitPutBufferList+   -- * Monadic+   , BitPut+   , BitPutT+   , runBitPut+   , runBitPutT+   , putBitsM+   , putBitBoolM+   , putBitsBufferM+   , changeBitPutOrder+   , withBitPutOrder+   )+where++import Control.Monad.State+import Control.Monad.Identity++import Haskus.Binary.BufferBuilder as B+import Haskus.Binary.Buffer+import Haskus.Number.Word+import Haskus.Binary.BufferList (BufferList)+import Haskus.Binary.Bits.Order+import Haskus.Binary.Bits+++-- | BitPut state+data BitPutState = BitPutState+   { bitPutStateBuilder          :: !BufferBuilder -- ^ Builder+   , bitPutStateCurrent          :: !Word8         -- ^ Current byte+   , bitPutStateOffset           :: !Word          -- ^ Current offset+   , bitPutStateBitOrder         :: !BitOrder      -- ^ Bit order+   }++-- | Create a new BitPut state+newBitPutState :: BitOrder -> BitPutState+newBitPutState = BitPutState mempty 0 0++-- | Put bits+putBits ::+   ( Integral a+   , Bits a+   , ReversableBits a+   ) => Word -> a -> BitPutState -> BitPutState+putBits n w s@(BitPutState builder b o bo) = s'+   where+      -- number of bits that will be stored in the current byte+      cn = min (8-o) n++      -- new state+      s' = case n of+            0 -> s+            _ -> putBits (n-cn) w' (flush (BitPutState builder b' (o+cn) bo))+      +      -- new current byte+      b' = shl (selectBits w) .|. b++      -- Word containing the remaining (n-cn) bits to store in its LSB+      w' = case bo of+         BB -> w+         BL -> w `shiftR` fromIntegral cn+         LL -> w `shiftR` fromIntegral cn+         LB -> w++      -- Select bits to store in the current byte.+      -- Put them in the correct order and return them in the least-significant+      -- bits of the returned value+      selectBits :: (Bits a, ReversableBits a, Integral a) => a -> Word8+      selectBits x = fromIntegral $ case bo of+         BB ->                       maskDyn cn $ x `shiftR` fromIntegral (n-cn)+         LB -> reverseLeastBits cn $ maskDyn cn $ x `shiftR` fromIntegral (n-cn)+         LL ->                       maskDyn cn x+         BL -> reverseLeastBits cn $ maskDyn cn x++      -- shift left at the correct position+      shl :: Word8 -> Word8+      shl x = case bo of+         BB -> x `shiftL` (8 - fromIntegral o - fromIntegral cn)+         BL -> x `shiftL` (8 - fromIntegral o - fromIntegral cn)+         LL -> x `shiftL` fromIntegral o+         LB -> x `shiftL` fromIntegral o++      -- flush the current byte if it is full+      flush s2@(BitPutState b2 w2 o2 bo2)+        | o2 == 8   = BitPutState (b2 `mappend` B.fromWord8 w2) 0 0 bo2+        | otherwise = s2+++-- | Put a Buffer+--+-- Examples: 3 bits are already written in the current byte+-- @  BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx @+-- @  LL: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC @+-- @  BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx @+-- @  LB: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON @+putBitsBuffer :: Buffer -> BitPutState -> BitPutState+putBitsBuffer bs s+   | isBufferEmpty bs = s+   | otherwise  = case s of+      (BitPutState builder b 0 BB) -> BitPutState (builder `mappend` B.fromBuffer bs) b 0 BB+      (BitPutState builder b 0 LL) -> BitPutState (builder `mappend` B.fromBuffer (bufferReverse bs)) b 0 LL+      (BitPutState builder b 0 LB) -> BitPutState (builder `mappend` B.fromBuffer (rev bs)) b 0 LB+      (BitPutState builder b 0 BL) -> BitPutState (builder `mappend` B.fromBuffer (rev (bufferReverse bs))) b 0 BL+      (BitPutState _ _ _ BB)       -> putBitsBuffer (bufferUnsafeTail bs) (putBits 8 (bufferUnsafeHead bs) s)+      (BitPutState _ _ _ LL)       -> putBitsBuffer (bufferUnsafeInit bs) (putBits 8 (bufferUnsafeLast bs) s)+      (BitPutState _ _ _ BL)       -> putBitsBuffer (bufferUnsafeInit bs) (putBits 8 (bufferUnsafeLast bs) s)+      (BitPutState _ _ _ LB)       -> putBitsBuffer (bufferUnsafeTail bs) (putBits 8 (bufferUnsafeHead bs) s)+   where+      rev    = bufferMap reverseBits++-- | Flush the current byte+flushIncomplete :: BitPutState -> BitPutState+flushIncomplete s@(BitPutState b w o bo)+  | o == 0    = s+  | otherwise = BitPutState (b `mappend` B.fromWord8 w) 0 0 bo++-- | Get a buffer list+getBitPutBufferList :: BitPutState -> BufferList+getBitPutBufferList = toBufferList . bitPutStateBuilder . flushIncomplete ++-- | Get a Buffer+getBitPutBuffer :: BitPutState -> Buffer+getBitPutBuffer =  toBuffer . bitPutStateBuilder . flushIncomplete++-- | BitPut monad transformer+type BitPutT m a = StateT BitPutState m a++-- | BitPut monad+type BitPut a    = BitPutT Identity a++-- | Evaluate a BitPut monad+runBitPutT :: Monad m => BitOrder -> BitPutT m a -> m Buffer+runBitPutT bo m = getBitPutBuffer <$> execStateT m (newBitPutState bo)++-- | Evaluate a BitPut monad+runBitPut :: BitOrder -> BitPut a -> Buffer+runBitPut bo m = runIdentity (runBitPutT bo m)++-- | Put bits (monadic)+putBitsM :: (Monad m, Integral a, Bits a, ReversableBits a) => Word -> a -> BitPutT m ()+putBitsM n w = modify (putBits n w)++-- | Put a single bit (monadic)+putBitBoolM :: (Monad m) => Bool -> BitPutT m ()+putBitBoolM b = putBitsM 1 (if b then 1 else  0 :: Word)++-- | Put a Buffer (monadic)+putBitsBufferM :: Monad m => Buffer -> BitPutT m ()+putBitsBufferM bs = modify (putBitsBuffer bs)++-- | Change the current bit ordering+--+-- Be careful to change the outer bit ordering (B* to L* or the inverse) only+-- on bytes boundaries! Otherwise, you will write the same bits more than once.+changeBitPutOrder :: Monad m => BitOrder -> BitPutT m ()+changeBitPutOrder bo = modify (\s -> s { bitPutStateBitOrder = bo })++-- | Change the bit ordering for the wrapped BitPut+--+-- Be careful, this function uses changeBitPutOrder internally.+withBitPutOrder :: Monad m => BitOrder -> BitPutT m a -> BitPutT m a+withBitPutOrder bo m = do+   bo' <- gets bitPutStateBitOrder+   changeBitPutOrder bo+   v <- m+   changeBitPutOrder bo'+   return v

@@ -0,0 +1,340 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Reverse bits+--+-- There are several algorithms performing the same thing here (reversing bits+-- into words of different sizes). There are benchmarks for them in the +-- "bench" directory. The fastest one for the current architecture should be+-- selected below. If you find that another algorithm is faster on your+-- architecture, please report it.+module Haskus.Binary.Bits.Reverse+   ( +   -- * Generic+     ReversableBits (..)+   , reverseBitsGeneric+   -- * Algorithms+   , reverseBitsObvious+   , reverseBits3Ops+   , reverseBits4Ops+   , reverseBitsTable+   , reverseBits7Ops+   , reverseBits5LgN+   , liftReverseBits+   )+where++import Haskus.Binary.Buffer+import Haskus.Number.Word+import Haskus.Number.Int+import Haskus.Binary.Bits.Finite+import Haskus.Binary.Bits.Shift+import Haskus.Binary.Bits.Bitwise+import Haskus.Binary.Bits.Index+import Haskus.Utils.Types (KnownNat)++---------------------------------------------------+-- Generic and specialized reverseBits+---------------------------------------------------+++-- | Reverse bits in a Word+reverseBitsGeneric ::+   ( FiniteBits a+   , Integral a+   , ShiftableBits a+   , Bitwise a+   , KnownNat (BitSize a)+   ) => a -> a+reverseBitsGeneric = liftReverseBits reverseBits4Ops++-- | Data whose bits can be reversed+class ReversableBits w where+   reverseBits :: w -> w++instance ReversableBits Word8 where+   reverseBits = reverseBits4Ops++instance ReversableBits Word16 where+   reverseBits = reverseBits5LgN++instance ReversableBits Word32 where+   reverseBits = reverseBits5LgN++instance ReversableBits Word64 where+   reverseBits = reverseBits5LgN++instance ReversableBits Word where+   reverseBits = reverseBits5LgN++instance ReversableBits Int8 where+   reverseBits = fromIntegral . reverseBits4Ops . fromIntegral++instance ReversableBits Int16 where+   reverseBits = reverseBits5LgN++instance ReversableBits Int32 where+   reverseBits = reverseBits5LgN++instance ReversableBits Int64 where+   reverseBits = reverseBits5LgN++instance ReversableBits Int where+   reverseBits = reverseBits5LgN+++---------------------------------------------------+-- Bit reversal algorithms+---------------------------------------------------++-- Algorithms and explanations adapted from:+-- http://graphics.stanford.edu/~seander/bithacks.html#ReverseByteWith64Bits++-- Reverse the bits the obvious way+-- ================================+--+--+-- unsigned int v;     // input bits to be reversed+-- unsigned int r = v; // r will be reversed bits of v; first get LSB of v+-- int s = sizeof(v) * CHAR_BIT - 1; // extra shift needed at end+-- +-- for (v >>= 1; v; v >>= 1)+-- {   +--   r <<= 1;+--   r |= v & 1;+--   s--;+-- }+-- r <<= s; // shift when v's highest bits are zero+--+-- On October 15, 2004, Michael Hoisie pointed out a bug in the original+-- version. Randal E. Bryant suggested removing an extra operation on May 3,+-- 2005. Behdad Esfabod suggested a slight change that eliminated one iteration+-- of the loop on May 18, 2005. Then, on February 6, 2007, Liyong Zhou+-- suggested a better version that loops while v is not 0, so rather than+-- iterating over all bits it stops early. ++-- | Obvious recursive version+reverseBitsObvious :: forall a.+   ( FiniteBits a+   , ShiftableBits a+   , IndexableBits a+   , Bitwise a+   , KnownNat (BitSize a)+   , Eq a+   ) => a -> a+reverseBitsObvious x = rec x (x `shiftR` 1) (bitSize x - 1)+   where+      rec :: FiniteBits a => a -> a -> Word -> a+      rec !r !v !s +         | v == zeroBits = r `shiftL` s+         | otherwise     = rec ((r `shiftL` 1) .|. (v .&. bit 0)) (v `shiftR` 1) (s - 1)++{-# SPECIALIZE reverseBitsObvious :: Word8  -> Word8  #-}+{-# SPECIALIZE reverseBitsObvious :: Word16 -> Word16 #-}+{-# SPECIALIZE reverseBitsObvious :: Word32 -> Word32 #-}+{-# SPECIALIZE reverseBitsObvious :: Word64 -> Word64 #-}++-- Reverse the bits in a byte with 3 operations (64-bit multiply and modulus division) +-- ===================================================================================+-- +-- unsigned char b; // reverse this (8-bit) byte+--  +-- b = (b * 0x0202020202ULL & 0x010884422010ULL) % 1023;+-- +-- The multiply operation creates five separate copies of the 8-bit byte+-- pattern to fan-out into a 64-bit value. The AND operation selects the bits+-- that are in the correct (reversed) positions, relative to each 10-bit groups+-- of bits. The multiply and the AND operations copy the bits from the original+-- byte so they each appear in only one of the 10-bit sets. The reversed+-- positions of the bits from the original byte coincide with their relative+-- positions within any 10-bit set. The last step, which involves modulus+-- division by 2^10 - 1, has the effect of merging together each set of 10 bits+-- (from positions 0-9, 10-19, 20-29, ...) in the 64-bit value. They do not+-- overlap, so the addition steps underlying the modulus division behave like+-- or operations.+-- +-- This method was attributed to Rich Schroeppel in the Programming Hacks+-- section of Beeler, M., Gosper, R. W., and Schroeppel, R. HAKMEM. MIT AI Memo+-- 239, Feb. 29, 1972.++-- | Reverse bits in a Word8 (3 64-bit operations, modulus division)+reverseBits3Ops :: Word8 -> Word8+{-# INLINABLE reverseBits3Ops #-}+reverseBits3Ops x = fromIntegral x'+   where+      !x' = ((fromIntegral x * 0x0202020202 :: Word64) .&. 0x010884422010) `mod` 1023+++-- Reverse the bits in a byte with 4 operations (64-bit multiply, no division) +-- ===========================================================================+--+-- unsigned char b; // reverse this (8-bit) byte+--  +-- b = ((b * 0x80200802ULL) & 0x0884422110ULL) * 0x0101010101ULL >> 32;+-- +-- The following shows the flow of the bit values with the boolean variables a,+-- b, c, d, e, f, g, and h, which comprise an 8-bit byte. Notice how the first+-- multiply fans out the bit pattern to multiple copies, while the last+-- multiply combines them in the fifth byte from the right. +--+--+--                                                                                         abcd efgh (-> hgfe dcba)+-- *                                                      1000 0000  0010 0000  0000 1000  0000 0010 (0x80200802)+-- -------------------------------------------------------------------------------------------------+--                                             0abc defg  h00a bcde  fgh0 0abc  defg h00a  bcde fgh0+-- &                                           0000 1000  1000 0100  0100 0010  0010 0001  0001 0000 (0x0884422110)+-- -------------------------------------------------------------------------------------------------+--                                             0000 d000  h000 0c00  0g00 00b0  00f0 000a  000e 0000+-- *                                           0000 0001  0000 0001  0000 0001  0000 0001  0000 0001 (0x0101010101)+-- -------------------------------------------------------------------------------------------------+--                                             0000 d000  h000 0c00  0g00 00b0  00f0 000a  000e 0000+--                                  0000 d000  h000 0c00  0g00 00b0  00f0 000a  000e 0000+--                       0000 d000  h000 0c00  0g00 00b0  00f0 000a  000e 0000+--            0000 d000  h000 0c00  0g00 00b0  00f0 000a  000e 0000+-- 0000 d000  h000 0c00  0g00 00b0  00f0 000a  000e 0000+-- -------------------------------------------------------------------------------------------------+-- 0000 d000  h000 dc00  hg00 dcb0  hgf0 dcba  hgfe dcba  hgfe 0cba  0gfe 00ba  00fe 000a  000e 0000+-- >> 32+-- -------------------------------------------------------------------------------------------------+--                                             0000 d000  h000 dc00  hg00 dcb0  hgf0 dcba  hgfe dcba  +-- &                                                                                       1111 1111+-- -------------------------------------------------------------------------------------------------+--                                                                                         hgfe dcba+-- Note that the last two steps can be combined on some processors because the+-- registers can be accessed as bytes; just multiply so that a register stores+-- the upper 32 bits of the result and the take the low byte. Thus, it may take+-- only 6 operations.+-- +-- Devised by Sean Anderson, July 13, 2001. ++-- | Reverse bits in a Word8 (4 64-bit operations, no division)+reverseBits4Ops :: Word8 -> Word8+{-# INLINABLE reverseBits4Ops #-}+reverseBits4Ops x = fromIntegral x'+   where+      !x' = (((fromIntegral x * 0x80200802 :: Word64) .&. 0x0884422110) * 0x0101010101) `shiftR` 32+++-- Reverse bits using a lookup table+-- =================================++-- | Reverse bits using a lookup table+reverseBitsTable :: Word8 -> Word8+{-# INLINABLE reverseBitsTable #-}+reverseBitsTable x = bitsTable `bufferIndex` (fromIntegral x)+++-- fill the table by using another method+bitsTable :: Buffer+bitsTable = bufferPackByteList $ fmap reverseBits4Ops [0..255]++-- Reverse the bits in a byte with 7 operations (no 64-bit)+-- ========================================================+-- +-- b = ((b * 0x0802LU & 0x22110LU) | (b * 0x8020LU & 0x88440LU)) * 0x10101LU >> 16; +-- +-- Make sure you assign or cast the result to an unsigned char to remove+-- garbage in the higher bits. Devised by Sean Anderson, July 13, 2001. Typo+-- spotted and correction supplied by Mike Keith, January 3, 2002. +++-- | Reverse bits in a Word8 (7 no 64-bit operations, no division)+reverseBits7Ops :: Word8 -> Word8+{-# INLINABLE reverseBits7Ops #-}+reverseBits7Ops b' = fromIntegral x'+   where+      b   = fromIntegral b' :: Word32+      !x' = ((((b * 0x0802) .&. 0x22110) .|. ((b * 0x8020) .&. 0x88440)) * 0x10101) `shiftR` 16+++-- Reverse an N-bit quantity in parallel in 5 * lg(N) operations+-- =============================================================+-- +-- unsigned int v; // 32-bit word to reverse bit order+-- +-- // swap odd and even bits+-- v = ((v >> 1) & 0x55555555) | ((v & 0x55555555) << 1);+-- // swap consecutive pairs+-- v = ((v >> 2) & 0x33333333) | ((v & 0x33333333) << 2);+-- // swap nibbles ... +-- v = ((v >> 4) & 0x0F0F0F0F) | ((v & 0x0F0F0F0F) << 4);+-- // swap bytes+-- v = ((v >> 8) & 0x00FF00FF) | ((v & 0x00FF00FF) << 8);+-- // swap 2-byte long pairs+-- v = ( v >> 16             ) | ( v               << 16);+-- +-- The following variation is also O(lg(N)), however it requires more+-- operations to reverse v. Its virtue is in taking less slightly memory by+-- computing the constants on the fly.+-- +-- unsigned int s = sizeof(v) * CHAR_BIT; // bit size; must be power of 2 +-- unsigned int mask = ~0;         +-- while ((s >>= 1) > 0) +-- {+--   mask ^= (mask << s);+--   v = ((v >> s) & mask) | ((v << s) & ~mask);+-- }+-- +-- These methods above are best suited to situations where N is large. If you+-- use the above with 64-bit ints (or larger), then you need to add more lines+-- (following the pattern); otherwise only the lower 32 bits will be reversed+-- and the result will be in the lower 32 bits.+-- +-- See Dr. Dobb's Journal 1983, Edwin Freed's article on Binary Magic Numbers+-- for more information. The second variation was suggested by Ken Raeburn on+-- September 13, 2005. Veldmeijer mentioned that the first version could do+-- without ANDS in the last line on March 19, 2006. ++-- | "Parallel" recursive version+reverseBits5LgN :: forall a.+   ( FiniteBits a+   , ShiftableBits a+   , Bitwise a+   , KnownNat (BitSize a)+   ) => a -> a+reverseBits5LgN x = rec (bitSize x `shiftR` 1) (complement zeroBits) x+   where+      rec :: FiniteBits a => Word -> a -> a -> a+      rec !s !mask !v+         | s <= 0        = v+         | otherwise     = rec (s `shiftR` 1) mask' v'+            where+               mask' = mask `xor` (mask `shiftL` s)+               v'    =      ((v `shiftR` s) .&. mask')+                        .|. ((v `shiftL` s) .&. complement mask')++{-# SPECIALIZE reverseBits5LgN :: Word8  -> Word8  #-}+{-# SPECIALIZE reverseBits5LgN :: Word16 -> Word16 #-}+{-# SPECIALIZE reverseBits5LgN :: Word32 -> Word32 #-}+{-# SPECIALIZE reverseBits5LgN :: Word64 -> Word64 #-}++++-- | Convert a function working on Word8 to one working on any Word+--+-- The number of bits in the Word must be a multiple of 8+liftReverseBits ::+   ( ShiftableBits a+   , Bitwise a+   , FiniteBits a+   , Integral a+   , KnownNat (BitSize a)+   ) => (Word8 -> Word8) -> a -> a+liftReverseBits f w = rec zeroBits 0+   where+      nb = bitSize w `shiftR` 3 -- div 8+      f' = fromIntegral . f . fromIntegral+      rec !v !o+         | o == nb    = v+         | otherwise = rec v' (o+1)+               where+                  -- multiplication by 8 replaced with (`shiftL` 3)+                  v' = v .|. ((f' (w `shiftR` (o `shiftL` 3))) `shiftL` ((nb-1-o) `shiftL` 3))++{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word8  -> Word8  #-}+{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word16 -> Word16 #-}+{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word32 -> Word32 #-}+{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word64 -> Word64 #-}+

@@ -0,0 +1,90 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Bit rotations+module Haskus.Binary.Bits.Rotate+   ( RotatableBits (..)+   )+where++import Haskus.Binary.Bits.Finite+import Haskus.Binary.Bits.Shift+import Haskus.Binary.Bits.Bitwise+import Haskus.Number.Word+import Haskus.Number.Int+import Haskus.Utils.Types++-- | Types whose bits can be rotated+class RotatableBits a where++   -- | Rotate left if positive, right if negative+   rotate :: a -> Int -> a+   default rotate ::+      ( FiniteBits a+      , KnownNat (BitSize a)+      ) => a -> Int -> a+   rotate a i+      | i' > 0     = rotateL a (fromIntegral i')+      | i' < 0     = rotateR a (fromIntegral (negate i'))+      | otherwise = a+      where+         i' = i `mod` bitSize a++   -- | Checked left bit rotation+   rotateL :: a -> Word -> a+   default rotateL ::+      ( FiniteBits a+      , KnownNat (BitSize a)+      ) => a -> Word -> a+   rotateL a n = uncheckedRotateL a (n `mod` bitSize a)++   -- | Checked right bit rotation+   rotateR :: a -> Word -> a+   default rotateR ::+      ( FiniteBits a+      , KnownNat (BitSize a)+      ) => a -> Word -> a+   rotateR a n = uncheckedRotateR a (n `mod` bitSize a)++   -- | Unchecked rotate left if positive, right if negative+   uncheckedRotate :: a -> Int -> a+   uncheckedRotate a i+      | i > 0     = uncheckedRotateL a (fromIntegral i)+      | i < 0     = uncheckedRotateR a (fromIntegral (negate i))+      | otherwise = a++   -- | Unchecked left bit rotation+   uncheckedRotateL :: a -> Word -> a+   default uncheckedRotateL ::+      ( ShiftableBits a+      , FiniteBits a+      , KnownNat (BitSize a)+      , Bitwise a+      ) => a -> Word -> a+   uncheckedRotateL a i = (a `uncheckedShiftL` i) .|. (a `uncheckedShiftR` (n-i))+      where n = bitSize a+      ++   -- | Unchecked right bit rotation+   uncheckedRotateR :: a -> Word -> a+   default uncheckedRotateR ::+      ( ShiftableBits a+      , FiniteBits a+      , KnownNat (BitSize a)+      , Bitwise a+      ) => a -> Word -> a+   uncheckedRotateR a i = (a `uncheckedShiftL` (n-i)) .|. (a `uncheckedShiftR` i)+      where n = bitSize a+++instance RotatableBits Word+instance RotatableBits Word8+instance RotatableBits Word16+instance RotatableBits Word32+instance RotatableBits Word64++instance RotatableBits Int+instance RotatableBits Int8+instance RotatableBits Int16+instance RotatableBits Int32+instance RotatableBits Int64

@@ -0,0 +1,324 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP #-}++-- | Bit shifts+module Haskus.Binary.Bits.Shift+   ( ShiftableBits (..)+   , SignedShiftableBits (..)+   )+where++import Haskus.Number.Word+import Haskus.Number.Int+import GHC.Exts+import GHC.Num++#include "MachDeps.h"++-- | Bit shifts+--+-- "Checked" means that there is an additional test to ensure that the shift+-- offset is valid (less than the bit count). If you are sure that the offset is+-- valid, use the "unchecked" version which should be faster.+--+-- To shift signed numbers, see `SignedShiftableBits` class methods.+class ShiftableBits a where+   -- | Checked right shift+   shiftR :: a -> Word -> a++   -- | Checked left shift+   shiftL :: a -> Word -> a++   -- | Unchecked right shift+   uncheckedShiftR :: a -> Word -> a++   -- | Unchecked left shift+   uncheckedShiftL :: a -> Word -> a++   -- | Checked shift to the left if positive, to the right if negative+   shift :: a -> Int -> a+   shift a i+      | i > 0     = shiftL a (fromIntegral i)+      | i < 0     = shiftR a (fromIntegral (negate i))+      | otherwise = a++   -- | Unchecked shift to the left if positive, to the right if negative+   uncheckedShift :: a -> Int -> a+   uncheckedShift a i+      | i > 0     = uncheckedShiftL a (fromIntegral i)+      | i < 0     = uncheckedShiftR a (fromIntegral (negate i))+      | otherwise = a++-- | Signed bit shifts+--+-- "Signed" means that the sign bit (the higher order bit):+--    - propagates to the right during right shifts and +--    - keeps its value during left shifts (except when all other bits are 0)+--+-- "Checked" means that there is an additional test to ensure that the shift+-- offset is valid (less than the bit count). If you are sure that the offset is+-- valid, use the "unchecked" version which should be faster.+class SignedShiftableBits a where+   -- | Checked signed right shift+   signedShiftR :: a -> Word -> a++   -- | Checked signed left shift+   signedShiftL :: a -> Word -> a++   -- | Unchecked signed right shift+   uncheckedSignedShiftR :: a -> Word -> a++   -- | Unchecked signed left shift+   uncheckedSignedShiftL :: a -> Word -> a++   -- | Checked signed shift to the left if positive, to the right if negative+   signedShift :: a -> Int -> a+   signedShift a i+      | i > 0     = signedShiftL a (fromIntegral i)+      | i < 0     = signedShiftR a (fromIntegral (negate i))+      | otherwise = a++   -- | Unchecked signed shift to the left if positive, to the right if negative+   uncheckedSignedShift :: a -> Int -> a+   uncheckedSignedShift a i+      | i > 0     = uncheckedSignedShiftL a (fromIntegral i)+      | i < 0     = uncheckedSignedShiftR a (fromIntegral (negate i))+      | otherwise = a+++instance ShiftableBits Word where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (W# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = W# 0##+      | otherwise                                  = W# (x# `uncheckedShiftL#` word2Int# i#)+   (W# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = W# 0##+      | otherwise                                  = W# (x# `uncheckedShiftRL#` word2Int# i#)+   (W# x#) `uncheckedShiftL` (W# i#) = W# (x# `uncheckedShiftL#` word2Int# i#)+   (W# x#) `uncheckedShiftR` (W# i#) = W# (x# `uncheckedShiftRL#` word2Int# i#)++instance ShiftableBits Word8 where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (W8# x#) `shiftL` (W# i#)+      | isTrue# (i# `geWord#` 8##)    = W8# 0##+      | otherwise                     = W8# (narrow8Word# (x# `uncheckedShiftL#` word2Int# i#))++   (W8# x#) `uncheckedShiftL` (W# i#) = W8# (narrow8Word# (x# `uncheckedShiftL#` word2Int# i#))+   +   (W8# x#) `shiftR` (W# i#)+      | isTrue# (i# `geWord#` 8##)    = W8# 0##+      | otherwise                     = W8# (x# `uncheckedShiftRL#` word2Int# i#)+   +   (W8# x#) `uncheckedShiftR` (W# i#) = W8# (x# `uncheckedShiftRL#` word2Int# i#)++instance ShiftableBits Word16 where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (W16# x#) `shiftL` (W# i#)+      | isTrue# (i# `geWord#` 16##)    = W16# 0##+      | otherwise                      = W16# (narrow16Word# (x# `uncheckedShiftL#` word2Int# i#))++   (W16# x#) `uncheckedShiftL` (W# i#) = W16# (narrow16Word# (x# `uncheckedShiftL#` word2Int# i#))+   +   (W16# x#) `shiftR` (W# i#)+      | isTrue# (i# `geWord#` 16##)    = W16# 0##+      | otherwise                      = W16# (x# `uncheckedShiftRL#` word2Int# i#)+   +   (W16# x#) `uncheckedShiftR` (W# i#) = W16# (x# `uncheckedShiftRL#` word2Int# i#)++instance ShiftableBits Word32 where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (W32# x#) `shiftL` (W# i#)+      | isTrue# (i# `geWord#` 32##)    = W32# 0##+      | otherwise                      = W32# (narrow32Word# (x# `uncheckedShiftL#` word2Int# i#))++   (W32# x#) `uncheckedShiftL` (W# i#) = W32# (narrow32Word# (x# `uncheckedShiftL#` word2Int# i#))+   +   (W32# x#) `shiftR` (W# i#)+      | isTrue# (i# `geWord#` 32##)    = W32# 0##+      | otherwise                      = W32# (x# `uncheckedShiftRL#` word2Int# i#)+   +   (W32# x#) `uncheckedShiftR` (W# i#) = W32# (x# `uncheckedShiftRL#` word2Int# i#)++instance ShiftableBits Word64 where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (W64# x#) `shiftL` (W# i#)+      | isTrue# (i# `geWord#` 64##)    = W64# 0##+      | otherwise                      = W64# (x# `uncheckedShiftL#` word2Int# i#)++   (W64# x#) `uncheckedShiftL` (W# i#) = W64# (x# `uncheckedShiftL#` word2Int# i#)+   +   (W64# x#) `shiftR` (W# i#)+      | isTrue# (i# `geWord#` 64##)    = W64# 0##+      | otherwise                      = W64# (x# `uncheckedShiftRL#` word2Int# i#)+   +   (W64# x#) `uncheckedShiftR` (W# i#) = W64# (x# `uncheckedShiftRL#` word2Int# i#)+++instance ShiftableBits Int where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (I# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = I# 0#+      | otherwise                                  = I# (x# `uncheckedIShiftL#` word2Int# i#)++   (I# x#) `uncheckedShiftL` (W# i#)               = I# (x# `uncheckedIShiftL#` word2Int# i#)+   +   (I# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = I# 0#+      | otherwise                                  = I# (x# `uncheckedIShiftRL#` word2Int# i#)+   +   (I# x#) `uncheckedShiftR` (W# i#)               = I# (x# `uncheckedIShiftRL#` word2Int# i#)++instance ShiftableBits Int8 where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (I8# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` 8##)    = I8# 0#+      | otherwise                     = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#))++   (I8# x#) `uncheckedShiftL` (W# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#))+   +   (I8# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` 8##)    = I8# 0#+      | otherwise                     = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))++   (I8# x#) `uncheckedShiftR` (W# i#) = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))+   ++instance ShiftableBits Int16 where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (I16# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` 16##)    = I16# 0#+      | otherwise                      = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#))++   (I16# x#) `uncheckedShiftL` (W# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#))+   +   (I16# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` 16##)    = I16# 0#+      | otherwise                      = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))++   (I16# x#) `uncheckedShiftR` (W# i#) = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))+++instance ShiftableBits Int32 where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (I32# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` 32##)    = I32# 0#+      | otherwise                      = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#))++   (I32# x#) `uncheckedShiftL` (W# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#))+   +   (I32# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` 32##)    = I32# 0#+      | otherwise                      = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))++   (I32# x#) `uncheckedShiftR` (W# i#) = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))++instance ShiftableBits Int64 where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   (I64# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` 64##)    = I64# 0#+      | otherwise                      = I64# (x# `uncheckedIShiftL#` word2Int# i#)++   (I64# x#) `uncheckedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL#` word2Int# i#)+   +   (I64# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` 64##)    = I64# 0#+      | otherwise                      = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#))++   (I64# x#) `uncheckedShiftR` (W# i#) = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#))+++instance SignedShiftableBits Int where+   (I# x#) `signedShiftL`          (W# i#) = I# (x# `iShiftL#` word2Int# i#)+   (I# x#) `signedShiftR`          (W# i#) = I# (x# `iShiftRA#` word2Int# i#)+   (I# x#) `uncheckedSignedShiftL` (W# i#) = I# (x# `uncheckedIShiftL#` word2Int# i#)+   (I# x#) `uncheckedSignedShiftR` (W# i#) = I# (x# `uncheckedIShiftRA#` word2Int# i#)++instance SignedShiftableBits Int8 where+   (I8# x#) `signedShiftL`          (W# i#) = I8# (narrow8Int# (x# `iShiftL#` word2Int# i#))+   (I8# x#) `signedShiftR`          (W# i#) = I8# (x# `iShiftRA#` word2Int# i#)+   (I8# x#) `uncheckedSignedShiftL` (W# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#))+   (I8# x#) `uncheckedSignedShiftR` (W# i#) = I8# (x# `uncheckedIShiftRA#` word2Int# i#)++instance SignedShiftableBits Int16 where+   (I16# x#) `signedShiftL`          (W# i#) = I16# (narrow16Int# (x# `iShiftL#` word2Int# i#))+   (I16# x#) `signedShiftR`          (W# i#) = I16# (x# `iShiftRA#` word2Int# i#)+   (I16# x#) `uncheckedSignedShiftL` (W# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#))+   (I16# x#) `uncheckedSignedShiftR` (W# i#) = I16# (x# `uncheckedIShiftRA#` word2Int# i#)++instance SignedShiftableBits Int32 where+   (I32# x#) `signedShiftL`          (W# i#) = I32# (narrow32Int# (x# `iShiftL#` word2Int# i#))+   (I32# x#) `signedShiftR`          (W# i#) = I32# (x# `iShiftRA#` word2Int# i#)+   (I32# x#) `uncheckedSignedShiftL` (W# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#))+   (I32# x#) `uncheckedSignedShiftR` (W# i#) = I32# (x# `uncheckedIShiftRA#` word2Int# i#)++instance SignedShiftableBits Int64 where+   (I64# x#) `signedShiftL`          (W# i#) = I64# (x# `iShiftL#` word2Int# i#)+   (I64# x#) `signedShiftR`          (W# i#) = I64# (x# `iShiftRA#` word2Int# i#)+   (I64# x#) `uncheckedSignedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL#` word2Int# i#)+   (I64# x#) `uncheckedSignedShiftR` (W# i#) = I64# (x# `uncheckedIShiftRA#` word2Int# i#)++++instance ShiftableBits Integer where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   x `shiftL` (W# i#) = shiftLInteger x (word2Int# i#)+   x `shiftR` (W# i#) = shiftRInteger x (word2Int# i#)++   uncheckedShiftL = shiftL+   uncheckedShiftR = shiftR++instance ShiftableBits Natural where+   {-# INLINABLE shiftR #-}+   {-# INLINABLE shiftL #-}+   {-# INLINABLE uncheckedShiftL #-}+   {-# INLINABLE uncheckedShiftR #-}++   x `shiftL` (W# i#) = shiftLNatural x (I# (word2Int# i#))+   x `shiftR` (W# i#) = shiftRNatural x (I# (word2Int# i#))++   uncheckedShiftL = shiftL+   uncheckedShiftR = shiftR

@@ -0,0 +1,353 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}++-- | A memory buffer with a fixed address+--+-- A buffer is a strict ByteString but with:+--+--   * a better interface: use Word instead of Int for sizes+--   * a better name: "string" is misleading+--   * some additional primitives+module Haskus.Binary.Buffer+   ( Buffer (..)+   , withBufferPtr+   , bufferSize+   , isBufferEmpty+   , emptyBuffer+   , bufferZero+   , bufferMap+   , bufferReverse+   , bufferDrop+   , bufferTail+   , bufferAppend+   , bufferCons+   , bufferSnoc+   , bufferInit+   , bufferSplitOn+   , bufferHead+   , bufferIndex+   , bufferTake+   , bufferTakeWhile+   , bufferTakeAtMost+   , bufferZipWith+   , bufferDup+   -- * Peek / Poke+   , bufferPeekStorable+   , bufferPeekStorableAt+   , bufferPopStorable+   , bufferPoke+   -- * Packing / Unpacking+   , bufferPackByteString+   , bufferPackByteList+   , bufferPackStorable+   , bufferPackStorableList+   , bufferPackPtr+   , bufferUnpackByteList+   , bufferUnpackByteString+   -- * Unsafe+   , bufferUnsafeDrop+   , bufferUnsafeTake+   , bufferUnsafeTail+   , bufferUnsafeHead+   , bufferUnsafeLast+   , bufferUnsafeInit+   , bufferUnsafeIndex+   , bufferUnsafeMapMemory+   , bufferUnsafeUsePtr+   , bufferUnsafePackPtr+   -- * IO+   , bufferReadFile+   , bufferWriteFile+   )+where++import Prelude hiding (length)++import System.IO.Unsafe+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import Foreign.Ptr+import Foreign.Marshal.Alloc (mallocBytes)++import Haskus.Number.Word+import Haskus.Binary.Storable+import Haskus.Binary.Bits.Helper+import Haskus.Binary.Bits.Bitwise+import Haskus.Binary.Bits.Index+import Haskus.Binary.Bits.Shift+import Haskus.Memory.Utils (memCopy,memSet)+import Haskus.Utils.List as List+import Haskus.Utils.Flow++-- | A buffer+newtype Buffer = Buffer ByteString deriving (Eq,Ord)++instance Show Buffer where+   show b = concatMap bToHex (bufferUnpackByteList b)+      where+         bToHex x = toHex (x `shiftR` 4) ++ toHex (x .&. 0x0F)+         toHex 0xA = "A"+         toHex 0xB = "B"+         toHex 0xC = "C"+         toHex 0xD = "D"+         toHex 0xE = "E"+         toHex 0xF = "F"+         toHex x   = show x++instance Bitwise Buffer where+   (.&.)      = bufferZipWith (.&.)+   (.|.)      = bufferZipWith (.|.)+   xor        = bufferZipWith xor++instance IndexableBits Buffer where+   bit i = bufferPackByteList +         (bit r : List.replicate (fromIntegral n) 0)+      where+         n = byteOffset i+         r = bitOffset i+   +   testBit b i = testBit p r+      where+         p = bufferIndex b (bufferSize b - n)+         n = byteOffset i+         r = bitOffset i++   setBit   = error "Can't set Buffer bit"+   clearBit = error "Can't clear Buffer bit"++   popCount b  = sum (fmap popCount (bufferUnpackByteList b))++++-- | Duplicate a buffer+bufferDup :: Buffer -> IO Buffer+bufferDup b = withBufferPtr b $ bufferPackPtr (bufferSize b)++-- | Buffer filled with zero+bufferZero :: Word -> Buffer+bufferZero n = unsafePerformIO $ do+   p <- mallocBytes (fromIntegral n)+   memSet p (fromIntegral n) 0+   bufferUnsafePackPtr n p++-- | Zip two buffers with the given function+bufferZipWith :: (Word8 -> Word8 -> Word8) -> Buffer -> Buffer -> Buffer+bufferZipWith f a b+      | bufferSize a /= bufferSize b = error "Non matching buffer sizes"+      | otherwise = unsafePerformIO $ do+            let sz = fromIntegral (bufferSize a)+            pc <- mallocBytes sz+            withBufferPtr a $ \pa ->+               withBufferPtr b $ \pb ->+                  forM_ [0..fromIntegral sz-1] $ \off -> do+                     v <- f <$> peekByteOff pa off+                            <*> peekByteOff pb off+                     pokeByteOff pc off (v :: Word8)+            bufferUnsafePackPtr (bufferSize a) pc++-- | Unsafe: be careful if you modify the buffer contents or you may break+-- referential transparency+withBufferPtr :: Buffer -> (Ptr b -> IO a) -> IO a+withBufferPtr (Buffer bs) f = BS.unsafeUseAsCString bs (f . castPtr)++-- | Test if the buffer is empty+isBufferEmpty :: Buffer -> Bool+isBufferEmpty (Buffer bs) = BS.null bs++-- | Empty buffer+emptyBuffer :: Buffer+emptyBuffer = Buffer BS.empty++-- | Buffer size+bufferSize :: Buffer -> Word+bufferSize (Buffer bs) = +      if s < 0+         then error "ByteString with size < 0"+         else fromIntegral s+   where+      s = BS.length bs++-- | Peek a storable+bufferPeekStorable :: forall a. Storable a => Buffer -> a+bufferPeekStorable = snd . bufferPopStorable++-- | Peek a storable at the given offset+bufferPeekStorableAt :: forall a.+   ( Storable a+   )+   => Buffer -> Word -> a+bufferPeekStorableAt b n+   | n + sizeOfT' @a > bufferSize b = error "Invalid buffer index"+   | otherwise                      = unsafePerformIO $ withBufferPtr b $ \p ->+                                        peekByteOff p (fromIntegral n)+   ++-- | Pop a Storable and return the new buffer+bufferPopStorable :: forall a. Storable a => Buffer -> (Buffer,a)+bufferPopStorable buf+   | bufferSize buf < sza = error "bufferRead: out of bounds"+   | otherwise            = unsafePerformIO $ do+         a <- withBufferPtr buf peek+         return (bufferDrop sza buf, a)+   where+      sza = sizeOfT' @a++-- | Poke a buffer+bufferPoke :: Ptr a -> Buffer -> IO ()+bufferPoke dest b = bufferUnsafeUsePtr b $ \src sz ->+   memCopy dest src (fromIntegral sz)++-- | Map+bufferMap :: (Word8 -> Word8) -> Buffer -> Buffer+bufferMap f (Buffer bs) = Buffer (BS.map f bs)++-- | Reverse+bufferReverse :: Buffer -> Buffer+bufferReverse (Buffer bs) = Buffer (BS.reverse bs)++-- | Drop some bytes O(1)+bufferDrop :: Word -> Buffer -> Buffer+bufferDrop n (Buffer bs) = Buffer $ BS.drop (fromIntegral n) bs++-- | Split on the given Byte values+bufferSplitOn :: Word8 -> Buffer -> [Buffer]+bufferSplitOn n (Buffer bs) = fmap Buffer (BS.split n bs)++-- | Tail+bufferTail :: Buffer -> Buffer+bufferTail (Buffer bs) = Buffer $ BS.tail bs++-- | Append+bufferAppend :: Buffer -> Buffer -> Buffer+bufferAppend (Buffer a) (Buffer b) = Buffer $ BS.append a b++-- | Cons+bufferCons :: Word8 -> Buffer -> Buffer+bufferCons w (Buffer bs) = Buffer $ BS.cons w bs++-- | Snoc+bufferSnoc :: Buffer -> Word8 -> Buffer+bufferSnoc (Buffer bs) w = Buffer $ BS.snoc bs w+++-- | Init+bufferInit :: Buffer -> Buffer+bufferInit (Buffer bs) = Buffer $ BS.init bs++-- | Head+bufferHead :: Buffer -> Word8+{-# INLINABLE bufferHead #-}+bufferHead (Buffer bs) = BS.head bs++-- | Index+bufferIndex :: Buffer -> Word -> Word8+{-# INLINABLE bufferIndex #-}+bufferIndex (Buffer bs) n = BS.index bs (fromIntegral n)++-- | Unpack+bufferUnpackByteList :: Buffer -> [Word8]+bufferUnpackByteList (Buffer bs) = BS.unpack bs++-- | Unpack+bufferUnpackByteString :: Buffer -> ByteString+bufferUnpackByteString (Buffer bs) = bs++-- | Take some bytes O(1)+bufferTake :: Word -> Buffer -> Buffer+bufferTake n (Buffer bs) = Buffer $ BS.take (fromIntegral n) bs++-- | Take some bytes O(n)+bufferTakeWhile :: (Word8 -> Bool) -> Buffer -> Buffer+bufferTakeWhile f (Buffer bs) = Buffer $ BS.takeWhile f bs++-- | Take some bytes O(1)+bufferTakeAtMost :: Word -> Buffer -> Buffer+bufferTakeAtMost n buf+   | bufferSize buf < n = buf+   | otherwise          = bufferTake n buf+++-- | Pack a ByteString+bufferPackByteString :: BS.ByteString -> Buffer+bufferPackByteString = Buffer++-- | Pack a list of bytes+bufferPackByteList :: [Word8] -> Buffer+bufferPackByteList = Buffer . BS.pack++-- | Pack a Storable+bufferPackStorable :: forall a. Storable a => a -> Buffer+bufferPackStorable x = Buffer $ unsafePerformIO $ do+   p <- malloc+   poke p x+   BS.unsafePackMallocCStringLen (castPtr p, sizeOfT' @a)++-- | Pack a list of Storable+bufferPackStorableList :: forall a. Storable a => [a] -> Buffer+bufferPackStorableList xs = Buffer $ unsafePerformIO $ do+   let lxs = length xs+   p <- mallocArray lxs+   forM_ (xs `zip` [0..]) $ \(x,o) ->+      pokeElemOff p o x+   BS.unsafePackMallocCStringLen (castPtr p, sizeOfT' @a * fromIntegral lxs)++-- | Pack from a pointer (copy)+bufferPackPtr :: MonadIO m => Word -> Ptr () -> m Buffer+bufferPackPtr sz ptr = do+   p <- liftIO (mallocBytes (fromIntegral sz))+   memCopy p ptr (fromIntegral sz)+   bufferUnsafePackPtr sz p++-- | Pack from a pointer (add finalizer)+bufferUnsafePackPtr :: MonadIO m => Word -> Ptr a -> m Buffer+bufferUnsafePackPtr sz p =+   Buffer <$> liftIO (BS.unsafePackMallocCStringLen (castPtr p, fromIntegral sz))++-- | Unsafe drop (don't check the size)+bufferUnsafeDrop :: Word -> Buffer -> Buffer+bufferUnsafeDrop n (Buffer bs) = Buffer (BS.unsafeDrop (fromIntegral n) bs)++-- | Unsafe take (don't check the size)+bufferUnsafeTake :: Word -> Buffer -> Buffer+bufferUnsafeTake n (Buffer bs) = Buffer (BS.unsafeTake (fromIntegral n) bs)++-- | Unsafe tail (don't check the size)+bufferUnsafeTail :: Buffer -> Buffer+bufferUnsafeTail (Buffer bs) = Buffer (BS.unsafeTail bs)++-- | Unsafe head (don't check the size)+bufferUnsafeHead :: Buffer -> Word8+bufferUnsafeHead (Buffer bs) = BS.unsafeHead bs++-- | Unsafe last (don't check the size)+bufferUnsafeLast :: Buffer -> Word8+bufferUnsafeLast (Buffer bs) = BS.unsafeLast bs++-- | Unsafe init (don't check the size)+bufferUnsafeInit :: Buffer -> Buffer+bufferUnsafeInit (Buffer bs) = Buffer (BS.unsafeInit bs)++-- | Unsafe index (don't check the size)+bufferUnsafeIndex :: Buffer -> Word -> Word8+bufferUnsafeIndex (Buffer bs) n = BS.unsafeIndex bs (fromIntegral n)++-- | Map memory+bufferUnsafeMapMemory :: MonadIO m => Word -> Ptr () -> m Buffer+bufferUnsafeMapMemory sz ptr =+   Buffer <$> liftIO (BS.unsafePackCStringLen (castPtr ptr, fromIntegral sz))++-- | Use buffer pointer+bufferUnsafeUsePtr :: MonadInIO m => Buffer -> (Ptr () -> Word -> m a) -> m a+bufferUnsafeUsePtr bu@(Buffer b) f =+   liftWith (BS.unsafeUseAsCString b) $ \p ->+      f (castPtr p) (bufferSize bu)++-- | Read file+bufferReadFile :: MonadIO m => FilePath -> m Buffer+bufferReadFile path = Buffer <$> liftIO (BS.readFile path)++-- | Write file+bufferWriteFile :: MonadIO m => FilePath -> Buffer -> m ()+bufferWriteFile path (Buffer bs) = liftIO (BS.writeFile path bs)

@@ -0,0 +1,47 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Buffer builder+module Haskus.Binary.BufferBuilder+   ( BufferBuilder+   , emptyBufferBuilder+   , toBufferList+   , toBuffer+   , fromBuffer+   , fromWord8+   )+where++import qualified Data.ByteString.Builder as B++import Haskus.Number.Word+import Haskus.Binary.Buffer+import qualified Haskus.Binary.BufferList as BL++-- | Buffer builder+newtype BufferBuilder+   = BufferBuilder B.Builder+   deriving (Semigroup,Monoid)++-- | Empty buffer builder+emptyBufferBuilder :: BufferBuilder+emptyBufferBuilder = BufferBuilder mempty++-- | Create a Builder denoting the same sequence of bytes as a strict+-- ByteString. The Builder inserts large ByteStrings directly, but copies small+-- ones to ensure that the generated chunks are large on average.+fromBuffer :: Buffer -> BufferBuilder+fromBuffer (Buffer bs) = BufferBuilder (B.byteString bs)++-- | Encode a single unsigned byte as-is.+fromWord8 :: Word8 -> BufferBuilder+fromWord8 w = BufferBuilder (B.word8 w)++-- | Execute a Builder and return the generated chunks as a BufferList. The work+-- is performed lazily, i.e., only when a chunk of the BufferList is forced.+toBufferList :: BufferBuilder -> BL.BufferList+toBufferList (BufferBuilder b) = BL.BufferList (B.toLazyByteString b)++-- | Execute a Builder and return the generated chunks as a Buffer.+toBuffer :: BufferBuilder -> Buffer+toBuffer = BL.toBuffer . toBufferList

@@ -0,0 +1,29 @@+-- | Buffer list+--+-- BufferList is a lazy ByteString+module Haskus.Binary.BufferList+   ( BufferList (..)+   , toBuffer+   , toBufferList+   , toLazyByteString+   )+where++import qualified Data.ByteString.Lazy as LBS++import Haskus.Binary.Buffer++-- | BufferList+newtype BufferList = BufferList LBS.ByteString++-- | Convert to a buffer+toBuffer :: BufferList -> Buffer+toBuffer (BufferList b) = Buffer (LBS.toStrict b)++-- | Convert from a buffer+toBufferList :: Buffer -> BufferList+toBufferList (Buffer b) = BufferList (LBS.fromStrict b)++-- | Convert to a lazy ByteString+toLazyByteString :: BufferList -> LBS.ByteString+toLazyByteString (BufferList b) = b

@@ -0,0 +1,13 @@+-- | Some C types+module Haskus.Binary.CTypes+   ( CSize(..)+   , CUShort+   , CShort+   , CUInt+   , CInt+   , CULong+   , CLong+   )+where++import Foreign.C.Types

@@ -0,0 +1,15 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Character+module Haskus.Binary.Char+   ( Char8 (..)+   )+where++import Haskus.Number.Word+import Haskus.Binary.Storable++-- | 8-bit character (ASCII, etc.)+newtype Char8+   = Char8 Word8+   deriving (Show,Eq,Ord,Storable)

@@ -0,0 +1,222 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Byte order ("endianness")+--+-- Indicate in which order bytes are stored in memory for multi-bytes types.+-- Big-endian means that most-significant bytes come first. Little-endian means+-- that least-significant bytes come first.+module Haskus.Binary.Endianness+   ( Endianness(..)+   , WordGetters (..)+   , WordPutters (..)+   , getWordGetters+   , getWordPutters+   , WordSize (..)+   , ExtendedWordGetters (..)+   , ExtendedWordPutters (..)+   , getExtendedWordGetters+   , getExtendedWordPutters+   , getHostEndianness+   , hostEndianness+   , ByteReversable (..)+   , AsBigEndian (..)+   , AsLittleEndian (..)+   )+where++import Haskus.Binary.Get+import Haskus.Binary.Put+import Haskus.Binary.Enum+import Haskus.Binary.Storable+import Haskus.Number.Word+import Haskus.Binary.Bits++import System.IO.Unsafe+import Foreign.Ptr++-- | Endianness+data Endianness +   = LittleEndian    -- ^ Less significant bytes first+   | BigEndian       -- ^ Most significant bytes first+   deriving (Eq,Show,Enum)++instance CEnum Endianness++-- | Word getter+data WordGetters = WordGetters+   { wordGetter8  :: Get Word8   -- ^ Read a Word8+   , wordGetter16 :: Get Word16  -- ^ Read a Word16+   , wordGetter32 :: Get Word32  -- ^ Read a Word32+   , wordGetter64 :: Get Word64  -- ^ Read a Word64+   }++-- | Word putters+data WordPutters = WordPutters+   { wordPutter8  :: Word8  -> Put -- ^ Write a Word8+   , wordPutter16 :: Word16 -> Put -- ^ Write a Word16+   , wordPutter32 :: Word32 -> Put -- ^ Write a Word32+   , wordPutter64 :: Word64 -> Put -- ^ Write a Word64+   }++-- | Get getters for the given endianness+getWordGetters :: Endianness -> WordGetters+getWordGetters e = case e of+   LittleEndian -> WordGetters getWord8 getWord16le getWord32le getWord64le+   BigEndian    -> WordGetters getWord8 getWord16be getWord32be getWord64be++-- | Get putters for the given endianness+getWordPutters :: Endianness -> WordPutters+getWordPutters e = case e of+   LittleEndian -> WordPutters putWord8 putWord16le putWord32le putWord64le+   BigEndian    -> WordPutters putWord8 putWord16be putWord32be putWord64be++++-- | Size of a machine word+data WordSize+   = WordSize32      -- ^ 32-bit+   | WordSize64      -- ^ 64-bit+   deriving (Show, Eq)++-- | Extended word getters+data ExtendedWordGetters = ExtendedWordGetters+   { extwordGetter8  :: Get Word8   -- ^ Read a Word8+   , extwordGetter16 :: Get Word16  -- ^ Read a Word16+   , extwordGetter32 :: Get Word32  -- ^ Read a Word32+   , extwordGetter64 :: Get Word64  -- ^ Read a Word64+   , extwordGetterN  :: Get Word64  -- ^ Read a native size word into a Word64+   }++-- | Extended word putters+data ExtendedWordPutters = ExtendedWordPutters+   { extwordPutter8  :: Word8  -> Put -- ^ Write a Word8+   , extwordPutter16 :: Word16 -> Put -- ^ Write a Word16+   , extwordPutter32 :: Word32 -> Put -- ^ Write a Word32+   , extwordPutter64 :: Word64 -> Put -- ^ Write a Word64+   , extwordPutterN  :: Word64 -> Put -- ^ Write a Word64 into a native size word+   }++-- | Return extended getters+getExtendedWordGetters :: Endianness -> WordSize -> ExtendedWordGetters+getExtendedWordGetters endian ws = ExtendedWordGetters gw8 gw16 gw32 gw64 gwN+   where+      WordGetters gw8 gw16 gw32 gw64 = getWordGetters endian+      gwN = case ws of+         WordSize64 -> gw64+         WordSize32 -> fromIntegral <$> gw32++-- | Return extended putters+getExtendedWordPutters :: Endianness -> WordSize -> ExtendedWordPutters+getExtendedWordPutters endian ws = ExtendedWordPutters pw8 pw16 pw32 pw64 pwN+   where+      WordPutters pw8 pw16 pw32 pw64 = getWordPutters endian+      pwN x = case ws of+         WordSize64 -> pw64 x+         WordSize32 -> if x > 0xffffffff+            then error $ "Number too big to be stored in 32-bit word ("++show x++")"+            else pw32 (fromIntegral x)++-- | Detect the endianness of the host memory+getHostEndianness :: IO Endianness+getHostEndianness = do+   -- Write a 32 bit word and check byte ordering+   let magic = 0x01020304 :: Word32+   alloca $ \p -> do+      poke p magic+      rs <- peekArray 4 (castPtr p :: Ptr Word8)+      return $ if rs == [1,2,3,4] then BigEndian else LittleEndian++-- | Detected host endianness+--+-- TODO: use targetByteOrder in GHC.ByteOrder (should be introduced in GHC 8.4)+hostEndianness :: Endianness+{-# NOINLINE hostEndianness #-}+hostEndianness = unsafePerformIO getHostEndianness++-- | Reverse bytes in a word+class ByteReversable w where+   reverseBytes       :: w -> w++   hostToBigEndian    :: w -> w+   hostToBigEndian w = case hostEndianness of+      BigEndian    -> w+      LittleEndian -> reverseBytes w++   bigEndianToHost    :: w -> w+   bigEndianToHost w = case hostEndianness of+      BigEndian    -> w+      LittleEndian -> reverseBytes w+++   hostToLittleEndian :: w -> w+   hostToLittleEndian w = case hostEndianness of+      BigEndian    -> reverseBytes w+      LittleEndian -> w++   littleEndianToHost :: w -> w+   littleEndianToHost w = case hostEndianness of+      BigEndian    -> reverseBytes w+      LittleEndian -> w++instance ByteReversable Word8 where+   reverseBytes = id++instance ByteReversable Word16 where+   reverseBytes = byteSwap16+                  +instance ByteReversable Word32 where+   reverseBytes = byteSwap32++instance ByteReversable Word64 where+   reverseBytes = byteSwap64++++-- | Force a data to be read/stored as big-endian+newtype AsBigEndian a+   = AsBigEndian a+   deriving (Eq,Ord,Enum,Num,Integral,Real,Bitwise,FiniteBits,ReversableBits,RotatableBits,ShiftableBits,IndexableBits)++instance Show a => Show (AsBigEndian a) where+   show (AsBigEndian a) = show a++-- | Force a data to be read/stored as little-endian+newtype AsLittleEndian a+   = AsLittleEndian a+   deriving (Eq,Ord,Enum,Num,Integral,Real,Bitwise,FiniteBits,ReversableBits,RotatableBits,ShiftableBits,IndexableBits)++instance Show a => Show (AsLittleEndian a) where+   show (AsLittleEndian a) = show a++instance (ByteReversable a, StaticStorable a) => StaticStorable (AsBigEndian a) where+   type SizeOf (AsBigEndian a)    = SizeOf a+   type Alignment (AsBigEndian a) = Alignment a++   staticPeekIO ptr                 = AsBigEndian . bigEndianToHost <$> staticPeek (castPtr ptr)+   staticPokeIO ptr (AsBigEndian v) = staticPoke (castPtr ptr) (hostToBigEndian v)+++instance (ByteReversable a, Storable a) => Storable (AsBigEndian a) where+   sizeOf _    = sizeOfT    @a+   alignment _ = alignmentT @a++   peekIO ptr                 = AsBigEndian . bigEndianToHost <$> peek (castPtr ptr)+   pokeIO ptr (AsBigEndian v) = poke (castPtr ptr) (hostToBigEndian v)++instance (ByteReversable a, StaticStorable a) => StaticStorable (AsLittleEndian a) where+   type SizeOf (AsLittleEndian a)    = SizeOf a+   type Alignment (AsLittleEndian a) = Alignment a++   staticPeekIO ptr                    = AsLittleEndian . bigEndianToHost <$> staticPeekIO (castPtr ptr)+   staticPokeIO ptr (AsLittleEndian v) = staticPokeIO (castPtr ptr) (hostToLittleEndian v)++instance (ByteReversable a, Storable a) => Storable (AsLittleEndian a) where+   sizeOf _    = sizeOfT    @a+   alignment _ = alignmentT @a++   peekIO ptr                    = AsLittleEndian . bigEndianToHost <$> peek (castPtr ptr)+   pokeIO ptr (AsLittleEndian v) = poke (castPtr ptr) (hostToLittleEndian v)

@@ -0,0 +1,144 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}++-- | Store an Enum in the given backing word type+module Haskus.Binary.Enum+   ( EnumField+   , CEnum (..)+   , fromEnumField+   , toEnumField+   , makeEnum+   , makeEnumMaybe+   , makeEnumWithCustom+   , dataToTag+   )+where++import Haskus.Binary.Storable++import Foreign.Ptr+import Data.Data+import GHC.Prim+import GHC.Int++-----------------------------------------------------------------------------+-- EnumField b a: directly store the value of enum "a" as a "b"+-----------------------------------------------------------------------------++-- | Store enum `a` as a `b`+newtype EnumField b a+   = EnumField b+   deriving (Show,Eq,Storable)++instance+      ( Integral b+      , StaticStorable b+      , CEnum a+      ) => StaticStorable (EnumField b a)+   where+      type SizeOf (EnumField b a)    = SizeOf b+      type Alignment (EnumField b a) = Alignment b+      staticPeekIO p                 = EnumField  <$> staticPeek (castPtr p :: Ptr b)+      staticPokeIO p (EnumField v)   = staticPoke (castPtr p :: Ptr b) v++-- | Read an enum field+fromEnumField :: (CEnum a, Integral b) => EnumField b a -> a+{-# INLINABLE fromEnumField #-}+fromEnumField (EnumField b) = toCEnum b++-- | Create an enum field+toEnumField :: (CEnum a, Integral b) => a -> EnumField b a+{-# INLINABLE toEnumField #-}+toEnumField = EnumField . fromCEnum+++-----------------------------------------------------------------------------+-- Extended Enum+-----------------------------------------------------------------------------++-- | Extended Enum+--+-- By default, use dataToTag and toEnum to convert from and to an Integral.+--+-- But it can be overloaded to perform transformation before using+-- fromEnum/toEnum. E.g. if values are shifted by 1 compared to Enum values,+-- define fromCEnum = (+1) . fromIntegral . dataToTag+--+class CEnum a where+   fromCEnum       :: Integral b => a -> b+   fromCEnum       = fromIntegral . dataToTag++   toCEnum         :: Integral b => b -> a+   default toCEnum :: (Enum a, Integral b) => b -> a+   toCEnum         = toEnum . fromIntegral++-- | Make an enum with the last constructor taking a parameter for the rest of+-- the range+--+-- @+-- data T = A | B | C | D Word8+--+-- makeEnumWithCustom :: Int -> T+-- makeEnumWithCustom x = case x of+--    0 -> A+--    1 -> B+--    2 -> C+--    n -> D (n - 3)+-- @+--+makeEnumWithCustom :: forall a i. (Data a,Integral i) => i -> a+{-# INLINABLE makeEnumWithCustom #-}+makeEnumWithCustom x =+   if x' < maxConstrIndex t+      then fromConstr (indexConstr t x')+      else fromConstrB (fromConstr (toConstr (x' - m)))+               (indexConstr t m)+   where+      m   = maxConstrIndex t+      x'  = fromIntegral x + 1+      t   = dataTypeOf (undefined :: a)++-- | Make an enum with the last constructor taking a parameter for the rest of+-- the range, but don't build the last constructor+--+-- @+-- data T = A | B | C | D Word8+--+-- makeEnumMaybe :: Int -> T+-- makeEnumMaybe x = case x of+--    0 -> Just A+--    1 -> Just B+--    2 -> Just C+--    n -> Nothing+-- @+--+makeEnumMaybe :: forall a i. (Data a,Integral i) => i -> Maybe a+{-# INLINABLE makeEnumMaybe #-}+makeEnumMaybe x =+   if x' < maxConstrIndex t+      then Just (fromConstr (indexConstr t x'))+      else Nothing+   where+      x'  = fromIntegral x + 1+      t   = dataTypeOf (undefined :: a)++-- | Make an enum from a number (0 indexed)+makeEnum :: forall a i. (Data a,Integral i) => i -> a+{-# INLINABLE makeEnum #-}+makeEnum x =fromConstr (indexConstr t x')+   where+      x'  = fromIntegral x + 1+      t   = dataTypeOf (undefined :: a)+++-- | Retrieve data tag+--+-- >>> data D = A | B | C+-- >>> dataToTag B+-- 1+dataToTag :: a -> Int+dataToTag a = I# (dataToTag# a)

@@ -0,0 +1,237 @@+{-# lANGUAGE LambdaCase #-}++-- | Get utilities+module Haskus.Binary.Get+   ( Get+   , runGet+   , runGetOrFail+   -- * Size & alignment+   , isEmpty+   , remaining+   , skip+   , uncheckedSkip+   , skipAlign+   , uncheckedSkipAlign+   , countBytes+   , alignAfter+   -- * Isolation+   , consumeExactly+   , consumeAtMost+   -- * Look-ahead+   , lookAhead+   , lookAheadM+   , lookAheadE+   -- * Read+   , getRemaining+   , getBuffer+   , getBufferNul+   , getWord8+   , getWord16le+   , getWord16be+   , getWord32le+   , getWord32be+   , getWord64le+   , getWord64be+   -- * Utilities+   , getWhile+   , getWhole+   , getBitGet+   , getManyAtMost+   , getManyBounded+   )+where++import qualified Data.Serialize.Get as BG+import Data.Serialize.Get (Get)++import Haskus.Binary.Buffer+import Haskus.Number.Word+import Haskus.Binary.Bits.Order+import Haskus.Binary.Bits.Get (BitGet, runBitGetPartial, skipBitsToAlignOnWord8M, bitGetStateInput)+import Haskus.Utils.Maybe+++-- | Test whether all input *in the current chunk* has been consumed+isEmpty :: Get Bool+isEmpty = BG.isEmpty++-- | Get the number of remaining unparsed bytes *in the current chunk*+remaining :: Get Word+remaining = fromIntegral <$> BG.remaining++-- | Skip ahead n bytes. Fails if fewer than n bytes are available.+skip :: Word -> Get ()+skip = BG.skip . fromIntegral++-- | Skip ahead n bytes. No error if there isn't enough bytes.+uncheckedSkip :: Word -> Get ()+uncheckedSkip = BG.uncheckedSkip . fromIntegral++-- | Skip to align n to al. Fails if fewer than n bytes are available.+skipAlign :: Word -> Word -> Get ()+skipAlign n al = skip n'+   where+      n' = case n `mod` al of+               0 -> 0+               x -> al - fromIntegral x++-- | Skip to align n to al. Fails if fewer than n bytes are available.+uncheckedSkipAlign :: Word -> Word -> Get ()+uncheckedSkipAlign n al = uncheckedSkip n'+   where+      n' = case n `mod` al of+               0 -> 0+               x -> al - fromIntegral x++-- | Run the getter without consuming its input. Fails if it fails+lookAhead :: Get a -> Get a+lookAhead = BG.lookAhead++-- | Run the getter. Consume its input if Just _ returned. Fails if it fails+lookAheadM :: Get (Maybe a) -> Get (Maybe a)+lookAheadM = BG.lookAheadM++-- | Run the getter. Consume its input if Right _ returned. Fails if it fails+lookAheadE :: Get (Either a b) -> Get (Either a b)+lookAheadE = BG.lookAheadE++-- | Require an action to consume exactly the given number of bytes, fail+-- otherwise+consumeExactly :: Word -> Get a -> Get a+consumeExactly sz = BG.isolate (fromIntegral sz)++-- | Require an action to consume at most the given number of bytes, fail+-- otherwise+consumeAtMost :: Word -> Get a -> Get a+consumeAtMost sz f = do+   sz' <- remaining+   (r,res) <- BG.lookAhead $ BG.isolate (fromIntegral (min sz sz')) $ do+      res <- f+      r <- remaining+      skip r -- skip remaining bytes, to make isolate happy+      return (r,res)+   skip (min sz' sz - r)+   return res++-- | Pull n bytes from the input, as a Buffer+getBuffer :: Word -> Get Buffer+getBuffer sz = Buffer <$> BG.getBytes (fromIntegral sz)++-- | Get Word8+getWord8 :: Get Word8+getWord8 = BG.getWord8++-- | Get Word16 little-endian+getWord16le :: Get Word16+getWord16le = BG.getWord16le++-- | Get Word16 big-endian+getWord16be :: Get Word16+getWord16be = BG.getWord16be++-- | Get Word32 little-endian+getWord32le :: Get Word32+getWord32le = BG.getWord32le++-- | Get Word32 big-endian+getWord32be :: Get Word32+getWord32be = BG.getWord32be++-- | Get Word64 little-endian+getWord64le :: Get Word64+getWord64le = BG.getWord64le++-- | Get Word64 big-endian+getWord64be :: Get Word64+getWord64be = BG.getWord64be++-- | Get while True (read and discard the ending element)+getWhile :: (a -> Bool) -> Get a -> Get [a]+getWhile cond getter = rec []+   where+      rec xs = do+         x <- getter+         if cond x+            then rec (x:xs)+            else return (reverse xs)++-- | Repeat the getter to read the whole bytestring+getWhole :: Get a -> Get [a]+getWhole getter = rec []+   where+      rec xs = do+         cond <- isEmpty+         if cond+            then return (reverse xs)+            else do+               x <- getter+               rec (x:xs)++-- | Get remaining bytes+getRemaining :: Get Buffer+getRemaining = do+   r <- remaining+   getBuffer r+++-- | Count the number of bytes consumed by a getter+countBytes :: Get a -> Get (Word, a)+countBytes g = do+   cnt0 <- remaining+   r <- g+   cnt1 <- remaining+   return (cnt0 - cnt1, r)++-- | Execute the getter and align on the given number of Word8+alignAfter :: Word -> Get a -> Get a+alignAfter alignment getter = do+   (cnt,r) <- countBytes getter+   uncheckedSkipAlign cnt alignment+   return r++-- | Get Buffer terminated with \0 (consume \0)+getBufferNul :: Get Buffer+getBufferNul = do+   bs <- lookAhead getRemaining+   let v = bufferTakeWhile (/= 0) bs+   uncheckedSkip (bufferSize v + 1)+   return v++-- | Run the Get monad+runGet :: Get a -> Buffer -> Either String a+runGet g (Buffer bs) = BG.runGet g bs++-- | Run a getter and throw an exception on error+runGetOrFail :: Get a -> Buffer -> a+runGetOrFail g bs = case runGet g bs of+   Left err -> error err+   Right x  -> x+++-- | Get bits from a BitGet. +--+-- Discard last bits to align on a Word8 boundary+--+-- FIXME: we use a continuation because Data.Serialize.Get doesn't export "put"+getBitGet :: BitOrder -> BitGet a -> (a -> Get b) -> Get b+getBitGet bo bg cont = do+   bs <- getRemaining+   let (v,s) = runBitGetPartial bo (bg <* skipBitsToAlignOnWord8M) bs+   return $ runGetOrFail (cont v) (bitGetStateInput s)++-- | Apply the getter at most 'max' times+getManyAtMost :: Word -> Get (Maybe a) -> Get [a]+getManyAtMost mx f = fromMaybe [] <$> getManyBounded Nothing (Just mx) f++-- | Apply the getter at least 'min' times and at most 'max' times+getManyBounded :: Maybe Word -> Maybe Word -> Get (Maybe a) -> Get (Maybe [a])+getManyBounded _ (Just 0) _  = return (Just [])+getManyBounded (Just 0) mx f = getManyBounded Nothing mx f+getManyBounded mn mx f       = lookAheadM $ f >>= \case+      Nothing -> case mn of+         Just n | n > 0 -> return Nothing+         _              -> return (Just [])+      Just x -> fmap (x:) <$> getManyBounded (minus1 mn) (minus1 mx) f+   where+      minus1 = fmap (\k -> k - 1)+

@@ -0,0 +1,89 @@+-- | Put monad+--+-- FIXME: PutM uses slow ByteString builder... We need to replace it with a+-- fast one+module Haskus.Binary.Put+   ( Put+   , PutM+   , runPut+   , runPutM+   -- * Put+   , putBuffer+   , putByteString+   , putPadding+   , putPaddingAlign+   , putWord8+   , putWord16le+   , putWord16be+   , putWord32le+   , putWord32be+   , putWord64le+   , putWord64be+   )+where++import qualified Data.ByteString as BS+import qualified Data.Serialize.Put as BP+import Data.Serialize.Put (Put,PutM)+import Data.Bifunctor++import Haskus.Utils.Flow (replicateM_)+import Haskus.Binary.Buffer+import Haskus.Number.Word++-- | Execute Put+runPut :: Put -> Buffer+runPut = Buffer . BP.runPut++-- | Execute PutM+runPutM :: PutM a -> (a,Buffer)+runPutM = second Buffer . BP.runPutM+++-- | Put a buffer+putBuffer :: Buffer -> Put+putBuffer (Buffer bs) = BP.putByteString bs++-- | Put a ByteString+putByteString :: BS.ByteString -> Put+putByteString = BP.putByteString++-- | Put null bytes+putPadding :: Word -> Put+putPadding n = replicateM_ (fromIntegral n) (BP.putWord8 0x00)++-- | Put null bytes to align the given value to the second+putPaddingAlign :: Word -> Word -> Put+putPaddingAlign n al = putPadding n'+   where+      n' = case n `mod` al of+               0 -> 0+               x -> al - fromIntegral x++-- | Put a Word8+putWord8 :: Word8 -> Put+putWord8 = BP.putWord8++-- | Put a Word16 little-endian+putWord16le :: Word16 -> Put+putWord16le = BP.putWord16le++-- | Put a Word16 big-endian+putWord16be :: Word16 -> Put+putWord16be = BP.putWord16be++-- | Put a Word32 little-endian+putWord32le :: Word32 -> Put+putWord32le = BP.putWord32le++-- | Put a Word32 big-endian+putWord32be :: Word32 -> Put+putWord32be = BP.putWord32be++-- | Put a Word64 little-endian+putWord64le :: Word64 -> Put+putWord64le = BP.putWord64le++-- | Put a Word64 big-endian+putWord64be :: Word64 -> Put+putWord64be = BP.putWord64be

@@ -0,0 +1,208 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Record (similar to C struct)+module Haskus.Binary.Record+   ( Record+   , Field+   , RecordSize+   , Alignment+   , Path+   , recordSize+   , recordAlignment+   , recordField+   , recordFieldOffset+   , recordFieldPath+   , recordFieldPathOffset+   , recordToList+   )+where++import System.IO.Unsafe+import Foreign.ForeignPtr+import Foreign.Ptr++import Haskus.Memory.Utils+import Haskus.Binary.Storable+import Haskus.Utils.HList+import Haskus.Utils.Types++-- | Record+newtype Record (fields :: [*]) = Record (ForeignPtr ())++-- | Field+data Field (name :: Symbol) typ++-- | Get record size without the ending padding bytes+type family RecordSize (fs :: [*]) (sz :: Nat) where+   RecordSize '[] sz                    = sz+   RecordSize (Field name typ ': fs) sz = +      RecordSize fs+         (sz+         -- padding bytes+         + Padding sz typ+         -- field size+         + SizeOf typ+         )++type family FieldOffset (name :: Symbol) (fs :: [*]) (sz :: Nat) where+   -- Found+   FieldOffset name (Field name typ ': fs) sz =+      sz + Padding sz typ+   -- Not found yet+   FieldOffset name (Field xx typ ': fs) sz =+      FieldOffset name fs+         (sz + Padding sz typ + SizeOf typ)++type family FieldType (name :: Symbol) (fs :: [*]) where+   FieldType name (Field name typ ': fs) = typ+   FieldType name (Field xx typ ': fs)   = FieldType name fs++-- | Record size (with ending padding bytes)+type family FullRecordSize fs where+   FullRecordSize fs =+      RecordSize fs 0+      + PaddingEx (Mod (RecordSize fs 0) (RecordAlignment fs 1))+         (RecordAlignment fs 1)++-- | Record alignment+type family RecordAlignment (fs :: [*]) a where+   RecordAlignment '[]                    a = a+   RecordAlignment (Field name typ ': fs) a =+      RecordAlignment fs+         (If (a <=? Alignment typ) (Alignment typ) a)++-- | Return offset from a field path+type family FieldPathOffset (fs :: [*]) (path :: [Symbol]) (off :: Nat) where+   FieldPathOffset fs '[p] off = off + FieldOffset p fs 0+   FieldPathOffset fs (p ': ps) off+      = FieldPathOffset (ExtractRecord (FieldType p fs))+            ps (off + FieldOffset p fs 0)++-- | Return type from a field path+type family FieldPathType (fs :: [*]) (path :: [Symbol]) where+   FieldPathType fs '[p] = FieldType p fs++   FieldPathType fs (p ': ps)+      = FieldPathType (ExtractRecord (FieldType p fs)) ps+   +type family ExtractRecord x where+   ExtractRecord (Record fs) = fs++-- | Get record size+recordSize :: forall fs.+   ( KnownNat (FullRecordSize fs)+   ) => Record fs -> Word+recordSize _ = natValue' @(FullRecordSize fs)++-- | Get record alignment+recordAlignment :: forall fs.+   ( KnownNat (RecordAlignment fs 1)+   ) => Record fs -> Word+recordAlignment _ = natValue' @(RecordAlignment fs 1)++-- | Get a field offset+recordFieldOffset :: forall (name :: Symbol) fs.+   ( KnownNat (FieldOffset name fs 0)+   ) => Record fs -> Int+recordFieldOffset _ = natValue @(FieldOffset name fs 0)++-- | Get a field+recordField :: forall (name :: Symbol) a fs.+   ( KnownNat (FieldOffset name fs 0)+   , a ~ FieldType name fs+   , StaticStorable a+   ) => Record fs -> a+recordField r@(Record fp) = unsafePerformIO $+   withForeignPtr fp $ \ptr ->do+      let ptr' = ptr `plusPtr` recordFieldOffset @name r+      staticPeek (castPtr ptr')++data Path (fs :: [Symbol])++-- | Get a field offset from its path+recordFieldPathOffset :: forall path fs o.+   ( o ~ FieldPathOffset fs path 0+   , KnownNat o+   ) => Path path -> Record fs -> Int+recordFieldPathOffset _ _ = natValue @o++-- | Get a field from its path+recordFieldPath :: forall path a fs o.+   ( o ~ FieldPathOffset fs path 0+   , a ~ FieldPathType fs path+   , KnownNat o+   , StaticStorable a+   ) => Path path -> Record fs -> a+recordFieldPath _ (Record fp) = unsafePerformIO $+   withForeignPtr fp $ \ptr -> do+      let+         ptr' = ptr `plusPtr` natValue @o+      staticPeek (castPtr ptr')+++instance forall fs s.+      ( s ~ FullRecordSize fs+      , KnownNat s+      )+      => StaticStorable (Record fs)+   where+      type SizeOf (Record fs)    = FullRecordSize fs+      type Alignment (Record fs) = RecordAlignment fs 1++      staticPeekIO ptr = do+         let sz = recordSize (undefined :: Record fs)+         fp <- mallocForeignPtrBytes (fromIntegral sz)+         withForeignPtr fp $ \p ->+            memCopy p ptr (fromIntegral sz)+         return (Record fp)++      staticPokeIO ptr (Record fp) = do+         let sz = recordSize (undefined :: Record fs)+         withForeignPtr fp $ \p ->+            memCopy ptr p (fromIntegral sz)+++data Extract = Extract++instance forall fs typ name rec b l2 i r.+   ( rec ~ Record fs                        -- the record+   , b ~ Field name typ                     -- the current field+   , i ~ (rec, HList l2)                    -- input type+   , typ ~ FieldType name fs+   , KnownNat (FieldOffset name fs 0)+   , StaticStorable typ+   , KnownSymbol name+   , r ~ (rec, HList ((String,typ) ': l2))  -- result type+   ) => Apply Extract (b, i) r where+      apply _ (_, (rec,xs)) =+         (rec, HCons (symbolValue @name, recordField @name rec) xs)++-- | Convert a record into a HList+recordToList :: forall fs.+   ( HFoldr' Extract (Record fs, HList '[]) fs (Record fs, HList fs)+   ) => Record fs -> HList fs+recordToList rec = snd res+   where+      res :: (Record fs, HList fs)+      res = hFoldr' Extract ((rec,HNil) :: (Record fs, HList '[])) (undefined :: HList fs)+++instance forall fs.+      ( HFoldr' Extract (Record fs, HList '[]) fs (Record fs, HList fs)+      , Show (HList fs)+      )+      => Show (Record fs)+   where+      show rec = show (recordToList rec :: HList fs)

@@ -0,0 +1,135 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Binary serialization of Haskell values+module Haskus.Binary.Serialize+   ( Serializable (..)+   , Size (..)+   )+where++import Haskus.Binary.Serialize.Put+import Haskus.Binary.Serialize.Size+import Haskus.Binary.Serialize.Get+import Haskus.Number.Word+import Haskus.Number.Int+import Haskus.Binary.Endianness+import Haskus.Utils.Types++-- | Size in bytes+data Size+   = Exactly Nat   -- ^ Exactly the given size+   | Dynamic       -- ^ Dynamically known size (the size is stored with the object)++-- | Binary serializable data+class Serializable a where++   -- | Size of the data in bytes+   type SizeOf a :: Size++   -- | Sensible to endianness+   type Endian a :: Bool++   -- | Dynamic size of the data in bytes+   --+   -- The default implementation execute the put method with a PutMonad that+   -- only stores the size in bytes. Overload this function if possible!+   sizeOf :: a -> Word+   sizeOf a = runGetSize (put LittleEndian a)++   -- | Serialize a value+   put :: PutMonad m => Endianness -> a -> m ()++   -- | Deserialize a value+   get :: GetMonad m => Endianness -> m a++--------------------------------------------+-- Instances+--------------------------------------------++instance Serializable Word8 where+   type SizeOf Word8  = 'Exactly 1+   type Endian Word8  = 'False+   sizeOf _           = 1+   put _ x            = putWord8 x+   get _              = getWord8++instance Serializable Word16 where+   type SizeOf Word16 = 'Exactly 2+   type Endian Word16 = 'True+   sizeOf _           = 2+   put LittleEndian x = putWord16LE x+   put BigEndian    x = putWord16BE x+   get LittleEndian   = getWord16LE+   get BigEndian      = getWord16BE++instance Serializable Word32 where+   type SizeOf Word32 = 'Exactly 4+   type Endian Word32 = 'True+   sizeOf _           = 4+   put LittleEndian x = putWord32LE x+   put BigEndian    x = putWord32BE x+   get LittleEndian   = getWord32LE+   get BigEndian      = getWord32BE++instance Serializable Word64 where+   type SizeOf Word64 = 'Exactly 8+   type Endian Word64 = 'True+   sizeOf _           = 8+   put LittleEndian x = putWord64LE x+   put BigEndian    x = putWord64BE x+   get LittleEndian   = getWord64LE+   get BigEndian      = getWord64BE++instance Serializable Int8 where+   type SizeOf Int8   = 'Exactly 1+   type Endian Int8   = 'False+   sizeOf _           = 1+   put _ x            = putWord8 (fromIntegral x)+   get _              = fromIntegral <$> getWord8++instance Serializable Int16 where+   type SizeOf Int16  = 'Exactly 2+   type Endian Int16  = 'True+   sizeOf _           = 2+   put LittleEndian x = putWord16LE (fromIntegral x)+   put BigEndian    x = putWord16BE (fromIntegral x)+   get LittleEndian   = fromIntegral <$> getWord16LE+   get BigEndian      = fromIntegral <$> getWord16BE++instance Serializable Int32 where+   type SizeOf Int32  = 'Exactly 4+   type Endian Int32  = 'True+   sizeOf _           = 4+   put LittleEndian x = putWord32LE (fromIntegral x)+   put BigEndian    x = putWord32BE (fromIntegral x)+   get LittleEndian   = fromIntegral <$> getWord32LE+   get BigEndian      = fromIntegral <$> getWord32BE++instance Serializable Int64 where+   type SizeOf Int64  = 'Exactly 8+   type Endian Int64  = 'True+   sizeOf _           = 8+   put LittleEndian x = putWord64LE (fromIntegral x)+   put BigEndian    x = putWord64BE (fromIntegral x)+   get LittleEndian   = fromIntegral <$> getWord64LE+   get BigEndian      = fromIntegral <$> getWord64BE++instance Serializable a => Serializable (AsBigEndian a) where+   type SizeOf (AsBigEndian a) = SizeOf a+   type Endian (AsBigEndian a) = 'False+   sizeOf (AsBigEndian b)      = sizeOf b+   put _ (AsBigEndian x)       = put BigEndian x+   get _                       = AsBigEndian <$> get BigEndian++instance Serializable a => Serializable (AsLittleEndian a) where+   type SizeOf (AsLittleEndian a) = SizeOf a+   type Endian (AsLittleEndian a) = 'False+   sizeOf (AsLittleEndian b)      = sizeOf b+   put _ (AsLittleEndian x)       = put LittleEndian x+   get _                          = AsLittleEndian <$> get LittleEndian

@@ -0,0 +1,368 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}++-- | Serializer into a mutable buffer+--+-- >>> let w = do putWord8 0x01 ; putWord32BE 0x23456789 ; putWord32BE 0xAABBCCDD+-- >>> b <- newBuffer 10+-- >>> void $ runBufferPut b 0 overflowBufferFail w+-- >>> xs <- forM [0..4] (bufferReadWord8IO b)+-- >>> xs == [0x01,0x23,0x45,0x67,0x89]+-- True+--+-- >>> b <- newBuffer 2 -- small buffer+-- >>> (_,b',_) <- runBufferPut b 0 overflowBufferDouble w+-- >>> xs <- forM [0..4] (bufferReadWord8IO b')+-- >>> xs == [0x01,0x23,0x45,0x67,0x89]+-- True+-- >>> bufferSizeIO b'+-- 16+--+module Haskus.Binary.Serialize.Buffer+   ( -- * Put+   BufferPutT (..)+   , BufferPut+   , getPutOffset+   , getPutBuffer+   , setPutOffset+   , runBufferPut+   , liftBufferPut+     -- * Get+   , BufferGetT (..)+   , BufferGet+   , getGetOffset+   , getGetBuffer+   , setGetOffset+   , runBufferGet+   , liftBufferGet+   -- * Buffer overflow+   , OverflowStrategy (..)+   , BufferOverflow (..)+   , getPutOverflowStrategy+   , getGetOverflowStrategy+   , overflowBufferFail+   , overflowBufferDouble+   , overflowBufferDoublePinned+   , overflowBufferAdd+   , overflowBufferAddPinned+   )+where++import Haskus.Binary.Serialize.Put+import Haskus.Binary.Serialize.Get+import Haskus.Memory.Buffer+import Haskus.Utils.Monad+import Haskus.Utils.Flow+import Haskus.Utils.Maybe++import Data.Functor.Identity+import Control.Monad.Trans.State.Strict as S+import Control.Monad.Fail as F+import Control.Monad.Fix++-- | Action to perform when the buffer isn't large enough to contain the+-- required data (extend the buffer, flush the data, etc.)+--+-- The returned buffer and offset replace the current ones.+newtype OverflowStrategy m b = OverflowStrategy (BufferOverflow b -> m (b,Word))++-- | Buffer overflow strategy: fails when there isn't enough space left+overflowBufferFail :: MonadFail m => OverflowStrategy m b+overflowBufferFail = OverflowStrategy \ex -> do+   F.fail $ "Not enough space in the buffer (requiring "+          ++ show (overflowRequired ex) ++ " bytes)"++-- | Buffer extend strategy: double the buffer size each time and copy the+-- original contents in it+overflowBufferDouble :: MonadIO m => OverflowStrategy m BufferM+overflowBufferDouble = OverflowStrategy \ex -> do+   sz <- bufferSizeIO (overflowBuffer ex)+   let off = overflowOffset   ex+       req = overflowRequired ex+       b   = overflowBuffer   ex+       makeSzs i = i*i : makeSzs (i*i) -- infinite list of doubling sizes+       newSz = head <| filter (> req+off) (makeSzs sz)+   newB <- newBuffer newSz+   copyBuffer b 0 newB 0 off+   pure (newB,off)++-- | Buffer extend strategy: double the buffer size each time and copy the+-- original contents in it+overflowBufferDoublePinned :: MonadIO m => Maybe Word -> OverflowStrategy m BufferMP+overflowBufferDoublePinned malignment = OverflowStrategy \ex -> do+   sz <- bufferSizeIO (overflowBuffer ex)+   let off = overflowOffset   ex+       req = overflowRequired ex+       b   = overflowBuffer   ex+       makeSzs i = i*i : makeSzs (i*i) -- infinite list of doubling sizes+       newSz = head <| filter (> req+off) (makeSzs sz)+   newB <- case malignment of+      Nothing -> newPinnedBuffer newSz+      Just al -> newAlignedPinnedBuffer newSz al+   copyBuffer b 0 newB 0 off+   pure (newB,off)++-- | Buffer extend strategy: add the given size each time and copy the+-- original contents in it+overflowBufferAdd :: MonadIO m => Word -> OverflowStrategy m BufferM+overflowBufferAdd addSz = OverflowStrategy \ex -> do+   sz <- bufferSizeIO (overflowBuffer ex)+   let off = overflowOffset   ex+       req = overflowRequired ex+       b   = overflowBuffer   ex+       makeSzs i = i+addSz : makeSzs (i+addSz) -- infinite list of added sizes+       newSz = head <| filter (> req+off) (makeSzs sz)+   newB <- newBuffer newSz+   copyBuffer b 0 newB 0 off+   pure (newB,off)++-- | Buffer extend strategy: add the given size each time and copy the+-- original contents in it+overflowBufferAddPinned :: MonadIO m => Maybe Word -> Word -> OverflowStrategy m BufferMP+overflowBufferAddPinned malignment addSz = OverflowStrategy \ex -> do+   sz <- bufferSizeIO (overflowBuffer ex)+   let off = overflowOffset   ex+       req = overflowRequired ex+       b   = overflowBuffer   ex+       makeSzs i = i+addSz : makeSzs (i+addSz) -- infinite list of added sizes+       newSz = head <| filter (> req+off) (makeSzs sz)+   newB <- case malignment of+      Nothing -> newPinnedBuffer newSz+      Just al -> newAlignedPinnedBuffer newSz al+   copyBuffer b 0 newB 0 off+   pure (newB,off)++++-- | Buffer extension information+data BufferOverflow b = BufferOverflow+   { overflowBuffer   :: b     -- ^ Current buffer+   , overflowOffset   :: Word  -- ^ Current offset in buffer+   , overflowRequired :: Word  -- ^ Required size in bytes (don't take into account leftover bytes in the current buffer)+   }++----------------------------------------------------------------------+-- BufferPut+----------------------------------------------------------------------++-- | BufferPutT state+data BufferPutState m b = BufferPutState+   { bufferPutBuffer :: !b                      -- ^ Buffer used for writing+   , bufferPutOffset :: !Word                   -- ^ Current offset+   , bufferPutStrat  :: !(OverflowStrategy m b) -- ^ Extension strategy+   }++-- | A Put monad than fails when there is not enough space in the target buffer+newtype BufferPutT b m a+   = BufferPutT (StateT (BufferPutState m b) m a)+   deriving newtype (Functor, Applicative, Monad, MonadFail, MonadFix, MonadIO)++type BufferPut b a = BufferPutT b Identity a++-- | Lift into BufferPutT+liftBufferPut :: Monad m => m a -> BufferPutT b m a+liftBufferPut act = BufferPutT (lift act)++-- | Run a buffer put+runBufferPut :: Monad m => b -> Word -> OverflowStrategy m b -> BufferPutT b m a -> m (a,b,Word)+runBufferPut b off strat (BufferPutT s) = do+   (a,s') <- runStateT s (BufferPutState b off strat)+   return (a,bufferPutBuffer s',bufferPutOffset s')++-- | Get current offset+getPutOffset :: Monad m => BufferPutT b m Word+getPutOffset = BufferPutT (bufferPutOffset <$> S.get)++-- | Get buffer+getPutBuffer :: Monad m => BufferPutT b m b+getPutBuffer = BufferPutT (bufferPutBuffer <$> S.get)++-- | Set buffer+setPutBuffer :: Monad m => b -> BufferPutT b m ()+setPutBuffer v = BufferPutT do+   S.modify \s -> s { bufferPutBuffer = v }+++-- | Get current offset+setPutOffset :: Monad m => Word -> BufferPutT b m ()+setPutOffset v = BufferPutT do+   S.modify \s -> s { bufferPutOffset = v }++-- | Get extend strategy+getPutOverflowStrategy :: Monad m => BufferPutT b m (OverflowStrategy m b)+getPutOverflowStrategy = BufferPutT (bufferPutStrat <$> S.get)+++-- | Helper to put something+putSomething+   :: MonadIO m+   => Word+   -> (Buffer 'Mutable pin fin heap -> Word -> t -> m ())+   -> t+   -> BufferPutT (Buffer 'Mutable pin fin heap) m ()+{-# INLINABLE putSomething #-}+putSomething sz act v = putSomeThings sz $ Just \b off -> act b off v++-- | Helper to put some things+putSomeThings+   :: MonadIO m+   => Word+   -> Maybe (Buffer 'Mutable pin fin heap -> Word -> m ())+   -> BufferPutT (Buffer 'Mutable pin fin heap) m ()+{-# INLINABLE putSomeThings #-}+putSomeThings sz mact = do+   off <- getPutOffset+   b   <- getPutBuffer+   bs  <- liftIO (bufferSizeIO b)+   let !newOff = off+sz++   if (newOff > bs)+      then do -- we need to extend/flush the buffer+         OverflowStrategy strat <- getPutOverflowStrategy+         (upB,upOff) <- liftBufferPut <| strat <| BufferOverflow+                              { overflowBuffer   = b+                              , overflowOffset   = off+                              , overflowRequired = sz+                              }+         setPutBuffer upB+         setPutOffset upOff+         putSomeThings sz mact++      else case mact of+            Nothing  -> return () -- we only preallocate+            Just act -> do        -- we write something for real+               liftBufferPut (act b off)+               setPutOffset newOff+   ++instance+   ( MonadIO m+   ) => PutMonad (BufferPutT (Buffer 'Mutable pin gc heap) m)+   where+      putWord8  = putSomething 1 bufferWriteWord8IO+      putWord16 = putSomething 2 bufferWriteWord16IO+      putWord32 = putSomething 4 bufferWriteWord32IO+      putWord64 = putSomething 8 bufferWriteWord64IO++      putWord8s xs = putSomeThings (fromIntegral (length xs)) $ Just \b off -> do+         forM_ ([off,(off+1)..] `zip` xs) $ \(boff,v) -> do+            bufferWriteWord8IO b boff v++      putWord16s xs = putSomeThings (2*fromIntegral (length xs)) $ Just \b off -> do+         forM_ ([off,(off+2)..] `zip` xs) $ \(boff,v) -> do+            bufferWriteWord16IO b boff v++      putWord32s xs = putSomeThings (4*fromIntegral (length xs)) $ Just \b off -> do+         forM_ ([off,(off+4)..] `zip` xs) $ \(boff,v) -> do+            bufferWriteWord32IO b boff v++      putWord64s xs = putSomeThings (8*fromIntegral (length xs)) $ Just \b off -> do+         forM_ ([off,(off+8)..] `zip` xs) $ \(boff,v) -> do+            bufferWriteWord64IO b boff v++      preAllocateAtLeast l = putSomeThings l Nothing++      putBuffer x = do+         sz <- liftIO (bufferSizeIO x)+         putSomeThings sz $ Just \b off -> copyBuffer x 0 b off sz++----------------------------------------------------------------------+-- BufferGet+----------------------------------------------------------------------++-- | BufferGetT state+data BufferGetState m b = BufferGetState+   { bufferGetBuffer :: !b                      -- ^ Buffer used for reading+   , bufferGetOffset :: !Word                   -- ^ Current offset+   , bufferGetStrat  :: !(OverflowStrategy m b) -- ^ Extension stretegy+   }++-- | A Get monad over a Buffer+newtype BufferGetT b m a+   = BufferGetT (StateT (BufferGetState m b) m a)+   deriving newtype (Functor, Applicative, Monad, MonadFail, MonadFix, MonadIO)++type BufferGet b a = BufferGetT b Identity a++instance+   ( MonadIO m+   ) => GetMonad (BufferGetT (Buffer mut pin gc heap) m)+   where+      getSkipBytes n = getSomething n \_ _ -> return ()+      getWord8       = getSomething 1 bufferReadWord8IO+      getWord16      = getSomething 2 bufferReadWord16IO+      getWord32      = getSomething 4 bufferReadWord32IO+      getWord64      = getSomething 8 bufferReadWord64IO+      getBuffer sz   = getSomething sz \b off -> do+         dest <- newBuffer sz+         copyBuffer b off dest 0 sz+         unsafeBufferFreeze dest+      getBufferInto sz dest mdoff = getSomething sz \b off -> do+         copyBuffer b off dest (fromMaybe 0 mdoff) sz++-- | Lift into BufferGetT+liftBufferGet :: Monad m => m a -> BufferGetT b m a+liftBufferGet act = BufferGetT (lift act)++-- | Run a buffer get+runBufferGet :: Monad m => b -> Word -> OverflowStrategy m b -> BufferGetT b m a -> m (a,b,Word)+runBufferGet b off strat (BufferGetT s) = do+   (a,s') <- runStateT s (BufferGetState b off strat)+   return (a,bufferGetBuffer s',bufferGetOffset s')++-- | Get current offset+getGetOffset :: Monad m => BufferGetT b m Word+getGetOffset = BufferGetT (bufferGetOffset <$> S.get)++-- | Get buffer+getGetBuffer :: Monad m => BufferGetT b m b+getGetBuffer = BufferGetT (bufferGetBuffer <$> S.get)++-- | Set buffer+setGetBuffer :: Monad m => b -> BufferGetT b m ()+setGetBuffer v = BufferGetT do+   S.modify \s -> s { bufferGetBuffer = v }+++-- | Get current offset+setGetOffset :: Monad m => Word -> BufferGetT b m ()+setGetOffset v = BufferGetT do+   S.modify \s -> s { bufferGetOffset = v }++-- | Get extend strategy+getGetOverflowStrategy :: Monad m => BufferGetT b m (OverflowStrategy m b)+getGetOverflowStrategy = BufferGetT (bufferGetStrat <$> S.get)++-- | Helper to get some things+getSomething ::+   ( Monad m+   , MonadIO m+   ) => Word+     -> (Buffer mut pin gc heap -> Word -> m a)+     -> BufferGetT (Buffer mut pin gc heap) m a+getSomething sz act = do+   off <- getGetOffset+   b   <- getGetBuffer+   bsz <- bufferSizeIO b++   let !newOff = off+sz++   if newOff > bsz+      then do -- we need to extend the buffer or fail+         OverflowStrategy strat <- getGetOverflowStrategy+         (upB,upOff) <- liftBufferGet <| strat <| BufferOverflow+                              { overflowBuffer   = b+                              , overflowOffset   = off+                              , overflowRequired = sz+                              }+         setGetBuffer upB+         setGetOffset upOff+         getSomething sz act++      else do+         setGetOffset newOff+         liftBufferGet (act b off)

@@ -0,0 +1,75 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Haskus.Binary.Serialize.File+   ( FileGetState (..)+   , FileGetT (..)+   , runFileGet+   , runFilePathGet+   )+where++import Haskus.Binary.Serialize.Get+import Haskus.Binary.Storable+import Haskus.Memory.Buffer+import Haskus.Utils.Monad+import Haskus.Utils.Maybe++import GHC.Exts (Ptr (..))+import System.IO+import Control.Monad.Trans.State.Strict as S+import Control.Monad.Fail as F+import Control.Monad.Fix++-- | FileGetT state+data FileGetState = FileGetState+   { fileGetHandle :: !Handle+   }++-- | A Get monad over a File+newtype FileGetT m a+   = FileGetT (StateT FileGetState m a)+   deriving newtype (Functor, Applicative, Monad, MonadFail, MonadFix, MonadIO)++-- | Get file handle+getHandle :: Monad m => FileGetT m (Handle)+getHandle = FileGetT (gets fileGetHandle)++-- | Helper to get some things+getSomething :: forall a m.+   ( MonadIO m+   ) => Word -> (Ptr a -> IO a) -> FileGetT m a+getSomething sz act = do+   hdl <- getHandle+   liftIO $ allocaBytes sz \p -> do+      -- FIXME: handle EOF+      _n <- hGetBuf hdl p (fromIntegral sz)+      act p+++instance (MonadIO m) => GetMonad (FileGetT m) where+      getSkipBytes n = do+         hdl <- getHandle+         liftIO $ hSeek hdl RelativeSeek (fromIntegral n)++      getWord8       = getSomething 1 peek+      getWord16      = getSomething 2 peek+      getWord32      = getSomething 4 peek+      getWord64      = getSomething 8 peek++      getBufferInto sz dest mdoff = getSomething sz \(Ptr addr) -> do+         let b = BufferE addr sz+         copyBuffer b 0 dest (fromMaybe 0 mdoff) sz+++-- | Run a getter on a file+runFileGet :: Handle -> FileGetT IO a -> IO a+runFileGet hdl (FileGetT s) = do+   (a,_s') <- runStateT s (FileGetState hdl)+   return a++-- | Run a getter on a file+runFilePathGet :: FilePath -> FileGetT IO a -> IO a+runFilePathGet path s = withBinaryFile path ReadMode (\hdl -> runFileGet hdl s)

@@ -0,0 +1,142 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Binary deserialization of Haskell values+module Haskus.Binary.Serialize.Get+   ( GetMonad (..)+   , getFloat32+   , getFloat32LE+   , getFloat32BE+   , getFloat64+   , getFloat64LE+   , getFloat64BE+   , getWord16BE+   , getWord32BE+   , getWord64BE+   , getWord16LE+   , getWord32LE+   , getWord64LE+   , getWord16BEs+   , getWord32BEs+   , getWord64BEs+   , getWord16LEs+   , getWord32LEs+   , getWord64LEs+   )+where++import Haskus.Memory.Buffer+import Haskus.Number.Word+import Haskus.Binary.Endianness+import Haskus.Number.Float+import Haskus.Utils.Flow++import GHC.Exts (IsList(..))+++-- | Monad which can read a sequence of bytes+class Monad m => GetMonad m where+   -- | Read a Word8+   getWord8    :: m Word8+   -- | Read a Word16 with host endianness+   getWord16   :: m Word16+   -- | Read a Word32 with host endianness+   getWord32   :: m Word32+   -- | Read a Word64 with host endianness+   getWord64   :: m Word64++   -- | Read some Word8+   getWord8s     :: Word -> m [Word8]+   getWord8s n = replicateM (fromIntegral n) getWord8+   -- | Read some Word16 with host endianness+   getWord16s    :: Word -> m [Word16]+   getWord16s n = replicateM (fromIntegral n) getWord16+   -- | Read some Word32 with host endianness+   getWord32s    :: Word -> m [Word32]+   getWord32s n = replicateM (fromIntegral n) getWord32+   -- | Read some Word64 with host endianness+   getWord64s    :: Word -> m [Word64]+   getWord64s n = replicateM (fromIntegral n) getWord64++   -- | Read the given amount of bytes into a new buffer+   getBuffer     :: Word -> m BufferI+   getBuffer n = do+      xs <- replicateM (fromIntegral n) getWord8+      return (fromListN (fromIntegral n) xs)++   -- | Read the given amount of bytes into the specified buffer at the+   -- optionally specified offset+   getBufferInto :: Word -> Buffer 'Mutable pin gc heap -> Maybe Word -> m ()++   -- | Skip the given amount of bytes+   getSkipBytes :: Word -> m ()+++-- | Get a Float64 with host order+getFloat64 :: GetMonad m => m Float64+getFloat64 = getWord64 ||> word64ToFloat64++-- | Get a Float64 with little-endian order+getFloat64LE :: GetMonad m => m Float64+getFloat64LE = getWord64LE ||> word64ToFloat64++-- | Get a Float64 with big-endian order+getFloat64BE :: GetMonad m => m Float64+getFloat64BE = getWord64BE ||> word64ToFloat64++-- | Get a Float32 with host order+getFloat32 :: GetMonad m => m Float32+getFloat32 = getWord32 ||> word32ToFloat32++-- | Get a Float32 with little-endian order+getFloat32LE :: GetMonad m => m Float32+getFloat32LE = getWord32LE ||> word32ToFloat32++-- | Get a Float32 with big-endian order+getFloat32BE :: GetMonad m => m Float32+getFloat32BE = getWord32BE ||> word32ToFloat32++-- | Read a Word16 with little-endian order+getWord16LE   :: GetMonad m => m Word16+getWord16LE = littleEndianToHost <$> getWord16+-- | Read a Word32 with little-endian order+getWord32LE   :: GetMonad m => m Word32+getWord32LE = littleEndianToHost <$> getWord32+-- | Read a Word64 with little-endian order+getWord64LE   :: GetMonad m => m Word64+getWord64LE = littleEndianToHost <$> getWord64+-- | Read a Word16 with big-endian order+getWord16BE   :: GetMonad m => m Word16+getWord16BE = bigEndianToHost <$> getWord16+-- | Read a Word32 with big-endian order+getWord32BE   :: GetMonad m => m Word32+getWord32BE = bigEndianToHost <$> getWord32+-- | Read a Word64 with big-endian order+getWord64BE   :: GetMonad m => m Word64+getWord64BE = bigEndianToHost <$> getWord64+++-- | Read some Word16 with little-endian order+getWord16LEs    :: GetMonad m => Word -> m [Word16]+getWord16LEs n = fmap littleEndianToHost <$> getWord16s n+-- | Read some Word32 with little-endian order+getWord32LEs    :: GetMonad m => Word -> m [Word32]+getWord32LEs n =  fmap littleEndianToHost <$> getWord32s n+-- | Read some Word64 with little-endian order+getWord64LEs    :: GetMonad m => Word -> m [Word64]+getWord64LEs n =  fmap littleEndianToHost <$> getWord64s n++-- | Read some Word16 with big-endian order+getWord16BEs    :: GetMonad m => Word -> m [Word16]+getWord16BEs n = fmap bigEndianToHost <$> getWord16s n+-- | Read some Word32 with big-endian order+getWord32BEs    :: GetMonad m => Word -> m [Word32]+getWord32BEs n = fmap bigEndianToHost <$> getWord32s n+-- | Read some Word64 with big-endian order+getWord64BEs    :: GetMonad m => Word -> m [Word64]+getWord64BEs n = fmap bigEndianToHost <$> getWord64s n

@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Binary serialization of Haskell values+module Haskus.Binary.Serialize.Put+   ( PutMonad (..)+   , putFloat32+   , putFloat32LE+   , putFloat32BE+   , putFloat64+   , putFloat64LE+   , putFloat64BE+   , putWord16BE+   , putWord32BE+   , putWord64BE+   , putWord16LE+   , putWord32LE+   , putWord64LE+   , putWord16BEs+   , putWord32BEs+   , putWord64BEs+   , putWord16LEs+   , putWord32LEs+   , putWord64LEs+   )+where++import Haskus.Memory.Buffer+import Haskus.Number.Word+import Haskus.Binary.Endianness+import Haskus.Number.Float+import Haskus.Utils.Flow++-- | Monad which can build a sequence of bytes+class Monad m => PutMonad m where+   -- | Write a Word8+   putWord8 :: Word8 -> m ()+   -- | Write a Word16+   putWord16 :: Word16 -> m ()+   -- | Write a Word32+   putWord32 :: Word32 -> m ()+   -- | Write a Word64+   putWord64 :: Word64 -> m ()++   -- | Write some Word8+   putWord8s   :: [Word8]  -> m ()+   putWord8s xs = forM_ xs putWord8++   -- | Write some Word16+   putWord16s  :: [Word16] -> m ()+   putWord16s xs = forM_ xs putWord16++   -- | Write some Word32+   putWord32s  :: [Word32] -> m ()+   putWord32s xs = forM_ xs putWord32++   -- | Write some Word64+   putWord64s  :: [Word64] -> m ()+   putWord64s xs = forM_ xs putWord64++   -- | Write the contents of a buffer+   putBuffer   :: BufferSize (Buffer Immutable pin gc heap) => Buffer Immutable pin gc heap -> m ()++   -- | Pre-allocate at least the given amount of bytes+   --+   -- This is a hint for the putter to speed up the allocation of memory+   preAllocateAtLeast :: Word -> m ()+   preAllocateAtLeast _ = return ()++-- | Write a Float64 with host order+putFloat64 :: PutMonad m => Float64 -> m ()+putFloat64 d = putWord64 (float64ToWord64 d)++-- | Write a Float64 with little-endian order+putFloat64LE :: PutMonad m => Float64 -> m ()+putFloat64LE d = putWord64LE (float64ToWord64 d)++-- | Write a Float64 with big-endian order+putFloat64BE :: PutMonad m => Float64 -> m ()+putFloat64BE d = putWord64BE (float64ToWord64 d)++-- | Write a Float32 with host order+putFloat32 :: PutMonad m => Float32 -> m ()+putFloat32 d = putWord32 (float32ToWord32 d)++-- | Write a Float32 with little-endian order+putFloat32LE :: PutMonad m => Float32 -> m ()+putFloat32LE d = putWord32LE (float32ToWord32 d)++-- | Write a Float32 with big-endian order+putFloat32BE :: PutMonad m => Float32 -> m ()+putFloat32BE d = putWord32BE (float32ToWord32 d)+++-- | Write a Word16 with little-endian order+putWord16LE :: PutMonad m => Word16 -> m ()+putWord16LE x = putWord16 (hostToLittleEndian x)+-- | Write a Word32 with little-endian order+putWord32LE :: PutMonad m => Word32 -> m ()+putWord32LE x = putWord32 (hostToLittleEndian x)+-- | Write a Word64 with little-endian order+putWord64LE :: PutMonad m => Word64 -> m ()+putWord64LE x = putWord64 (hostToLittleEndian x)++-- | Write a Word16 with big-endian order+putWord16BE :: PutMonad m => Word16 -> m ()+putWord16BE x = putWord16 (hostToBigEndian x)+-- | Write a Word32 with big-endian order+putWord32BE :: PutMonad m => Word32 -> m ()+putWord32BE x = putWord32 (hostToBigEndian x)+-- | Write a Word64 with big-endian order+putWord64BE :: PutMonad m => Word64 -> m ()+putWord64BE x = putWord64 (hostToBigEndian x)++-- | Write some Word16 with little-endian order+putWord16LEs  :: PutMonad m => [Word16] -> m ()+putWord16LEs xs = putWord16s (fmap hostToLittleEndian xs)+-- | Write some Word32 with little-endian order+putWord32LEs  :: PutMonad m => [Word32] -> m ()+putWord32LEs xs = putWord32s (fmap hostToLittleEndian xs)+-- | Write some Word64 with little-endian order+putWord64LEs :: PutMonad m => [Word64] -> m ()+putWord64LEs xs = putWord64s (fmap hostToLittleEndian xs)+-- | Write some Word16 with big-endian order+putWord16BEs  :: PutMonad m => [Word16] -> m ()+putWord16BEs xs = putWord16s (fmap hostToBigEndian xs)+-- | Write some Word32 with big-endian order+putWord32BEs  :: PutMonad m => [Word32] -> m ()+putWord32BEs xs = putWord32s (fmap hostToBigEndian xs)+-- | Write some Word64 with big-endian order+putWord64BEs :: PutMonad m => [Word64] -> m ()+putWord64BEs xs = putWord64s (fmap hostToBigEndian xs)+

@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}++module Haskus.Binary.Serialize.Size+   ( GetSize (..)+   , runGetSize+   )+where++import Haskus.Binary.Serialize.Put+import Haskus.Memory.Buffer+import Control.Monad.Trans.State.Strict as S++newtype GetSize a+   = GetSize (State Word a) +   deriving newtype (Functor, Applicative, Monad)++-- | Increment the current size+incSize :: Word -> GetSize ()+incSize x = GetSize (state (\s -> ((),s+x)))++-- | Get the total size+runGetSize :: GetSize a -> Word+runGetSize (GetSize s) = execState s 0++instance PutMonad GetSize where+   putWord8 _  = incSize 1+   putWord16 _ = incSize 2+   putWord32 _ = incSize 4+   putWord64 _ = incSize 8+   putBuffer b = incSize (bufferSize b)

@@ -0,0 +1,544 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Storable class+module Haskus.Binary.Storable+   ( StaticStorable (..)+   , staticPeek+   , staticPoke+   , staticSizeOf+   , staticAlignment+   , wordBytes+   -- * Storable+   , Storable (..)+   , peek+   , poke+   , sizeOf'+   , sizeOfT+   , sizeOfT'+   , alignment'+   , alignmentT+   , alignmentT'+   , peekByteOff+   , pokeByteOff+   , peekElemOff+   , pokeElemOff+   , alloca+   , allocaBytes+   , allocaBytesAligned+   , malloc+   , with+   , withMany+   , allocaArray+   , mallocArray+   , withArray+   , withArrayLen+   , peekArray+   , pokeArray+   -- * Padding+   , RequiredPadding+   , Padding+   , PaddingEx+   )+where++import qualified Foreign.Storable as FS+import Foreign.C.Types (CSize,CChar,CULong,CLong,CUInt,CInt,CUShort,CShort)+import qualified Foreign.Marshal.Alloc as P+import System.IO.Unsafe++import Haskus.Number.Word+import Haskus.Number.Int+import Haskus.Memory.Ptr+import Haskus.Utils.Types+import Haskus.Utils.Types.Generics+import Haskus.Utils.Flow+import Foreign.Ptr++-- | A storable data in constant space whose size is known at compile time+class StaticStorable a where+   -- | Size of the stored data (in bytes)+   type SizeOf a    :: Nat++   -- | Alignment requirement (in bytes)+   type Alignment a :: Nat++   -- | Peek (read) a value from a memory address+   staticPeekIO :: Ptr a -> IO a++   -- | Poke (write) a value at the given memory address+   staticPokeIO :: Ptr a -> a -> IO ()++-- | Peek (read) a value from a memory address+staticPeek :: (StaticStorable a, MonadIO m) => Ptr a -> m a+staticPeek p = liftIO (staticPeekIO p)++-- | Poke (write) a value at the given memory address+staticPoke :: (StaticStorable a, MonadIO m) => Ptr a -> a -> m ()+staticPoke p a = liftIO (staticPokeIO p a)+++-- | Get statically known size+staticSizeOf :: forall a.+   ( KnownNat (SizeOf a)+   ) => a -> Word+staticSizeOf _ = natValue' @(SizeOf a)++-- | Get statically known alignment+staticAlignment :: forall a.+   ( KnownNat (Alignment a)+   ) => a -> Word+staticAlignment _ = natValue' @(Alignment a)+++-- | Get bytes in host-endianness order+wordBytes :: forall a.+   ( Storable a+   , KnownNat (SizeOf a)+   ) => a -> [Word8]+{-# INLINABLE wordBytes #-}+wordBytes x = unsafePerformIO $+   with x $ \p -> mapM (peekByteOff (castPtr p)) [0..natValue @(SizeOf a) - 1]++++-- | Storable data-types+--+-- Currently we cannot automatically derive a Storable class with type-level+-- naturals for "alignment" and "sizeOf". Instead we define a Storable class+-- isomorphic to the Foreign.Storable's one but with default methods using+-- DefaultSignatures (i.e., the Storable instance can be automatically derived+-- from a Generic instance).+class Storable a where+  peekIO            :: Ptr a -> IO a+  default peekIO    :: (Generic a, GStorable (Rep a)) => Ptr a -> IO a+  peekIO p          = fmap to $ gcPeek 0 (castPtr p)++  pokeIO            :: Ptr a -> a -> IO ()+  default pokeIO    :: (Generic a, GStorable (Rep a)) => Ptr a -> a -> IO ()+  pokeIO p x        = gcPoke 0 (castPtr p) $ from x++  alignment         :: a -> Word+  default alignment :: (Generic a, GStorable (Rep a)) => a -> Word+  alignment         = gcAlignment . from++  sizeOf            :: a -> Word+  default sizeOf    :: (Generic a, GStorable (Rep a)) => a -> Word+  sizeOf            = gcSizeOf 0 . from++-- | Peek a value from a pointer+peek :: (Storable a, MonadIO m) => Ptr a -> m a+peek p = liftIO (peekIO p)++-- | Poke a value to a pointer+poke :: (Storable a, MonadIO m) => Ptr a -> a -> m ()+poke p v = liftIO (pokeIO p v)++-- | Generalized 'sizeOf'+sizeOf' :: (Integral b, Storable a) => a -> b+{-# INLINABLE sizeOf' #-}+sizeOf' = fromIntegral . sizeOf++-- | SizeOf (for type-application)+sizeOfT :: forall a. (Storable a) => Word+{-# INLINABLE sizeOfT #-}+sizeOfT = sizeOf (undefined :: a)++-- | SizeOf' (for type-application)+sizeOfT' :: forall a b. (Storable a, Integral b) => b+{-# INLINABLE sizeOfT' #-}+sizeOfT' = sizeOf' (undefined :: a)++-- | Generalized 'alignment'+alignment' :: (Integral b, Storable a) => a -> b+{-# INLINABLE alignment' #-}+alignment' = fromIntegral . alignment++-- | Alignment (for type-application)+alignmentT :: forall a. (Storable a) => Word+{-# INLINABLE alignmentT #-}+alignmentT = alignment (undefined :: a)++-- | Alignment' (for type-application)+alignmentT' :: forall a b. (Storable a, Integral b) => b+{-# INLINABLE alignmentT' #-}+alignmentT' = alignment' (undefined :: a)++-- | Peek with byte offset+peekByteOff :: (MonadIO m, Storable a) => Ptr a -> Int -> m a+{-# INLINABLE peekByteOff #-}+peekByteOff ptr off = peek (ptr `plusPtr` off)++-- | Poke with byte offset+pokeByteOff :: (MonadIO m, Storable a) => Ptr a -> Int -> a -> m ()+{-# INLINABLE pokeByteOff #-}+pokeByteOff ptr off = poke (ptr `plusPtr` off)++-- | Peek with element size offset+peekElemOff :: forall a m. (MonadIO m, Storable a) => Ptr a -> Int -> m a+peekElemOff ptr off = peekByteOff ptr (off * sizeOfT' @a)++-- | Poke with element size offset+pokeElemOff :: (MonadIO m, Storable a) => Ptr a -> Int -> a -> m ()+pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf' val) val++-- | Allocate some bytes+allocaBytes :: MonadInIO m => Word -> (Ptr a -> m b) -> m b+allocaBytes sz = liftWith (P.allocaBytes (fromIntegral sz))++-- | Allocate some aligned bytes+allocaBytesAligned :: MonadInIO m => Word -> Word -> (Ptr a -> m b) -> m b+allocaBytesAligned sz align = liftWith (P.allocaBytesAligned (fromIntegral sz) (fromIntegral align))++-- | @'alloca' f@ executes the computation @f@, passing as argument+-- a pointer to a temporarily allocated block of memory sufficient to+-- hold values of type @a@.+--+-- The memory is freed when @f@ terminates (either normally or via an+-- exception), so the pointer passed to @f@ must /not/ be used after this.+--+alloca :: forall a b m. (MonadInIO m, Storable a) => (Ptr a -> m b) -> m b+{-# INLINABLE alloca #-}+alloca = allocaBytesAligned (sizeOfT' @a) (alignmentT' @a)++-- | Allocate a block of memory that is sufficient to hold values of type+-- @a@. The size of the area allocated is determined by the 'sizeOf'+-- method from the instance of 'Storable' for the appropriate type.+--+-- The memory may be deallocated using 'free' or 'finalizerFree' when+-- no longer required.+malloc :: forall a m. (MonadIO m, Storable a) => m (Ptr a)+{-# INLINABLE malloc #-}+malloc = liftIO (P.mallocBytes (fromIntegral (sizeOfT @a)))++-- | @'with' val f@ executes the computation @f@, passing as argument+-- a pointer to a temporarily allocated block of memory into which+-- @val@ has been marshalled (the combination of 'alloca' and 'poke').+--+-- The memory is freed when @f@ terminates (either normally or via an+-- exception), so the pointer passed to @f@ must /not/ be used after this.+with :: (MonadInIO m, Storable a) => a -> (Ptr a -> m b) -> m b+{-# INLINABLE with #-}+with val f =+   alloca $ \ptr -> do+      poke ptr val+      f ptr++-- | Temporarily allocate space for the given number of elements+-- (like 'alloca', but for multiple elements).+allocaArray :: forall a b m. (MonadInIO m, Storable a) => Word -> (Ptr a -> m b) -> m b+allocaArray size = liftWith (allocaBytesAligned (size * sizeOfT' @a) (alignmentT' @a))++-- | Allocate space for the given number of elements+-- (like 'malloc', but for multiple elements).+mallocArray :: forall a m. (MonadIO m, Storable a) => Word -> m (Ptr a)+mallocArray size = liftIO $ P.mallocBytes (fromIntegral (size * sizeOfT @a))++-- | Convert an array of given length into a Haskell list.  The implementation+-- is tail-recursive and so uses constant stack space.+peekArray :: (MonadIO m, Storable a) => Word -> Ptr a -> m [a]+peekArray size ptr+   | size <= 0 = return []+   | otherwise = f (size-1) []+  where+    f 0 acc = (:acc) <$> peekElemOff ptr 0+    f n acc = f (n-1) =<< ((:acc) <$> peekElemOff ptr (fromIntegral n))++-- | Write the list elements consecutive into memory+pokeArray :: (MonadIO m, Storable a) => Ptr a -> [a] -> m ()+pokeArray ptr vals0 = go vals0 0+  where go [] _         = return ()+        go (val:vals) n = do pokeElemOff ptr n val; go vals (n+1)++-- | Temporarily store a list of storable values in memory+-- (like 'with', but for multiple elements).+withArray :: (MonadInIO m, Storable a) => [a] -> (Ptr a -> m b) -> m b+withArray vals = withArrayLen vals . const++-- | Like 'withArray', but the action gets the number of values+-- as an additional parameter+withArrayLen :: (MonadInIO m, Storable a) => [a] -> (Word -> Ptr a -> m b) -> m b+withArrayLen vals f  =+  allocaArray len $ \ptr -> do+      pokeArray ptr vals+      f len ptr+  where+    len = fromIntegral (length vals)++-- | Replicates a @withXXX@ combinator over a list of objects, yielding a list of+-- marshalled objects+withMany :: (a -> (b -> res) -> res)  -- withXXX combinator for one object+         -> [a]                       -- storable objects+         -> ([b] -> res)              -- action on list of marshalled obj.s+         -> res+withMany _       []     f = f []+withMany withFoo (x:xs) f = withFoo x $ \x' ->+                              withMany withFoo xs (\xs' -> f (x':xs'))++class GStorable a where+  gcAlignment :: a x -> Word+  gcPeek      :: Word -> Ptr (a x)-> IO (a x)+  gcPoke      :: Word -> Ptr (a x) -> a x -> IO ()+  gcSizeOf    :: Word -> a x -> Word++  -- padding before the field to align from the given offset+  gcPadding   :: Word -> a x -> Word+  gcPadding off a = (gcAlignment a - off) `mod` gcAlignment a++instance GStorable U1 where+  gcAlignment _ = 0+  gcPeek _ _    = return U1+  gcPoke _ _ _  = return ()+  gcSizeOf _ _  = 0+  gcPadding _ _ = 0++instance (GStorable a, GStorable b) => GStorable (a :*: b) where+  gcAlignment _ = lcm (gcAlignment (undefined :: a x))+                      (gcAlignment (undefined :: b y))++  gcPeek off p = do+    a <- gcPeek off                    $ castPtr p+    b <- gcPeek (off + gcSizeOf off a) $ castPtr p+    return $ a :*: b++  gcPoke off p (a :*: b) = do+    gcPoke off                    (castPtr p) a+    gcPoke (off + gcSizeOf off a) (castPtr p) b++  gcSizeOf off _    = let+    a = undefined :: a x+    b = undefined :: b y+    off2 = off + gcSizeOf off a+    in gcSizeOf off a + gcSizeOf off2 b++instance (GStorable a) => GStorable (M1 i c a) where+  gcAlignment (M1 x)     = gcAlignment x+  gcPeek off p           = fmap M1 $ gcPeek off (castPtr p)+  gcPoke off p (M1 x)    = gcPoke off (castPtr p) x+  gcSizeOf off (M1 x)    = gcSizeOf off x+  gcPadding off (M1 x)   = gcPadding off x++instance (Storable a) => GStorable (K1 i a) where+  gcAlignment (K1 x)     = alignment x+  gcPeek off p           = fmap K1 $ peek (castPtr p `plusPtr` fromIntegral (off + gcPadding off (undefined :: K1 i a x)))+  gcPoke off p (K1 x)    = poke (castPtr p `plusPtr` fromIntegral (off + gcPadding off (undefined :: K1 i a x))) x+  gcSizeOf off (K1 x)    = gcPadding off (undefined :: K1 i a x) + sizeOf x+++-- | Generalize FS.peek+fsPeek :: (FS.Storable a, MonadIO m) => Ptr a -> m a+fsPeek = liftIO . FS.peek++-- | Generalize FS.poke+fsPoke :: (FS.Storable a, MonadIO m) => Ptr a -> a -> m ()+fsPoke ptr a = liftIO (FS.poke ptr a)++instance StaticStorable Word8 where+   type SizeOf    Word8 = 1+   type Alignment Word8 = 1+   staticPeekIO         = fsPeek+   staticPokeIO         = fsPoke++instance StaticStorable Word16 where+   type SizeOf    Word16 = 2+   type Alignment Word16 = 2+   staticPeekIO          = fsPeek+   staticPokeIO          = fsPoke++instance StaticStorable Word32 where+   type SizeOf    Word32 = 4+   type Alignment Word32 = 4+   staticPeekIO          = fsPeek+   staticPokeIO          = fsPoke++instance StaticStorable Word64 where+   type SizeOf    Word64 = 8+   type Alignment Word64 = 8+   staticPeekIO          = fsPeek+   staticPokeIO          = fsPoke++instance StaticStorable Int8 where+   type SizeOf    Int8 = 1+   type Alignment Int8 = 1+   staticPeekIO        = fsPeek+   staticPokeIO        = fsPoke++instance StaticStorable Int16 where+   type SizeOf    Int16 = 2+   type Alignment Int16 = 2+   staticPeekIO         = fsPeek+   staticPokeIO         = fsPoke++instance StaticStorable Int32 where+   type SizeOf    Int32 = 4+   type Alignment Int32 = 4+   staticPeekIO         = fsPeek+   staticPokeIO         = fsPoke++instance StaticStorable Int64 where+   type SizeOf    Int64 = 8+   type Alignment Int64 = 8+   staticPeekIO         = fsPeek+   staticPokeIO         = fsPoke+++instance Storable Word8 where+   sizeOf    _ = 1+   alignment _ = 1+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Word16 where+   sizeOf    _ = 2+   alignment _ = 2+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Word32 where+   sizeOf    _ = 4+   alignment _ = 4+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Word64 where+   sizeOf    _ = 8+   alignment _ = 8+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Int8 where+   sizeOf    _ = 1+   alignment _ = 1+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Int16 where+   sizeOf    _ = 2+   alignment _ = 2+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Int32 where+   sizeOf    _ = 4+   alignment _ = 4+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Int64 where+   sizeOf    _ = 8+   alignment _ = 8+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Float where+   sizeOf    _ = 4+   alignment _ = 4+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Double where+   sizeOf    _ = 8+   alignment _ = 8+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Char where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Word where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable Int where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable (Ptr a) where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable CSize where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable CChar where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable CULong where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable CLong where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable CUInt where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable CInt where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable CUShort where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable CShort where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++instance Storable WordPtr where+   sizeOf      = fromIntegral . FS.sizeOf+   alignment   = fromIntegral . FS.alignment+   peekIO      = fsPeek+   pokeIO      = fsPoke++---------------------------+-- Padding+---------------------------++-- | Compute the required padding between a and b to respect b's alignment+type family RequiredPadding a b where+   RequiredPadding a b = Padding (SizeOf a) b++-- | Compute the required padding between the size sz and b to respect b's alignment+type family Padding (sz :: Nat) b where+   Padding sz b = PaddingEx (Mod sz (Alignment b)) (Alignment b)++type family PaddingEx (m :: Nat) (a :: Nat) where+   PaddingEx 0 a = 0+   PaddingEx m a = a - m

@@ -0,0 +1,186 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Union (as in C)+--+-- Unions are storable and can contain any storable data.+-- +-- Use 'fromUnion' to read an alternative:+--+-- @+-- {-# LANGUAGE DataKinds #-}+--+-- getUnion :: IO (Union '[Word16, Word32, Word64])+-- getUnion = ...+--+-- test = do+--    u <- getUnion+--+--    -- to get one of the member+--    let v = fromUnion u :: Word16+--    let v = fromUnion u :: Word32+--    let v = fromUnion u :: Word64+--+--    -- This won't compile (Word8 is not a member of the union)+--    let v = fromUnion u :: Word8+-- @+--+-- Use 'toUnion' to create a new union:+--+-- @+-- let+--    u2 :: Union '[Word32, Vector 4 Word8]+--    u2 = toUnion (0x12345678 :: Word32)+-- @+--+module Haskus.Binary.Union+   ( Union+   , fromUnion+   , toUnion+   , toUnionZero+   )+where++import Haskus.Utils.Types hiding (Union)+import Haskus.Utils.HList+import Haskus.Utils.Flow (when)+import Haskus.Binary.Storable+import Haskus.Memory.Utils (memCopy, memSet)++import System.IO.Unsafe (unsafePerformIO)++import Foreign.ForeignPtr+import Foreign.Ptr+import qualified Foreign.Storable as FS+++-- TODO: rewrite rules+-- poke p (toUnion x) = poke (castPtr p) x+--+-- (fromUnion <$> peek p) :: IO a  = peek (castPtr p) :: IO a++++-- | An union +--+-- We use a list of types as a parameter.+--+-- The union is just a pointer to a buffer containing the value(s). The size of+-- the buffer is implicitly known from the types in the list.+newtype Union (x :: [*]) = Union (ForeignPtr ()) deriving (Show)++-- | Retrieve a union member from its type+fromUnion :: (Storable a, Member a l) => Union l -> a+fromUnion (Union fp) = unsafePerformIO $ withForeignPtr fp (peek . castPtr)++-- | Create a new union from one of the union types+toUnion :: forall a l . (Storable (Union l), Storable a, Member a l) => a -> Union l+toUnion = toUnion' False++-- | Like 'toUnion' but set the remaining bytes to 0+toUnionZero :: forall a l . (Storable (Union l), Storable a, Member a l) => a -> Union l+toUnionZero = toUnion' True+++-- | Create a new union from one of the union types+toUnion' :: forall a l . (Storable (Union l), Storable a, Member a l) => Bool -> a -> Union l+toUnion' zero v = unsafePerformIO $ do+   let sz = sizeOfT @(Union l)+   fp <- mallocForeignPtrBytes (fromIntegral sz)+   withForeignPtr fp $ \p -> do+      -- set bytes after the object to 0+      when zero $ do+         let psz = sizeOfT @a+         memSet (p `plusPtr` fromIntegral psz) (fromIntegral (sz - psz)) 0+      poke (castPtr p) v+   return $ Union fp++type family MapSizeOf fs where+   MapSizeOf '[]       = '[]+   MapSizeOf (x ': xs) = SizeOf x ': MapSizeOf xs++type family MapAlignment fs where+   MapAlignment '[]       = '[]+   MapAlignment (x ': xs) = Alignment x ': MapAlignment xs+++instance forall fs.+      ( KnownNat (ListMax (MapSizeOf fs))+      , KnownNat (ListMax (MapAlignment fs))+      )+      => StaticStorable (Union fs)+   where+      type SizeOf (Union fs)    = ListMax (MapSizeOf fs)+      type Alignment (Union fs) = ListMax (MapAlignment fs)++      staticPeekIO ptr = do+         let sz = natValue @(SizeOf (Union fs))+         fp <- mallocForeignPtrBytes sz+         withForeignPtr fp $ \p -> +            memCopy p (castPtr ptr) (fromIntegral sz)+         return (Union fp)++      staticPokeIO ptr (Union fp) = do+         withForeignPtr fp $ \p ->+            memCopy (castPtr ptr) p (natValue @(SizeOf (Union fs)))++-------------------------------------------------------------------------------------+-- We use HFoldr' to get the maximum size and alignment of the types in the union+-------------------------------------------------------------------------------------++data FoldSizeOf    = FoldSizeOf+data FoldAlignment = FoldAlignment++instance (r ~ Word, Storable a) => Apply FoldSizeOf (a, Word) r where+   apply _ (_,r) = max r (sizeOfT @a)++instance (r ~ Word, Storable a) => Apply FoldAlignment (a, Word) r where+   apply _ (_,r) = max r (alignmentT @a)++-- | Get the union size (i.e. the maximum of the types in the union)+unionSize :: forall l . HFoldr' FoldSizeOf Word l Word => Union l -> Word+unionSize _ = hFoldr' FoldSizeOf (0 :: Word) (undefined :: HList l)++-- | Get the union alignment (i.e. the maximum of the types in the union)+unionAlignment :: forall l . HFoldr' FoldAlignment Word l Word => Union l -> Word+unionAlignment _ = hFoldr' FoldAlignment (0 :: Word) (undefined :: HList l)+++-------------------------------------------------------------------------------------+-- Finally we can write the Storable instance+-------------------------------------------------------------------------------------++instance+   ( HFoldr' FoldSizeOf Word l Word+   , HFoldr' FoldAlignment Word l Word+   ) => Storable (Union l) where+   sizeOf     = unionSize+   alignment  = unionAlignment+   peekIO ptr = do+      let sz = sizeOfT' @(Union l)+      fp <- mallocForeignPtrBytes sz+      withForeignPtr fp $ \p -> +         memCopy p (castPtr ptr) (fromIntegral sz)+      return (Union fp)++   pokeIO ptr (Union fp) = withForeignPtr fp $ \p ->+      memCopy (castPtr ptr) p (sizeOfT' @(Union l))+++-- compatibility instance with Foreign.Storable+instance+   ( HFoldr' FoldSizeOf Word l Word+   , HFoldr' FoldAlignment Word l Word+   ) => FS.Storable (Union l) where+   sizeOf     = fromIntegral . unionSize+   alignment  = fromIntegral . unionAlignment+   peek       = peekIO+   poke       = pokeIO