diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskus-binary.cabal b/haskus-binary.cabal new file mode 100644 --- /dev/null +++ b/haskus-binary.cabal @@ -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 diff --git a/src/bench/BitReverse.hs b/src/bench/BitReverse.hs new file mode 100644 --- /dev/null +++ b/src/bench/BitReverse.hs @@ -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 + ] + ] + diff --git a/src/lib/Haskus/Format/Binary/BitField.hs b/src/lib/Haskus/Format/Binary/BitField.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/BitField.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/BitSet.hs b/src/lib/Haskus/Format/Binary/BitSet.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/BitSet.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/Bits.hs b/src/lib/Haskus/Format/Binary/Bits.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Bits.hs @@ -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 + diff --git a/src/lib/Haskus/Format/Binary/Bits/Basic.hs b/src/lib/Haskus/Format/Binary/Bits/Basic.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Bits/Basic.hs @@ -0,0 +1,7 @@ +-- | Basic operations on bits +module Haskus.Format.Binary.Bits.Basic + ( module Data.Bits + ) +where + +import Data.Bits diff --git a/src/lib/Haskus/Format/Binary/Bits/Get.hs b/src/lib/Haskus/Format/Binary/Bits/Get.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Bits/Get.hs @@ -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 + diff --git a/src/lib/Haskus/Format/Binary/Bits/Order.hs b/src/lib/Haskus/Format/Binary/Bits/Order.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Bits/Order.hs @@ -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) diff --git a/src/lib/Haskus/Format/Binary/Bits/Put.hs b/src/lib/Haskus/Format/Binary/Bits/Put.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Bits/Put.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/Bits/Reverse.hs b/src/lib/Haskus/Format/Binary/Bits/Reverse.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Bits/Reverse.hs @@ -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 #-} + diff --git a/src/lib/Haskus/Format/Binary/Buffer.hs b/src/lib/Haskus/Format/Binary/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Buffer.hs @@ -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) diff --git a/src/lib/Haskus/Format/Binary/BufferBuilder.hs b/src/lib/Haskus/Format/Binary/BufferBuilder.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/BufferBuilder.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/BufferList.hs b/src/lib/Haskus/Format/Binary/BufferList.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/BufferList.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/Endianness.hs b/src/lib/Haskus/Format/Binary/Endianness.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Endianness.hs @@ -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) diff --git a/src/lib/Haskus/Format/Binary/Enum.hs b/src/lib/Haskus/Format/Binary/Enum.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Enum.hs @@ -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) + diff --git a/src/lib/Haskus/Format/Binary/FixedPoint.hs b/src/lib/Haskus/Format/Binary/FixedPoint.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/FixedPoint.hs @@ -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) diff --git a/src/lib/Haskus/Format/Binary/Get.hs b/src/lib/Haskus/Format/Binary/Get.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Get.hs @@ -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) + diff --git a/src/lib/Haskus/Format/Binary/Layout.hs b/src/lib/Haskus/Format/Binary/Layout.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Layout.hs @@ -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)) diff --git a/src/lib/Haskus/Format/Binary/Ptr.hs b/src/lib/Haskus/Format/Binary/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Ptr.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/Put.hs b/src/lib/Haskus/Format/Binary/Put.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Put.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/Record.hs b/src/lib/Haskus/Format/Binary/Record.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Record.hs @@ -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) diff --git a/src/lib/Haskus/Format/Binary/Storable.hs b/src/lib/Haskus/Format/Binary/Storable.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Storable.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/Union.hs b/src/lib/Haskus/Format/Binary/Union.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Union.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/Unum.hs b/src/lib/Haskus/Format/Binary/Unum.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Unum.hs @@ -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) + diff --git a/src/lib/Haskus/Format/Binary/VariableLength.hs b/src/lib/Haskus/Format/Binary/VariableLength.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/VariableLength.hs @@ -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) + diff --git a/src/lib/Haskus/Format/Binary/Vector.hs b/src/lib/Haskus/Format/Binary/Vector.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Vector.hs @@ -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 diff --git a/src/lib/Haskus/Format/Binary/Word.hs b/src/lib/Haskus/Format/Binary/Word.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Format/Binary/Word.hs @@ -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 diff --git a/src/lib/Haskus/Utils/Memory.hs b/src/lib/Haskus/Utils/Memory.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Utils/Memory.hs @@ -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 diff --git a/src/tests/Haskus/Tests/Common.hs b/src/tests/Haskus/Tests/Common.hs new file mode 100644 --- /dev/null +++ b/src/tests/Haskus/Tests/Common.hs @@ -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] diff --git a/src/tests/Haskus/Tests/Format/Binary.hs b/src/tests/Haskus/Tests/Format/Binary.hs new file mode 100644 --- /dev/null +++ b/src/tests/Haskus/Tests/Format/Binary.hs @@ -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 + ] diff --git a/src/tests/Haskus/Tests/Format/Binary/Bits.hs b/src/tests/Haskus/Tests/Format/Binary/Bits.hs new file mode 100644 --- /dev/null +++ b/src/tests/Haskus/Tests/Format/Binary/Bits.hs @@ -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)) diff --git a/src/tests/Haskus/Tests/Format/Binary/GetPut.hs b/src/tests/Haskus/Tests/Format/Binary/GetPut.hs new file mode 100644 --- /dev/null +++ b/src/tests/Haskus/Tests/Format/Binary/GetPut.hs @@ -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) diff --git a/src/tests/Haskus/Tests/Format/Binary/Vector.hs b/src/tests/Haskus/Tests/Format/Binary/Vector.hs new file mode 100644 --- /dev/null +++ b/src/tests/Haskus/Tests/Format/Binary/Vector.hs @@ -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] + ] diff --git a/src/tests/Main.hs b/src/tests/Main.hs new file mode 100644 --- /dev/null +++ b/src/tests/Main.hs @@ -0,0 +1,5 @@ +import Haskus.Tests.Format.Binary +import Test.Tasty + +main :: IO () +main = defaultMain testsBinary