packages feed

haskus-binary (empty) → 0.6.0.0

raw patch · 36 files changed

+5499/−0 lines, 36 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, cereal, criterion, haskus-binary, haskus-utils, mtl, tasty, tasty-quickcheck

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2013-2017, Haskus organization+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.++    * Neither the name of Sylvain Henry nor the names of other contributors +      may be used to endorse or promote products derived from this software +      without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT,+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskus-binary.cabal view
@@ -0,0 +1,101 @@+name:                haskus-binary+version:             0.6.0.0+synopsis:            Haskus binary format manipulation+license:             BSD3+license-file:        LICENSE+author:              Sylvain Henry+maintainer:          sylvain@haskus.fr+homepage:            http://www.haskus.org/system+copyright:           Sylvain Henry 2017+category:            System+build-type:          Simple+cabal-version:       >=1.20++description:+   A set of types and tools to manipulate binary data, memory, etc. In+   particular to interface Haskell data types with foreign data types (C+   structs, unions, enums, etc.).++source-repository head+  type: git+  location: git://github.com/haskus/haskus-binary.git++library+  exposed-modules:++    Haskus.Format.Binary.Bits+    Haskus.Format.Binary.Bits.Basic+    Haskus.Format.Binary.Bits.Reverse+    Haskus.Format.Binary.Bits.Order+    Haskus.Format.Binary.Bits.Get+    Haskus.Format.Binary.Bits.Put++    Haskus.Format.Binary.BitSet+    Haskus.Format.Binary.BitField+    Haskus.Format.Binary.Buffer+    Haskus.Format.Binary.BufferList+    Haskus.Format.Binary.BufferBuilder+    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.Record+    Haskus.Format.Binary.Storable+    Haskus.Format.Binary.Word+    Haskus.Format.Binary.Ptr++    Haskus.Format.Binary.Layout++    Haskus.Utils.Memory++  other-modules:++  build-depends:       +         base                      >= 4.9 && < 4.10+      ,  haskus-utils              >= 0.6+      ,  cereal                    >= 0.5+      ,  bytestring                >= 0.10+      ,  mtl                       >= 2.2++  build-tools: +  ghc-options:          -Wall+  default-language:     Haskell2010+  hs-source-dirs:       src/lib++test-suite tests+   type:                exitcode-stdio-1.0+   main-is:             Main.hs+   hs-source-dirs:      src/tests/+   ghc-options:         -O2 -Wall -threaded+   default-language:    Haskell2010+   other-modules:+         Haskus.Tests.Format.Binary+      ,  Haskus.Tests.Common+      ,  Haskus.Tests.Format.Binary.Bits+      ,  Haskus.Tests.Format.Binary.GetPut+      ,  Haskus.Tests.Format.Binary.Vector++   build-depends:    +         base+      ,  haskus-binary+      ,  haskus-utils+      ,  tasty                   >= 0.11+      ,  tasty-quickcheck        >= 0.8+      ,  QuickCheck              >= 2.8+      ,  bytestring++Benchmark bench-BitReverse+   type:               exitcode-stdio-1.0+   main-is:            BitReverse.hs+   hs-source-dirs:     src/bench+   ghc-options:         -Wall -threaded -O3+   default-language:     Haskell2010+   build-depends:+         base+      ,  haskus-binary+      ,  criterion
+ src/bench/BitReverse.hs view
@@ -0,0 +1,51 @@++import Criterion.Main+import Haskus.Format.Binary.Bits.Reverse+import Haskus.Format.Binary.Word++main :: IO ()+main = do+   let +      w8  = 0x37               :: Word8+      w16 = 0x3547             :: Word16+      w32 = 0x3547ea87         :: Word32+      w64 = 0x3547ea8712345678 :: Word64+   defaultMain+      [ bgroup "Reverse bits in Word8"+         [ bench "Obvious way"                           $ whnf reverseBitsObvious w8+         , bench "4 64-bit operations, no division"      $ whnf reverseBits4Ops    w8+         , bench "3 64-bit operations, modulus division" $ whnf reverseBits3Ops    w8+         , bench "Lookup table"                          $ whnf reverseBitsTable   w8+         , bench "7 no 64-bit operations, no division"   $ whnf reverseBits7Ops    w8+         , bench "5LgN operations, no division"          $ whnf reverseBits5LgN    w8+         , bench "Currently selected algorithm"          $ whnf reverseBits        w8+         ]+      , bgroup "Reverse bits in Word16"+         [ bench "Obvious way"                           $ whnf (                reverseBitsObvious) w16+         , bench "4 64-bit operations, no division"      $ whnf (liftReverseBits reverseBits4Ops)    w16+         , bench "3 64-bit operations, modulus division" $ whnf (liftReverseBits reverseBits3Ops)    w16+         , bench "Lookup table"                          $ whnf (liftReverseBits reverseBitsTable)   w16+         , bench "7 no 64-bit operations, no division"   $ whnf (liftReverseBits reverseBits7Ops)    w16+         , bench "5LgN operations, no division"          $ whnf (                reverseBits5LgN)    w16+         , bench "Currently selected algorithm"          $ whnf (                reverseBits)        w16+         ]+      , bgroup "Reverse bits in Word32"+         [ bench "Obvious way"                           $ whnf (                reverseBitsObvious) w32+         , bench "4 64-bit operations, no division"      $ whnf (liftReverseBits reverseBits4Ops)    w32+         , bench "3 64-bit operations, modulus division" $ whnf (liftReverseBits reverseBits3Ops)    w32+         , bench "Lookup table"                          $ whnf (liftReverseBits reverseBitsTable)   w32+         , bench "7 no 64-bit operations, no division"   $ whnf (liftReverseBits reverseBits7Ops)    w32+         , bench "5LgN operations, no division"          $ whnf (                reverseBits5LgN)    w32+         , bench "Currently selected algorithm"          $ whnf (                reverseBits)        w32+         ]+      , bgroup "Reverse bits in Word64"+         [ bench "Obvious way"                           $ whnf (                reverseBitsObvious) w64+         , bench "4 64-bit operations, no division"      $ whnf (liftReverseBits reverseBits4Ops)    w64+         , bench "3 64-bit operations, modulus division" $ whnf (liftReverseBits reverseBits3Ops)    w64+         , bench "Lookup table"                          $ whnf (liftReverseBits reverseBitsTable)   w64+         , bench "7 no 64-bit operations, no division"   $ whnf (liftReverseBits reverseBits7Ops)    w64+         , bench "5LgN operations, no division"          $ whnf (                reverseBits5LgN)    w64+         , bench "Currently selected algorithm"          $ whnf (                reverseBits)        w64+         ]+      ]+
+ src/lib/Haskus/Format/Binary/BitField.hs view
@@ -0,0 +1,363 @@+{-# 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,CBitSet)+--+-- w :: BitFields Word16 '[ BitField 5 "X" (EnumField Word8 A)+--                        , BitField 9 "Y" Word16+--                        , BitField 2 "Z" (BitSet Word8 B)+--                        ]+-- w = BitFields 0x0102+-- @+module Haskus.Format.Binary.BitField+   ( BitFields (..)+   , bitFieldsBits+   , BitField (..)+   , extractField+   , extractField'+   , updateField+   , updateField'+   , withField+   , withField'+   , matchFields+   , matchNamedFields+   , Field+   )+where++import Haskus.Format.Binary.BitSet as BitSet+import Haskus.Format.Binary.Enum+import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Bits+import Haskus.Format.Binary.Storable+import Haskus.Utils.HList+import Haskus.Utils.Types+import Haskus.Utils.Types.List++-- | Bit fields on a base type b+newtype BitFields b (f :: [*]) = BitFields b deriving (Storable)++-- | Get backing word+bitFieldsBits :: BitFields b f -> b+{-# INLINE 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, CBitSet a) => Field (BitSet b a) where+   fromField = fromIntegral . BitSet.toBits+   toField   = BitSet.fromBits . fromIntegral++instance 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+{-# INLINE 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+{-# INLINE 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+{-# INLINE 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+{-# INLINE 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+{-# INLINE 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+{-# INLINE 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+   ) => bs -> t+matchFields = hToTuple' . 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+   ) => bs -> t+matchNamedFields = hToTuple' . 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
+ src/lib/Haskus/Format/Binary/BitSet.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DefaultSignatures #-}++-- | 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 CBitSet+--+-- Example:+--+-- @+-- {-# LANGUAGE DeriveAnyClass #-}+-- data Flag+--    = FlagXXX+--    | FlagYYY+--    | FlagWWW+--    deriving (Show,Eq,Enum,CBitSet)+--+-- -- 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.Format.Binary.BitSet+   ( BitSet+   , CBitSet (..)+   , null+   , empty+   , singleton+   , insert+   , delete+   , toBits+   , fromBits+   , member+   , elem+   , notMember+   , elems+   , intersection+   , union+   , unions+   , fromListToBits+   , toListFromBits+   , fromList+   , toList+   )+where++import Prelude hiding (null,elem)++import qualified GHC.Exts as Ext++import Data.Foldable (foldl')++import Haskus.Format.Binary.Bits+import Haskus.Format.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, CBitSet a, FiniteBits b) => Show (BitSet b a) where+   show b = "fromList " ++ show (toList b)++-- | Indicate if the set is empty+null :: (FiniteBits b) => BitSet b a -> Bool+{-# INLINE null #-}+null (BitSet b) = b == zeroBits+++-- | Empty bitset+empty :: (FiniteBits b) => BitSet b a+{-# INLINE empty #-}+empty = BitSet zeroBits+++-- | Create a BitSet from a single element+singleton :: (Bits b, CBitSet a) => a -> BitSet b a+{-# INLINE singleton #-}+singleton e = BitSet $ setBit zeroBits (toBitOffset e)+++-- | Insert an element in the set+insert :: (Bits b, CBitSet a) => BitSet b a -> a -> BitSet b a+{-# INLINE insert #-}+insert (BitSet b) e = BitSet $ setBit b (toBitOffset e)+++-- | Remove an element from the set+delete :: (Bits b, CBitSet a) => BitSet b a -> a -> BitSet b a+{-# INLINE 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 :: (CBitSet a, FiniteBits b) => b -> BitSet b a+fromBits = BitSet++-- | Test if an element is in the set+member :: (CBitSet a, FiniteBits b) => BitSet b a -> a -> Bool+{-# INLINE member #-}+member (BitSet b) e = testBit b (toBitOffset e)+++-- | Test if an element is in the set+elem :: (CBitSet a, FiniteBits b) => a -> BitSet b a -> Bool+{-# INLINE elem #-}+elem e (BitSet b) = testBit b (toBitOffset e)+++-- | Test if an element is not in the set+notMember :: (CBitSet a, FiniteBits b) => BitSet b a -> a -> Bool+{-# INLINE notMember #-}+notMember b e = not (member b e)+++-- | Retrieve elements in the set+elems :: (CBitSet a, FiniteBits 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 => BitSet b a -> BitSet b a -> BitSet b a+{-# INLINE intersection #-}+intersection (BitSet b1) (BitSet b2) = BitSet (b1 .&. b2)+++-- | Intersection of two sets+union :: FiniteBits b => BitSet b a -> BitSet b a -> BitSet b a+{-# INLINE union #-}+union (BitSet b1) (BitSet b2) = BitSet (b1 .|. b2)+++-- | Intersection of several sets+unions :: FiniteBits b => [BitSet b a] -> BitSet b a+{-# INLINE unions #-}+unions = foldl' union empty+++-- | Bit set indexed with a+class CBitSet a where+   -- | Return the bit offset of an element+   toBitOffset         :: a -> Int+   default toBitOffset :: Enum a => a -> Int+   toBitOffset         = fromEnum++   -- | Return the value associated with a bit offset+   fromBitOffset         :: Int -> a+   default fromBitOffset :: Enum a => Int -> a+   fromBitOffset         = toEnum++-- | It can be useful to get the indexes of the set bits+instance CBitSet Int 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 :: (CBitSet a, FiniteBits b, Foldable m) => m a -> b+fromListToBits = toBits . fromList++-- | Convert a bitset into a list of Enum elements+toListFromBits :: (CBitSet a, FiniteBits b) => b -> [a]+toListFromBits = toList . BitSet++-- | Convert a set into a list+toList :: (CBitSet a, FiniteBits b) => BitSet b a -> [a]+toList = elems++-- | Convert a Foldable into a set+fromList :: (CBitSet a, FiniteBits b, Foldable m) => m a -> BitSet b a+fromList = foldl' insert (BitSet zeroBits)+++instance (FiniteBits b, CBitSet a) => Ext.IsList (BitSet b a) where+   type Item (BitSet b a) = a+   fromList = fromList+   toList   = toList
+ src/lib/Haskus/Format/Binary/Bits.hs view
@@ -0,0 +1,93 @@+-- | Operations on bits+module Haskus.Format.Binary.Bits+   (+   -- * Basic+     module Haskus.Format.Binary.Bits.Basic+   -- * Bit reversal+   , BitReversable (..)+   , reverseBitsGeneric+   , reverseLeastBits+   -- * Mask+   , makeMask+   , maskLeastBits+   -- * String conversion+   , bitsToString+   , bitsFromString+   -- * Shift+   , getBitRange+   -- * Various+   , bitOffset+   , byteOffset+   )+where++import Haskus.Utils.List (foldl')+import Haskus.Format.Binary.Bits.Basic+import Haskus.Format.Binary.Bits.Reverse+import Haskus.Format.Binary.Bits.Order+import Haskus.Format.Binary.Word++-- | makeMask 3 = 00000111+makeMask :: (FiniteBits a) => Word -> a+makeMask n = x' `shiftR` (finiteBitSize x - fromIntegral n)+   where+      x = complement zeroBits+      x' = if isSigned x +               then error "Cannot use makeMask with a signed type"+               else x+{-# SPECIALIZE makeMask :: Word -> Int #-}+{-# SPECIALIZE makeMask :: Word -> Word #-}+{-# SPECIALIZE makeMask :: Word -> Word8 #-}+{-# SPECIALIZE makeMask :: Word -> Word16 #-}+{-# SPECIALIZE makeMask :: Word -> Word32 #-}+{-# SPECIALIZE makeMask :: Word -> Word64 #-}++-- | Keep only the n least-significant bits of the given value+maskLeastBits :: (FiniteBits a) => Word -> a -> a+{-# INLINE maskLeastBits #-}+maskLeastBits n v = v .&. makeMask n++-- | Compute bit offset (equivalent to x `mod` 8 but faster)+bitOffset :: Word -> Word+{-# INLINE bitOffset #-}+bitOffset n = makeMask 3 .&. n++-- | Compute byte offset (equivalent to x `div` 8 but faster)+byteOffset :: Word -> Word+{-# INLINE byteOffset #-}+byteOffset n = n `shiftR` 3++-- | Reverse the @n@ least important bits of the given value. The higher bits+-- are set to 0.+reverseLeastBits :: (FiniteBits a, BitReversable a) => Word -> a -> a+reverseLeastBits n value = reverseBits value `shiftR` (finiteBitSize value - fromIntegral n)++-- | Convert bits into a string composed of '0' and '1' chars+bitsToString :: FiniteBits a => a -> String+bitsToString x = fmap b [s, s-1 .. 0]+   where+      s   = finiteBitSize x - 1+      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]+++-- | Take n bits at offset o and put them in the least-significant+-- bits of the result+getBitRange :: (BitReversable b, FiniteBits b) => BitOrder -> Word -> Word -> b -> b+{-# INLINE getBitRange #-}+getBitRange bo o n c = case bo of+      BB -> maskLeastBits n $ c             `shiftR` d+      BL -> maskLeastBits n $ reverseBits c `shiftR` o'+      LB -> maskLeastBits n $ reverseBits c `shiftR` d+      LL -> maskLeastBits n $ c             `shiftR` o'+   where +      o' = fromIntegral o+      d  = finiteBitSize c - fromIntegral n - fromIntegral o+
+ src/lib/Haskus/Format/Binary/Bits/Basic.hs view
@@ -0,0 +1,7 @@+-- | Basic operations on bits+module Haskus.Format.Binary.Bits.Basic+   ( module Data.Bits+   )+where++import Data.Bits
+ src/lib/Haskus/Format/Binary/Bits/Get.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE BangPatterns #-}++-- | Bit getter+module Haskus.Format.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 Haskus.Format.Binary.Ptr+import Haskus.Format.Binary.Buffer+import Haskus.Format.Binary.Bits.Order+import Haskus.Format.Binary.Bits+import Haskus.Format.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, FiniteBits 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, FiniteBits a, BitReversable a) => Word -> Word -> BitGetState -> a+{-# INLINE 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 `indexPtr` 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, FiniteBits 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, FiniteBits a, BitReversable 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+
+ src/lib/Haskus/Format/Binary/Bits/Order.hs view
@@ -0,0 +1,27 @@+-- | Bit orderings+module Haskus.Format.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)
+ src/lib/Haskus/Format/Binary/Bits/Put.hs view
@@ -0,0 +1,169 @@+-- | Bit putter+module Haskus.Format.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.Format.Binary.BufferBuilder as B+import Haskus.Format.Binary.Buffer+import Haskus.Format.Binary.Word+import Haskus.Format.Binary.BufferList (BufferList)+import Haskus.Format.Binary.Bits.Order+import Haskus.Format.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, FiniteBits a, BitReversable 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 :: (FiniteBits a, BitReversable a, Integral a) => a -> Word8+      selectBits x = fromIntegral $ case bo of+         BB ->                       maskLeastBits cn $ x `shiftR` fromIntegral (n-cn)+         LB -> reverseLeastBits cn $ maskLeastBits cn $ x `shiftR` fromIntegral (n-cn)+         LL ->                       maskLeastBits cn x+         BL -> reverseLeastBits cn $ maskLeastBits 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 lazy byte string+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, FiniteBits a, BitReversable 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
+ src/lib/Haskus/Format/Binary/Bits/Reverse.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Reverse bits+--+-- There are several algorithms performing the same thing here (reversing bits+-- into words of different sizes). There are benchmarks for them in Haskus's+-- "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.Format.Binary.Bits.Reverse+   ( +   -- * Generic+     BitReversable (..)+   , reverseBitsGeneric+   -- * Algorithms+   , reverseBitsObvious+   , reverseBits3Ops+   , reverseBits4Ops+   , reverseBitsTable+   , reverseBits7Ops+   , reverseBits5LgN+   , liftReverseBits+   )+where++import Haskus.Format.Binary.Buffer+import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Bits.Basic++---------------------------------------------------+-- Generic and specialized reverseBits+---------------------------------------------------+++-- | Reverse bits in a Word+reverseBitsGeneric :: (FiniteBits a, Integral a) => a -> a+reverseBitsGeneric = liftReverseBits reverseBits4Ops++-- | Data whose bits can be reversed+class BitReversable w where+   reverseBits :: w -> w++instance BitReversable Word8 where+   reverseBits = reverseBits4Ops++instance BitReversable Word16 where+   reverseBits = reverseBits5LgN++instance BitReversable Word32 where+   reverseBits = reverseBits5LgN++instance BitReversable Word64 where+   reverseBits = reverseBits5LgN++instance BitReversable Word 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 verion+reverseBitsObvious :: FiniteBits a => a -> a+reverseBitsObvious x = rec x (x `shiftR` 1) (finiteBitSize x - 1)+   where+      rec :: FiniteBits a => a -> a -> Int -> 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+{-# INLINE 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+{-# INLINE 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+{-# INLINE 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+{-# INLINE 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 :: FiniteBits a => a -> a+reverseBits5LgN x = rec (finiteBitSize x `shiftR` 1) (complement zeroBits) x+   where+      rec :: FiniteBits a => Int -> 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 :: (FiniteBits a, Integral a) => (Word8 -> Word8) -> a -> a+liftReverseBits f w = rec zeroBits 0+   where+      nb = finiteBitSize 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 #-}+
+ src/lib/Haskus/Format/Binary/Buffer.hs view
@@ -0,0 +1,351 @@+{-# 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.Format.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 System.IO.Unsafe+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS++import Haskus.Format.Binary.Ptr+import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Storable+import Haskus.Format.Binary.Bits.Basic+import Haskus.Utils.Memory (memCopy,memSet)+import Haskus.Utils.List (foldl')+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 Bits Buffer where+   (.&.)      = bufferZipWith (.&.)+   (.|.)      = bufferZipWith (.|.)+   xor        = bufferZipWith xor+   complement = bufferMap complement+   shift b n+      | n == 0     = b+      | abs n <= 8 = bufferMap (`shift` n) b+      | otherwise  = if q > 0+            then bufferAppend zs b'+            else bufferAppend b' zs+         where+            (q,r) = n `quotRem` 8+            zs = bufferZero (fromIntegral (abs q))+            b' = bufferMap (`shift` r) b++   rotate     = shift+   zeroBits   = emptyBuffer+   isSigned _ = False+   bitSize _  = undefined+   bitSizeMaybe _ = Nothing+   testBit b n = testBit p r+      where+         p     = bufferIndex b (bufferSize b - fromIntegral q)+         (q,r) = n `quotRem` 8++   bit _       = undefined+   popCount b  = foldl' (+) 0 (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+{-# INLINE bufferHead #-}+bufferHead (Buffer bs) = BS.head bs++-- | Index+bufferIndex :: Buffer -> Word -> Word8+{-# INLINE 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 (fromIntegral lxs)+   forM_ (xs `zip` [0..]) $ \(x,o) ->+      pokeElemOff p o x+   BS.unsafePackMallocCStringLen (castPtr p, sizeOfT' @a * lxs)++-- | Pack from a pointer (copy)+bufferPackPtr :: MonadIO m => Word -> Ptr () -> m Buffer+bufferPackPtr sz ptr = do+   p <- 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)
+ src/lib/Haskus/Format/Binary/BufferBuilder.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Buffer builder+module Haskus.Format.Binary.BufferBuilder+   ( BufferBuilder+   , emptyBufferBuilder+   , toBufferList+   , toBuffer+   , fromBuffer+   , fromWord8+   )+where++import qualified Data.ByteString.Builder as B++import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Buffer+import qualified Haskus.Format.Binary.BufferList as BL++-- | Buffer builder+newtype BufferBuilder = BufferBuilder B.Builder++deriving instance Monoid BufferBuilder++-- | 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
+ src/lib/Haskus/Format/Binary/BufferList.hs view
@@ -0,0 +1,29 @@+-- | Buffer list+--+-- BufferList is a lazy ByteString+module Haskus.Format.Binary.BufferList+   ( BufferList (..)+   , toBuffer+   , toBufferList+   , toLazyByteString+   )+where++import qualified Data.ByteString.Lazy as LBS++import Haskus.Format.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
+ src/lib/Haskus/Format/Binary/Endianness.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | 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.Format.Binary.Endianness+   ( Endianness(..)+   , WordGetters (..)+   , WordPutters (..)+   , getWordGetters+   , getWordPutters+   , WordSize (..)+   , ExtendedWordGetters (..)+   , ExtendedWordPutters (..)+   , getExtendedWordGetters+   , getExtendedWordPutters+   , getHostEndianness+   , hostEndianness+   , ByteReversable (..)+   , AsBigEndian (..)+   , AsLittleEndian (..)+   )+where++import Haskus.Format.Binary.Get+import Haskus.Format.Binary.Put+import Haskus.Format.Binary.Enum+import Haskus.Format.Binary.Ptr+import Haskus.Format.Binary.Bits ((.|.), shiftL)+import Haskus.Format.Binary.Storable+import Haskus.Format.Binary.Word++import System.IO.Unsafe++-- | 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 Word132+   , 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 Word132+   , 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 Word132+   , 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 Word132+   , 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 Int and check byte ordering+   let magic = 1 .|. shiftL 8 2 .|. shiftL 16 3 .|. shiftL 24 4 :: 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+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)++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)++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)
+ src/lib/Haskus/Format/Binary/Enum.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}++-- | Store an Enum in the given backing word type+module Haskus.Format.Binary.Enum+   ( EnumField+   , CEnum (..)+   , fromEnumField+   , toEnumField+   , makeEnum+   , makeEnumMaybe+   , makeEnumWithCustom+   )+where++import Haskus.Format.Binary.Storable+import Haskus.Format.Binary.Ptr++import Data.Data++-----------------------------------------------------------------------------+-- EnumField b a: directly store the value of enum "a" as a "b"+-----------------------------------------------------------------------------++-- | Store enum 'a' as a 'b'+newtype EnumField b a = EnumField a deriving (Show,Eq)++instance+      ( Storable b+      , Integral b+      , CEnum a+      ) => Storable (EnumField b a)+   where+      sizeOf _               = sizeOfT    @b+      alignment _            = alignmentT @b+      peekIO p               = (EnumField . toCEnum) <$> peek (castPtr p :: Ptr b)+      pokeIO p (EnumField v) = poke (castPtr p :: Ptr b) (fromCEnum v)++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 . toCEnum) <$> staticPeek (castPtr p :: Ptr b)+      staticPokeIO p (EnumField v)   = staticPoke (castPtr p :: Ptr b) (fromCEnum v)++-- | Read an enum field+fromEnumField :: EnumField b a -> a+{-# INLINE fromEnumField #-}+fromEnumField (EnumField a) = a++-- | Create an enum field+toEnumField :: a -> EnumField b a+{-# INLINE toEnumField #-}+toEnumField = EnumField+++-----------------------------------------------------------------------------+-- Extended Enum+-----------------------------------------------------------------------------++-- | By default, use fromEnum/toEnum to convert from/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 . fromEnum+--+class CEnum a where+   fromCEnum         :: Integral b => a -> b+   default fromCEnum :: (Enum a, Integral b) => a -> b+   fromCEnum         = fromIntegral . fromEnum++   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+--+-- E.g., 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+{-# INLINE 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+--+-- E.g., 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+{-# INLINE 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+{-# INLINE makeEnum #-}+makeEnum x =fromConstr (indexConstr t x')+   where+      x'  = fromIntegral x + 1+      t   = dataTypeOf (undefined :: a)+
+ src/lib/Haskus/Format/Binary/FixedPoint.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Fixed-point numbers+module Haskus.Format.Binary.FixedPoint+   ( FixedPoint+   , toFixedPoint+   , fromFixedPoint+   )+where++import Haskus.Format.Binary.BitField+import Haskus.Format.Binary.Bits+import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Storable+import Haskus.Utils.Types++-- | Fixed-point number+-- `w` is the backing type+-- `i` is the number of bits for the integer part (before the readix point)+-- `f` is the number of bits for the fractional part (after the radix point)+newtype FixedPoint w (i :: Nat) (f :: Nat) = FixedPoint (BitFields w+   '[ BitField i "integer"    w+    , BitField f "fractional" w+    ])+   deriving (Storable)++deriving instance forall w n d.+   ( Integral w+   , Bits w+   , Field w+   , BitSize w ~ (n + d)+   , KnownNat n+   , KnownNat d+   ) => Eq (FixedPoint w n d)++deriving instance forall w n d.+   ( Integral w+   , Bits w+   , Field w+   , BitSize w ~ (n + d)+   , KnownNat n+   , KnownNat d+   , Show w+   ) => Show (FixedPoint w n d)++-- | Convert to a fixed point value+toFixedPoint :: forall a w (n :: Nat) (d :: Nat).+   ( RealFrac a+   , BitSize w ~ (n + d)+   , KnownNat n+   , KnownNat d+   , Bits w+   , Field w+   , Num w+   , Integral w+   ) => a -> FixedPoint w n d+toFixedPoint a = FixedPoint $ BitFields (round (a * 2^natValue' @d))++-- | Convert from a fixed-point value+fromFixedPoint :: forall a w (n :: Nat) (d :: Nat).+   ( RealFrac a+   , BitSize w ~ (n + d)+   , KnownNat n+   , KnownNat d+   , Bits w+   , Field w+   , Num w+   , Integral w+   ) => FixedPoint w n d -> a+fromFixedPoint (FixedPoint bf) = w / 2^(natValue' @d)+   where+      w = fromIntegral (bitFieldsBits bf)
+ src/lib/Haskus/Format/Binary/Get.hs view
@@ -0,0 +1,237 @@+{-# lANGUAGE LambdaCase #-}++-- | Get utilities+module Haskus.Format.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.Format.Binary.Buffer+import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Bits.Order+import Haskus.Format.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)+
+ src/lib/Haskus/Format/Binary/Layout.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Memory layout+--+-- Describe a memory region+module Haskus.Format.Binary.Layout+   ( LayoutPathType+   , LayoutPathOffset+   , LayoutRoot+   , LayoutPath (..)+   , LayoutIndex (..)+   , LayoutSymbol (..)+   , layoutIndex+   , layoutSymbol+   , (:->)+   , (:#>)+   )+where++import Haskus.Utils.Types+import Haskus.Utils.Types.List++-- | Path in a layout+data LayoutPath (path :: [*])   = LayoutPath++-- | Index in a layout path+data LayoutIndex (n :: Nat)     = LayoutIndex++-- | Symbol in a layout path+data LayoutSymbol (s :: Symbol) = LayoutSymbol++-- | Index in the layout path+layoutIndex :: forall n. LayoutPath '[LayoutIndex n]+layoutIndex = LayoutPath++-- | Symbol in the layout path+layoutSymbol :: forall s. LayoutPath '[LayoutSymbol s]+layoutSymbol = LayoutPath+++-- | Type obtained when following path p+type family LayoutPathType l p :: *+type instance LayoutPathType l (LayoutPath '[])  = l++-- | Offset obtained when following path p+type family LayoutPathOffset l p :: Nat+type instance LayoutPathOffset e (LayoutPath '[])  = 0++type LayoutRoot = LayoutPath '[]++type family (:->) p (s :: Symbol) where+   (:->) (LayoutPath xs) s = LayoutPath (Snoc xs (LayoutSymbol s))++type family (:#>) p (n :: Nat) where+   (:#>) (LayoutPath xs) n = LayoutPath (Snoc xs (LayoutIndex n))
+ src/lib/Haskus/Format/Binary/Ptr.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}++-- | Pointers+--+-- A pointer is a number: an offset into a memory. This is the `Addr#` type.+--+-- We want the type-system to help us avoid errors when we use pointers, hence+-- we decorate them with phantom types describing the memory layout at the+-- pointed address. This is the `Ptr a` data type that wraps an `Addr#`.+--+-- We often want to associate finalizers to pointers, i.e., actions to be run+-- when the pointer is collected by the GC. These actions take the pointer as a+-- parameter. This is the `ForeignPtr a` data type.+--+-- A `ForeignPtr a` cannot be manipulated like a number because somehow we need+-- to keep the pointer value that will be passed to the finalizers. Moreover we+-- don't want finalizers to be executed too early, so we can't easily create a+-- new ForeignPtr from another (it would require a way to disable the existing+-- finalizers of a ForeignPtr, which would in turn open a whole can of worms).+-- Hence we use the `FinalizedPtr a` pointer type, which has an additional+-- offset field.+module Haskus.Format.Binary.Ptr+   ( PtrLike (..)+   , indexPtr'+   -- * Pointer+   , Ptr (..)+   , free+   -- * Finalized pointer+   , FinalizedPtr (..)+   , withFinalizedPtr+   -- * Foreign pointer+   , ForeignPtr+   , withForeignPtr+   , mallocForeignPtrBytes+   , nullForeignPtr+   -- * Function pointer+   , Ptr.FunPtr+   , Ptr.nullFunPtr+   , Ptr.castPtrToFunPtr+   , Ptr.castFunPtrToPtr+   -- * Pointer as a Word+   , Ptr.WordPtr+   , Ptr.wordPtrToPtr+   , Ptr.ptrToWordPtr+   )+where++import qualified Foreign.Ptr               as Ptr+import qualified Foreign.Marshal.Alloc     as Ptr+import qualified Foreign.ForeignPtr        as FP+import qualified Foreign.ForeignPtr.Unsafe as FP+-- we import GHC.Ptr instead of Foreign.Ptr to have access to Ptr constructors+import GHC.Ptr (Ptr (..))+import Foreign.ForeignPtr (ForeignPtr)+import Unsafe.Coerce+import System.IO.Unsafe++import Haskus.Format.Binary.Layout+import Haskus.Utils.Types+import Haskus.Utils.Monad+++-- | A finalized pointer+--+-- We use an offset because we can't modify the pointer directly (it is+-- passed to the foreign pointer destructors)+data FinalizedPtr l = FinalizedPtr {-# UNPACK #-} !(ForeignPtr l)+                                   {-# UNPACK #-} !Word  -- offset++type role FinalizedPtr phantom++instance Show (FinalizedPtr l) where+   show (FinalizedPtr fp o) = show (FP.unsafeForeignPtrToPtr fp +                                    `indexPtr` fromIntegral o)++-- | Null foreign pointer+nullForeignPtr :: ForeignPtr a+{-# NOINLINE nullForeignPtr #-}+nullForeignPtr = unsafePerformIO $ FP.newForeignPtr_ nullPtr++-- | Null finalized pointer+nullFinalizedPtr :: FinalizedPtr a+nullFinalizedPtr = FinalizedPtr nullForeignPtr 0++-- | Use a finalized pointer+withFinalizedPtr :: FinalizedPtr a -> (Ptr a -> IO b) -> IO b+{-# INLINE withFinalizedPtr #-}+withFinalizedPtr (FinalizedPtr fp o) f =+   FP.withForeignPtr fp (f . (`indexPtr` fromIntegral o))++-- | Pointer operations+class PtrLike (p :: * -> *) where+   -- | Cast a pointer from one type to another+   castPtr :: p a -> p b+   {-# INLINE castPtr #-}+   castPtr = unsafeCoerce++   -- | Null pointer (offset is 0)+   nullPtr :: forall a. p a++   -- | Advance a pointer by the given amount of bytes (may be negative)+   indexPtr :: p a -> Int -> p a++   -- | Distance between two pointers in bytes (p2 - p1)+   ptrDistance :: p a -> p b -> Int++   -- | Use the pointer+   withPtr :: p a -> (Ptr a -> IO b) -> IO b++   -- | Malloc the given number of bytes+   mallocBytes :: MonadIO m => Word -> m (p a)++   -- | Add offset to the given layout field+   indexField :: forall path l.+      ( KnownNat (LayoutPathOffset l path)+      ) => p l -> path -> p (LayoutPathType l path)+   {-# INLINE indexField #-}+   indexField p _ = castPtr (p `indexPtr` natValue @(LayoutPathOffset l path))++   -- | Add offset corresponding to the layout field with the given symbol+   (-->) :: forall s l.+      ( KnownNat (LayoutPathOffset l (LayoutPath '[LayoutSymbol s]))+      ) => p l -> LayoutSymbol s -> p (LayoutPathType l (LayoutPath '[LayoutSymbol s]))+   {-# INLINE (-->) #-}+   (-->) l _ = indexField l (layoutSymbol :: LayoutPath '[LayoutSymbol s])++   -- | Add offset corresponding to the layout field with the given index+   (-#>) :: forall n l.+      ( KnownNat (LayoutPathOffset l (LayoutPath '[LayoutIndex n]))+      ) => p l -> LayoutIndex n -> p (LayoutPathType l (LayoutPath '[LayoutIndex n]))+   {-# INLINE (-#>) #-}+   (-#>) l _ = indexField l (layoutIndex :: LayoutPath '[LayoutIndex n])++-- TODO+-- {-# RULES+--  "indexField concat paths" forall l p1 p2 .+--       indexField (indexField l p1) p2 = indexField l (concatPaths p1 p2)+--  #-}+-- concatLayoutPaths :: LayoutPath p1 -> LayoutPath p2 -> LayoutPath (Concat p1 p2)+-- concatPaths = undefined++-- | Generalized version of 'indexPtr'+indexPtr' :: Integral b => Ptr a -> b -> Ptr a+indexPtr' p a = indexPtr p (fromIntegral a)+++instance PtrLike Ptr where+   {-# INLINE nullPtr #-}+   nullPtr = Ptr.nullPtr++   {-# INLINE indexPtr #-}+   indexPtr = Ptr.plusPtr++   {-# INLINE ptrDistance #-}+   ptrDistance = Ptr.minusPtr++   {-# INLINE withPtr #-}+   withPtr p f = f p++   {-# INLINE mallocBytes #-}+   mallocBytes = liftIO . Ptr.mallocBytes . fromIntegral+++instance PtrLike FinalizedPtr where+   {-# INLINE nullPtr #-}+   nullPtr = nullFinalizedPtr++   {-# INLINE indexPtr #-}+   indexPtr (FinalizedPtr fp o) n+      | n >= 0    = FinalizedPtr fp (o+fromIntegral n)+      | otherwise = FinalizedPtr fp (o-fromIntegral (abs n))++   {-# INLINE ptrDistance #-}+   ptrDistance (FinalizedPtr fp1 o1) (FinalizedPtr fp2 o2)+      | o2 > o1   = d + fromIntegral (o2 - o1)+      | otherwise = d - fromIntegral (o1 - o2)+      where+         d = ptrDistance (FP.unsafeForeignPtrToPtr fp1)+                         (FP.unsafeForeignPtrToPtr fp2)++   {-# INLINE withPtr #-}+   withPtr = withFinalizedPtr++   {-# INLINE mallocBytes #-}+   mallocBytes n = do+      fp <- mallocForeignPtrBytes (fromIntegral n)+      return (FinalizedPtr fp 0)++-- | Malloc a foreign pointer+mallocForeignPtrBytes :: MonadIO m => Word -> m (ForeignPtr a)+mallocForeignPtrBytes = liftIO . FP.mallocForeignPtrBytes . fromIntegral++-- | Use a foreign pointer+withForeignPtr :: (MonadInIO m) => ForeignPtr a -> (Ptr a -> m b) -> m b+withForeignPtr p = liftWith (FP.withForeignPtr p)++-- | Free a malloced memory+free :: MonadIO m => Ptr a -> m ()+free = liftIO . Ptr.free
+ src/lib/Haskus/Format/Binary/Put.hs view
@@ -0,0 +1,78 @@+-- | Put monad+module Haskus.Format.Binary.Put+   ( Put+   , runPut+   -- * 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)++import Haskus.Utils.Flow (replicateM_)+import Haskus.Format.Binary.Buffer+import Haskus.Format.Binary.Word++-- | Execute Put+runPut :: Put -> Buffer+runPut = Buffer . BP.runPut++-- | 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
+ src/lib/Haskus/Format/Binary/Record.hs view
@@ -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.Format.Binary.Record+   ( Record+   , Field+   , RecordSize+   , Alignment+   , Modulo+   , Path+   , recordSize+   , recordAlignment+   , recordField+   , recordFieldOffset+   , recordFieldPath+   , recordFieldPathOffset+   , recordToList+   )+where++import System.IO.Unsafe++import Haskus.Format.Binary.Ptr+import Haskus.Format.Binary.Storable+import Haskus.Utils.HList+import Haskus.Utils.Memory+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 (Modulo (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+         (IfNat (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 `indexPtr` 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 `indexPtr` 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 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)
+ src/lib/Haskus/Format/Binary/Storable.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Storable class+module Haskus.Format.Binary.Storable+   ( StaticStorable (..)+   , staticPeek+   , staticPoke+   , RequiredPadding+   , Padding+   , PaddingEx+   , 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+   )+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.Format.Binary.Word+import Haskus.Format.Binary.Ptr+import Haskus.Utils.Types+import Haskus.Utils.Types.Generics+import Haskus.Utils.Flow++-- | 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)+++-- | 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 (Modulo sz (Alignment b)) (Alignment b)++type family PaddingEx (m :: Nat) (a :: Nat) where+   PaddingEx 0 a = 0+   PaddingEx m a = a - m+++-- | 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]+{-# INLINE 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+{-# INLINE sizeOf' #-}+sizeOf' = fromIntegral . sizeOf++-- | SizeOf (for type-application)+sizeOfT :: forall a. (Storable a) => Word+{-# INLINE sizeOfT #-}+sizeOfT = sizeOf (undefined :: a)++-- | SizeOf' (for type-application)+sizeOfT' :: forall a b. (Storable a, Integral b) => b+{-# INLINE sizeOfT' #-}+sizeOfT' = sizeOf' (undefined :: a)++-- | Generalized 'alignment'+alignment' :: (Integral b, Storable a) => a -> b+{-# INLINE alignment' #-}+alignment' = fromIntegral . alignment++-- | Alignment (for type-application)+alignmentT :: forall a. (Storable a) => Word+{-# INLINE alignmentT #-}+alignmentT = alignment (undefined :: a)++-- | Alignment' (for type-application)+alignmentT' :: forall a b. (Storable a, Integral b) => b+{-# INLINE alignmentT' #-}+alignmentT' = alignment' (undefined :: a)++-- | Peek with byte offset+peekByteOff :: (MonadIO m, Storable a) => Ptr a -> Int -> m a+{-# INLINE peekByteOff #-}+peekByteOff ptr off = peek (ptr `indexPtr` off)++-- | Poke with byte offset+pokeByteOff :: (MonadIO m, Storable a) => Ptr a -> Int -> a -> m ()+{-# INLINE pokeByteOff #-}+pokeByteOff ptr off = poke (ptr `indexPtr` 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+{-# INLINE 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)+{-# INLINE malloc #-}+malloc = liftIO (mallocBytes (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+{-# INLINE 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 = mallocBytes (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 `indexPtr'` (off + gcPadding off (undefined :: K1 i a x)))+  gcPoke off p (K1 x)    = poke (castPtr p `indexPtr'` (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
+ src/lib/Haskus/Format/Binary/Union.hs view
@@ -0,0 +1,185 @@+{-# 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 a 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.Format.Binary.Union+   ( Union+   , fromUnion+   , toUnion+   , toUnionZero+   )+where++import Haskus.Utils.Memory (memCopy, memSet)+import Haskus.Utils.Types+import Haskus.Utils.Types.List hiding (Union)+import Haskus.Utils.HList+import Haskus.Utils.Flow (when)+import Haskus.Format.Binary.Storable+import Haskus.Format.Binary.Ptr++import System.IO.Unsafe (unsafePerformIO)++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, IsMember a l ~ 'True) => 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, IsMember a l ~ 'True) => a -> Union l+toUnion = toUnion' False++-- | Like 'toUnion' but set the remaining bytes to 0+toUnionZero :: forall a l . (Storable (Union l), Storable a, IsMember a l ~ 'True) => 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, IsMember a l ~ 'True) => 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 `indexPtr'` 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 (Max (MapSizeOf fs))+      , KnownNat (Max (MapAlignment fs))+      )+      => StaticStorable (Union fs)+   where+      type SizeOf (Union fs)    = Max (MapSizeOf fs)+      type Alignment (Union fs) = Max (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
+ src/lib/Haskus/Format/Binary/Unum.hs view
@@ -0,0 +1,733 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Haskus.Format.Binary.Unum+   ( Unum+   , UnumNum (..)+   , I+   , U (..)+   , Neg+   , Rcp+   , Infinite+   , Log2+   , UnumNumbers+   , UnumSize+   , BackingWord+   , UBit (..)+   , unumSize+   , unumZero+   , unumInfinite+   , unumEncode+   , unumBits+   , unumNegate+   , unumReciprocate+   , unumLabels+   , Sign (..)+   , unumSign+   -- * SORN (bit-sets)+   , SORN+   , SORNBackingWord+   , sornBits+   , sornSize+   , sornEmpty+   , sornFull+   , sornNonInfinite+   , sornNonZero+   , sornSingle+   , sornInsert+   , sornMember+   , sornRemove+   , sornUnion+   , sornIntersect+   , sornComplement+   , sornNegate+   , sornElems+   , sornFromElems+   , sornFromTo+   , SornAdd (..)+   -- * Contiguous SORN+   , CSORN (..)+   , csornSize+   , csornBits+   , csornToSorn+   , csornEmpty+   , csornIsEmpty+   , csornFromTo+   , csornFull+   , csornSingle+   )+where++import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Bits+import Haskus.Format.Binary.BitField+import Haskus.Utils.Types+import Haskus.Utils.Types.List+import Haskus.Utils.HList+import Haskus.Utils.Flow++-- | An Unum+--+-- 0 (and its reciprocal) is always included.+-- Numbers have to be >= 1 and sorted.+--+-- e.g., Unum '[] => /0 .. 0 .. /0+--       Unum '[I 1] => /0 .. -1 .. 0 .. 1 .. /0+--       Unum '[I 1, I 2] => /0 .. -2 .. -1 .. -/2 .. 0 .. /2 .. 1 .. 2 .. /0+--       Unum '[I 1, PI]  => /0 .. -PI .. -1 .. -/PI .. 0 .. /PI .. 1 .. PI .. /0+data Unum (xs :: [*])+++class UnumNum a where+   unumLabel :: a -> String++data I (n :: Nat)+data Neg a+data Rcp a+data Uncertain a++instance KnownNat n => UnumNum (I n) where+   unumLabel _ = show (natValue' @n)++instance UnumNum x => UnumNum (Rcp x) where+   unumLabel _ = "/" ++ unumLabel (undefined :: x)++instance UnumNum x => UnumNum (Neg x) where+   unumLabel _ = "-" ++ unumLabel (undefined :: x)++instance UnumNum x => UnumNum (Uncertain x) where+   unumLabel _ = unumLabel (undefined :: x) ++ ".."++type Infinite = Rcp (I 0)++type family Simplify a where+   Simplify a = Simplify' 'True a++type family Simplify' loop a where+   Simplify' l (Rcp (Rcp x))  = Simplify x+   Simplify' l (Neg (Neg x))  = Simplify x+   Simplify' l (Neg (I 0))    = I 0+   Simplify' l (Rcp (I 1))    = I 1+   Simplify' l (Neg Infinite) = Infinite -- infinite is special+   Simplify' l (Rcp (Neg x))  = Simplify (Neg (Rcp x)) -- Neg are outer+   Simplify' 'True (Rcp x)    = Simplify' 'False (Rcp (Simplify x))+   Simplify' 'True (Neg x)    = Simplify' 'False (Neg (Simplify x))+   Simplify' 'False (Rcp x)   = Rcp (Simplify x)+   Simplify' 'False (Neg x)   = Neg (Simplify x)+   Simplify' l x              = x++-- | Compute the precise numbers set+type family UnumNumbers x where+   -- add /0 (infinite), add reciprocals, add negations, nub+   UnumNumbers (Unum xs) = Nub (AddNeg (AddRcp (Snoc xs Infinite)))++-- | Positive numbers in the unums+type family UnumPositives x where+   UnumPositives (Unum xs) = Nub (AddRcp (Snoc xs Infinite))++-- | Indexable numbers+type family UnumIndexables x where+   UnumIndexables u =+      Nub (Concat (UnumPositives u) (Reverse (MapNeg (UnumPositives u))))++-- | All unum members+type family UnumMembers x where+   UnumMembers u = MakeMembers (UnumIndexables u)++type family MakeMembers xs where+   MakeMembers '[]       = '[]+   MakeMembers (x ': xs) = x ': Uncertain x ': MakeMembers xs+ ++data GetLabel = GetLabel++instance  forall a r.+   ( UnumNum a+   , r ~ [String]+   ) => Apply GetLabel (a, [String]) r where+   apply _ (x,xs) = unumLabel x : xs++-- | Unum labels+unumLabels :: forall u v.+   ( HFoldr' GetLabel [String] v [String]+   , v ~ UnumMembers u+   ) => [String]+unumLabels = hFoldr' GetLabel ([] :: [String]) (undefined :: HList v)++-- | Compute the number of bits required+type family UnumSize x where+   UnumSize x = 1 + Log2 (Length (UnumNumbers x)) -- add 1 for ubit++-- | Size of an unum in bits+unumSize :: forall u.+   ( KnownNat (UnumSize u)+   ) => Word+unumSize = natValue @(UnumSize u)++-- | Zero+unumZero :: forall u.+   ( Num (BackingWord u)+   , Bits (BackingWord u)+   , Encodable (I 0) u+   ) => U u+unumZero = unumEncode @u @(I 0) ExactNumber++-- | Infinite+unumInfinite :: forall u.+   ( Num (BackingWord u)+   , Bits (BackingWord u)+   , Encodable Infinite u+   ) => U u+unumInfinite = unumEncode @u @Infinite ExactNumber++type family Div2 n where+  Div2 0 = 0+  Div2 1 = 0+  Div2 n = Div2 (n - 2) + 1++type family Log2 n where+  Log2 0 = 0+  Log2 1 = 0+  Log2 n = Log2 (Div2 n) + 1++-- | Backing word for the unum+type family BackingWord x where+   BackingWord x = WordAtLeast (UnumSize x)++type family MapRcp xs where+   MapRcp '[] = '[]+   MapRcp (x ': xs) = Simplify (Rcp x) ': MapRcp xs++type family MapNeg xs where+   MapNeg '[] = '[]+   MapNeg (x ': xs) = Simplify (Neg x) ': MapNeg xs++type family AddRcp xs where+   AddRcp xs = Concat (Reverse (MapRcp xs)) xs++type family AddNeg xs where+   AddNeg xs = Concat (Reverse (MapNeg xs)) xs++newtype U u = U (BackingWord u)++instance Eq (BackingWord u) => Eq (U u) where+   U x == U y = x == y++instance forall u v.+   ( HFoldr' GetLabel [String] v [String]+   , v ~ UnumMembers u+   , Integral (BackingWord u)+   ) => Show (U u) where+   show (U w) = unumLabels @u !! fromIntegral w++unumBits :: forall u.+   ( FiniteBits (BackingWord u)+   , KnownNat (UnumSize u)+   ) => U u -> String+unumBits (U w) = drop (finiteBitSize w - fromIntegral (unumSize @u)) (bitsToString w)++type Encodable x u =+   ( KnownNat (IndexOf (Simplify x) (UnumIndexables u)))+++-- | Uncertainty bit+data UBit+   = ExactNumber   -- ^ Exact number+   | OpenInterval  -- ^ OpenInterval above the exact number+   deriving (Show,Eq)++-- | Encode a number+unumEncode :: forall u x i.+   ( i ~ IndexOf (Simplify x) (UnumIndexables u)+   , KnownNat i+   , Num (BackingWord u)+   , Bits (BackingWord u)+   ) => UBit -> U u+{-# INLINE unumEncode #-}+unumEncode b = case b of+      ExactNumber  -> U w+      OpenInterval -> U (setBit w 0)+   where+      w = natValue @i `shiftL` 1+++-- | Negate a number+unumNegate :: forall u.+   ( FiniteBits (BackingWord u)+   , Num (BackingWord u)+   , KnownNat (UnumSize u)+   ) => U u -> U u+{-# INLINE unumNegate #-}+unumNegate (U w) = U (maskLeastBits s (complement w + 1))+   where+      s = unumSize @u+++-- | Reciprocate a number+unumReciprocate :: forall u.+   ( FiniteBits (BackingWord u)+   , Num (BackingWord u)+   , KnownNat (UnumSize u)+   ) => U u -> U u+{-# INLINE unumReciprocate #-}+unumReciprocate (U w) = U (w `xor` m + 1)+   where+      s = unumSize @u+      m = makeMask (s-1)+++data Sign+   = Positive+   | Negative+   | NoSign+   deriving (Show,Eq)++-- | Get unum sign+unumSign :: forall u.+   ( Bits (BackingWord u)+   , KnownNat (UnumSize u)+   ) => U u -> Sign+unumSign (U w) =+      if clearBit w n == zeroBits -- infinity or zero+         then NoSign+         else if testBit w n +            then Negative +            else Positive+   where+      n = fromIntegral (unumSize @u - 1)++++--------------------------------------------------------------------------------+-- SORN implementation as bit-sets+-- -------------------------------+--  +-- We use one bit per unum in the set.+--+-- E.g., 2-bit  unum means 4-bit          SORN+--       8-bit  unum means 256-bit        SORN (32 B)+--       16-bit unum means 65536-bit      SORN (8 kB)+--       24-bit unum means 16777216-bit   SORN (2 MB)+--       32-bit unum means 4294967296-bit SORN (512 MB)+--+--------------------------------------------------------------------------------+++type family SORNSize u where+   SORNSize u = Length (UnumMembers u)++type family SORNBackingWord u where+   SORNBackingWord u = WordAtLeast (SORNSize u)++newtype SORN u = SORN (SORNBackingWord u)++instance forall u v.+   ( KnownNat (SORNSize u)+   , Bits (SORNBackingWord u)+   , Num (BackingWord u)+   , Integral (BackingWord u)+   , HFoldr' GetLabel [String] v [String]+   , v ~ UnumMembers u+   ) => Show (SORN u) where+   show = show . sornElems+   ++-- | Show SORN bits+sornBits :: forall u s.+   ( FiniteBits (SORNBackingWord u)+   , KnownNat (UnumSize u)+   , s ~ SORNSize u+   , KnownNat s+   ) => SORN u -> String+sornBits (SORN w) = drop (finiteBitSize w - natValue @s) (bitsToString w)++++-- | Size of a SORN in bits+sornSize :: forall u s.+   ( s ~ SORNSize u+   , KnownNat s+   ) => Word+sornSize = natValue @s++-- | Empty SORN+sornEmpty :: (Bits (SORNBackingWord u)) => SORN u+sornEmpty = SORN zeroBits++-- | Full SORN+sornFull :: forall u.+   ( FiniteBits (SORNBackingWord u)+   , KnownNat (SORNSize u)+   ) => SORN u+sornFull = SORN (maskLeastBits s (complement zeroBits))+   where+      s = sornSize @u++-- | Full SORN without infinite+sornNonInfinite :: forall u.+   ( Bits (SORNBackingWord u)+   , Integral (BackingWord u)+   , Bits (BackingWord u)+   , Encodable Infinite u+   ) => SORN u+sornNonInfinite = sornRemove (SORN (complement zeroBits)) inf+   where+      inf = unumEncode @u @Infinite ExactNumber++-- | Full SORN without infinite+sornNonZero ::+   ( Bits (SORNBackingWord u)+   , Integral (BackingWord u)+   , Bits (BackingWord u)+   , Encodable (I 0) u+   ) => SORN u+sornNonZero = sornRemove (SORN (complement zeroBits)) unumZero++-- | SORN singleton+sornSingle ::+   ( Integral (BackingWord u)+   , Bits (SORNBackingWord u)+   ) => U u -> SORN u+sornSingle = sornInsert sornEmpty++-- | Insert in a SORN+sornInsert :: forall u.+   ( Bits (SORNBackingWord u)+   , Integral (BackingWord u)+   ) => SORN u -> U u -> SORN u+sornInsert (SORN w) (U v) = SORN (setBit w (fromIntegral v))++-- | Remove in a SORN+sornRemove :: forall u.+   ( Bits (SORNBackingWord u)+   , Integral (BackingWord u)+   ) => SORN u -> U u -> SORN u+sornRemove (SORN w) (U v) = SORN (clearBit w (fromIntegral v))++-- | Test membership in a SORN+sornMember :: forall u.+   ( Bits (SORNBackingWord u)+   , Integral (BackingWord u)+   ) => SORN u -> U u -> Bool+sornMember (SORN w) (U x) = testBit w (fromIntegral x)++-- | Union of two SORNs+sornUnion :: forall u.+   ( Bits (SORNBackingWord u)+   ) => SORN u -> SORN u -> SORN u+sornUnion (SORN w) (SORN v) = SORN (w .|. v)++-- | Intersection of two SORNs+sornIntersect :: forall u.+   ( Bits (SORNBackingWord u)+   ) => SORN u -> SORN u -> SORN u+sornIntersect (SORN w) (SORN v) = SORN (w .&. v)++-- | Complement the SORN+sornComplement ::+   ( Bits (SORNBackingWord u)+   ) => SORN u -> SORN u+sornComplement (SORN x) = SORN (complement x)++-- | Negate a SORN+sornNegate :: forall u.+   ( FiniteBits (SORNBackingWord u)+   , FiniteBits (BackingWord u)+   , Integral (BackingWord u)+   , KnownNat (SORNSize u)+   , KnownNat (UnumSize u)+   ) => SORN u -> SORN u+sornNegate = sornFromElems . fmap unumNegate . sornElems++-- | Elements in the SORN+sornElems :: forall u s.+   ( s ~ SORNSize u+   , KnownNat s+   , Bits (SORNBackingWord u)+   , Num (BackingWord u)+   ) => SORN u -> [U u]+sornElems (SORN x) = foldl b [] (reverse ([s `shiftR` 1 .. s-1]+                                  ++ [0 .. (s-1) `shiftR` 1]))+   where+      s      = natValue @s+      b us i = if testBit x i+                  then U (fromIntegral i) : us+                  else us++-- | Create a SORN from its elements+sornFromElems ::+   ( Integral (BackingWord u)+   , Bits (SORNBackingWord u)+   ) => [U u] -> SORN u+sornFromElems = foldl sornInsert sornEmpty++-- | Create a contiguous SORN from two elements+sornFromTo :: forall u.+   ( Integral (BackingWord u)+   , Bits (SORNBackingWord u)+   , FiniteBits (BackingWord u)+   , KnownNat (UnumSize u)+   ) => U u -> U u -> SORN u+sornFromTo (U a) (U b) = go sornEmpty a+   where+      go w x +         | x == b    = sornInsert w (U x)+         | otherwise = go (sornInsert w (U x)) (mask (x+1))+      mask = maskLeastBits s+      s = unumSize @u+++class SornAdd u where+   -- | Add two Unums+   sornAddU :: U u -> U u -> SORN u++   -- | Add two SORNs+   sornAdd ::+      ( KnownNat (SORNSize u)+      , Bits (SORNBackingWord u)+      , Num (BackingWord u)+      ) => SORN u -> SORN u -> SORN u+   sornAdd a b =+      foldl sornUnion sornEmpty [ sornAddU x y+                                | x <- sornElems a+                                , y <- sornElems b+                                ]++   -- | Add a SORN with itself+   sornAddDep ::+      ( KnownNat (SORNSize u)+      , Bits (SORNBackingWord u)+      , Num (BackingWord u)+      ) => SORN u -> SORN u+   sornAddDep a =+      foldl sornUnion sornEmpty [ sornAddU x x+                                | x <- sornElems a+                                ]++   -- | Subtract two Unums+   sornSubU :: +      ( FiniteBits (BackingWord u)+      , Num (BackingWord u)+      , KnownNat (UnumSize u)+      ) => U u -> U u -> SORN u+   sornSubU a b = sornAddU a (unumNegate b)++   -- | Subtract two SORNS+   sornSub ::+      ( KnownNat (SORNSize u)+      , Bits (SORNBackingWord u)+      , FiniteBits (BackingWord u)+      , Num (BackingWord u)+      , KnownNat (UnumSize u)+      ) => SORN u -> SORN u -> SORN u+   sornSub a b =+      foldl sornUnion sornEmpty [ sornSubU x y+                                | x <- sornElems a+                                , y <- sornElems b+                                ]++   -- | Subtract a SORN with itself+   sornSubDep ::+      ( KnownNat (SORNSize u)+      , Bits (SORNBackingWord u)+      , FiniteBits (BackingWord u)+      , Num (BackingWord u)+      , KnownNat (UnumSize u)+      ) => SORN u -> SORN u+   sornSubDep a =+      foldl sornUnion sornEmpty [ sornSubU x x+                                | x <- sornElems a+                                ]++++--------------------------------------------------------------------------------+-- Contiguous SORN implementation+-- -------------------------------+--  +-- We encode contiguous SORN with two values:+--    * start: the starting unum+--    * count: the number of unums from start upwards+--+-- If count == 0+--    If start == 0+--       then empty SORN+--       else full SORN+--+-- Pros:+--    * size is much smaller (2 * unum size),  especially for look-up tables because+--    connected sets remain connected under addition, subtraction, multiplication+--    and division.+--    * trivial logic for negate and reciprocate (i.e., operate on bounds only)+--------------------------------------------------------------------------------++type family CSORNSize u where+   CSORNSize u = 2 * UnumSize u++type family CSORNBackingWord u where+   CSORNBackingWord u = WordAtLeast (CSORNSize u)++newtype CSORN u+   = CSORN (BitFields (CSORNBackingWord u)+      '[ BitField (UnumSize u) "start" (BackingWord u)+       , BitField (UnumSize u) "count" (BackingWord u)+       ])++csornStart :: forall u.+   ( Integral (BackingWord u)+   , Integral (CSORNBackingWord u)+   , KnownNat (UnumSize u)+   , Bits (CSORNBackingWord u)+   , Field (BackingWord u)+   ) => CSORN u -> U u+csornStart c = U (csornStart' c)++csornStart' :: forall u.+   ( Integral (BackingWord u)+   , Integral (CSORNBackingWord u)+   , KnownNat (UnumSize u)+   , Bits (CSORNBackingWord u)+   , Field (BackingWord u)+   ) => CSORN u -> BackingWord u+csornStart' (CSORN c) = extractField' @"start" c++csornCount ::+   ( Integral (BackingWord u)+   , Integral (CSORNBackingWord u)+   , KnownNat (UnumSize u)+   , Bits (CSORNBackingWord u)+   , Field (BackingWord u)+   ) => CSORN u -> BackingWord u+csornCount (CSORN c) = extractField' @"count" c++instance forall u v.+   ( KnownNat (SORNSize u)+   , KnownNat (UnumSize u)+   , FiniteBits (BackingWord u)+   , Bits (CSORNBackingWord u)+   , Integral (CSORNBackingWord u)+   , Num (BackingWord u)+   , Integral (BackingWord u)+   , HFoldr' GetLabel [String] v [String]+   , Field (BackingWord u)+   , Bits (SORNBackingWord u)+   , FiniteBits (SORNBackingWord u)+   , v ~ UnumMembers u+   ) => Show (CSORN u) where+   show = show . csornToSorn ++-- | Convert a contiguous SORN into a SORN+csornToSorn :: forall u.+   ( KnownNat (UnumSize u)+   , Num (BackingWord u)+   , Integral (BackingWord u)+   , Integral (CSORNBackingWord u)+   , Bits (CSORNBackingWord u)+   , FiniteBits (BackingWord u)+   , Bits (SORNBackingWord u)+   , Field (BackingWord u)+   , KnownNat (SORNSize u)+   , FiniteBits (SORNBackingWord u)+   ) => CSORN u -> SORN u+csornToSorn c =+   if csornCount c == 0+      then if start == 0+         then sornEmpty+         else sornFull+      else sornFromTo (csornStart c) (U x')+   where+      start = csornStart' c+      x'    = maskLeastBits s (start + csornCount c - 1)+      s     = unumSize @u++-- | Size of a contiguous SORN in bits+csornSize :: forall u s.+   ( s ~ CSORNSize u+   , KnownNat s+   ) => Word+csornSize = natValue @s++-- | Show contiguous SORN bits+csornBits :: forall u s.+   ( FiniteBits (CSORNBackingWord u)+   , KnownNat (UnumSize u)+   , s ~ CSORNSize u+   , KnownNat s+   ) => CSORN u -> String+csornBits (CSORN (BitFields w)) = drop (finiteBitSize w - natValue @s) (bitsToString w)+++-- | Empty contigiuous SORN+csornEmpty :: forall u.+   ( Bits (CSORNBackingWord u)+   ) => CSORN u+csornEmpty = CSORN (BitFields zeroBits)++-- | Test if a contigiuous SORN is empty+csornIsEmpty :: forall u.+   ( Bits (CSORNBackingWord u)+   ) => CSORN u -> Bool+{-# INLINE csornIsEmpty #-}+csornIsEmpty (CSORN (BitFields b)) = b == zeroBits++-- | Contiguous SORN build+csornFromTo :: forall u.+   ( Num (BackingWord u)+   , Bits (BackingWord u)+   , KnownNat (UnumSize u)+   , KnownNat (SORNSize u)+   , FiniteBits (BackingWord u)+   , Integral (CSORNBackingWord u)+   , Bits (CSORNBackingWord u)+   , Field (BackingWord u)+   , Integral (BackingWord u)+   ) => U u -> U u -> CSORN u+csornFromTo start stop =+      if fromIntegral count == unumSize @u+         then csornFull+         else CSORN b+   where+      U x   = start+      U y   = stop+      s     = unumSize @u+      count = maskLeastBits s (y-x+1)+      b     = BitFields 0+              |> updateField' @"start" x+              |> updateField' @"count" count+++-- | Full contiguous SORN+csornFull :: forall u. +   ( Bits (CSORNBackingWord u)+   , Integral (CSORNBackingWord u)+   , Integral (BackingWord u)+   , KnownNat (UnumSize u)+   , Field (BackingWord u)+   ) => CSORN u+csornFull = CSORN (BitFields zeroBits+  |> updateField' @"start" 1 -- dummy /= 0+  |> updateField' @"count" 0)+++-- | Contiguous SORN singleton+csornSingle :: forall u.+   ( Bits (CSORNBackingWord u)+   , Integral (CSORNBackingWord u)+   , Integral (BackingWord u)+   , KnownNat (UnumSize u)+   , Field (BackingWord u)+   ) => U u -> CSORN u+csornSingle (U u) = CSORN (BitFields zeroBits+  |> updateField' @"start" u+  |> updateField' @"count" 1)+
+ src/lib/Haskus/Format/Binary/VariableLength.hs view
@@ -0,0 +1,92 @@+-- | Variable length encodings+module Haskus.Format.Binary.VariableLength+   ( getULEB128+   , putULEB128+   , getSLEB128+   , putSLEB128+   , getLEB128Buffer+   )+where++import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Get+import Haskus.Format.Binary.Put+import Haskus.Format.Binary.Bits+import Haskus.Format.Binary.Bits.Put+import Haskus.Format.Binary.Bits.Order+import Haskus.Format.Binary.Buffer++-- Unsigned Little Endian Base 128 (ULEB128)+-- The word is splitted in chunks of 7 bits, starting from least significant+-- bits. Each chunk is put in a Word8. The highest bit indicates if there is a+-- following byte (0 false, 1 true)++-- | Get an unsigned word in Little Endian Base 128+getULEB128 :: (Integral a, Bits a) => Get a+getULEB128 = do+   a <- getWord8+   let w = fromIntegral (a .&. 0x7f)+   if not (testBit a 7)+      then return w+      else do+         b <- getULEB128+         return $ (b `shiftL` 7) .|. w++-- | Put an unsigned word in Little Endian Base 128+putULEB128 :: (Integral a, Bits a) => a -> Put+putULEB128 = rec True+   where+      rec first x = case (first,x) of+         (True,0)  -> putWord8 0+         (False,0) -> return ()+         _         -> do+            let +               r = x `shiftR` 7+               w = x .&. 0x7f+               w' = if r == 0 then w else setBit w 7+            putWord8 (fromIntegral w')+            rec False r++-- | Get a signed int in Little Endian Base 128+getSLEB128 :: (Integral a, Bits a) => Get a+getSLEB128 = do+   let toInt8 :: Word8 -> Int8+       toInt8 = fromIntegral+   a <- getWord8+   if not (testBit a 7)+      then return . fromIntegral . toInt8 $ (a .&. 0x7f) .|. ((a .&. 0x40) `shiftL` 1)+      else do+         b <- getSLEB128+         return $ (b `shiftL` 7) .|. (fromIntegral (a .&. 0x7f))++-- | Put a signed int in Little Endian Base 128+putSLEB128 :: (Integral a, Bits a) => a -> Put+putSLEB128 a = rec a+   where+      ext = if a >= 0 then 0 else complement 0+      rec x =  do+         let +            r = x `shiftR` 7+            w = x .&. 0x7f+         if r /= ext+            then do+               putWord8 (fromIntegral w .|. 0x80)+               rec r+            else if (testBit w 6 && a < 0) || (not (testBit w 6) && a >= 0)+               then putWord8 (fromIntegral w)   -- no need for sign byte+               else do+                  putWord8 (fromIntegral w .|. 0x80)+                  putWord8 (fromIntegral ext .&. 0x7f)   -- sign byte+++-- | Get a bytestring containing a decoded LEB128 string+getLEB128Buffer :: BitOrder -> Get Buffer+getLEB128Buffer bo = rec (newBitPutState bo)+   where+      rec state = do+         w      <- getWord8+         let state2 = putBits 7 w state+         case testBit w 7 of+            True  -> rec state2+            False -> return (getBitPutBuffer state2)+
+ src/lib/Haskus/Format/Binary/Vector.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+++-- | Vector with size in the type+module Haskus.Format.Binary.Vector+   ( Vector (..)+   , vectorBuffer+   , take+   , drop+   , index+   , fromList+   , fromFilledList+   , fromFilledListZ+   , toList+   , replicate+   , concat+   )+where++import Prelude hiding (replicate, head, last,+                       tail, init, map, length, drop, take, concat)+import System.IO.Unsafe (unsafePerformIO)++import qualified Haskus.Utils.List as List+import Haskus.Utils.Types+import Haskus.Utils.HList+import Haskus.Format.Binary.Storable+import Haskus.Format.Binary.Ptr+import Haskus.Format.Binary.Buffer++-- | Vector with type-checked size+data Vector (n :: Nat) a = Vector Buffer++instance (Storable a, Show a, KnownNat n) => Show (Vector n a) where+   show v = "fromList " ++ show (toList v)++-- | Return the buffer backing the vector+vectorBuffer :: Vector n a -> Buffer+vectorBuffer (Vector b) = b++-- | Offset of the i-th element in a stored vector+type family ElemOffset a i n where+   ElemOffset a i n = IfNat (i+1 <=? n)+      (i * (SizeOf a))+      (TypeError ('Text "Invalid vector index: " ':<>: 'ShowType i+                 ':$$: 'Text "Vector size: "     ':<>: 'ShowType n))++instance forall a n.+   ( KnownNat (SizeOf a * n)+   ) => StaticStorable (Vector n a) where++   type SizeOf (Vector n a)    = SizeOf a * n+   type Alignment (Vector n a) = Alignment a++   staticPeekIO ptr =+      Vector <$> bufferPackPtr (natValue @(SizeOf a * n)) (castPtr ptr)++   staticPokeIO ptr (Vector b) = bufferPoke ptr b++instance forall a n.+   ( KnownNat n+   , Storable a+   ) => Storable (Vector n a) where+   sizeOf _    = natValue @n * sizeOfT @a+   alignment _ = alignmentT @a+   peekIO ptr  = +      Vector <$> bufferPackPtr (sizeOfT' @(Vector n a)) (castPtr ptr)++   pokeIO ptr (Vector b) = bufferPoke ptr b++-- | Yield the first n elements+take :: forall n m a.+   ( KnownNat (SizeOf a * n)+   ) => Vector (m+n) a -> Vector n a+{-# INLINE take #-}+take (Vector b) = Vector (bufferTake (natValue @(SizeOf a * n)) b)++-- | Drop the first n elements+drop :: forall n m a.+   ( KnownNat (SizeOf a * n)+   ) => Vector (m+n) a -> Vector m a+{-# INLINE drop #-}+drop (Vector b) = Vector (bufferDrop (natValue @(SizeOf a * n)) b)++-- | /O(1)/ Index safely into the vector using a type level index.+index :: forall i a n.+   ( KnownNat (ElemOffset a i n)+   , Storable a+   ) => Vector n a -> a+{-# INLINE index #-}+index (Vector b) = bufferPeekStorableAt b (natValue @(ElemOffset a i n))++-- | Convert a list into a vector if the number of elements matches+fromList :: forall a (n :: Nat) .+   ( KnownNat n+   , Storable a+   ) => [a] -> Maybe (Vector n a)+{-# INLINE fromList #-}+fromList v+   | n' /= n   = Nothing+   | n' == 0   = Just $ Vector $ emptyBuffer+   | otherwise = Just $ Vector $ bufferPackStorableList v+   where+      n' = natValue' @n+      n  = fromIntegral (List.length v)++-- | Take at most n element from the list, then use z+fromFilledList :: forall a (n :: Nat) .+   ( KnownNat n+   , Storable a+   ) => a -> [a] -> Vector n a+{-# INLINE fromFilledList #-}+fromFilledList z v = Vector $ bufferPackStorableList v'+   where+      v' = List.take (natValue @n) (v ++ repeat z)++-- | Take at most (n-1) element from the list, then use z+fromFilledListZ :: forall a (n :: Nat) .+   ( KnownNat n+   , Storable a+   ) => a -> [a] -> Vector n a+{-# INLINE fromFilledListZ #-}+fromFilledListZ z v = fromFilledList z v'+   where+      v' = List.take (natValue @n - 1) v++-- | Convert a vector into a list+toList :: forall a (n :: Nat) .+   ( KnownNat n+   , Storable a+   ) => Vector n a -> [a]+{-# INLINE toList #-}+toList (Vector b)+   | n == 0    = []+   | otherwise = fmap (bufferPeekStorableAt b . (sza*)) [0..n-1]+   where+      n   = natValue @n+      sza = sizeOfT' @a++-- | Create a vector by replicating a value+replicate :: forall a (n :: Nat) .+   ( KnownNat n+   , Storable a+   ) => a -> Vector n a+{-# INLINE replicate #-}+replicate v = fromFilledList v []+++data StoreVector = StoreVector -- Store a vector at the right offset++instance forall n v a r.+   ( v ~ Vector n a+   , r ~ IO (Ptr a)+   , KnownNat n+   , KnownNat (SizeOf a)+   , StaticStorable a+   , Storable a+   ) => Apply StoreVector (v, IO (Ptr a)) r where+      apply _ (v, getP) = do+         p <- getP+         let+            vsz = natValue @n+            p'  = p `indexPtr'` (-1 * vsz * sizeOfT @a)+         poke (castPtr p') v +         return p'++type family WholeSize fs :: Nat where+   WholeSize '[]                 = 0+   WholeSize (Vector n s ': xs)  = n + WholeSize xs++-- | Concat several vectors into a single one+concat :: forall l (n :: Nat) a .+   ( n ~ WholeSize l+   , KnownNat n+   , Storable a+   , StaticStorable a+   , HFoldr StoreVector (IO (Ptr a)) l (IO (Ptr a))+   )+   => HList l -> Vector n a+concat vs = unsafePerformIO $ do+   let sz = sizeOfT @a * natValue @n+   p <- mallocBytes (fromIntegral sz) :: IO (Ptr ())+   _ <- hFoldr StoreVector (return (castPtr p `indexPtr'` sz) :: IO (Ptr a)) vs :: IO (Ptr a)+   Vector <$> bufferUnsafePackPtr (fromIntegral sz) p
+ src/lib/Haskus/Format/Binary/Word.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MagicHash #-}++-- | Unsigned and signed words+module Haskus.Format.Binary.Word+   ( Int8+   , Int16+   , Int32+   , Int64+   , BitSize+   , WordAtLeast+   -- * Some C types+   , CSize(..)+   , CUShort+   , CShort+   , CUInt+   , CInt+   , CULong+   , CLong+   -- * Unlifted+   , module GHC.Word+   , Word#+   , Int#+   , plusWord#+   , minusWord#+   , (+#)+   , (-#)+   , (==#)+   , (>#)+   , (<#)+   , (>=#)+   , (<=#)+   , ltWord#+   , leWord#+   , gtWord#+   , geWord#+   , eqWord#+   , isTrue#+   )+where++import Data.Word+import Data.Int+import Foreign.C.Types+import GHC.Word+import GHC.Exts++import Haskus.Utils.Types++-- | Return a Word with at least 'n' bits+type family WordAtLeast (n :: Nat) where+   WordAtLeast n =+       If (n <=? 8) Word8+      (If (n <=? 16) Word16+      (If (n <=? 32) Word32+      (If (n <=? 64) Word64+      (TypeError ('Text "Cannot find Word with size " ':<>: 'ShowType n))+      )))++-- | Bit size+type family BitSize a :: Nat+type instance BitSize Word8  = 8+type instance BitSize Word16 = 16+type instance BitSize Word32 = 32+type instance BitSize Word64 = 64
+ src/lib/Haskus/Utils/Memory.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Memory utilities+module Haskus.Utils.Memory+   ( memCopy+   , memSet+   , allocaArrays+   , peekArrays+   , pokeArrays+   , withArrays+   , withMaybeOrNull+   )+where++import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Ptr+import Haskus.Format.Binary.Storable+import Haskus.Utils.Flow++-- | Copy memory+memCopy :: MonadIO m => Ptr a -> Ptr b -> Word64 -> m ()+{-# INLINE memCopy #-}+memCopy dest src size = liftIO (void (memcpy dest src size))++-- | memcpy+foreign import ccall unsafe memcpy  :: Ptr a -> Ptr b -> Word64 -> IO (Ptr c)++++-- | Set memory+memSet :: MonadIO m => Ptr a -> Word64 -> Word8 -> m ()+{-# INLINE memSet #-}+memSet dest size fill = liftIO (void (memset dest fill size))++-- | memset+foreign import ccall unsafe memset  :: Ptr a -> Word8 -> Word64 -> IO (Ptr c)+++-- | Allocate several arrays+allocaArrays :: (MonadInIO m, Storable s, Integral a) => [a] -> ([Ptr s] -> m b) -> m b+allocaArrays sizes f = go [] sizes+   where+      go as []     = f (reverse as)+      go as (x:xs) = allocaArray (fromIntegral x) $ \a -> go (a:as) xs++-- | Peek several arrays+peekArrays :: (MonadIO m, Storable s, Integral a) => [a] -> [Ptr s] -> m [[s]]+peekArrays szs ptrs = mapM f (szs `zip` ptrs)+   where+      f (sz,p) = peekArray (fromIntegral sz) p++-- | Poke several arrays+pokeArrays :: (MonadIO m, Storable s) => [Ptr s] -> [[s]] -> m ()+pokeArrays ptrs vs = mapM_ f (ptrs `zip` vs)+   where+      f = uncurry pokeArray++-- | Allocate several arrays+withArrays :: (MonadInIO m, Storable s) => [[s]] -> ([Ptr s] -> m b) -> m b+withArrays vs f = go [] vs+   where+      go as []     = f (reverse as)+      go as (x:xs) = withArray x $ \a -> go (a:as) xs++-- | Execute f with a pointer to 'a' or NULL+withMaybeOrNull ::+   ( Storable a+   , MonadInIO m+   ) => Maybe a -> (Ptr a -> m b) -> m b+withMaybeOrNull s f = case s of+   Nothing -> f nullPtr+   Just x  -> with x f
+ src/tests/Haskus/Tests/Common.hs view
@@ -0,0 +1,73 @@+module Haskus.Tests.Common+   ( isBijective+   , isEquivalent+   , ArbitraryByteString (..)+   , ArbitraryByteStringNoNul (..)+   , ArbitraryBuffer (..)+   , ArbitraryBufferNoNul (..)+   )+where+++import Test.Tasty.QuickCheck as QC++import qualified Data.ByteString as BS++import Haskus.Format.Binary.Buffer++-- | Ensure a function is bijective+isBijective :: Eq a => (a -> a) -> a -> Bool+isBijective f w = w == (f (f w))++-- | Ensure that two functions return the same thing for the same input+isEquivalent :: Eq b => (a -> b) -> (a -> b) -> a -> Bool+isEquivalent f g x = (f x) == (g x)++-- | Arbitrary ByteString (50 chars long max)+newtype ArbitraryByteString+   = ArbitraryByteString BS.ByteString+   deriving (Show)++instance Arbitrary ArbitraryByteString where+   arbitrary                       = ArbitraryByteString . BS.pack <$> resize 50 (listOf arbitrary)+   shrink (ArbitraryByteString bs)+      | BS.null bs = []+      | otherwise  = [ArbitraryByteString $ BS.take (BS.length bs `div` 2) bs]++-- | Arbitrary ByteString (50 chars long max, no Nul)+newtype ArbitraryByteStringNoNul+   = ArbitraryByteStringNoNul BS.ByteString+   deriving (Show)++instance Arbitrary ArbitraryByteStringNoNul where+   arbitrary                       = ArbitraryByteStringNoNul . BS.pack <$> resize 50 (listOf (choose (1,255))) -- we exclude 0+   shrink (ArbitraryByteStringNoNul bs)+      | BS.null bs = []+      | otherwise  = [ArbitraryByteStringNoNul $ BS.take (BS.length bs `div` 2) bs]++-- | Arbitrary Buffer (50 chars long max)+newtype ArbitraryBuffer+   = ArbitraryBuffer Buffer+   deriving (Show)++instance Arbitrary ArbitraryBuffer where+   arbitrary = do+         ArbitraryByteString bs <- arbitrary+         return (ArbitraryBuffer (Buffer bs))++   shrink (ArbitraryBuffer bs)+      | isBufferEmpty bs = []+      | otherwise        = [ArbitraryBuffer $ bufferTake (bufferSize bs `div` 2) bs]++-- | Arbitrary Buffer (50 chars long max, no Nul)+newtype ArbitraryBufferNoNul+   = ArbitraryBufferNoNul Buffer+   deriving (Show)++instance Arbitrary ArbitraryBufferNoNul where+   arbitrary = do+      ArbitraryByteStringNoNul bs <- arbitrary+      return (ArbitraryBufferNoNul (Buffer bs))+   shrink (ArbitraryBufferNoNul bs)+      | isBufferEmpty bs = []+      | otherwise        = [ArbitraryBufferNoNul $ bufferTake (bufferSize bs `div` 2) bs]
+ src/tests/Haskus/Tests/Format/Binary.hs view
@@ -0,0 +1,14 @@+module Haskus.Tests.Format.Binary where++import Test.Tasty++import Haskus.Tests.Format.Binary.Bits+import Haskus.Tests.Format.Binary.GetPut+import Haskus.Tests.Format.Binary.Vector++testsBinary :: TestTree+testsBinary = testGroup "Binary"+   [ testsBits+   , testsGetPut+   , testsVector+   ]
+ src/tests/Haskus/Tests/Format/Binary/Bits.hs view
@@ -0,0 +1,202 @@+module Haskus.Tests.Format.Binary.Bits +   ( testsBits+   )+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.QuickCheck.Gen (elements,choose,vectorOf)++import Haskus.Tests.Common++import Haskus.Format.Binary.Bits.Put+import Haskus.Format.Binary.Bits.Get+import Haskus.Format.Binary.Bits.Order+import Haskus.Format.Binary.Bits.Reverse+import Haskus.Format.Binary.Bits++import Haskus.Format.Binary.Buffer+import Haskus.Format.Binary.Get+import Haskus.Format.Binary.Put+import Haskus.Format.Binary.VariableLength+import Haskus.Format.Binary.Word++testsBits :: TestTree+testsBits = testGroup "Binary bits" $+   [ testGroup "Bits to/from string"+      [ testProperty "Bits from string \"01010011\" (Word8)" (bitsFromString "01010011" == (83 :: Word8))+      , testProperty "Bits from string reverse (Word64)" prop_bits_from_string+      , testProperty "Bits to string (Word8)"            (prop_bits_to_string :: Word8  -> Bool)+      , testProperty "Bits to string (Word16)"           (prop_bits_to_string :: Word16 -> Bool)+      , testProperty "Bits to string (Word32)"           (prop_bits_to_string :: Word32 -> Bool)+      , testProperty "Bits to string (Word64)"           (prop_bits_to_string :: Word64 -> Bool)+      ]+   , testGroup "Bit put/bit get"+      [ testProperty "Bit put/get Word8  - 8  bits"      (prop_reverse_word 8  :: Word8  -> ArbitraryBitOrder -> Bool)+      , testProperty "Bit put/get Word16 - 16 bits"      (prop_reverse_word 16 :: Word16 -> ArbitraryBitOrder -> Bool)+      , testProperty "Bit put/get Word32 - 32 bits"      (prop_reverse_word 32 :: Word32 -> ArbitraryBitOrder -> Bool)+      , testProperty "Bit put/get Word64 - 64 bits"      (prop_reverse_word 64 :: Word64 -> ArbitraryBitOrder -> Bool)+      , testProperty "Bit put/get Word8  - [1,8]  bits"  (prop_reverse_word_size :: Size8  -> Word8   -> ArbitraryBitOrder -> Bool)+      , testProperty "Bit put/get Word16 - [1,16] bits"  (prop_reverse_word_size :: Size16 -> Word16  -> ArbitraryBitOrder -> Bool)+      , testProperty "Bit put/get Word32 - [1,32] bits"  (prop_reverse_word_size :: Size32 -> Word32  -> ArbitraryBitOrder -> Bool)+      , testProperty "Bit put/get Word64 - [1,64] bits"  (prop_reverse_word_size :: Size64 -> Word64  -> ArbitraryBitOrder -> Bool)+      , testProperty "Monadic BitPut/BitGet, two parts of two Word64"+         (prop_split_word :: Size64 -> Size64 -> Word64 -> Word64 -> ArbitraryBitOrder -> Bool)+      , testProperty "Monadic BitPut/BitGet, bytestring with offset" prop_reverse_bs+      ]+   , testGroup "Variable length (LEB128)"+      [ testProperty "Put/Get reverse (Word8)"           (prop_uleb128_reverse :: Word8 -> Bool)+      , testProperty "Put/Get reverse (Word16)"          (prop_uleb128_reverse :: Word16 -> Bool)+      , testProperty "Put/Get reverse (Word32)"          (prop_uleb128_reverse :: Word32 -> Bool)+      , testProperty "Put/Get reverse (Word64)"          (prop_uleb128_reverse :: Word64 -> Bool)+      ]+   , testGroup "Reverse bits (Word8)"+      [ testProperty "Reverse bits in a Word8"  (reverseBits (0x28 :: Word8) == 0x14)+      , testProperty "Bijective: obvious"       (isBijective (reverseBitsObvious :: Word8 -> Word8))+      , testProperty "Bijective: 3Ops"          (isBijective reverseBits3Ops)+      , testProperty "Bijective: 4Ops"          (isBijective reverseBits4Ops)+      , testProperty "Bijective: lookup table"  (isBijective reverseBitsTable)+      , testProperty "Bijective: 7Ops"          (isBijective reverseBits7Ops)+      , testProperty "Bijective: 5LgN"          (isBijective (reverseBits5LgN :: Word8 -> Word8))+      , testProperty "Equivalent: obvious"      (isEquivalent (reverseBits :: Word8 -> Word8) reverseBitsObvious)+      , testProperty "Equivalent: 3Ops"         (isEquivalent (reverseBits :: Word8 -> Word8) reverseBits3Ops)+      , testProperty "Equivalent: 4Ops"         (isEquivalent (reverseBits :: Word8 -> Word8) reverseBits4Ops)+      , testProperty "Equivalent: lookup table" (isEquivalent (reverseBits :: Word8 -> Word8) reverseBitsTable)+      , testProperty "Equivalent: 7Ops"         (isEquivalent (reverseBits :: Word8 -> Word8) reverseBits7Ops)+      , testProperty "Equivalent: 5LgN"         (isEquivalent (reverseBits :: Word8 -> Word8) reverseBits5LgN)+      ]+   , testGroup "Reverse bits (Word16)"+      [ testProperty "Reverse bits in a Word16" (reverseBits (0x2817 :: Word16) == 0xe814)+      , testProperty "Bijective: obvious"       (isBijective (                reverseBitsObvious :: Word16 -> Word16))+      , testProperty "Bijective: 3Ops"          (isBijective (liftReverseBits reverseBits3Ops    :: Word16 -> Word16))+      , testProperty "Bijective: 4Ops"          (isBijective (liftReverseBits reverseBits4Ops    :: Word16 -> Word16))+      , testProperty "Bijective: lookup table"  (isBijective (liftReverseBits reverseBitsTable   :: Word16 -> Word16))+      , testProperty "Bijective: 7Ops"          (isBijective (liftReverseBits reverseBits7Ops    :: Word16 -> Word16))+      , testProperty "Bijective: 5LgN"          (isBijective (                reverseBits5LgN    :: Word16 -> Word16))+      , testProperty "Equivalent: obvious"      (isEquivalent (reverseBits :: Word16 -> Word16) reverseBitsObvious)+      , testProperty "Equivalent: 3Ops"         (isEquivalent (reverseBits :: Word16 -> Word16) (liftReverseBits reverseBits3Ops))+      , testProperty "Equivalent: 4Ops"         (isEquivalent (reverseBits :: Word16 -> Word16) (liftReverseBits reverseBits4Ops))+      , testProperty "Equivalent: lookup table" (isEquivalent (reverseBits :: Word16 -> Word16) (liftReverseBits reverseBitsTable))+      , testProperty "Equivalent: 7Ops"         (isEquivalent (reverseBits :: Word16 -> Word16) (liftReverseBits reverseBits7Ops))+      , testProperty "Equivalent: 5LgN"         (isEquivalent (reverseBits :: Word16 -> Word16) reverseBits5LgN)+      ]+   , testGroup "Reverse bits (Word32)"+      [ testProperty "Reverse bits in a Word32" (reverseBits (0x28173456 :: Word32) == 0x6a2ce814)+      , testProperty "Bijective: obvious"       (isBijective (                reverseBitsObvious :: Word32 -> Word32))+      , testProperty "Bijective: 3Ops"          (isBijective (liftReverseBits reverseBits3Ops    :: Word32 -> Word32))+      , testProperty "Bijective: 4Ops"          (isBijective (liftReverseBits reverseBits4Ops    :: Word32 -> Word32))+      , testProperty "Bijective: lookup table"  (isBijective (liftReverseBits reverseBitsTable   :: Word32 -> Word32))+      , testProperty "Bijective: 7Ops"          (isBijective (liftReverseBits reverseBits7Ops    :: Word32 -> Word32))+      , testProperty "Bijective: 5LgN"          (isBijective (                reverseBits5LgN    :: Word32 -> Word32))+      , testProperty "Equivalent: obvious"      (isEquivalent (reverseBits :: Word32 -> Word32) reverseBitsObvious)+      , testProperty "Equivalent: 3Ops"         (isEquivalent (reverseBits :: Word32 -> Word32) (liftReverseBits reverseBits3Ops))+      , testProperty "Equivalent: 4Ops"         (isEquivalent (reverseBits :: Word32 -> Word32) (liftReverseBits reverseBits4Ops))+      , testProperty "Equivalent: lookup table" (isEquivalent (reverseBits :: Word32 -> Word32) (liftReverseBits reverseBitsTable))+      , testProperty "Equivalent: 7Ops"         (isEquivalent (reverseBits :: Word32 -> Word32) (liftReverseBits reverseBits7Ops))+      , testProperty "Equivalent: 5LgN"         (isEquivalent (reverseBits :: Word32 -> Word32) reverseBits5LgN)+      ]+   , testGroup "Reverse bits (Word64)"+      [ testProperty "Reverse bits in a Word64" (reverseBits (0x2800017003450060 :: Word64) == 0x0600a2c00e800014)+      , testProperty "Bijective: obvious"       (isBijective (                reverseBitsObvious :: Word64 -> Word64))+      , testProperty "Bijective: 3Ops"          (isBijective (liftReverseBits reverseBits3Ops    :: Word64 -> Word64))+      , testProperty "Bijective: 4Ops"          (isBijective (liftReverseBits reverseBits4Ops    :: Word64 -> Word64))+      , testProperty "Bijective: lookup table"  (isBijective (liftReverseBits reverseBitsTable   :: Word64 -> Word64))+      , testProperty "Bijective: 7Ops"          (isBijective (liftReverseBits reverseBits7Ops    :: Word64 -> Word64))+      , testProperty "Bijective: 5LgN"          (isBijective (                reverseBits5LgN    :: Word64 -> Word64))+      , testProperty "Equivalent: obvious"      (isEquivalent (reverseBits :: Word64 -> Word64) reverseBitsObvious)+      , testProperty "Equivalent: 3Ops"         (isEquivalent (reverseBits :: Word64 -> Word64) (liftReverseBits reverseBits3Ops))+      , testProperty "Equivalent: 4Ops"         (isEquivalent (reverseBits :: Word64 -> Word64) (liftReverseBits reverseBits4Ops))+      , testProperty "Equivalent: lookup table" (isEquivalent (reverseBits :: Word64 -> Word64) (liftReverseBits reverseBitsTable))+      , testProperty "Equivalent: 7Ops"         (isEquivalent (reverseBits :: Word64 -> Word64) (liftReverseBits reverseBits7Ops))+      , testProperty "Equivalent: 5LgN"         (isEquivalent (reverseBits :: Word64 -> Word64) reverseBits5LgN)+      ]+   ]++newtype ArbitraryBitOrder = ArbitraryBitOrder BitOrder deriving (Show)++instance Arbitrary ArbitraryBitOrder where+   arbitrary = elements $ fmap ArbitraryBitOrder [BB,LB,BL,LL]+   shrink (ArbitraryBitOrder x) = case x of+      LL -> fmap ArbitraryBitOrder [BB,LB,BL]+      BL -> fmap ArbitraryBitOrder [BB,LB]+      LB -> fmap ArbitraryBitOrder [BB]+      BB -> fmap ArbitraryBitOrder []++class Size x where+   fromSize :: x -> Word++newtype Size8  = Size8  Word deriving (Show)+newtype Size16 = Size16 Word deriving (Show)+newtype Size32 = Size32 Word deriving (Show)+newtype Size64 = Size64 Word deriving (Show)++instance Size Size8  where fromSize (Size8  x) = x+instance Size Size16 where fromSize (Size16 x) = x+instance Size Size32 where fromSize (Size32 x) = x+instance Size Size64 where fromSize (Size64 x) = x++instance Arbitrary Size8  where arbitrary = fmap Size8  $ choose (1,8)+instance Arbitrary Size16 where arbitrary = fmap Size16 $ choose (1,16)+instance Arbitrary Size32 where arbitrary = fmap Size32 $ choose (1,32)+instance Arbitrary Size64 where arbitrary = fmap Size64 $ choose (1,64)+++newtype BitString = BitString String deriving (Show)++instance Arbitrary BitString where+   arbitrary = fmap BitString $ vectorOf 64 (elements ['0','1'])++-- | Test that a random BitString (i.e. a string with length 64 and only+-- composed of 0s and 1s) can be converted into a Word64 and back into a string+prop_bits_from_string :: BitString -> Bool+prop_bits_from_string (BitString s) = bitsToString (bitsFromString s :: Word64) == s++-- | Test that a word can be converted into a BitString and back+prop_bits_to_string :: FiniteBits a => a -> Bool+prop_bits_to_string x = bitsFromString (bitsToString x) == x++-- | Test that words of the given length can be written and read back with+-- BitGet/BitPut. Test every bit ordering.+prop_reverse_word :: (Integral a, FiniteBits a, BitReversable a) => Word -> a -> ArbitraryBitOrder -> Bool+prop_reverse_word n w (ArbitraryBitOrder bo) = maskLeastBits n w == dec+   where+      enc = getBitPutBuffer  $ putBits n w $ newBitPutState bo+      dec = getBits n $ newBitGetState bo enc++-- | Test that a ByteString can be written and read back with+-- BitGet/BitPut. Test every bit ordering.+prop_reverse_bs :: Word64 -> Size64 -> ArbitraryBuffer -> ArbitraryBitOrder -> Bool+prop_reverse_bs w s (ArbitraryBuffer bs) (ArbitraryBitOrder bo) = runBitGet bo dec (runBitPut bo enc)+   where+      len = bufferSize bs+      enc = do+         putBitsM (fromSize s) w+         putBitsBufferM bs+      dec = do+         w2  <- getBitsM (fromSize s)+         bs' <- getBitsBSM (fromIntegral len)+         return (bs == bs' && w2 == maskLeastBits (fromSize s) w)++-- | Test that words with arbitrary (but still valid) lengths can be written and+-- read back with BitGet/BitPut. Test every bit ordering.+prop_reverse_word_size :: (Integral a, FiniteBits a, BitReversable a, Size s) => s -> a -> ArbitraryBitOrder -> Bool+prop_reverse_word_size n w bo = prop_reverse_word (fromSize n) w bo++-- | Write two parts of two words and read them back+prop_split_word :: (Num a, Integral a, FiniteBits a, BitReversable a,+                    Num b, Integral b, FiniteBits b, BitReversable b,+                    Size s1, Size s2) => s1 -> s2 -> a -> b -> ArbitraryBitOrder -> Bool+prop_split_word s1 s2 w1 w2 (ArbitraryBitOrder bo) = runBitGet bo dec (runBitPut bo enc)+   where+      enc = do+         putBitsM (fromSize s1) w1+         putBitsM (fromSize s2) w2+      dec = do+         v1 <- getBitsM (fromSize s1)+         v2 <- getBitsM (fromSize s2)+         return (v1 == maskLeastBits (fromSize s1) w1 && v2 == maskLeastBits (fromSize s2) w2)++-- | Test that ULEB128 decoder can read back what has been written with ULEB128+-- encoder+prop_uleb128_reverse :: (Integral a, Bits a) => a -> Bool+prop_uleb128_reverse w = w == runGetOrFail getULEB128 (runPut (putULEB128 w))
+ src/tests/Haskus/Tests/Format/Binary/GetPut.hs view
@@ -0,0 +1,29 @@+module Haskus.Tests.Format.Binary.GetPut+   ( testsGetPut+   )+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC++import Haskus.Tests.Common++import Haskus.Format.Binary.Get+import Haskus.Format.Binary.Buffer++testsGetPut :: TestTree+testsGetPut = testGroup "Get/Put" $+   [ testGroup "getBufferNul"+      [ testProperty "Read two successives strings" getBufferNul_basic+      ]+   ]+++getBufferNul_basic :: ArbitraryBufferNoNul -> ArbitraryBufferNoNul -> Bool+getBufferNul_basic (ArbitraryBufferNoNul s1) (ArbitraryBufferNoNul s2) = runGetOrFail getter str+   where+      str    = (s1 `bufferSnoc` 0) `bufferAppend` s2+      getter = do+         a <- getBufferNul+         b <- getBufferNul+         return (a == s1 && b == s2)
+ src/tests/Haskus/Tests/Format/Binary/Vector.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Haskus.Tests.Format.Binary.Vector+   ( testsVector+   )+where++import Prelude hiding (concat, replicate, take, drop)++import Test.Tasty+import Test.Tasty.QuickCheck as QC++import Haskus.Utils.Maybe+import Haskus.Utils.HList+import Haskus.Format.Binary.Vector+import Haskus.Format.Binary.Word++v1234 :: Vector 4 Word32+v1234 = fromJust $ fromList [1,2,3,4]++v567 :: Vector 3 Word32+v567 = fromJust $ fromList [5,6,7]++testsVector :: TestTree+testsVector = testGroup "Vector" $+   [ testProperty "toList . fromList == id" $+         toList v1234 == [1,2,3,4]++   , testProperty "toList (fromList []) == []" $+         toList (fromJust (fromList []) :: Vector 0 Word64) == []++   , testProperty "fromFilledList: shorter input" $+         toList (fromFilledList 5 [1,2,3,4] :: Vector 8 Word32) == [1,2,3,4,5,5,5,5]++   , testProperty "fromFilledList: longer input" $+         toList (fromFilledList 5 [1,2,3,4] :: Vector 3 Word32) == [1,2,3]++   , testProperty "fromFilledList: equal input" $+         toList (fromFilledList 5 [1,2,3,4] :: Vector 4 Word32) == [1,2,3,4]++   , testProperty "fromFilledListZ: shorter input" $+         toList (fromFilledListZ 5 [1,2,3,4] :: Vector 8 Word32) == [1,2,3,4,5,5,5,5]++   , testProperty "fromFilledListZ: longer input" $+         toList (fromFilledListZ 5 [1,2,3,4] :: Vector 3 Word32) == [1,2,5]++   , testProperty "fromFilledListZ: equal input" $+         toList (fromFilledListZ 5 [1,2,3,4] :: Vector 4 Word32) == [1,2,3,5]++   , testProperty "take less" $+         toList (take @2 v1234) == [1,2]++   , testProperty "take equal" $+         toList (take @4 v1234) == [1,2,3,4]++   , testProperty "drop less" $+         toList (drop @2 v1234) == [3,4]++   , testProperty "drop equal" $+         toList (drop @4 v1234) == []++   , testProperty "index" $+         index @2 v1234 == 3++   , testProperty "replicate" $+         toList (replicate 5 :: Vector 4 Word32) == [5,5,5,5]++   , testProperty "concat two vectors" $+         toList (concat (v1234 `HCons` v567 `HCons` HNil)) == [1,2,3,4,5,6,7]++   , testProperty "concat 4 vectors" $+         toList (concat (v1234 `HCons` v567 `HCons` v567 `HCons` v1234 `HCons` HNil)) == [1,2,3,4,5,6,7,5,6,7,1,2,3,4]+   ]
+ src/tests/Main.hs view
@@ -0,0 +1,5 @@+import Haskus.Tests.Format.Binary+import Test.Tasty++main :: IO ()+main = defaultMain testsBinary