diff --git a/haskus-binary.cabal b/haskus-binary.cabal --- a/haskus-binary.cabal +++ b/haskus-binary.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: haskus-binary -version: 1.4 +version: 1.5 synopsis: Haskus binary format manipulation license: BSD-3-Clause license-file: LICENSE @@ -18,57 +18,68 @@ source-repository head type: git - location: git://github.com/haskus/haskus-packages.git + location: git://github.com/haskus/packages.git library exposed-modules: - Haskus.Format.Binary.Bits - Haskus.Format.Binary.Bits.Finite - Haskus.Format.Binary.Bits.Index - Haskus.Format.Binary.Bits.Bitwise - Haskus.Format.Binary.Bits.Reverse - Haskus.Format.Binary.Bits.Rotate - Haskus.Format.Binary.Bits.Shift - Haskus.Format.Binary.Bits.Order - Haskus.Format.Binary.Bits.Get - Haskus.Format.Binary.Bits.Put - Haskus.Format.Binary.Bits.Mask - Haskus.Format.Binary.Bits.Helper + Haskus.Binary.Bits + Haskus.Binary.Bits.Finite + Haskus.Binary.Bits.Index + Haskus.Binary.Bits.Bitwise + Haskus.Binary.Bits.Reverse + Haskus.Binary.Bits.Rotate + Haskus.Binary.Bits.Shift + Haskus.Binary.Bits.Order + Haskus.Binary.Bits.Get + Haskus.Binary.Bits.Put + Haskus.Binary.Bits.Mask + Haskus.Binary.Bits.Helper - Haskus.Format.Binary.BitSet - Haskus.Format.Binary.BitField - Haskus.Format.Binary.Buffer - Haskus.Format.Binary.BufferList - Haskus.Format.Binary.BufferBuilder - Haskus.Format.Binary.Char - Haskus.Format.Binary.Enum - Haskus.Format.Binary.Endianness - Haskus.Format.Binary.FixedPoint - Haskus.Format.Binary.Get - Haskus.Format.Binary.Put - Haskus.Format.Binary.VariableLength - Haskus.Format.Binary.Vector - Haskus.Format.Binary.Union - Haskus.Format.Binary.Unum - Haskus.Format.Binary.Posit - Haskus.Format.Binary.Record - Haskus.Format.Binary.Storable - Haskus.Format.Binary.Word - Haskus.Format.Binary.Ptr - Haskus.Format.Binary.Serialize - Haskus.Format.Binary.Serialize.Buffer - Haskus.Format.Binary.Layout + Haskus.Binary.BitSet + Haskus.Binary.BitField + Haskus.Binary.Buffer + Haskus.Binary.BufferList + Haskus.Binary.BufferBuilder + Haskus.Binary.Char + Haskus.Binary.Enum + Haskus.Binary.Endianness + Haskus.Binary.Get + Haskus.Binary.Put + Haskus.Binary.Vector + Haskus.Binary.Union + Haskus.Binary.Unum + Haskus.Binary.Record + Haskus.Binary.Storable + Haskus.Binary.Serialize + Haskus.Binary.Serialize.Size + Haskus.Binary.Serialize.Put + Haskus.Binary.Serialize.Get + Haskus.Binary.Serialize.Buffer + Haskus.Binary.Serialize.File + Haskus.Binary.CTypes - Haskus.Format.Number - Haskus.Format.Number.BitNat - Haskus.Format.Number.NaturalRange + Haskus.Number + Haskus.Number.Word + Haskus.Number.Int + Haskus.Number.Float + Haskus.Number.VariableLength + Haskus.Number.Posit + Haskus.Number.FixedPoint + Haskus.Number.BitNat + Haskus.Number.Signed + Haskus.Number.SignedSafe + Haskus.Number.NaturalRange - Haskus.Utils.Memory + Haskus.Memory.Utils Haskus.Memory.Buffer Haskus.Memory.Allocator.Malloc Haskus.Memory.Embed + Haskus.Memory.Layout Haskus.Memory.View + Haskus.Memory.Ptr + Haskus.Memory.Property + Haskus.Memory.Typed other-modules: @@ -81,15 +92,13 @@ , cereal >= 0.5 , bytestring >= 0.10 , mtl >= 2.2 - , primitive , megaparsec , template-haskell , transformers , directory , filepath - build-tools: - ghc-options: -Wall + ghc-options: -Wall -Wno-unticked-promoted-constructors default-language: Haskell2010 hs-source-dirs: src/lib diff --git a/src/bench/BitReverse.hs b/src/bench/BitReverse.hs --- a/src/bench/BitReverse.hs +++ b/src/bench/BitReverse.hs @@ -1,7 +1,7 @@ import Criterion.Main -import Haskus.Format.Binary.Bits.Reverse -import Haskus.Format.Binary.Word +import Haskus.Binary.Bits.Reverse +import Haskus.Number.Word main :: IO () main = do diff --git a/src/lib/Haskus/Binary/BitField.hs b/src/lib/Haskus/Binary/BitField.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/BitField.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Bit fields (as in C) +-- +-- This module allows you to define bit fields over words. For instance, you can +-- have a Word16 split into 3 fields X, Y and Z composed of 5, 9 and 2 bits +-- respectively. +-- +-- @ X Y Z @ +-- @ w :: Word16 |0 0 0 0 0|0 0 0 0 0 0 0 0 0|0 0| @ +-- +-- You define it as follows: +-- +-- @ +-- {-# LANGUAGE DataKinds #-} +-- +-- w :: BitFields Word16 '[ BitField 5 "X" Word8 +-- , BitField 9 "Y" Word16 +-- , BitField 2 "Z" Word8 +-- ] +-- w = BitFields 0x0102 +-- @ +-- +-- Note that each field has its own associated type (e.g. Word8 for X and Z) +-- that must be large enough to hold the number of bits for the field. +-- +-- Operations on BitFields expect that the cumulated size of the fields is equal +-- to the whole word size: use a padding field if necessary. Otherwise you can +-- use unsafe versions of the functions: extractField', updateField', +-- withField'. +-- +-- You can extract and update the value of a field by its name: +-- +-- @ +-- x = extractField @"X" w +-- z = extractField @"Z" w +-- w' = updateField @"Y" 0x16 w +-- @ +-- +-- Fields can also be 'BitSet' or 'EnumField': +-- +-- @ +-- {-# LANGUAGE DataKinds #-} +-- +-- data A = A0 | A1 | A2 | A3 deriving (Enum,CEnum) +-- +-- data B = B0 | B1 deriving (Enum,BitOffset) +-- +-- w :: BitFields Word16 '[ BitField 5 "X" (EnumField Word8 A) +-- , BitField 9 "Y" Word16 +-- , BitField 2 "Z" (BitSet Word8 B) +-- ] +-- w = BitFields 0x0102 +-- @ +-- +module Haskus.Binary.BitField + ( BitFields (..) + , bitFieldsBits + , BitField (..) + , extractField + , extractField' + , updateField + , updateField' + , withField + , withField' + , matchFields + , matchNamedFields + , Field + ) +where + +import Haskus.Binary.BitSet as BitSet +import Haskus.Binary.Enum +import Haskus.Number.Word +import Haskus.Number.Int +import Haskus.Binary.Bits +import Haskus.Binary.Storable +import Haskus.Utils.HList +import Haskus.Utils.Types +import Haskus.Utils.Tuple + +-- | Bit fields on a base type b +newtype BitFields b (f :: [*]) = BitFields b deriving (Storable) + +-- | Get backing word +bitFieldsBits :: BitFields b f -> b +{-# INLINABLE bitFieldsBits #-} +bitFieldsBits (BitFields b) = b + + +-- | A field of n bits +newtype BitField (n :: Nat) (name :: Symbol) s = BitField s deriving (Storable) + +-- | Get the bit offset of a field from its name +type family Offset (name :: Symbol) fs :: Nat where + Offset name (BitField n name s ': xs) = AddOffset xs + Offset name (BitField n name2 s ': xs) = Offset name xs + +type family AddOffset fs :: Nat where + AddOffset '[] = 0 + AddOffset (BitField n name s ': xs) = n + AddOffset xs + +-- | Get the type of a field from its name +type family Output (name :: Symbol) fs :: * where + Output name (BitField n name s ': xs) = s + Output name (BitField n name2 s ': xs) = Output name xs + +-- | Get the size of a field from it name +type family Size (name :: Symbol) fs :: Nat where + Size name (BitField n name s ': xs) = n + Size name (BitField n name2 s ': xs) = Size name xs + +-- | Get the whole size of a BitFields +type family WholeSize fs :: Nat where + WholeSize '[] = 0 + WholeSize (BitField n name s ': xs) = n + WholeSize xs + +type family BitFieldTypes xs where + BitFieldTypes '[] = '[] + BitFieldTypes (BitField n name s ': xs) = s ': BitFieldTypes xs + +class Field f where + fromField :: Integral b => f -> b + toField :: Integral b => b -> f + +instance Field Bool where + fromField True = 1 + fromField False = 0 + toField 0 = False + toField _ = True + +instance Field Word where + fromField = fromIntegral + toField = fromIntegral + +instance Field Word8 where + fromField = fromIntegral + toField = fromIntegral + +instance Field Word16 where + fromField = fromIntegral + toField = fromIntegral + +instance Field Word32 where + fromField = fromIntegral + toField = fromIntegral + +instance Field Word64 where + fromField = fromIntegral + toField = fromIntegral + +instance Field Int where + fromField = fromIntegral + toField = fromIntegral + +instance Field Int8 where + fromField = fromIntegral + toField = fromIntegral + +instance Field Int16 where + fromField = fromIntegral + toField = fromIntegral + +instance Field Int32 where + fromField = fromIntegral + toField = fromIntegral + +instance Field Int64 where + fromField = fromIntegral + toField = fromIntegral + +instance (FiniteBits b, Integral b, BitOffset a) => Field (BitSet b a) where + fromField = fromIntegral . BitSet.toBits + toField = BitSet.fromBits . fromIntegral + +instance (Integral b, CEnum a) => Field (EnumField b a) where + fromField = fromCEnum . fromEnumField + toField = toEnumField . toCEnum + +-- | Get the value of a field +extractField :: forall (name :: Symbol) fields b . + ( KnownNat (Offset name fields) + , KnownNat (Size name fields) + , WholeSize fields ~ BitSize b + , Bits b, Integral b + , Field (Output name fields) + ) => BitFields b fields -> Output name fields +{-# INLINABLE extractField #-} +extractField = extractField' @name + +-- | Get the value of a field (without checking sizes) +extractField' :: forall (name :: Symbol) fields b . + ( KnownNat (Offset name fields) + , KnownNat (Size name fields) + , Bits b, Integral b + , Field (Output name fields) + ) => BitFields b fields -> Output name fields +{-# INLINABLE extractField' #-} +extractField' (BitFields w) = toField ((w `shiftR` off) .&. ((1 `shiftL` sz) - 1)) + where + off = natValue @(Offset name fields) + sz = natValue @(Size name fields) + + +-- | Set the value of a field +updateField :: forall name fields b . + ( KnownNat (Offset name fields) + , KnownNat (Size name fields) + , WholeSize fields ~ BitSize b + , Bits b, Integral b + , Field (Output name fields) + ) => Output name fields -> BitFields b fields -> BitFields b fields +{-# INLINABLE updateField #-} +updateField = updateField' @name + +-- | Set the value of a field (without checking sizes) +updateField' :: forall name fields b . + ( KnownNat (Offset name fields) + , KnownNat (Size name fields) + , Bits b, Integral b + , Field (Output name fields) + ) => Output name fields -> BitFields b fields -> BitFields b fields +{-# INLINABLE updateField' #-} +updateField' value (BitFields w) = BitFields $ ((fromField value `shiftL` off) .&. mask') .|. (w .&. complement mask') + where + off = natValue @(Offset name fields) + sz = natValue @(Size name fields) + mask' = ((1 `shiftL` sz) - 1) `shiftL` off + + +-- | Modify the value of a field +withField :: forall name fields b f . + ( KnownNat (Offset name fields) + , KnownNat (Size name fields) + , WholeSize fields ~ BitSize b + , Bits b, Integral b + , f ~ Output name fields + , Field f + ) => (f -> f) -> BitFields b fields -> BitFields b fields +{-# INLINABLE withField #-} +withField = withField' @name + +-- | Modify the value of a field (without checking sizes) +withField' :: forall (name :: Symbol) fields b f . + ( KnownNat (Offset name fields) + , KnownNat (Size name fields) + , Bits b, Integral b + , f ~ Output name fields + , Field f + ) => (f -> f) -> BitFields b fields -> BitFields b fields +{-# INLINABLE withField' #-} +withField' f bs = updateField' @name (f v) bs + where + v = extractField' @name bs + + +------------------------------------------------------------------------------------- +-- We use HFoldr' to extract each component and create a HList from it. Then we +-- convert it into a Tuple +------------------------------------------------------------------------------------- +data Extract = Extract +data Name = Name + +instance forall name bs b l l2 i (n :: Nat) s r w . + ( bs ~ BitFields w l -- the bitfields + , b ~ BitField n name s -- the current field + , i ~ (bs, HList l2) -- input type + , r ~ (bs, HList (Output name l ': l2)) -- result type + , BitSize w ~ WholeSize l + , Integral w, Bits w + , KnownNat (Offset name l) + , KnownNat (Size name l) + , Field (Output name l) + ) => Apply Extract (b, i) r where + apply _ (_, (bs,xs)) = + (bs, HCons (extractField @name bs) xs) + +instance forall name bs b l l2 i (n :: Nat) s r w . + ( bs ~ BitFields w l -- the bitfields + , b ~ BitField n name s -- the current field + , i ~ HList l2 -- input type + , r ~ HList (String ': l2) -- result type + , KnownSymbol name + ) => Apply Name (b, i) r where + apply _ (_, xs) = HCons (symbolValue @name) xs + +fieldValues :: forall l l2 w bs . + ( bs ~ BitFields w l + , HFoldr' Extract (bs, HList '[]) l (bs, HList l2) + ) => bs -> HList l2 +fieldValues bs = snd res + where + res :: (bs, HList l2) + res = hFoldr' Extract ((bs, HNil) :: (bs, HList '[])) (undefined :: HList l) + +fieldNames :: forall l l2 w bs . + ( bs ~ BitFields w l + , HFoldr' Name (HList '[]) l (HList l2) + ) => bs -> HList l2 +fieldNames _ = hFoldr' Name (HNil :: HList '[]) (undefined :: HList l) + +-- | Get values in a tuple +matchFields :: forall l l2 w bs t . + ( bs ~ BitFields w l + , HFoldr' Extract (bs, HList '[]) l (bs, HList l2) + , HTuple l2 + , t ~ Tuple l2 + ) => bs -> t +matchFields = hToTuple @l2 . fieldValues + + +-- | Get field names and values in a tuple +matchNamedFields ::forall lt lv ln lnv w bs t . + ( bs ~ BitFields w lt + , HFoldr' Extract (bs, HList '[]) lt (bs, HList lv) + , HFoldr' Name (HList '[]) lt (HList ln) + , HZipList ln lv lnv + , HTuple lnv + , t ~ Tuple lnv + ) => bs -> t +matchNamedFields = hToTuple @lnv . matchNamedFields' + +-- | Get field names and values in a tuple +matchNamedFields' ::forall lt lv ln lnv w bs . + ( bs ~ BitFields w lt + , HFoldr' Extract (bs, HList '[]) lt (bs, HList lv) + , HFoldr' Name (HList '[]) lt (HList ln) + , HZipList ln lv lnv + ) => bs -> HList lnv +matchNamedFields' bs = hZipList names values + where + names = fieldNames bs + values = fieldValues bs + +-- | Get field names and values in a tuple +instance forall lt ln lnv w bs. + ( bs ~ BitFields w lt + , ln ~ Replicate (Length lt) String + , HFoldr' Extract (bs, HList '[]) lt (bs, HList (BitFieldTypes lt)) + , HFoldr' Name (HList '[]) lt (HList ln) + , HZipList ln (BitFieldTypes lt) lnv + , Show (HList lnv) + ) => Show (BitFields w lt) where + show bs = show (matchNamedFields' bs :: HList lnv) + + +instance forall lt lt2 w bs. + ( bs ~ BitFields w lt + , HFoldr' Extract (bs, HList '[]) lt (bs, HList lt2) + , Eq (HList lt2) + , lt2 ~ BitFieldTypes lt + ) => Eq (BitFields w lt) where + (==) x y = x' == y' + where + x' :: HList lt2 + x' = fieldValues x + y' :: HList lt2 + y' = fieldValues y diff --git a/src/lib/Haskus/Binary/BitSet.hs b/src/lib/Haskus/Binary/BitSet.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/BitSet.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | A bit set based on Enum to name the bits. Use bitwise operations and +-- minimal storage in a safer way. +-- +-- Similar to Data.Bitset.Generic from bitset package, but +-- +-- * We don't have the Num constraint +-- * We dont use the deprecated bitSize function +-- * We use countTrailingZeros instead of iterating on the +-- number of bits +-- * We add a typeclass BitOffset +-- +-- Example: +-- +-- @ +-- {-# LANGUAGE DeriveAnyClass #-} +-- data Flag +-- = FlagXXX +-- | FlagYYY +-- | FlagWWW +-- deriving (Show,Eq,Enum,BitOffset) +-- +-- -- Adapt the backing type, here we choose Word16 +-- type Flags = 'BitSet' Word16 Flag +-- @ +-- +-- Then you can convert (for free) a Word16 into Flags with 'fromBits' and +-- convert back with 'toBits'. +-- +-- You can check if a flag is set or not with 'member' and 'notMember' and get +-- a list of set flags with 'toList'. You can 'insert' or 'delete' flags. You +-- can also perform set operations such as 'union' and 'intersection'. +-- +module Haskus.Binary.BitSet + ( BitSet + , BitOffset (..) + , null + , empty + , singleton + , insert + , delete + , toBits + , fromBits + , member + , elem + , notMember + , elems + , intersection + , union + , unions + , fromListToBits + , toListFromBits + , enumerateSetBits + , fromList + , toList + ) +where + +import Prelude hiding (null,elem) + +import qualified GHC.Exts as Ext + +import Data.Foldable (foldl') + +import Haskus.Binary.Bits +import Haskus.Binary.Storable + +-- | A bit set: use bitwise operations (fast!) and minimal storage (sizeOf +-- basetype) +-- +-- * b is the base type (Bits b) +-- * a is the element type (Enum a) +-- +-- The elements in the Enum a are flags corresponding to each bit of b starting +-- from the least-significant bit. +newtype BitSet b a = BitSet b deriving (Eq,Ord,Storable) + +instance + ( Show a + , BitOffset a + , FiniteBits b + , IndexableBits b + , Eq b + ) => Show (BitSet b a) + where + show b = "fromList " ++ show (toList b) + +-- | Indicate if the set is empty +null :: + ( FiniteBits b + , Eq b + ) => BitSet b a -> Bool +{-# INLINABLE null #-} +null (BitSet b) = b == zeroBits + + +-- | Empty bitset +empty :: (FiniteBits b) => BitSet b a +{-# INLINABLE empty #-} +empty = BitSet zeroBits + + +-- | Create a BitSet from a single element +singleton :: (IndexableBits b, BitOffset a) => a -> BitSet b a +{-# INLINABLE singleton #-} +singleton e = BitSet $ bit (toBitOffset e) + + +-- | Insert an element in the set +insert :: (IndexableBits b, BitOffset a) => BitSet b a -> a -> BitSet b a +{-# INLINABLE insert #-} +insert (BitSet b) e = BitSet $ setBit b (toBitOffset e) + + +-- | Remove an element from the set +delete :: (IndexableBits b, BitOffset a) => BitSet b a -> a -> BitSet b a +{-# INLINABLE delete #-} +delete (BitSet b) e = BitSet $ clearBit b (toBitOffset e) + + +-- | Unwrap the bitset +toBits :: BitSet b a -> b +toBits (BitSet b) = b + +-- | Wrap a bitset +fromBits :: (BitOffset a, FiniteBits b) => b -> BitSet b a +fromBits = BitSet + +-- | Test if an element is in the set +member :: + ( BitOffset a + , FiniteBits b + , IndexableBits b + ) => BitSet b a -> a -> Bool +{-# INLINABLE member #-} +member (BitSet b) e = testBit b (toBitOffset e) + + +-- | Test if an element is in the set +elem :: + ( BitOffset a + , FiniteBits b + , IndexableBits b + ) => a -> BitSet b a -> Bool +{-# INLINABLE elem #-} +elem e (BitSet b) = testBit b (toBitOffset e) + + +-- | Test if an element is not in the set +notMember :: + ( BitOffset a + , FiniteBits b + , IndexableBits b + ) => BitSet b a -> a -> Bool +{-# INLINABLE notMember #-} +notMember b e = not (member b e) + + +-- | Retrieve elements in the set +elems :: + ( BitOffset a + , FiniteBits b + , IndexableBits b + , Eq b + ) => BitSet b a -> [a] +elems (BitSet b) = go b + where + go !c + | c == zeroBits = [] + | otherwise = let e = countTrailingZeros c in fromBitOffset e : go (clearBit c e) + +-- | Intersection of two sets +intersection :: + ( FiniteBits b + , Bitwise b + ) => BitSet b a -> BitSet b a -> BitSet b a +{-# INLINABLE intersection #-} +intersection (BitSet b1) (BitSet b2) = BitSet (b1 .&. b2) + + +-- | Intersection of two sets +union :: + ( FiniteBits b + , Bitwise b + ) => BitSet b a -> BitSet b a -> BitSet b a +{-# INLINABLE union #-} +union (BitSet b1) (BitSet b2) = BitSet (b1 .|. b2) + + +-- | Intersection of several sets +unions :: + ( FiniteBits b + , Bitwise b + ) => [BitSet b a] -> BitSet b a +{-# INLINABLE unions #-} +unions = foldl' union empty + + +-- | Bit set indexed with a +class BitOffset a where + -- | Return the bit offset of an element + toBitOffset :: a -> Word + default toBitOffset :: Enum a => a -> Word + toBitOffset = fromIntegral . fromEnum + + -- | Return the value associated with a bit offset + fromBitOffset :: Word -> a + default fromBitOffset :: Enum a => Word -> a + fromBitOffset = toEnum . fromIntegral + +-- | It can be useful to get the indexes of the set bits +instance BitOffset Int where + toBitOffset = fromIntegral + fromBitOffset = fromIntegral + +-- | It can be useful to get the indexes of the set bits +instance BitOffset Word where + toBitOffset = id + fromBitOffset = id + + + +-- | Convert a list of enum elements into a bitset Warning: b +-- must have enough bits to store the given elements! (we don't +-- perform any check, for performance reason) +fromListToBits :: + ( BitOffset a + , FiniteBits b + , IndexableBits b + , Foldable m + ) => m a -> b +fromListToBits = toBits . fromList + +-- | Convert a bitset into a list of Enum elements +toListFromBits :: + ( BitOffset a + , FiniteBits b + , IndexableBits b + , Eq b + ) => b -> [a] +toListFromBits = toList . BitSet + +-- | Convert a bitset into a list of Enum elements by testing the Enum values +-- successively. +-- +-- The difference with `toListFromBits` is that extra values in the BitSet will +-- be ignored. +enumerateSetBits :: + ( BitOffset a + , FiniteBits b + , IndexableBits b + , Eq b + , Bounded a + , Enum a + ) => b -> [a] +enumerateSetBits b = go [] [minBound..] + where + go rs [] = rs + go rs (x:xs) + | member (BitSet b) x = go (x:rs) xs + | otherwise = go rs xs + +-- | Convert a set into a list +toList :: + ( BitOffset a + , FiniteBits b + , IndexableBits b + , Eq b + ) => BitSet b a -> [a] +toList = elems + +-- | Convert a Foldable into a set +fromList :: + ( BitOffset a + , IndexableBits b + , FiniteBits b + , Foldable m + ) => m a -> BitSet b a +fromList = foldl' insert (BitSet zeroBits) + + +instance + ( FiniteBits b + , IndexableBits b + , BitOffset a + , Eq b + ) => Ext.IsList (BitSet b a) + where + type Item (BitSet b a) = a + fromList = fromList + toList = toList diff --git a/src/lib/Haskus/Binary/Bits.hs b/src/lib/Haskus/Binary/Bits.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} + +-- | Operations on bits +module Haskus.Binary.Bits + ( Bits + , FiniteBits (..) + , IndexableBits (..) + , ShiftableBits (..) + , SignedShiftableBits (..) + , RotatableBits (..) + , Bitwise (..) + -- * Bit reversal + , ReversableBits (..) + , reverseBitsGeneric + , reverseLeastBits + -- * Mask + , MaskBits (..) + , Maskable + , maskDyn + , mask + -- * String conversion + , bitsToString + , bitsToStringN + , bitsFromString + -- * Shift + , getBitRange + -- * Various + , bitOffset + , byteOffset + , isPowerOfTwo + , isPowerOfFour + , getPowerOfTwo + , getPowerOfFour + ) +where + +import Haskus.Utils.List (foldl') +import Haskus.Utils.Types +import Haskus.Utils.Maybe +import Haskus.Binary.Bits.Finite +import Haskus.Binary.Bits.Index +import Haskus.Binary.Bits.Reverse +import Haskus.Binary.Bits.Rotate +import Haskus.Binary.Bits.Shift +import Haskus.Binary.Bits.Bitwise +import Haskus.Binary.Bits.Order +import Haskus.Binary.Bits.Mask +import Haskus.Binary.Bits.Helper + +type Bits a = + ( Eq a + , FiniteBits a + , IndexableBits a + , ShiftableBits a + , Bitwise a + , RotatableBits a + , KnownNat (BitSize a) + , MaskBits a + ) + +-- | Check if a number is a power of two (2^n) +-- +-- >>> isPowerOfTwo (10 :: Word) +-- False +-- >>> isPowerOfTwo (16 :: Word) +-- True +isPowerOfTwo :: IndexableBits a => a -> Bool +isPowerOfTwo x = popCount x == 1 + +-- | Check if a number is a power of two (2^n) and return `n` +-- +-- >>> getPowerOfTwo (10 :: Word) +-- Nothing +-- >>> getPowerOfTwo (16 :: Word) +-- Just 4 +getPowerOfTwo :: (IndexableBits a, FiniteBits a) => a -> Maybe Word +getPowerOfTwo x + | isPowerOfTwo x = Just (countTrailingZeros x) + | otherwise = Nothing + +-- | Check if a number is a power of four (4^n) +-- +-- >>> isPowerOfFour (10 :: Word) +-- False +-- >>> isPowerOfFour (16 :: Word) +-- True +isPowerOfFour :: (IndexableBits a, FiniteBits a) => a -> Bool +isPowerOfFour x = isJust (getPowerOfFour x) + +-- | Check if a number is a power of four (4^n) and return `n` +-- +-- >>> getPowerOfFour (10 :: Word) +-- Nothing +-- >>> getPowerOfFour (16 :: Word) +-- Just 2 +getPowerOfFour :: (IndexableBits a, FiniteBits a) => a -> Maybe Word +getPowerOfFour x + | popCount x == 1 -- test that a single bit is set to 1 + , let c = countTrailingZeros x -- and that it is followed by an even + , testBit c 0 == False -- number of zeros + = Just (c `shiftR` 1) + | otherwise = Nothing + +-- | Reverse the @n@ least important bits of the given value. The higher bits +-- are set to 0. +reverseLeastBits :: + ( ShiftableBits a + , FiniteBits a + , ReversableBits a + , KnownNat (BitSize a) + ) => Word -> a -> a +reverseLeastBits n value = reverseBits value `uncheckedShiftR` ((bitSize value) - n) + +-- | Convert bits into a string composed of '0' and '1' chars +bitsToString :: forall a. + ( FiniteBits a + , IndexableBits a + , KnownNat (BitSize a) + ) => a -> String +bitsToString = bitsToStringN (natValue @(BitSize a)) + +-- | Convert a specified amount of bits into a string composed of '0' and '1' chars +bitsToStringN :: forall a. + ( IndexableBits a + ) => Word -> a -> String +bitsToStringN n x = fmap b [n-1, n-2 .. 0] + where + b v = if testBit x v then '1' else '0' + +-- | Convert a string of '0' and '1' chars into a word +bitsFromString :: Bits a => String -> a +bitsFromString xs = foldl' b zeroBits (reverse xs `zip` [0..]) + where + b x ('0',i) = clearBit x i + b x ('1',i) = setBit x i + b _ (c,_) = error $ "Invalid character in the string: " ++ [c] + + +-- | `getBitRange bo offset n c` takes n bits at offset in c and put them in the +-- least-significant bits of the result +getBitRange :: forall b. + ( ShiftableBits b + , ReversableBits b + , FiniteBits b + , KnownNat (BitSize b) + , Bitwise b + , MaskBits b + ) => BitOrder -> Word -> Word -> b -> b +{-# INLINABLE getBitRange #-} +getBitRange bo o n c = case bo of + BB -> maskDyn n $ c `uncheckedShiftR` d + BL -> maskDyn n $ reverseBits c `uncheckedShiftR` o + LB -> maskDyn n $ reverseBits c `uncheckedShiftR` d + LL -> maskDyn n $ c `uncheckedShiftR` o + where + d = bitSize c - n - o + diff --git a/src/lib/Haskus/Binary/Bits/Bitwise.hs b/src/lib/Haskus/Binary/Bits/Bitwise.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Bitwise.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} + +-- | Bitwise bit operations +module Haskus.Binary.Bits.Bitwise + ( Bitwise (..) + ) +where + +import Haskus.Number.Word +import Haskus.Number.Int +import GHC.Exts +import GHC.Num + +-- | Bitwise bit operations +class Bitwise a where + -- | Bitwise "and" + (.&.) :: a -> a -> a + + -- | Bitwise "or" + (.|.) :: a -> a -> a + + -- | Bitwise "xor" + xor :: a -> a -> a + + +instance Bitwise Word where + (W# x#) .&. (W# y#) = W# (x# `and#` y#) + (W# x#) .|. (W# y#) = W# (x# `or#` y#) + (W# x#) `xor` (W# y#) = W# (x# `xor#` y#) + +instance Bitwise Word8 where + (W8# x#) .&. (W8# y#) = W8# (x# `and#` y#) + (W8# x#) .|. (W8# y#) = W8# (x# `or#` y#) + (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#) + +instance Bitwise Word16 where + (W16# x#) .&. (W16# y#) = W16# (x# `and#` y#) + (W16# x#) .|. (W16# y#) = W16# (x# `or#` y#) + (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#) + +instance Bitwise Word32 where + (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#) + (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#) + (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#) + +instance Bitwise Word64 where + (W64# x#) .&. (W64# y#) = W64# (x# `and#` y#) + (W64# x#) .|. (W64# y#) = W64# (x# `or#` y#) + (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#) + +instance Bitwise Int where + (I# x#) .&. (I# y#) = I# (x# `andI#` y#) + (I# x#) .|. (I# y#) = I# (x# `orI#` y#) + (I# x#) `xor` (I# y#) = I# (x# `xorI#` y#) + +instance Bitwise Int8 where + (I8# x#) .&. (I8# y#) = I8# (word2Int# (int2Word# x# `and#` int2Word# y#)) + (I8# x#) .|. (I8# y#) = I8# (word2Int# (int2Word# x# `or#` int2Word# y#)) + (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#)) + +instance Bitwise Int16 where + (I16# x#) .&. (I16# y#) = I16# (word2Int# (int2Word# x# `and#` int2Word# y#)) + (I16# x#) .|. (I16# y#) = I16# (word2Int# (int2Word# x# `or#` int2Word# y#)) + (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#)) + +instance Bitwise Int32 where + (I32# x#) .&. (I32# y#) = I32# (word2Int# (int2Word# x# `and#` int2Word# y#)) + (I32# x#) .|. (I32# y#) = I32# (word2Int# (int2Word# x# `or#` int2Word# y#)) + (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#)) + +instance Bitwise Int64 where + (I64# x#) .&. (I64# y#) = I64# (word2Int# (int2Word# x# `and#` int2Word# y#)) + (I64# x#) .|. (I64# y#) = I64# (word2Int# (int2Word# x# `or#` int2Word# y#)) + (I64# x#) `xor` (I64# y#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#)) + +instance Bitwise Integer where + (.&.) = andInteger + (.|.) = orInteger + xor = xorInteger + +instance Bitwise Natural where + (.&.) = andNatural + (.|.) = orNatural + xor = xorNatural diff --git a/src/lib/Haskus/Binary/Bits/Finite.hs b/src/lib/Haskus/Binary/Bits/Finite.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Finite.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Types with finite bit count +module Haskus.Binary.Bits.Finite + ( FiniteBits (..) + ) +where + +import Haskus.Utils.Types +import Haskus.Number.Word +import Haskus.Number.Int +import GHC.Exts + +#include "MachDeps.h" + +-- | Type representable by a fixed amount of bits +class FiniteBits a where + + -- | Number of bits + type BitSize a :: Nat + + -- | Number of bits (the value is ignored) + bitSize :: (Integral i, KnownNat (BitSize a)) => a -> i + bitSize _ = natValue @(BitSize a) + + -- | All bits set to 0 + zeroBits :: a + + -- | All bits set to 1 + oneBits :: a + oneBits = complement zeroBits + + -- | Count number of zero bits preceding the most significant set bit + countLeadingZeros :: a -> Word + + -- | Count number of zero bits following the least significant set bit + countTrailingZeros :: a -> Word + + -- | Complement + complement :: a -> a + + +instance FiniteBits Word where + type BitSize Word = WORD_SIZE_IN_BITS + zeroBits = 0 + oneBits = maxBound + countLeadingZeros (W# x#) = W# (clz# x#) + countTrailingZeros (W# x#) = W# (ctz# x#) + complement (W# x#) = W# (x# `xor#` mb#) + where !(W# mb#) = maxBound + +instance FiniteBits Word8 where + type BitSize Word8 = 8 + zeroBits = 0 + oneBits = maxBound + countLeadingZeros (W8# x#) = W# (clz8# x#) + countTrailingZeros (W8# x#) = W# (ctz8# x#) + complement (W8# x#) = W8# (x# `xor#` mb#) + where !(W8# mb#) = maxBound + +instance FiniteBits Word16 where + type BitSize Word16 = 16 + zeroBits = 0 + oneBits = maxBound + countLeadingZeros (W16# x#) = W# (clz16# x#) + countTrailingZeros (W16# x#) = W# (ctz16# x#) + complement (W16# x#) = W16# (x# `xor#` mb#) + where !(W16# mb#) = maxBound + +instance FiniteBits Word32 where + type BitSize Word32 = 32 + zeroBits = 0 + oneBits = maxBound + countLeadingZeros (W32# x#) = W# (clz32# x#) + countTrailingZeros (W32# x#) = W# (ctz32# x#) + complement (W32# x#) = W32# (x# `xor#` mb#) + where !(W32# mb#) = maxBound + +instance FiniteBits Word64 where + type BitSize Word64 = 64 + zeroBits = 0 + oneBits = maxBound + countLeadingZeros (W64# x#) = W# (clz64# x#) + countTrailingZeros (W64# x#) = W# (ctz64# x#) + complement (W64# x#) = W64# (x# `xor#` mb#) + where !(W64# mb#) = maxBound + + +instance FiniteBits Int where + type BitSize Int = WORD_SIZE_IN_BITS + zeroBits = 0 + oneBits = (-1) + countLeadingZeros (I# x#) = W# (clz# (int2Word# x#)) + countTrailingZeros (I# x#) = W# (ctz# (int2Word# x#)) + complement (I# x#) = I# (notI# x#) + +instance FiniteBits Int8 where + type BitSize Int8 = 8 + zeroBits = 0 + oneBits = (-1) + countLeadingZeros (I8# x#) = W# (clz8# (int2Word# x#)) + countTrailingZeros (I8# x#) = W# (ctz8# (int2Word# x#)) + complement (I8# x#) = I8# (word2Int# (not# (int2Word# x#))) + +instance FiniteBits Int16 where + type BitSize Int16 = 16 + zeroBits = 0 + oneBits = (-1) + countLeadingZeros (I16# x#) = W# (clz16# (int2Word# x#)) + countTrailingZeros (I16# x#) = W# (ctz16# (int2Word# x#)) + complement (I16# x#) = I16# (word2Int# (not# (int2Word# x#))) + +instance FiniteBits Int32 where + type BitSize Int32 = 32 + zeroBits = 0 + oneBits = (-1) + countLeadingZeros (I32# x#) = W# (clz32# (int2Word# x#)) + countTrailingZeros (I32# x#) = W# (ctz32# (int2Word# x#)) + complement (I32# x#) = I32# (word2Int# (not# (int2Word# x#))) + +instance FiniteBits Int64 where + type BitSize Int64 = 64 + zeroBits = 0 + oneBits = (-1) + countLeadingZeros (I64# x#) = W# (clz64# (int2Word# x#)) + countTrailingZeros (I64# x#) = W# (ctz64# (int2Word# x#)) + complement (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) diff --git a/src/lib/Haskus/Binary/Bits/Get.hs b/src/lib/Haskus/Binary/Bits/Get.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Get.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Bit getter +module Haskus.Binary.Bits.Get + ( BitGetState(..) + , newBitGetState + , isEmpty + , skipBits + , skipBitsToAlignOnWord8 + , getBits + , getBitsChecked + , getBitsBuffer + -- * Monadic + , BitGet + , BitGetT + , runBitGet + , runBitGetT + , runBitGetPartialT + , runBitGetPartial + , resumeBitGetPartialT + , resumeBitGetPartial + , isEmptyM + , skipBitsM + , skipBitsToAlignOnWord8M + , getBitsM + , getBitsCheckedM + , getBitBoolM + , getBitsBSM + , changeBitGetOrder + , withBitGetOrder + ) +where + +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.State +import Control.Monad.Identity +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Ptr + +import Haskus.Binary.Buffer +import Haskus.Binary.Bits.Order +import Haskus.Binary.Bits +import Haskus.Binary.Storable (poke) + +-- | BitGet state +data BitGetState = BitGetState + { bitGetStateInput :: {-# UNPACK #-} !Buffer -- ^ Input + , bitGetStateBitOffset :: {-# UNPACK #-} !Word -- ^ Bit offset (0-7) + , bitGetStateBitOrder :: !BitOrder -- ^ Bit order + } deriving (Show) + +-- | Create a new BitGetState +newBitGetState :: BitOrder -> Buffer -> BitGetState +newBitGetState bo bs = BitGetState bs 0 bo + +-- | Indicate that the source is empty +isEmpty :: BitGetState -> Bool +isEmpty (BitGetState bs o _) = o == 0 && isBufferEmpty bs + +-- | Skip the given number of bits from the input +skipBits :: Word -> BitGetState -> BitGetState +skipBits o (BitGetState bs n bo) = BitGetState (bufferUnsafeDrop d bs) n' bo + where + !o' = n+o + !d = fromIntegral $ byteOffset o' + !n' = bitOffset o' + +-- | Skip the required number of bits to be aligned on 8-bits +skipBitsToAlignOnWord8 :: BitGetState -> BitGetState +skipBitsToAlignOnWord8 s = case bitGetStateBitOffset s of + 0 -> s + n -> skipBits (8-n) s + +-- | Read the given number of bits and put the result in a word +getBits :: (Integral a, Bits a) => Word -> BitGetState -> a +getBits nbits (BitGetState bs off bo) = rec zeroBits 0 bs off nbits + where + -- w = current result + -- n = number of valid bits in w + -- i = input bytestring + -- o = bit offset in input bytestring + -- r = number of remaining bits to read + rec w _ _ _ 0 = w + rec w n i o r = rec nw (n+nb) (bufferTail i) o' (r-nb) + where + -- current Word8 + c = bufferHead i + -- number of bits to take from the current Word8 + nb = min (8-o) r + -- bits taken from the current Word8 and put in correct order in least-significant bits + tc = fromIntegral $ getBitRange bo o nb c + -- mix new bits with the current result + nw = case bo of + BB -> (w `shiftL` fromIntegral nb) .|. tc + LB -> (w `shiftL` fromIntegral nb) .|. tc + BL -> (tc `shiftL` fromIntegral n) .|. w + LL -> (tc `shiftL` fromIntegral n) .|. w + -- new offset ((o + nb) `mod` 8) + o' = bitOffset (o + nb) + +-- | Perform some checks before calling getBits +-- +-- Check that the number of bits to read is not greater than the first parameter +getBitsChecked :: (Integral a, Bits a, ReversableBits a) => Word -> Word -> BitGetState -> a +{-# INLINABLE getBitsChecked #-} +getBitsChecked m n s + | n > m = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")" + | otherwise = getBits n s + +-- | Read the given number of Word8 and return them in a Buffer +-- +-- Examples: +-- @ BB: xxxABCDE FGHIJKLM NOPxxxxx -> ABCDEFGH IJKLMNOP @ +-- @ LL: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP @ +-- @ BL: xxxPONML KJIHGFED CBAxxxxx -> ABCDEFGH IJKLMNOP @ +-- @ LB: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP @ +getBitsBuffer :: Word -> BitGetState -> Buffer +getBitsBuffer n (BitGetState bs o bo) = + if n == 0 + then emptyBuffer + else + let + bs' = bufferUnsafeTake (n+1) bs + bs'' = bufferUnsafeTake n bs + rev = bufferMap reverseBits + in case (o,bo) of + (0,BB) -> bs'' + (0,LL) -> bufferReverse bs'' + (0,LB) -> rev bs'' + (0,BL) -> rev $ bufferReverse bs'' + (_,LL) -> getBitsBuffer n (BitGetState (bufferReverse bs') (8-o) BB) + (_,BL) -> rev . bufferReverse $ getBitsBuffer n (BitGetState bs' o BB) + (_,LB) -> rev . bufferReverse $ getBitsBuffer n (BitGetState bs' o LL) + (_,BB) -> unsafePerformIO $ do + let len = n+1 + ptr <- mallocBytes (fromIntegral len) + let f r i = do + let + w = bufferUnsafeIndex bs (len-i) + w' = (w `shiftL` fromIntegral o) .|. r + r' = w `shiftR` (8-fromIntegral o) + poke (castPtr ptr `plusPtr` fromIntegral (len-i)) w' + return r' + foldM_ f 0 [1..len] + bufferUnsafeInit <$> bufferPackPtr len ptr + + + +-- | BitGet monad transformer +type BitGetT m a = StateT BitGetState m a + +-- | BitGet monad +type BitGet a = BitGetT Identity a + +-- | Evaluate a BitGet monad +runBitGetT :: Monad m => BitOrder -> BitGetT m a -> Buffer -> m a +runBitGetT bo m bs = evalStateT m (newBitGetState bo bs) + +-- | Evaluate a BitGet monad +runBitGet :: BitOrder -> BitGet a -> Buffer -> a +runBitGet bo m bs = runIdentity (runBitGetT bo m bs) + +-- | Evaluate a BitGet monad, return the remaining state +runBitGetPartialT :: BitOrder -> BitGetT m a -> Buffer -> m (a, BitGetState) +runBitGetPartialT bo m bs = runStateT m (newBitGetState bo bs) + +-- | Evaluate a BitGet monad, return the remaining state +runBitGetPartial :: BitOrder -> BitGet a -> Buffer -> (a, BitGetState) +runBitGetPartial bo m bs = runIdentity (runBitGetPartialT bo m bs) + +-- | Resume a BitGet evaluation +resumeBitGetPartialT :: BitGetT m a -> BitGetState -> m (a, BitGetState) +resumeBitGetPartialT = runStateT + +-- | Resume a BitGet evaluation +resumeBitGetPartial :: BitGet a -> BitGetState -> (a,BitGetState) +resumeBitGetPartial m s = runIdentity (resumeBitGetPartialT m s) + +-- | Indicate if all bits have been read +isEmptyM :: Monad m => BitGetT m Bool +isEmptyM = gets isEmpty + +-- | Skip the given number of bits from the input (monadic version) +skipBitsM :: Monad m => Word -> BitGetT m () +skipBitsM = modify . skipBits + + +-- | Skip the required number of bits to be aligned on 8-bits (monadic version) +skipBitsToAlignOnWord8M :: Monad m => BitGetT m () +skipBitsToAlignOnWord8M = modify skipBitsToAlignOnWord8 + +-- | Read the given number of bits and put the result in a word +getBitsM :: (Integral a, Bits a, Monad m) => Word -> BitGetT m a +getBitsM n = do + v <- gets (getBits n) + skipBitsM n + return v + +-- | Perform some checks before calling getBitsM +getBitsCheckedM :: (Integral a, Bits a, ReversableBits a, Monad m) => Word -> Word -> BitGetT m a +getBitsCheckedM m n = do + v <- gets (getBitsChecked m n) + skipBitsM n + return v + +-- | Get a bit and convert it into a Bool +getBitBoolM :: (Monad m) => BitGetT m Bool +getBitBoolM = do + v <- getBitsM 1 + return ((v :: Word) == 1) + +-- | Get the given number of Word8 +getBitsBSM :: (Monad m) => Word -> BitGetT m Buffer +getBitsBSM n = do + bs <- gets (getBitsBuffer n) + skipBitsM (8*n) + return bs + +-- | Change the current bit ordering +-- +-- Be careful to change the outer bit ordering (B* to L* or the inverse) only +-- on bytes boundaries! Otherwise, you will read the same bits more than once. +changeBitGetOrder :: Monad m => BitOrder -> BitGetT m () +changeBitGetOrder bo = modify (\s -> s { bitGetStateBitOrder = bo }) + +-- | Change the bit ordering for the wrapped BitGet +-- +-- Be careful, this function uses changeBitGetOrder internally. +withBitGetOrder :: Monad m => BitOrder -> BitGetT m a -> BitGetT m a +withBitGetOrder bo m = do + bo' <- gets bitGetStateBitOrder + changeBitGetOrder bo + v <- m + changeBitGetOrder bo' + return v + diff --git a/src/lib/Haskus/Binary/Bits/Helper.hs b/src/lib/Haskus/Binary/Bits/Helper.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Helper.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} + +module Haskus.Binary.Bits.Helper + ( bitOffset + , byteOffset + ) +where + +import Haskus.Binary.Bits.Shift +import Haskus.Binary.Bits.Mask + +-- | Compute bit offset (equivalent to x `mod` 8 but faster) +bitOffset :: Word -> Word +{-# INLINABLE bitOffset #-} +bitOffset n = mask @3 n + +-- | Compute byte offset (equivalent to x `div` 8 but faster) +byteOffset :: Word -> Word +{-# INLINABLE byteOffset #-} +byteOffset n = n `uncheckedShiftR` 3 diff --git a/src/lib/Haskus/Binary/Bits/Index.hs b/src/lib/Haskus/Binary/Bits/Index.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Index.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +-- | Bit indexable types +module Haskus.Binary.Bits.Index + ( IndexableBits (..) + ) +where + +import Haskus.Binary.Bits.Shift +import Haskus.Binary.Bits.Bitwise +import Haskus.Binary.Bits.Finite +import Haskus.Number.Word +import Haskus.Number.Int + +import GHC.Exts +import qualified Data.Bits as BaseBits +import Numeric.Natural + +-- | Type whose bits are indexable +class IndexableBits a where + -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear. + bit :: Word -> a + default bit :: (Num a, ShiftableBits a) => Word -> a + bit i = 1 `shiftL` i + + -- | @x \`setBit\` i@ is the same as @x .|. bit i@ + setBit :: a -> Word -> a + default setBit :: (Bitwise a) => a -> Word -> a + setBit a i = a .|. bit i + + -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@ + clearBit :: a -> Word -> a + default clearBit :: (FiniteBits a,Bitwise a) => a -> Word -> a + clearBit a i = a .&. complement (bit i) + + -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@ + complementBit :: a -> Word -> a + default complementBit :: (Bitwise a) => a -> Word -> a + complementBit a i = a `xor` bit i + + -- | Return 'True' if the @n@th bit of the argument is 1 + testBit :: a -> Word -> Bool + default testBit :: (Bitwise a, Num a, Eq a) => a -> Word -> Bool + testBit a i = (a .&. bit i) /= 0 + + -- | Return the number of set bits + popCount :: a -> Word + default popCount :: (Bitwise a, Num a, Eq a) => a -> Word + popCount = go 0 + where + go !c 0 = c + go c w = go (c+1) (w .&. (w-1)) + + +instance IndexableBits Word where + popCount (W# x#) = W# (popCnt# x#) + +instance IndexableBits Word8 where + popCount (W8# x#) = W# (popCnt8# x#) + +instance IndexableBits Word16 where + popCount (W16# x#) = W# (popCnt16# x#) + +instance IndexableBits Word32 where + popCount (W32# x#) = W# (popCnt32# x#) + +instance IndexableBits Word64 where + popCount (W64# x#) = W# (popCnt64# x#) + +instance IndexableBits Int where + popCount (I# x#) = W# (popCnt# (int2Word# x#)) + +instance IndexableBits Int8 where + popCount (I8# x#) = W# (popCnt8# (int2Word# x#)) + +instance IndexableBits Int16 where + popCount (I16# x#) = W# (popCnt16# (int2Word# x#)) + +instance IndexableBits Int32 where + popCount (I32# x#) = W# (popCnt32# (int2Word# x#)) + +instance IndexableBits Int64 where + popCount (I64# x#) = W# (popCnt64# (int2Word# x#)) + +instance IndexableBits Integer where + -- we don't have access to Integer primitive (we would have to conditionally + -- import integer-gmp or integer-simple like `base` does) so we use Data.Bits + -- from `base` instead. + testBit x i = BaseBits.testBit x (fromIntegral i) + bit i = BaseBits.bit (fromIntegral i) + popCount x = fromIntegral (BaseBits.popCount x) + clearBit x i = BaseBits.clearBit x (fromIntegral i) + +instance IndexableBits Natural where + testBit x i = BaseBits.testBit x (fromIntegral i) + bit i = BaseBits.bit (fromIntegral i) + popCount x = fromIntegral (BaseBits.popCount x) + clearBit x i = BaseBits.clearBit x (fromIntegral i) diff --git a/src/lib/Haskus/Binary/Bits/Mask.hs b/src/lib/Haskus/Binary/Bits/Mask.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Mask.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} + +module Haskus.Binary.Bits.Mask + ( MaskBits (..) + , makeMaskFinite + , makeMask + , maskDyn + , Maskable + , mask + ) +where + +import Haskus.Binary.Bits.Finite +import Haskus.Binary.Bits.Shift +import Haskus.Binary.Bits.Bitwise +import Haskus.Number.Word +import Haskus.Number.Int +import Haskus.Utils.Types +import GHC.Natural + +-- | makeMaskFinite 3 = 00000111 +makeMaskFinite :: forall a. + ( ShiftableBits a + , FiniteBits a + , KnownNat (BitSize a) + , Bitwise a + ) => Word -> a +{-# INLINABLE makeMaskFinite #-} +makeMaskFinite n = complement zeroBits `shiftR` off + where + off = natValue' @(BitSize a) - n + +{-# SPECIALIZE makeMaskFinite :: Word -> Int #-} +{-# SPECIALIZE makeMaskFinite :: Word -> Int8 #-} +{-# SPECIALIZE makeMaskFinite :: Word -> Int16 #-} +{-# SPECIALIZE makeMaskFinite :: Word -> Int32 #-} +{-# SPECIALIZE makeMaskFinite :: Word -> Int64 #-} +{-# SPECIALIZE makeMaskFinite :: Word -> Word #-} +{-# SPECIALIZE makeMaskFinite :: Word -> Word8 #-} +{-# SPECIALIZE makeMaskFinite :: Word -> Word16 #-} +{-# SPECIALIZE makeMaskFinite :: Word -> Word32 #-} +{-# SPECIALIZE makeMaskFinite :: Word -> Word64 #-} + +class MaskBits a where + -- | Make a mask dynamically + makeMaskDyn :: Word -> a + +instance MaskBits Natural where + makeMaskDyn n = mkNatural (replicate (fromIntegral q) c ++ [makeMaskFinite r]) + where + c = complement zeroBits + (q,r) = n `quotRem` 32 + +instance MaskBits Word where makeMaskDyn = makeMaskFinite +instance MaskBits Word8 where makeMaskDyn = makeMaskFinite +instance MaskBits Word16 where makeMaskDyn = makeMaskFinite +instance MaskBits Word32 where makeMaskDyn = makeMaskFinite +instance MaskBits Word64 where makeMaskDyn = makeMaskFinite +instance MaskBits Int where makeMaskDyn = makeMaskFinite +instance MaskBits Int8 where makeMaskDyn = makeMaskFinite +instance MaskBits Int16 where makeMaskDyn = makeMaskFinite +instance MaskBits Int32 where makeMaskDyn = makeMaskFinite +instance MaskBits Int64 where makeMaskDyn = makeMaskFinite + +-- | Make a mask statically +makeMask :: forall n a. + ( KnownNat n + , MaskBits a + ) => a +{-# INLINABLE makeMask #-} +makeMask = makeMaskDyn (natValue' @n) + +-- | Keep only the n least-significant bits of the given value +maskDyn :: + ( MaskBits a + , Bitwise a + ) => Word -> a -> a +{-# INLINABLE maskDyn #-} +maskDyn n v = v .&. makeMaskDyn n + +-- | Keep only the n least-significant bits of the given value +mask :: forall n a. Maskable n a => a -> a +{-# INLINABLE mask #-} +mask v = v .&. makeMask @n + +type Maskable n a = + ( MaskBits a + , Bitwise a + , KnownNat n + ) diff --git a/src/lib/Haskus/Binary/Bits/Order.hs b/src/lib/Haskus/Binary/Bits/Order.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Order.hs @@ -0,0 +1,29 @@ +-- | Bit orderings +module Haskus.Binary.Bits.Order + ( BitOrder(..) + ) +where + +-- | Bit order +-- +-- The first letter indicates the outer bit ordering, i.e. how bytes are filled: +-- +-- * B?: from left to right (B is for BigEndian) +-- * L?: from right to left (L is for LittleEndian) +-- +-- The second letter indicates the inner bit ordering, i.e. how words are stored: +-- +-- * ?B: the most significant bit is stored first (in the outer bit order!) +-- * ?L: the least-significant bit is stored first (in the outer bit order!) +-- +-- E.g. two successive words of 5 bits: ABCDE, VWXYZ +-- @ BB: ABCDEVWX YZxxxxxx @ +-- @ BL: EDCBAZYX WVxxxxxx @ +-- @ LB: XWVEDCBA xxxxxxZY @ +-- @ LL: XYZABCDE xxxxxxVW @ +data BitOrder + = BB + | LB + | BL + | LL + deriving (Show,Eq) diff --git a/src/lib/Haskus/Binary/Bits/Put.hs b/src/lib/Haskus/Binary/Bits/Put.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Put.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Bit putter +module Haskus.Binary.Bits.Put + ( BitPutState(..) + , newBitPutState + , putBits + , putBitsBuffer + , getBitPutBuffer + , getBitPutBufferList + -- * Monadic + , BitPut + , BitPutT + , runBitPut + , runBitPutT + , putBitsM + , putBitBoolM + , putBitsBufferM + , changeBitPutOrder + , withBitPutOrder + ) +where + +import Control.Monad.State +import Control.Monad.Identity + +import Haskus.Binary.BufferBuilder as B +import Haskus.Binary.Buffer +import Haskus.Number.Word +import Haskus.Binary.BufferList (BufferList) +import Haskus.Binary.Bits.Order +import Haskus.Binary.Bits + + +-- | BitPut state +data BitPutState = BitPutState + { bitPutStateBuilder :: !BufferBuilder -- ^ Builder + , bitPutStateCurrent :: !Word8 -- ^ Current byte + , bitPutStateOffset :: !Word -- ^ Current offset + , bitPutStateBitOrder :: !BitOrder -- ^ Bit order + } + +-- | Create a new BitPut state +newBitPutState :: BitOrder -> BitPutState +newBitPutState = BitPutState mempty 0 0 + +-- | Put bits +putBits :: + ( Integral a + , Bits a + , ReversableBits a + ) => Word -> a -> BitPutState -> BitPutState +putBits n w s@(BitPutState builder b o bo) = s' + where + -- number of bits that will be stored in the current byte + cn = min (8-o) n + + -- new state + s' = case n of + 0 -> s + _ -> putBits (n-cn) w' (flush (BitPutState builder b' (o+cn) bo)) + + -- new current byte + b' = shl (selectBits w) .|. b + + -- Word containing the remaining (n-cn) bits to store in its LSB + w' = case bo of + BB -> w + BL -> w `shiftR` fromIntegral cn + LL -> w `shiftR` fromIntegral cn + LB -> w + + -- Select bits to store in the current byte. + -- Put them in the correct order and return them in the least-significant + -- bits of the returned value + selectBits :: (Bits a, ReversableBits a, Integral a) => a -> Word8 + selectBits x = fromIntegral $ case bo of + BB -> maskDyn cn $ x `shiftR` fromIntegral (n-cn) + LB -> reverseLeastBits cn $ maskDyn cn $ x `shiftR` fromIntegral (n-cn) + LL -> maskDyn cn x + BL -> reverseLeastBits cn $ maskDyn cn x + + -- shift left at the correct position + shl :: Word8 -> Word8 + shl x = case bo of + BB -> x `shiftL` (8 - fromIntegral o - fromIntegral cn) + BL -> x `shiftL` (8 - fromIntegral o - fromIntegral cn) + LL -> x `shiftL` fromIntegral o + LB -> x `shiftL` fromIntegral o + + -- flush the current byte if it is full + flush s2@(BitPutState b2 w2 o2 bo2) + | o2 == 8 = BitPutState (b2 `mappend` B.fromWord8 w2) 0 0 bo2 + | otherwise = s2 + + +-- | Put a Buffer +-- +-- Examples: 3 bits are already written in the current byte +-- @ BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx @ +-- @ LL: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC @ +-- @ BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx @ +-- @ LB: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON @ +putBitsBuffer :: Buffer -> BitPutState -> BitPutState +putBitsBuffer bs s + | isBufferEmpty bs = s + | otherwise = case s of + (BitPutState builder b 0 BB) -> BitPutState (builder `mappend` B.fromBuffer bs) b 0 BB + (BitPutState builder b 0 LL) -> BitPutState (builder `mappend` B.fromBuffer (bufferReverse bs)) b 0 LL + (BitPutState builder b 0 LB) -> BitPutState (builder `mappend` B.fromBuffer (rev bs)) b 0 LB + (BitPutState builder b 0 BL) -> BitPutState (builder `mappend` B.fromBuffer (rev (bufferReverse bs))) b 0 BL + (BitPutState _ _ _ BB) -> putBitsBuffer (bufferUnsafeTail bs) (putBits 8 (bufferUnsafeHead bs) s) + (BitPutState _ _ _ LL) -> putBitsBuffer (bufferUnsafeInit bs) (putBits 8 (bufferUnsafeLast bs) s) + (BitPutState _ _ _ BL) -> putBitsBuffer (bufferUnsafeInit bs) (putBits 8 (bufferUnsafeLast bs) s) + (BitPutState _ _ _ LB) -> putBitsBuffer (bufferUnsafeTail bs) (putBits 8 (bufferUnsafeHead bs) s) + where + rev = bufferMap reverseBits + +-- | Flush the current byte +flushIncomplete :: BitPutState -> BitPutState +flushIncomplete s@(BitPutState b w o bo) + | o == 0 = s + | otherwise = BitPutState (b `mappend` B.fromWord8 w) 0 0 bo + +-- | Get a buffer list +getBitPutBufferList :: BitPutState -> BufferList +getBitPutBufferList = toBufferList . bitPutStateBuilder . flushIncomplete + +-- | Get a Buffer +getBitPutBuffer :: BitPutState -> Buffer +getBitPutBuffer = toBuffer . bitPutStateBuilder . flushIncomplete + +-- | BitPut monad transformer +type BitPutT m a = StateT BitPutState m a + +-- | BitPut monad +type BitPut a = BitPutT Identity a + +-- | Evaluate a BitPut monad +runBitPutT :: Monad m => BitOrder -> BitPutT m a -> m Buffer +runBitPutT bo m = getBitPutBuffer <$> execStateT m (newBitPutState bo) + +-- | Evaluate a BitPut monad +runBitPut :: BitOrder -> BitPut a -> Buffer +runBitPut bo m = runIdentity (runBitPutT bo m) + +-- | Put bits (monadic) +putBitsM :: (Monad m, Integral a, Bits a, ReversableBits a) => Word -> a -> BitPutT m () +putBitsM n w = modify (putBits n w) + +-- | Put a single bit (monadic) +putBitBoolM :: (Monad m) => Bool -> BitPutT m () +putBitBoolM b = putBitsM 1 (if b then 1 else 0 :: Word) + +-- | Put a Buffer (monadic) +putBitsBufferM :: Monad m => Buffer -> BitPutT m () +putBitsBufferM bs = modify (putBitsBuffer bs) + +-- | Change the current bit ordering +-- +-- Be careful to change the outer bit ordering (B* to L* or the inverse) only +-- on bytes boundaries! Otherwise, you will write the same bits more than once. +changeBitPutOrder :: Monad m => BitOrder -> BitPutT m () +changeBitPutOrder bo = modify (\s -> s { bitPutStateBitOrder = bo }) + +-- | Change the bit ordering for the wrapped BitPut +-- +-- Be careful, this function uses changeBitPutOrder internally. +withBitPutOrder :: Monad m => BitOrder -> BitPutT m a -> BitPutT m a +withBitPutOrder bo m = do + bo' <- gets bitPutStateBitOrder + changeBitPutOrder bo + v <- m + changeBitPutOrder bo' + return v diff --git a/src/lib/Haskus/Binary/Bits/Reverse.hs b/src/lib/Haskus/Binary/Bits/Reverse.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Reverse.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Reverse bits +-- +-- There are several algorithms performing the same thing here (reversing bits +-- into words of different sizes). There are benchmarks for them in the +-- "bench" directory. The fastest one for the current architecture should be +-- selected below. If you find that another algorithm is faster on your +-- architecture, please report it. +module Haskus.Binary.Bits.Reverse + ( + -- * Generic + ReversableBits (..) + , reverseBitsGeneric + -- * Algorithms + , reverseBitsObvious + , reverseBits3Ops + , reverseBits4Ops + , reverseBitsTable + , reverseBits7Ops + , reverseBits5LgN + , liftReverseBits + ) +where + +import Haskus.Binary.Buffer +import Haskus.Number.Word +import Haskus.Number.Int +import Haskus.Binary.Bits.Finite +import Haskus.Binary.Bits.Shift +import Haskus.Binary.Bits.Bitwise +import Haskus.Binary.Bits.Index +import Haskus.Utils.Types (KnownNat) + +--------------------------------------------------- +-- Generic and specialized reverseBits +--------------------------------------------------- + + +-- | Reverse bits in a Word +reverseBitsGeneric :: + ( FiniteBits a + , Integral a + , ShiftableBits a + , Bitwise a + , KnownNat (BitSize a) + ) => a -> a +reverseBitsGeneric = liftReverseBits reverseBits4Ops + +-- | Data whose bits can be reversed +class ReversableBits w where + reverseBits :: w -> w + +instance ReversableBits Word8 where + reverseBits = reverseBits4Ops + +instance ReversableBits Word16 where + reverseBits = reverseBits5LgN + +instance ReversableBits Word32 where + reverseBits = reverseBits5LgN + +instance ReversableBits Word64 where + reverseBits = reverseBits5LgN + +instance ReversableBits Word where + reverseBits = reverseBits5LgN + +instance ReversableBits Int8 where + reverseBits = fromIntegral . reverseBits4Ops . fromIntegral + +instance ReversableBits Int16 where + reverseBits = reverseBits5LgN + +instance ReversableBits Int32 where + reverseBits = reverseBits5LgN + +instance ReversableBits Int64 where + reverseBits = reverseBits5LgN + +instance ReversableBits Int where + reverseBits = reverseBits5LgN + + +--------------------------------------------------- +-- Bit reversal algorithms +--------------------------------------------------- + +-- Algorithms and explanations adapted from: +-- http://graphics.stanford.edu/~seander/bithacks.html#ReverseByteWith64Bits + +-- Reverse the bits the obvious way +-- ================================ +-- +-- +-- unsigned int v; // input bits to be reversed +-- unsigned int r = v; // r will be reversed bits of v; first get LSB of v +-- int s = sizeof(v) * CHAR_BIT - 1; // extra shift needed at end +-- +-- for (v >>= 1; v; v >>= 1) +-- { +-- r <<= 1; +-- r |= v & 1; +-- s--; +-- } +-- r <<= s; // shift when v's highest bits are zero +-- +-- On October 15, 2004, Michael Hoisie pointed out a bug in the original +-- version. Randal E. Bryant suggested removing an extra operation on May 3, +-- 2005. Behdad Esfabod suggested a slight change that eliminated one iteration +-- of the loop on May 18, 2005. Then, on February 6, 2007, Liyong Zhou +-- suggested a better version that loops while v is not 0, so rather than +-- iterating over all bits it stops early. + +-- | Obvious recursive version +reverseBitsObvious :: forall a. + ( FiniteBits a + , ShiftableBits a + , IndexableBits a + , Bitwise a + , KnownNat (BitSize a) + , Eq a + ) => a -> a +reverseBitsObvious x = rec x (x `shiftR` 1) (bitSize x - 1) + where + rec :: FiniteBits a => a -> a -> Word -> a + rec !r !v !s + | v == zeroBits = r `shiftL` s + | otherwise = rec ((r `shiftL` 1) .|. (v .&. bit 0)) (v `shiftR` 1) (s - 1) + +{-# SPECIALIZE reverseBitsObvious :: Word8 -> Word8 #-} +{-# SPECIALIZE reverseBitsObvious :: Word16 -> Word16 #-} +{-# SPECIALIZE reverseBitsObvious :: Word32 -> Word32 #-} +{-# SPECIALIZE reverseBitsObvious :: Word64 -> Word64 #-} + +-- Reverse the bits in a byte with 3 operations (64-bit multiply and modulus division) +-- =================================================================================== +-- +-- unsigned char b; // reverse this (8-bit) byte +-- +-- b = (b * 0x0202020202ULL & 0x010884422010ULL) % 1023; +-- +-- The multiply operation creates five separate copies of the 8-bit byte +-- pattern to fan-out into a 64-bit value. The AND operation selects the bits +-- that are in the correct (reversed) positions, relative to each 10-bit groups +-- of bits. The multiply and the AND operations copy the bits from the original +-- byte so they each appear in only one of the 10-bit sets. The reversed +-- positions of the bits from the original byte coincide with their relative +-- positions within any 10-bit set. The last step, which involves modulus +-- division by 2^10 - 1, has the effect of merging together each set of 10 bits +-- (from positions 0-9, 10-19, 20-29, ...) in the 64-bit value. They do not +-- overlap, so the addition steps underlying the modulus division behave like +-- or operations. +-- +-- This method was attributed to Rich Schroeppel in the Programming Hacks +-- section of Beeler, M., Gosper, R. W., and Schroeppel, R. HAKMEM. MIT AI Memo +-- 239, Feb. 29, 1972. + +-- | Reverse bits in a Word8 (3 64-bit operations, modulus division) +reverseBits3Ops :: Word8 -> Word8 +{-# INLINABLE reverseBits3Ops #-} +reverseBits3Ops x = fromIntegral x' + where + !x' = ((fromIntegral x * 0x0202020202 :: Word64) .&. 0x010884422010) `mod` 1023 + + +-- Reverse the bits in a byte with 4 operations (64-bit multiply, no division) +-- =========================================================================== +-- +-- unsigned char b; // reverse this (8-bit) byte +-- +-- b = ((b * 0x80200802ULL) & 0x0884422110ULL) * 0x0101010101ULL >> 32; +-- +-- The following shows the flow of the bit values with the boolean variables a, +-- b, c, d, e, f, g, and h, which comprise an 8-bit byte. Notice how the first +-- multiply fans out the bit pattern to multiple copies, while the last +-- multiply combines them in the fifth byte from the right. +-- +-- +-- abcd efgh (-> hgfe dcba) +-- * 1000 0000 0010 0000 0000 1000 0000 0010 (0x80200802) +-- ------------------------------------------------------------------------------------------------- +-- 0abc defg h00a bcde fgh0 0abc defg h00a bcde fgh0 +-- & 0000 1000 1000 0100 0100 0010 0010 0001 0001 0000 (0x0884422110) +-- ------------------------------------------------------------------------------------------------- +-- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 +-- * 0000 0001 0000 0001 0000 0001 0000 0001 0000 0001 (0x0101010101) +-- ------------------------------------------------------------------------------------------------- +-- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 +-- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 +-- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 +-- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 +-- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 +-- ------------------------------------------------------------------------------------------------- +-- 0000 d000 h000 dc00 hg00 dcb0 hgf0 dcba hgfe dcba hgfe 0cba 0gfe 00ba 00fe 000a 000e 0000 +-- >> 32 +-- ------------------------------------------------------------------------------------------------- +-- 0000 d000 h000 dc00 hg00 dcb0 hgf0 dcba hgfe dcba +-- & 1111 1111 +-- ------------------------------------------------------------------------------------------------- +-- hgfe dcba +-- Note that the last two steps can be combined on some processors because the +-- registers can be accessed as bytes; just multiply so that a register stores +-- the upper 32 bits of the result and the take the low byte. Thus, it may take +-- only 6 operations. +-- +-- Devised by Sean Anderson, July 13, 2001. + +-- | Reverse bits in a Word8 (4 64-bit operations, no division) +reverseBits4Ops :: Word8 -> Word8 +{-# INLINABLE reverseBits4Ops #-} +reverseBits4Ops x = fromIntegral x' + where + !x' = (((fromIntegral x * 0x80200802 :: Word64) .&. 0x0884422110) * 0x0101010101) `shiftR` 32 + + +-- Reverse bits using a lookup table +-- ================================= + +-- | Reverse bits using a lookup table +reverseBitsTable :: Word8 -> Word8 +{-# INLINABLE reverseBitsTable #-} +reverseBitsTable x = bitsTable `bufferIndex` (fromIntegral x) + + +-- fill the table by using another method +bitsTable :: Buffer +bitsTable = bufferPackByteList $ fmap reverseBits4Ops [0..255] + +-- Reverse the bits in a byte with 7 operations (no 64-bit) +-- ======================================================== +-- +-- b = ((b * 0x0802LU & 0x22110LU) | (b * 0x8020LU & 0x88440LU)) * 0x10101LU >> 16; +-- +-- Make sure you assign or cast the result to an unsigned char to remove +-- garbage in the higher bits. Devised by Sean Anderson, July 13, 2001. Typo +-- spotted and correction supplied by Mike Keith, January 3, 2002. + + +-- | Reverse bits in a Word8 (7 no 64-bit operations, no division) +reverseBits7Ops :: Word8 -> Word8 +{-# INLINABLE reverseBits7Ops #-} +reverseBits7Ops b' = fromIntegral x' + where + b = fromIntegral b' :: Word32 + !x' = ((((b * 0x0802) .&. 0x22110) .|. ((b * 0x8020) .&. 0x88440)) * 0x10101) `shiftR` 16 + + +-- Reverse an N-bit quantity in parallel in 5 * lg(N) operations +-- ============================================================= +-- +-- unsigned int v; // 32-bit word to reverse bit order +-- +-- // swap odd and even bits +-- v = ((v >> 1) & 0x55555555) | ((v & 0x55555555) << 1); +-- // swap consecutive pairs +-- v = ((v >> 2) & 0x33333333) | ((v & 0x33333333) << 2); +-- // swap nibbles ... +-- v = ((v >> 4) & 0x0F0F0F0F) | ((v & 0x0F0F0F0F) << 4); +-- // swap bytes +-- v = ((v >> 8) & 0x00FF00FF) | ((v & 0x00FF00FF) << 8); +-- // swap 2-byte long pairs +-- v = ( v >> 16 ) | ( v << 16); +-- +-- The following variation is also O(lg(N)), however it requires more +-- operations to reverse v. Its virtue is in taking less slightly memory by +-- computing the constants on the fly. +-- +-- unsigned int s = sizeof(v) * CHAR_BIT; // bit size; must be power of 2 +-- unsigned int mask = ~0; +-- while ((s >>= 1) > 0) +-- { +-- mask ^= (mask << s); +-- v = ((v >> s) & mask) | ((v << s) & ~mask); +-- } +-- +-- These methods above are best suited to situations where N is large. If you +-- use the above with 64-bit ints (or larger), then you need to add more lines +-- (following the pattern); otherwise only the lower 32 bits will be reversed +-- and the result will be in the lower 32 bits. +-- +-- See Dr. Dobb's Journal 1983, Edwin Freed's article on Binary Magic Numbers +-- for more information. The second variation was suggested by Ken Raeburn on +-- September 13, 2005. Veldmeijer mentioned that the first version could do +-- without ANDS in the last line on March 19, 2006. + +-- | "Parallel" recursive version +reverseBits5LgN :: forall a. + ( FiniteBits a + , ShiftableBits a + , Bitwise a + , KnownNat (BitSize a) + ) => a -> a +reverseBits5LgN x = rec (bitSize x `shiftR` 1) (complement zeroBits) x + where + rec :: FiniteBits a => Word -> a -> a -> a + rec !s !mask !v + | s <= 0 = v + | otherwise = rec (s `shiftR` 1) mask' v' + where + mask' = mask `xor` (mask `shiftL` s) + v' = ((v `shiftR` s) .&. mask') + .|. ((v `shiftL` s) .&. complement mask') + +{-# SPECIALIZE reverseBits5LgN :: Word8 -> Word8 #-} +{-# SPECIALIZE reverseBits5LgN :: Word16 -> Word16 #-} +{-# SPECIALIZE reverseBits5LgN :: Word32 -> Word32 #-} +{-# SPECIALIZE reverseBits5LgN :: Word64 -> Word64 #-} + + + +-- | Convert a function working on Word8 to one working on any Word +-- +-- The number of bits in the Word must be a multiple of 8 +liftReverseBits :: + ( ShiftableBits a + , Bitwise a + , FiniteBits a + , Integral a + , KnownNat (BitSize a) + ) => (Word8 -> Word8) -> a -> a +liftReverseBits f w = rec zeroBits 0 + where + nb = bitSize w `shiftR` 3 -- div 8 + f' = fromIntegral . f . fromIntegral + rec !v !o + | o == nb = v + | otherwise = rec v' (o+1) + where + -- multiplication by 8 replaced with (`shiftL` 3) + v' = v .|. ((f' (w `shiftR` (o `shiftL` 3))) `shiftL` ((nb-1-o) `shiftL` 3)) + +{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word8 -> Word8 #-} +{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word16 -> Word16 #-} +{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word32 -> Word32 #-} +{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word64 -> Word64 #-} + diff --git a/src/lib/Haskus/Binary/Bits/Rotate.hs b/src/lib/Haskus/Binary/Bits/Rotate.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Rotate.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Bit rotations +module Haskus.Binary.Bits.Rotate + ( RotatableBits (..) + ) +where + +import Haskus.Binary.Bits.Finite +import Haskus.Binary.Bits.Shift +import Haskus.Binary.Bits.Bitwise +import Haskus.Number.Word +import Haskus.Number.Int +import Haskus.Utils.Types + +-- | Types whose bits can be rotated +class RotatableBits a where + + -- | Rotate left if positive, right if negative + rotate :: a -> Int -> a + default rotate :: + ( FiniteBits a + , KnownNat (BitSize a) + ) => a -> Int -> a + rotate a i + | i' > 0 = rotateL a (fromIntegral i') + | i' < 0 = rotateR a (fromIntegral (negate i')) + | otherwise = a + where + i' = i `mod` bitSize a + + -- | Checked left bit rotation + rotateL :: a -> Word -> a + default rotateL :: + ( FiniteBits a + , KnownNat (BitSize a) + ) => a -> Word -> a + rotateL a n = uncheckedRotateL a (n `mod` bitSize a) + + -- | Checked right bit rotation + rotateR :: a -> Word -> a + default rotateR :: + ( FiniteBits a + , KnownNat (BitSize a) + ) => a -> Word -> a + rotateR a n = uncheckedRotateR a (n `mod` bitSize a) + + -- | Unchecked rotate left if positive, right if negative + uncheckedRotate :: a -> Int -> a + uncheckedRotate a i + | i > 0 = uncheckedRotateL a (fromIntegral i) + | i < 0 = uncheckedRotateR a (fromIntegral (negate i)) + | otherwise = a + + -- | Unchecked left bit rotation + uncheckedRotateL :: a -> Word -> a + default uncheckedRotateL :: + ( ShiftableBits a + , FiniteBits a + , KnownNat (BitSize a) + , Bitwise a + ) => a -> Word -> a + uncheckedRotateL a i = (a `uncheckedShiftL` i) .|. (a `uncheckedShiftR` (n-i)) + where n = bitSize a + + + -- | Unchecked right bit rotation + uncheckedRotateR :: a -> Word -> a + default uncheckedRotateR :: + ( ShiftableBits a + , FiniteBits a + , KnownNat (BitSize a) + , Bitwise a + ) => a -> Word -> a + uncheckedRotateR a i = (a `uncheckedShiftL` (n-i)) .|. (a `uncheckedShiftR` i) + where n = bitSize a + + +instance RotatableBits Word +instance RotatableBits Word8 +instance RotatableBits Word16 +instance RotatableBits Word32 +instance RotatableBits Word64 + +instance RotatableBits Int +instance RotatableBits Int8 +instance RotatableBits Int16 +instance RotatableBits Int32 +instance RotatableBits Int64 diff --git a/src/lib/Haskus/Binary/Bits/Shift.hs b/src/lib/Haskus/Binary/Bits/Shift.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Bits/Shift.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} + +-- | Bit shifts +module Haskus.Binary.Bits.Shift + ( ShiftableBits (..) + , SignedShiftableBits (..) + ) +where + +import Haskus.Number.Word +import Haskus.Number.Int +import GHC.Exts +import GHC.Num + +#include "MachDeps.h" + +-- | Bit shifts +-- +-- "Checked" means that there is an additional test to ensure that the shift +-- offset is valid (less than the bit count). If you are sure that the offset is +-- valid, use the "unchecked" version which should be faster. +-- +-- To shift signed numbers, see `SignedShiftableBits` class methods. +class ShiftableBits a where + -- | Checked right shift + shiftR :: a -> Word -> a + + -- | Checked left shift + shiftL :: a -> Word -> a + + -- | Unchecked right shift + uncheckedShiftR :: a -> Word -> a + + -- | Unchecked left shift + uncheckedShiftL :: a -> Word -> a + + -- | Checked shift to the left if positive, to the right if negative + shift :: a -> Int -> a + shift a i + | i > 0 = shiftL a (fromIntegral i) + | i < 0 = shiftR a (fromIntegral (negate i)) + | otherwise = a + + -- | Unchecked shift to the left if positive, to the right if negative + uncheckedShift :: a -> Int -> a + uncheckedShift a i + | i > 0 = uncheckedShiftL a (fromIntegral i) + | i < 0 = uncheckedShiftR a (fromIntegral (negate i)) + | otherwise = a + +-- | Signed bit shifts +-- +-- "Signed" means that the sign bit (the higher order bit): +-- - propagates to the right during right shifts and +-- - keeps its value during left shifts (except when all other bits are 0) +-- +-- "Checked" means that there is an additional test to ensure that the shift +-- offset is valid (less than the bit count). If you are sure that the offset is +-- valid, use the "unchecked" version which should be faster. +class SignedShiftableBits a where + -- | Checked signed right shift + signedShiftR :: a -> Word -> a + + -- | Checked signed left shift + signedShiftL :: a -> Word -> a + + -- | Unchecked signed right shift + uncheckedSignedShiftR :: a -> Word -> a + + -- | Unchecked signed left shift + uncheckedSignedShiftL :: a -> Word -> a + + -- | Checked signed shift to the left if positive, to the right if negative + signedShift :: a -> Int -> a + signedShift a i + | i > 0 = signedShiftL a (fromIntegral i) + | i < 0 = signedShiftR a (fromIntegral (negate i)) + | otherwise = a + + -- | Unchecked signed shift to the left if positive, to the right if negative + uncheckedSignedShift :: a -> Int -> a + uncheckedSignedShift a i + | i > 0 = uncheckedSignedShiftL a (fromIntegral i) + | i < 0 = uncheckedSignedShiftR a (fromIntegral (negate i)) + | otherwise = a + + +instance ShiftableBits Word where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (W# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = W# 0## + | otherwise = W# (x# `uncheckedShiftL#` word2Int# i#) + (W# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = W# 0## + | otherwise = W# (x# `uncheckedShiftRL#` word2Int# i#) + (W# x#) `uncheckedShiftL` (W# i#) = W# (x# `uncheckedShiftL#` word2Int# i#) + (W# x#) `uncheckedShiftR` (W# i#) = W# (x# `uncheckedShiftRL#` word2Int# i#) + +instance ShiftableBits Word8 where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (W8# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` 8##) = W8# 0## + | otherwise = W8# (narrow8Word# (x# `uncheckedShiftL#` word2Int# i#)) + + (W8# x#) `uncheckedShiftL` (W# i#) = W8# (narrow8Word# (x# `uncheckedShiftL#` word2Int# i#)) + + (W8# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` 8##) = W8# 0## + | otherwise = W8# (x# `uncheckedShiftRL#` word2Int# i#) + + (W8# x#) `uncheckedShiftR` (W# i#) = W8# (x# `uncheckedShiftRL#` word2Int# i#) + +instance ShiftableBits Word16 where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (W16# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` 16##) = W16# 0## + | otherwise = W16# (narrow16Word# (x# `uncheckedShiftL#` word2Int# i#)) + + (W16# x#) `uncheckedShiftL` (W# i#) = W16# (narrow16Word# (x# `uncheckedShiftL#` word2Int# i#)) + + (W16# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` 16##) = W16# 0## + | otherwise = W16# (x# `uncheckedShiftRL#` word2Int# i#) + + (W16# x#) `uncheckedShiftR` (W# i#) = W16# (x# `uncheckedShiftRL#` word2Int# i#) + +instance ShiftableBits Word32 where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (W32# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` 32##) = W32# 0## + | otherwise = W32# (narrow32Word# (x# `uncheckedShiftL#` word2Int# i#)) + + (W32# x#) `uncheckedShiftL` (W# i#) = W32# (narrow32Word# (x# `uncheckedShiftL#` word2Int# i#)) + + (W32# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` 32##) = W32# 0## + | otherwise = W32# (x# `uncheckedShiftRL#` word2Int# i#) + + (W32# x#) `uncheckedShiftR` (W# i#) = W32# (x# `uncheckedShiftRL#` word2Int# i#) + +instance ShiftableBits Word64 where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (W64# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` 64##) = W64# 0## + | otherwise = W64# (x# `uncheckedShiftL#` word2Int# i#) + + (W64# x#) `uncheckedShiftL` (W# i#) = W64# (x# `uncheckedShiftL#` word2Int# i#) + + (W64# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` 64##) = W64# 0## + | otherwise = W64# (x# `uncheckedShiftRL#` word2Int# i#) + + (W64# x#) `uncheckedShiftR` (W# i#) = W64# (x# `uncheckedShiftRL#` word2Int# i#) + + +instance ShiftableBits Int where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (I# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = I# 0# + | otherwise = I# (x# `uncheckedIShiftL#` word2Int# i#) + + (I# x#) `uncheckedShiftL` (W# i#) = I# (x# `uncheckedIShiftL#` word2Int# i#) + + (I# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = I# 0# + | otherwise = I# (x# `uncheckedIShiftRL#` word2Int# i#) + + (I# x#) `uncheckedShiftR` (W# i#) = I# (x# `uncheckedIShiftRL#` word2Int# i#) + +instance ShiftableBits Int8 where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (I8# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` 8##) = I8# 0# + | otherwise = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#)) + + (I8# x#) `uncheckedShiftL` (W# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#)) + + (I8# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` 8##) = I8# 0# + | otherwise = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) + + (I8# x#) `uncheckedShiftR` (W# i#) = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) + + +instance ShiftableBits Int16 where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (I16# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` 16##) = I16# 0# + | otherwise = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#)) + + (I16# x#) `uncheckedShiftL` (W# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#)) + + (I16# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` 16##) = I16# 0# + | otherwise = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) + + (I16# x#) `uncheckedShiftR` (W# i#) = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) + + +instance ShiftableBits Int32 where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (I32# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` 32##) = I32# 0# + | otherwise = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#)) + + (I32# x#) `uncheckedShiftL` (W# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#)) + + (I32# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` 32##) = I32# 0# + | otherwise = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) + + (I32# x#) `uncheckedShiftR` (W# i#) = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) + +instance ShiftableBits Int64 where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + (I64# x#) `shiftL` (W# i#) + | isTrue# (i# `geWord#` 64##) = I64# 0# + | otherwise = I64# (x# `uncheckedIShiftL#` word2Int# i#) + + (I64# x#) `uncheckedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL#` word2Int# i#) + + (I64# x#) `shiftR` (W# i#) + | isTrue# (i# `geWord#` 64##) = I64# 0# + | otherwise = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#)) + + (I64# x#) `uncheckedShiftR` (W# i#) = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#)) + + +instance SignedShiftableBits Int where + (I# x#) `signedShiftL` (W# i#) = I# (x# `iShiftL#` word2Int# i#) + (I# x#) `signedShiftR` (W# i#) = I# (x# `iShiftRA#` word2Int# i#) + (I# x#) `uncheckedSignedShiftL` (W# i#) = I# (x# `uncheckedIShiftL#` word2Int# i#) + (I# x#) `uncheckedSignedShiftR` (W# i#) = I# (x# `uncheckedIShiftRA#` word2Int# i#) + +instance SignedShiftableBits Int8 where + (I8# x#) `signedShiftL` (W# i#) = I8# (narrow8Int# (x# `iShiftL#` word2Int# i#)) + (I8# x#) `signedShiftR` (W# i#) = I8# (x# `iShiftRA#` word2Int# i#) + (I8# x#) `uncheckedSignedShiftL` (W# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#)) + (I8# x#) `uncheckedSignedShiftR` (W# i#) = I8# (x# `uncheckedIShiftRA#` word2Int# i#) + +instance SignedShiftableBits Int16 where + (I16# x#) `signedShiftL` (W# i#) = I16# (narrow16Int# (x# `iShiftL#` word2Int# i#)) + (I16# x#) `signedShiftR` (W# i#) = I16# (x# `iShiftRA#` word2Int# i#) + (I16# x#) `uncheckedSignedShiftL` (W# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#)) + (I16# x#) `uncheckedSignedShiftR` (W# i#) = I16# (x# `uncheckedIShiftRA#` word2Int# i#) + +instance SignedShiftableBits Int32 where + (I32# x#) `signedShiftL` (W# i#) = I32# (narrow32Int# (x# `iShiftL#` word2Int# i#)) + (I32# x#) `signedShiftR` (W# i#) = I32# (x# `iShiftRA#` word2Int# i#) + (I32# x#) `uncheckedSignedShiftL` (W# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#)) + (I32# x#) `uncheckedSignedShiftR` (W# i#) = I32# (x# `uncheckedIShiftRA#` word2Int# i#) + +instance SignedShiftableBits Int64 where + (I64# x#) `signedShiftL` (W# i#) = I64# (x# `iShiftL#` word2Int# i#) + (I64# x#) `signedShiftR` (W# i#) = I64# (x# `iShiftRA#` word2Int# i#) + (I64# x#) `uncheckedSignedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL#` word2Int# i#) + (I64# x#) `uncheckedSignedShiftR` (W# i#) = I64# (x# `uncheckedIShiftRA#` word2Int# i#) + + + +instance ShiftableBits Integer where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + x `shiftL` (W# i#) = shiftLInteger x (word2Int# i#) + x `shiftR` (W# i#) = shiftRInteger x (word2Int# i#) + + uncheckedShiftL = shiftL + uncheckedShiftR = shiftR + +instance ShiftableBits Natural where + {-# INLINABLE shiftR #-} + {-# INLINABLE shiftL #-} + {-# INLINABLE uncheckedShiftL #-} + {-# INLINABLE uncheckedShiftR #-} + + x `shiftL` (W# i#) = shiftLNatural x (I# (word2Int# i#)) + x `shiftR` (W# i#) = shiftRNatural x (I# (word2Int# i#)) + + uncheckedShiftL = shiftL + uncheckedShiftR = shiftR diff --git a/src/lib/Haskus/Binary/Buffer.hs b/src/lib/Haskus/Binary/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Buffer.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} + +-- | A memory buffer with a fixed address +-- +-- A buffer is a strict ByteString but with: +-- +-- * a better interface: use Word instead of Int for sizes +-- * a better name: "string" is misleading +-- * some additional primitives +module Haskus.Binary.Buffer + ( Buffer (..) + , withBufferPtr + , bufferSize + , isBufferEmpty + , emptyBuffer + , bufferZero + , bufferMap + , bufferReverse + , bufferDrop + , bufferTail + , bufferAppend + , bufferCons + , bufferSnoc + , bufferInit + , bufferSplitOn + , bufferHead + , bufferIndex + , bufferTake + , bufferTakeWhile + , bufferTakeAtMost + , bufferZipWith + , bufferDup + -- * Peek / Poke + , bufferPeekStorable + , bufferPeekStorableAt + , bufferPopStorable + , bufferPoke + -- * Packing / Unpacking + , bufferPackByteString + , bufferPackByteList + , bufferPackStorable + , bufferPackStorableList + , bufferPackPtr + , bufferUnpackByteList + , bufferUnpackByteString + -- * Unsafe + , bufferUnsafeDrop + , bufferUnsafeTake + , bufferUnsafeTail + , bufferUnsafeHead + , bufferUnsafeLast + , bufferUnsafeInit + , bufferUnsafeIndex + , bufferUnsafeMapMemory + , bufferUnsafeUsePtr + , bufferUnsafePackPtr + -- * IO + , bufferReadFile + , bufferWriteFile + ) +where + +import Prelude hiding (length) + +import System.IO.Unsafe +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import Foreign.Ptr +import Foreign.Marshal.Alloc (mallocBytes) + +import Haskus.Number.Word +import Haskus.Binary.Storable +import Haskus.Binary.Bits.Helper +import Haskus.Binary.Bits.Bitwise +import Haskus.Binary.Bits.Index +import Haskus.Binary.Bits.Shift +import Haskus.Memory.Utils (memCopy,memSet) +import Haskus.Utils.List as List +import Haskus.Utils.Flow + +-- | A buffer +newtype Buffer = Buffer ByteString deriving (Eq,Ord) + +instance Show Buffer where + show b = concatMap bToHex (bufferUnpackByteList b) + where + bToHex x = toHex (x `shiftR` 4) ++ toHex (x .&. 0x0F) + toHex 0xA = "A" + toHex 0xB = "B" + toHex 0xC = "C" + toHex 0xD = "D" + toHex 0xE = "E" + toHex 0xF = "F" + toHex x = show x + +instance Bitwise Buffer where + (.&.) = bufferZipWith (.&.) + (.|.) = bufferZipWith (.|.) + xor = bufferZipWith xor + +instance IndexableBits Buffer where + bit i = bufferPackByteList + (bit r : List.replicate (fromIntegral n) 0) + where + n = byteOffset i + r = bitOffset i + + testBit b i = testBit p r + where + p = bufferIndex b (bufferSize b - n) + n = byteOffset i + r = bitOffset i + + setBit = error "Can't set Buffer bit" + clearBit = error "Can't clear Buffer bit" + + popCount b = sum (fmap popCount (bufferUnpackByteList b)) + + + +-- | Duplicate a buffer +bufferDup :: Buffer -> IO Buffer +bufferDup b = withBufferPtr b $ bufferPackPtr (bufferSize b) + +-- | Buffer filled with zero +bufferZero :: Word -> Buffer +bufferZero n = unsafePerformIO $ do + p <- mallocBytes (fromIntegral n) + memSet p (fromIntegral n) 0 + bufferUnsafePackPtr n p + +-- | Zip two buffers with the given function +bufferZipWith :: (Word8 -> Word8 -> Word8) -> Buffer -> Buffer -> Buffer +bufferZipWith f a b + | bufferSize a /= bufferSize b = error "Non matching buffer sizes" + | otherwise = unsafePerformIO $ do + let sz = fromIntegral (bufferSize a) + pc <- mallocBytes sz + withBufferPtr a $ \pa -> + withBufferPtr b $ \pb -> + forM_ [0..fromIntegral sz-1] $ \off -> do + v <- f <$> peekByteOff pa off + <*> peekByteOff pb off + pokeByteOff pc off (v :: Word8) + bufferUnsafePackPtr (bufferSize a) pc + +-- | Unsafe: be careful if you modify the buffer contents or you may break +-- referential transparency +withBufferPtr :: Buffer -> (Ptr b -> IO a) -> IO a +withBufferPtr (Buffer bs) f = BS.unsafeUseAsCString bs (f . castPtr) + +-- | Test if the buffer is empty +isBufferEmpty :: Buffer -> Bool +isBufferEmpty (Buffer bs) = BS.null bs + +-- | Empty buffer +emptyBuffer :: Buffer +emptyBuffer = Buffer BS.empty + +-- | Buffer size +bufferSize :: Buffer -> Word +bufferSize (Buffer bs) = + if s < 0 + then error "ByteString with size < 0" + else fromIntegral s + where + s = BS.length bs + +-- | Peek a storable +bufferPeekStorable :: forall a. Storable a => Buffer -> a +bufferPeekStorable = snd . bufferPopStorable + +-- | Peek a storable at the given offset +bufferPeekStorableAt :: forall a. + ( Storable a + ) + => Buffer -> Word -> a +bufferPeekStorableAt b n + | n + sizeOfT' @a > bufferSize b = error "Invalid buffer index" + | otherwise = unsafePerformIO $ withBufferPtr b $ \p -> + peekByteOff p (fromIntegral n) + + +-- | Pop a Storable and return the new buffer +bufferPopStorable :: forall a. Storable a => Buffer -> (Buffer,a) +bufferPopStorable buf + | bufferSize buf < sza = error "bufferRead: out of bounds" + | otherwise = unsafePerformIO $ do + a <- withBufferPtr buf peek + return (bufferDrop sza buf, a) + where + sza = sizeOfT' @a + +-- | Poke a buffer +bufferPoke :: Ptr a -> Buffer -> IO () +bufferPoke dest b = bufferUnsafeUsePtr b $ \src sz -> + memCopy dest src (fromIntegral sz) + +-- | Map +bufferMap :: (Word8 -> Word8) -> Buffer -> Buffer +bufferMap f (Buffer bs) = Buffer (BS.map f bs) + +-- | Reverse +bufferReverse :: Buffer -> Buffer +bufferReverse (Buffer bs) = Buffer (BS.reverse bs) + +-- | Drop some bytes O(1) +bufferDrop :: Word -> Buffer -> Buffer +bufferDrop n (Buffer bs) = Buffer $ BS.drop (fromIntegral n) bs + +-- | Split on the given Byte values +bufferSplitOn :: Word8 -> Buffer -> [Buffer] +bufferSplitOn n (Buffer bs) = fmap Buffer (BS.split n bs) + +-- | Tail +bufferTail :: Buffer -> Buffer +bufferTail (Buffer bs) = Buffer $ BS.tail bs + +-- | Append +bufferAppend :: Buffer -> Buffer -> Buffer +bufferAppend (Buffer a) (Buffer b) = Buffer $ BS.append a b + +-- | Cons +bufferCons :: Word8 -> Buffer -> Buffer +bufferCons w (Buffer bs) = Buffer $ BS.cons w bs + +-- | Snoc +bufferSnoc :: Buffer -> Word8 -> Buffer +bufferSnoc (Buffer bs) w = Buffer $ BS.snoc bs w + + +-- | Init +bufferInit :: Buffer -> Buffer +bufferInit (Buffer bs) = Buffer $ BS.init bs + +-- | Head +bufferHead :: Buffer -> Word8 +{-# INLINABLE bufferHead #-} +bufferHead (Buffer bs) = BS.head bs + +-- | Index +bufferIndex :: Buffer -> Word -> Word8 +{-# INLINABLE bufferIndex #-} +bufferIndex (Buffer bs) n = BS.index bs (fromIntegral n) + +-- | Unpack +bufferUnpackByteList :: Buffer -> [Word8] +bufferUnpackByteList (Buffer bs) = BS.unpack bs + +-- | Unpack +bufferUnpackByteString :: Buffer -> ByteString +bufferUnpackByteString (Buffer bs) = bs + +-- | Take some bytes O(1) +bufferTake :: Word -> Buffer -> Buffer +bufferTake n (Buffer bs) = Buffer $ BS.take (fromIntegral n) bs + +-- | Take some bytes O(n) +bufferTakeWhile :: (Word8 -> Bool) -> Buffer -> Buffer +bufferTakeWhile f (Buffer bs) = Buffer $ BS.takeWhile f bs + +-- | Take some bytes O(1) +bufferTakeAtMost :: Word -> Buffer -> Buffer +bufferTakeAtMost n buf + | bufferSize buf < n = buf + | otherwise = bufferTake n buf + + +-- | Pack a ByteString +bufferPackByteString :: BS.ByteString -> Buffer +bufferPackByteString = Buffer + +-- | Pack a list of bytes +bufferPackByteList :: [Word8] -> Buffer +bufferPackByteList = Buffer . BS.pack + +-- | Pack a Storable +bufferPackStorable :: forall a. Storable a => a -> Buffer +bufferPackStorable x = Buffer $ unsafePerformIO $ do + p <- malloc + poke p x + BS.unsafePackMallocCStringLen (castPtr p, sizeOfT' @a) + +-- | Pack a list of Storable +bufferPackStorableList :: forall a. Storable a => [a] -> Buffer +bufferPackStorableList xs = Buffer $ unsafePerformIO $ do + let lxs = length xs + p <- mallocArray lxs + forM_ (xs `zip` [0..]) $ \(x,o) -> + pokeElemOff p o x + BS.unsafePackMallocCStringLen (castPtr p, sizeOfT' @a * fromIntegral lxs) + +-- | Pack from a pointer (copy) +bufferPackPtr :: MonadIO m => Word -> Ptr () -> m Buffer +bufferPackPtr sz ptr = do + p <- liftIO (mallocBytes (fromIntegral sz)) + memCopy p ptr (fromIntegral sz) + bufferUnsafePackPtr sz p + +-- | Pack from a pointer (add finalizer) +bufferUnsafePackPtr :: MonadIO m => Word -> Ptr a -> m Buffer +bufferUnsafePackPtr sz p = + Buffer <$> liftIO (BS.unsafePackMallocCStringLen (castPtr p, fromIntegral sz)) + +-- | Unsafe drop (don't check the size) +bufferUnsafeDrop :: Word -> Buffer -> Buffer +bufferUnsafeDrop n (Buffer bs) = Buffer (BS.unsafeDrop (fromIntegral n) bs) + +-- | Unsafe take (don't check the size) +bufferUnsafeTake :: Word -> Buffer -> Buffer +bufferUnsafeTake n (Buffer bs) = Buffer (BS.unsafeTake (fromIntegral n) bs) + +-- | Unsafe tail (don't check the size) +bufferUnsafeTail :: Buffer -> Buffer +bufferUnsafeTail (Buffer bs) = Buffer (BS.unsafeTail bs) + +-- | Unsafe head (don't check the size) +bufferUnsafeHead :: Buffer -> Word8 +bufferUnsafeHead (Buffer bs) = BS.unsafeHead bs + +-- | Unsafe last (don't check the size) +bufferUnsafeLast :: Buffer -> Word8 +bufferUnsafeLast (Buffer bs) = BS.unsafeLast bs + +-- | Unsafe init (don't check the size) +bufferUnsafeInit :: Buffer -> Buffer +bufferUnsafeInit (Buffer bs) = Buffer (BS.unsafeInit bs) + +-- | Unsafe index (don't check the size) +bufferUnsafeIndex :: Buffer -> Word -> Word8 +bufferUnsafeIndex (Buffer bs) n = BS.unsafeIndex bs (fromIntegral n) + +-- | Map memory +bufferUnsafeMapMemory :: MonadIO m => Word -> Ptr () -> m Buffer +bufferUnsafeMapMemory sz ptr = + Buffer <$> liftIO (BS.unsafePackCStringLen (castPtr ptr, fromIntegral sz)) + +-- | Use buffer pointer +bufferUnsafeUsePtr :: MonadInIO m => Buffer -> (Ptr () -> Word -> m a) -> m a +bufferUnsafeUsePtr bu@(Buffer b) f = + liftWith (BS.unsafeUseAsCString b) $ \p -> + f (castPtr p) (bufferSize bu) + +-- | Read file +bufferReadFile :: MonadIO m => FilePath -> m Buffer +bufferReadFile path = Buffer <$> liftIO (BS.readFile path) + +-- | Write file +bufferWriteFile :: MonadIO m => FilePath -> Buffer -> m () +bufferWriteFile path (Buffer bs) = liftIO (BS.writeFile path bs) diff --git a/src/lib/Haskus/Binary/BufferBuilder.hs b/src/lib/Haskus/Binary/BufferBuilder.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/BufferBuilder.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Buffer builder +module Haskus.Binary.BufferBuilder + ( BufferBuilder + , emptyBufferBuilder + , toBufferList + , toBuffer + , fromBuffer + , fromWord8 + ) +where + +import qualified Data.ByteString.Builder as B + +import Haskus.Number.Word +import Haskus.Binary.Buffer +import qualified Haskus.Binary.BufferList as BL + +-- | Buffer builder +newtype BufferBuilder + = BufferBuilder B.Builder + deriving (Semigroup,Monoid) + +-- | Empty buffer builder +emptyBufferBuilder :: BufferBuilder +emptyBufferBuilder = BufferBuilder mempty + +-- | Create a Builder denoting the same sequence of bytes as a strict +-- ByteString. The Builder inserts large ByteStrings directly, but copies small +-- ones to ensure that the generated chunks are large on average. +fromBuffer :: Buffer -> BufferBuilder +fromBuffer (Buffer bs) = BufferBuilder (B.byteString bs) + +-- | Encode a single unsigned byte as-is. +fromWord8 :: Word8 -> BufferBuilder +fromWord8 w = BufferBuilder (B.word8 w) + +-- | Execute a Builder and return the generated chunks as a BufferList. The work +-- is performed lazily, i.e., only when a chunk of the BufferList is forced. +toBufferList :: BufferBuilder -> BL.BufferList +toBufferList (BufferBuilder b) = BL.BufferList (B.toLazyByteString b) + +-- | Execute a Builder and return the generated chunks as a Buffer. +toBuffer :: BufferBuilder -> Buffer +toBuffer = BL.toBuffer . toBufferList diff --git a/src/lib/Haskus/Binary/BufferList.hs b/src/lib/Haskus/Binary/BufferList.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/BufferList.hs @@ -0,0 +1,29 @@ +-- | Buffer list +-- +-- BufferList is a lazy ByteString +module Haskus.Binary.BufferList + ( BufferList (..) + , toBuffer + , toBufferList + , toLazyByteString + ) +where + +import qualified Data.ByteString.Lazy as LBS + +import Haskus.Binary.Buffer + +-- | BufferList +newtype BufferList = BufferList LBS.ByteString + +-- | Convert to a buffer +toBuffer :: BufferList -> Buffer +toBuffer (BufferList b) = Buffer (LBS.toStrict b) + +-- | Convert from a buffer +toBufferList :: Buffer -> BufferList +toBufferList (Buffer b) = BufferList (LBS.fromStrict b) + +-- | Convert to a lazy ByteString +toLazyByteString :: BufferList -> LBS.ByteString +toLazyByteString (BufferList b) = b diff --git a/src/lib/Haskus/Binary/CTypes.hs b/src/lib/Haskus/Binary/CTypes.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/CTypes.hs @@ -0,0 +1,13 @@ +-- | Some C types +module Haskus.Binary.CTypes + ( CSize(..) + , CUShort + , CShort + , CUInt + , CInt + , CULong + , CLong + ) +where + +import Foreign.C.Types diff --git a/src/lib/Haskus/Binary/Char.hs b/src/lib/Haskus/Binary/Char.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Char.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Character +module Haskus.Binary.Char + ( Char8 (..) + ) +where + +import Haskus.Number.Word +import Haskus.Binary.Storable + +-- | 8-bit character (ASCII, etc.) +newtype Char8 + = Char8 Word8 + deriving (Show,Eq,Ord,Storable) diff --git a/src/lib/Haskus/Binary/Endianness.hs b/src/lib/Haskus/Binary/Endianness.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Endianness.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Byte order ("endianness") +-- +-- Indicate in which order bytes are stored in memory for multi-bytes types. +-- Big-endian means that most-significant bytes come first. Little-endian means +-- that least-significant bytes come first. +module Haskus.Binary.Endianness + ( Endianness(..) + , WordGetters (..) + , WordPutters (..) + , getWordGetters + , getWordPutters + , WordSize (..) + , ExtendedWordGetters (..) + , ExtendedWordPutters (..) + , getExtendedWordGetters + , getExtendedWordPutters + , getHostEndianness + , hostEndianness + , ByteReversable (..) + , AsBigEndian (..) + , AsLittleEndian (..) + ) +where + +import Haskus.Binary.Get +import Haskus.Binary.Put +import Haskus.Binary.Enum +import Haskus.Binary.Storable +import Haskus.Number.Word +import Haskus.Binary.Bits + +import System.IO.Unsafe +import Foreign.Ptr + +-- | Endianness +data Endianness + = LittleEndian -- ^ Less significant bytes first + | BigEndian -- ^ Most significant bytes first + deriving (Eq,Show,Enum) + +instance CEnum Endianness + +-- | Word getter +data WordGetters = WordGetters + { wordGetter8 :: Get Word8 -- ^ Read a Word8 + , wordGetter16 :: Get Word16 -- ^ Read a Word16 + , wordGetter32 :: Get Word32 -- ^ Read a Word32 + , wordGetter64 :: Get Word64 -- ^ Read a Word64 + } + +-- | Word putters +data WordPutters = WordPutters + { wordPutter8 :: Word8 -> Put -- ^ Write a Word8 + , wordPutter16 :: Word16 -> Put -- ^ Write a Word16 + , wordPutter32 :: Word32 -> Put -- ^ Write a Word32 + , wordPutter64 :: Word64 -> Put -- ^ Write a Word64 + } + +-- | Get getters for the given endianness +getWordGetters :: Endianness -> WordGetters +getWordGetters e = case e of + LittleEndian -> WordGetters getWord8 getWord16le getWord32le getWord64le + BigEndian -> WordGetters getWord8 getWord16be getWord32be getWord64be + +-- | Get putters for the given endianness +getWordPutters :: Endianness -> WordPutters +getWordPutters e = case e of + LittleEndian -> WordPutters putWord8 putWord16le putWord32le putWord64le + BigEndian -> WordPutters putWord8 putWord16be putWord32be putWord64be + + + +-- | Size of a machine word +data WordSize + = WordSize32 -- ^ 32-bit + | WordSize64 -- ^ 64-bit + deriving (Show, Eq) + +-- | Extended word getters +data ExtendedWordGetters = ExtendedWordGetters + { extwordGetter8 :: Get Word8 -- ^ Read a Word8 + , extwordGetter16 :: Get Word16 -- ^ Read a Word16 + , extwordGetter32 :: Get Word32 -- ^ Read a Word32 + , extwordGetter64 :: Get Word64 -- ^ Read a Word64 + , extwordGetterN :: Get Word64 -- ^ Read a native size word into a Word64 + } + +-- | Extended word putters +data ExtendedWordPutters = ExtendedWordPutters + { extwordPutter8 :: Word8 -> Put -- ^ Write a Word8 + , extwordPutter16 :: Word16 -> Put -- ^ Write a Word16 + , extwordPutter32 :: Word32 -> Put -- ^ Write a Word32 + , extwordPutter64 :: Word64 -> Put -- ^ Write a Word64 + , extwordPutterN :: Word64 -> Put -- ^ Write a Word64 into a native size word + } + +-- | Return extended getters +getExtendedWordGetters :: Endianness -> WordSize -> ExtendedWordGetters +getExtendedWordGetters endian ws = ExtendedWordGetters gw8 gw16 gw32 gw64 gwN + where + WordGetters gw8 gw16 gw32 gw64 = getWordGetters endian + gwN = case ws of + WordSize64 -> gw64 + WordSize32 -> fromIntegral <$> gw32 + +-- | Return extended putters +getExtendedWordPutters :: Endianness -> WordSize -> ExtendedWordPutters +getExtendedWordPutters endian ws = ExtendedWordPutters pw8 pw16 pw32 pw64 pwN + where + WordPutters pw8 pw16 pw32 pw64 = getWordPutters endian + pwN x = case ws of + WordSize64 -> pw64 x + WordSize32 -> if x > 0xffffffff + then error $ "Number too big to be stored in 32-bit word ("++show x++")" + else pw32 (fromIntegral x) + +-- | Detect the endianness of the host memory +getHostEndianness :: IO Endianness +getHostEndianness = do + -- Write a 32 bit word and check byte ordering + let magic = 0x01020304 :: Word32 + alloca $ \p -> do + poke p magic + rs <- peekArray 4 (castPtr p :: Ptr Word8) + return $ if rs == [1,2,3,4] then BigEndian else LittleEndian + +-- | Detected host endianness +-- +-- TODO: use targetByteOrder in GHC.ByteOrder (should be introduced in GHC 8.4) +hostEndianness :: Endianness +{-# NOINLINE hostEndianness #-} +hostEndianness = unsafePerformIO getHostEndianness + +-- | Reverse bytes in a word +class ByteReversable w where + reverseBytes :: w -> w + + hostToBigEndian :: w -> w + hostToBigEndian w = case hostEndianness of + BigEndian -> w + LittleEndian -> reverseBytes w + + bigEndianToHost :: w -> w + bigEndianToHost w = case hostEndianness of + BigEndian -> w + LittleEndian -> reverseBytes w + + + hostToLittleEndian :: w -> w + hostToLittleEndian w = case hostEndianness of + BigEndian -> reverseBytes w + LittleEndian -> w + + littleEndianToHost :: w -> w + littleEndianToHost w = case hostEndianness of + BigEndian -> reverseBytes w + LittleEndian -> w + +instance ByteReversable Word8 where + reverseBytes = id + +instance ByteReversable Word16 where + reverseBytes = byteSwap16 + +instance ByteReversable Word32 where + reverseBytes = byteSwap32 + +instance ByteReversable Word64 where + reverseBytes = byteSwap64 + + + +-- | Force a data to be read/stored as big-endian +newtype AsBigEndian a + = AsBigEndian a + deriving (Eq,Ord,Enum,Num,Integral,Real,Bitwise,FiniteBits,ReversableBits,RotatableBits,ShiftableBits,IndexableBits) + +instance Show a => Show (AsBigEndian a) where + show (AsBigEndian a) = show a + +-- | Force a data to be read/stored as little-endian +newtype AsLittleEndian a + = AsLittleEndian a + deriving (Eq,Ord,Enum,Num,Integral,Real,Bitwise,FiniteBits,ReversableBits,RotatableBits,ShiftableBits,IndexableBits) + +instance Show a => Show (AsLittleEndian a) where + show (AsLittleEndian a) = show a + +instance (ByteReversable a, StaticStorable a) => StaticStorable (AsBigEndian a) where + type SizeOf (AsBigEndian a) = SizeOf a + type Alignment (AsBigEndian a) = Alignment a + + staticPeekIO ptr = AsBigEndian . bigEndianToHost <$> staticPeek (castPtr ptr) + staticPokeIO ptr (AsBigEndian v) = staticPoke (castPtr ptr) (hostToBigEndian v) + + +instance (ByteReversable a, Storable a) => Storable (AsBigEndian a) where + sizeOf _ = sizeOfT @a + alignment _ = alignmentT @a + + peekIO ptr = AsBigEndian . bigEndianToHost <$> peek (castPtr ptr) + pokeIO ptr (AsBigEndian v) = poke (castPtr ptr) (hostToBigEndian v) + +instance (ByteReversable a, StaticStorable a) => StaticStorable (AsLittleEndian a) where + type SizeOf (AsLittleEndian a) = SizeOf a + type Alignment (AsLittleEndian a) = Alignment a + + staticPeekIO ptr = AsLittleEndian . bigEndianToHost <$> staticPeekIO (castPtr ptr) + staticPokeIO ptr (AsLittleEndian v) = staticPokeIO (castPtr ptr) (hostToLittleEndian v) + +instance (ByteReversable a, Storable a) => Storable (AsLittleEndian a) where + sizeOf _ = sizeOfT @a + alignment _ = alignmentT @a + + peekIO ptr = AsLittleEndian . bigEndianToHost <$> peek (castPtr ptr) + pokeIO ptr (AsLittleEndian v) = poke (castPtr ptr) (hostToLittleEndian v) diff --git a/src/lib/Haskus/Binary/Enum.hs b/src/lib/Haskus/Binary/Enum.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Enum.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} + +-- | Store an Enum in the given backing word type +module Haskus.Binary.Enum + ( EnumField + , CEnum (..) + , fromEnumField + , toEnumField + , makeEnum + , makeEnumMaybe + , makeEnumWithCustom + , dataToTag + ) +where + +import Haskus.Binary.Storable + +import Foreign.Ptr +import Data.Data +import GHC.Prim +import GHC.Int + +----------------------------------------------------------------------------- +-- EnumField b a: directly store the value of enum "a" as a "b" +----------------------------------------------------------------------------- + +-- | Store enum `a` as a `b` +newtype EnumField b a + = EnumField b + deriving (Show,Eq,Storable) + +instance + ( Integral b + , StaticStorable b + , CEnum a + ) => StaticStorable (EnumField b a) + where + type SizeOf (EnumField b a) = SizeOf b + type Alignment (EnumField b a) = Alignment b + staticPeekIO p = EnumField <$> staticPeek (castPtr p :: Ptr b) + staticPokeIO p (EnumField v) = staticPoke (castPtr p :: Ptr b) v + +-- | Read an enum field +fromEnumField :: (CEnum a, Integral b) => EnumField b a -> a +{-# INLINABLE fromEnumField #-} +fromEnumField (EnumField b) = toCEnum b + +-- | Create an enum field +toEnumField :: (CEnum a, Integral b) => a -> EnumField b a +{-# INLINABLE toEnumField #-} +toEnumField = EnumField . fromCEnum + + +----------------------------------------------------------------------------- +-- Extended Enum +----------------------------------------------------------------------------- + +-- | Extended Enum +-- +-- By default, use dataToTag and toEnum to convert from and to an Integral. +-- +-- But it can be overloaded to perform transformation before using +-- fromEnum/toEnum. E.g. if values are shifted by 1 compared to Enum values, +-- define fromCEnum = (+1) . fromIntegral . dataToTag +-- +class CEnum a where + fromCEnum :: Integral b => a -> b + fromCEnum = fromIntegral . dataToTag + + toCEnum :: Integral b => b -> a + default toCEnum :: (Enum a, Integral b) => b -> a + toCEnum = toEnum . fromIntegral + +-- | Make an enum with the last constructor taking a parameter for the rest of +-- the range +-- +-- @ +-- data T = A | B | C | D Word8 +-- +-- makeEnumWithCustom :: Int -> T +-- makeEnumWithCustom x = case x of +-- 0 -> A +-- 1 -> B +-- 2 -> C +-- n -> D (n - 3) +-- @ +-- +makeEnumWithCustom :: forall a i. (Data a,Integral i) => i -> a +{-# INLINABLE makeEnumWithCustom #-} +makeEnumWithCustom x = + if x' < maxConstrIndex t + then fromConstr (indexConstr t x') + else fromConstrB (fromConstr (toConstr (x' - m))) + (indexConstr t m) + where + m = maxConstrIndex t + x' = fromIntegral x + 1 + t = dataTypeOf (undefined :: a) + +-- | Make an enum with the last constructor taking a parameter for the rest of +-- the range, but don't build the last constructor +-- +-- @ +-- data T = A | B | C | D Word8 +-- +-- makeEnumMaybe :: Int -> T +-- makeEnumMaybe x = case x of +-- 0 -> Just A +-- 1 -> Just B +-- 2 -> Just C +-- n -> Nothing +-- @ +-- +makeEnumMaybe :: forall a i. (Data a,Integral i) => i -> Maybe a +{-# INLINABLE makeEnumMaybe #-} +makeEnumMaybe x = + if x' < maxConstrIndex t + then Just (fromConstr (indexConstr t x')) + else Nothing + where + x' = fromIntegral x + 1 + t = dataTypeOf (undefined :: a) + +-- | Make an enum from a number (0 indexed) +makeEnum :: forall a i. (Data a,Integral i) => i -> a +{-# INLINABLE makeEnum #-} +makeEnum x =fromConstr (indexConstr t x') + where + x' = fromIntegral x + 1 + t = dataTypeOf (undefined :: a) + + +-- | Retrieve data tag +-- +-- >>> data D = A | B | C +-- >>> dataToTag B +-- 1 +dataToTag :: a -> Int +dataToTag a = I# (dataToTag# a) diff --git a/src/lib/Haskus/Binary/Get.hs b/src/lib/Haskus/Binary/Get.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Get.hs @@ -0,0 +1,237 @@ +{-# lANGUAGE LambdaCase #-} + +-- | Get utilities +module Haskus.Binary.Get + ( Get + , runGet + , runGetOrFail + -- * Size & alignment + , isEmpty + , remaining + , skip + , uncheckedSkip + , skipAlign + , uncheckedSkipAlign + , countBytes + , alignAfter + -- * Isolation + , consumeExactly + , consumeAtMost + -- * Look-ahead + , lookAhead + , lookAheadM + , lookAheadE + -- * Read + , getRemaining + , getBuffer + , getBufferNul + , getWord8 + , getWord16le + , getWord16be + , getWord32le + , getWord32be + , getWord64le + , getWord64be + -- * Utilities + , getWhile + , getWhole + , getBitGet + , getManyAtMost + , getManyBounded + ) +where + +import qualified Data.Serialize.Get as BG +import Data.Serialize.Get (Get) + +import Haskus.Binary.Buffer +import Haskus.Number.Word +import Haskus.Binary.Bits.Order +import Haskus.Binary.Bits.Get (BitGet, runBitGetPartial, skipBitsToAlignOnWord8M, bitGetStateInput) +import Haskus.Utils.Maybe + + +-- | Test whether all input *in the current chunk* has been consumed +isEmpty :: Get Bool +isEmpty = BG.isEmpty + +-- | Get the number of remaining unparsed bytes *in the current chunk* +remaining :: Get Word +remaining = fromIntegral <$> BG.remaining + +-- | Skip ahead n bytes. Fails if fewer than n bytes are available. +skip :: Word -> Get () +skip = BG.skip . fromIntegral + +-- | Skip ahead n bytes. No error if there isn't enough bytes. +uncheckedSkip :: Word -> Get () +uncheckedSkip = BG.uncheckedSkip . fromIntegral + +-- | Skip to align n to al. Fails if fewer than n bytes are available. +skipAlign :: Word -> Word -> Get () +skipAlign n al = skip n' + where + n' = case n `mod` al of + 0 -> 0 + x -> al - fromIntegral x + +-- | Skip to align n to al. Fails if fewer than n bytes are available. +uncheckedSkipAlign :: Word -> Word -> Get () +uncheckedSkipAlign n al = uncheckedSkip n' + where + n' = case n `mod` al of + 0 -> 0 + x -> al - fromIntegral x + +-- | Run the getter without consuming its input. Fails if it fails +lookAhead :: Get a -> Get a +lookAhead = BG.lookAhead + +-- | Run the getter. Consume its input if Just _ returned. Fails if it fails +lookAheadM :: Get (Maybe a) -> Get (Maybe a) +lookAheadM = BG.lookAheadM + +-- | Run the getter. Consume its input if Right _ returned. Fails if it fails +lookAheadE :: Get (Either a b) -> Get (Either a b) +lookAheadE = BG.lookAheadE + +-- | Require an action to consume exactly the given number of bytes, fail +-- otherwise +consumeExactly :: Word -> Get a -> Get a +consumeExactly sz = BG.isolate (fromIntegral sz) + +-- | Require an action to consume at most the given number of bytes, fail +-- otherwise +consumeAtMost :: Word -> Get a -> Get a +consumeAtMost sz f = do + sz' <- remaining + (r,res) <- BG.lookAhead $ BG.isolate (fromIntegral (min sz sz')) $ do + res <- f + r <- remaining + skip r -- skip remaining bytes, to make isolate happy + return (r,res) + skip (min sz' sz - r) + return res + +-- | Pull n bytes from the input, as a Buffer +getBuffer :: Word -> Get Buffer +getBuffer sz = Buffer <$> BG.getBytes (fromIntegral sz) + +-- | Get Word8 +getWord8 :: Get Word8 +getWord8 = BG.getWord8 + +-- | Get Word16 little-endian +getWord16le :: Get Word16 +getWord16le = BG.getWord16le + +-- | Get Word16 big-endian +getWord16be :: Get Word16 +getWord16be = BG.getWord16be + +-- | Get Word32 little-endian +getWord32le :: Get Word32 +getWord32le = BG.getWord32le + +-- | Get Word32 big-endian +getWord32be :: Get Word32 +getWord32be = BG.getWord32be + +-- | Get Word64 little-endian +getWord64le :: Get Word64 +getWord64le = BG.getWord64le + +-- | Get Word64 big-endian +getWord64be :: Get Word64 +getWord64be = BG.getWord64be + +-- | Get while True (read and discard the ending element) +getWhile :: (a -> Bool) -> Get a -> Get [a] +getWhile cond getter = rec [] + where + rec xs = do + x <- getter + if cond x + then rec (x:xs) + else return (reverse xs) + +-- | Repeat the getter to read the whole bytestring +getWhole :: Get a -> Get [a] +getWhole getter = rec [] + where + rec xs = do + cond <- isEmpty + if cond + then return (reverse xs) + else do + x <- getter + rec (x:xs) + +-- | Get remaining bytes +getRemaining :: Get Buffer +getRemaining = do + r <- remaining + getBuffer r + + +-- | Count the number of bytes consumed by a getter +countBytes :: Get a -> Get (Word, a) +countBytes g = do + cnt0 <- remaining + r <- g + cnt1 <- remaining + return (cnt0 - cnt1, r) + +-- | Execute the getter and align on the given number of Word8 +alignAfter :: Word -> Get a -> Get a +alignAfter alignment getter = do + (cnt,r) <- countBytes getter + uncheckedSkipAlign cnt alignment + return r + +-- | Get Buffer terminated with \0 (consume \0) +getBufferNul :: Get Buffer +getBufferNul = do + bs <- lookAhead getRemaining + let v = bufferTakeWhile (/= 0) bs + uncheckedSkip (bufferSize v + 1) + return v + +-- | Run the Get monad +runGet :: Get a -> Buffer -> Either String a +runGet g (Buffer bs) = BG.runGet g bs + +-- | Run a getter and throw an exception on error +runGetOrFail :: Get a -> Buffer -> a +runGetOrFail g bs = case runGet g bs of + Left err -> error err + Right x -> x + + +-- | Get bits from a BitGet. +-- +-- Discard last bits to align on a Word8 boundary +-- +-- FIXME: we use a continuation because Data.Serialize.Get doesn't export "put" +getBitGet :: BitOrder -> BitGet a -> (a -> Get b) -> Get b +getBitGet bo bg cont = do + bs <- getRemaining + let (v,s) = runBitGetPartial bo (bg <* skipBitsToAlignOnWord8M) bs + return $ runGetOrFail (cont v) (bitGetStateInput s) + +-- | Apply the getter at most 'max' times +getManyAtMost :: Word -> Get (Maybe a) -> Get [a] +getManyAtMost mx f = fromMaybe [] <$> getManyBounded Nothing (Just mx) f + +-- | Apply the getter at least 'min' times and at most 'max' times +getManyBounded :: Maybe Word -> Maybe Word -> Get (Maybe a) -> Get (Maybe [a]) +getManyBounded _ (Just 0) _ = return (Just []) +getManyBounded (Just 0) mx f = getManyBounded Nothing mx f +getManyBounded mn mx f = lookAheadM $ f >>= \case + Nothing -> case mn of + Just n | n > 0 -> return Nothing + _ -> return (Just []) + Just x -> fmap (x:) <$> getManyBounded (minus1 mn) (minus1 mx) f + where + minus1 = fmap (\k -> k - 1) + diff --git a/src/lib/Haskus/Binary/Put.hs b/src/lib/Haskus/Binary/Put.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Put.hs @@ -0,0 +1,89 @@ +-- | Put monad +-- +-- FIXME: PutM uses slow ByteString builder... We need to replace it with a +-- fast one +module Haskus.Binary.Put + ( Put + , PutM + , runPut + , runPutM + -- * Put + , putBuffer + , putByteString + , putPadding + , putPaddingAlign + , putWord8 + , putWord16le + , putWord16be + , putWord32le + , putWord32be + , putWord64le + , putWord64be + ) +where + +import qualified Data.ByteString as BS +import qualified Data.Serialize.Put as BP +import Data.Serialize.Put (Put,PutM) +import Data.Bifunctor + +import Haskus.Utils.Flow (replicateM_) +import Haskus.Binary.Buffer +import Haskus.Number.Word + +-- | Execute Put +runPut :: Put -> Buffer +runPut = Buffer . BP.runPut + +-- | Execute PutM +runPutM :: PutM a -> (a,Buffer) +runPutM = second Buffer . BP.runPutM + + +-- | Put a buffer +putBuffer :: Buffer -> Put +putBuffer (Buffer bs) = BP.putByteString bs + +-- | Put a ByteString +putByteString :: BS.ByteString -> Put +putByteString = BP.putByteString + +-- | Put null bytes +putPadding :: Word -> Put +putPadding n = replicateM_ (fromIntegral n) (BP.putWord8 0x00) + +-- | Put null bytes to align the given value to the second +putPaddingAlign :: Word -> Word -> Put +putPaddingAlign n al = putPadding n' + where + n' = case n `mod` al of + 0 -> 0 + x -> al - fromIntegral x + +-- | Put a Word8 +putWord8 :: Word8 -> Put +putWord8 = BP.putWord8 + +-- | Put a Word16 little-endian +putWord16le :: Word16 -> Put +putWord16le = BP.putWord16le + +-- | Put a Word16 big-endian +putWord16be :: Word16 -> Put +putWord16be = BP.putWord16be + +-- | Put a Word32 little-endian +putWord32le :: Word32 -> Put +putWord32le = BP.putWord32le + +-- | Put a Word32 big-endian +putWord32be :: Word32 -> Put +putWord32be = BP.putWord32be + +-- | Put a Word64 little-endian +putWord64le :: Word64 -> Put +putWord64le = BP.putWord64le + +-- | Put a Word64 big-endian +putWord64be :: Word64 -> Put +putWord64be = BP.putWord64be diff --git a/src/lib/Haskus/Binary/Record.hs b/src/lib/Haskus/Binary/Record.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/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.Binary.Record + ( Record + , Field + , RecordSize + , Alignment + , Path + , recordSize + , recordAlignment + , recordField + , recordFieldOffset + , recordFieldPath + , recordFieldPathOffset + , recordToList + ) +where + +import System.IO.Unsafe +import Foreign.ForeignPtr +import Foreign.Ptr + +import Haskus.Memory.Utils +import Haskus.Binary.Storable +import Haskus.Utils.HList +import Haskus.Utils.Types + +-- | Record +newtype Record (fields :: [*]) = Record (ForeignPtr ()) + +-- | Field +data Field (name :: Symbol) typ + +-- | Get record size without the ending padding bytes +type family RecordSize (fs :: [*]) (sz :: Nat) where + RecordSize '[] sz = sz + RecordSize (Field name typ ': fs) sz = + RecordSize fs + (sz + -- padding bytes + + Padding sz typ + -- field size + + SizeOf typ + ) + +type family FieldOffset (name :: Symbol) (fs :: [*]) (sz :: Nat) where + -- Found + FieldOffset name (Field name typ ': fs) sz = + sz + Padding sz typ + -- Not found yet + FieldOffset name (Field xx typ ': fs) sz = + FieldOffset name fs + (sz + Padding sz typ + SizeOf typ) + +type family FieldType (name :: Symbol) (fs :: [*]) where + FieldType name (Field name typ ': fs) = typ + FieldType name (Field xx typ ': fs) = FieldType name fs + +-- | Record size (with ending padding bytes) +type family FullRecordSize fs where + FullRecordSize fs = + RecordSize fs 0 + + PaddingEx (Mod (RecordSize fs 0) (RecordAlignment fs 1)) + (RecordAlignment fs 1) + +-- | Record alignment +type family RecordAlignment (fs :: [*]) a where + RecordAlignment '[] a = a + RecordAlignment (Field name typ ': fs) a = + RecordAlignment fs + (If (a <=? Alignment typ) (Alignment typ) a) + +-- | Return offset from a field path +type family FieldPathOffset (fs :: [*]) (path :: [Symbol]) (off :: Nat) where + FieldPathOffset fs '[p] off = off + FieldOffset p fs 0 + FieldPathOffset fs (p ': ps) off + = FieldPathOffset (ExtractRecord (FieldType p fs)) + ps (off + FieldOffset p fs 0) + +-- | Return type from a field path +type family FieldPathType (fs :: [*]) (path :: [Symbol]) where + FieldPathType fs '[p] = FieldType p fs + + FieldPathType fs (p ': ps) + = FieldPathType (ExtractRecord (FieldType p fs)) ps + +type family ExtractRecord x where + ExtractRecord (Record fs) = fs + +-- | Get record size +recordSize :: forall fs. + ( KnownNat (FullRecordSize fs) + ) => Record fs -> Word +recordSize _ = natValue' @(FullRecordSize fs) + +-- | Get record alignment +recordAlignment :: forall fs. + ( KnownNat (RecordAlignment fs 1) + ) => Record fs -> Word +recordAlignment _ = natValue' @(RecordAlignment fs 1) + +-- | Get a field offset +recordFieldOffset :: forall (name :: Symbol) fs. + ( KnownNat (FieldOffset name fs 0) + ) => Record fs -> Int +recordFieldOffset _ = natValue @(FieldOffset name fs 0) + +-- | Get a field +recordField :: forall (name :: Symbol) a fs. + ( KnownNat (FieldOffset name fs 0) + , a ~ FieldType name fs + , StaticStorable a + ) => Record fs -> a +recordField r@(Record fp) = unsafePerformIO $ + withForeignPtr fp $ \ptr ->do + let ptr' = ptr `plusPtr` recordFieldOffset @name r + staticPeek (castPtr ptr') + +data Path (fs :: [Symbol]) + +-- | Get a field offset from its path +recordFieldPathOffset :: forall path fs o. + ( o ~ FieldPathOffset fs path 0 + , KnownNat o + ) => Path path -> Record fs -> Int +recordFieldPathOffset _ _ = natValue @o + +-- | Get a field from its path +recordFieldPath :: forall path a fs o. + ( o ~ FieldPathOffset fs path 0 + , a ~ FieldPathType fs path + , KnownNat o + , StaticStorable a + ) => Path path -> Record fs -> a +recordFieldPath _ (Record fp) = unsafePerformIO $ + withForeignPtr fp $ \ptr -> do + let + ptr' = ptr `plusPtr` natValue @o + staticPeek (castPtr ptr') + + +instance forall fs s. + ( s ~ FullRecordSize fs + , KnownNat s + ) + => StaticStorable (Record fs) + where + type SizeOf (Record fs) = FullRecordSize fs + type Alignment (Record fs) = RecordAlignment fs 1 + + staticPeekIO ptr = do + let sz = recordSize (undefined :: Record fs) + fp <- mallocForeignPtrBytes (fromIntegral sz) + withForeignPtr fp $ \p -> + memCopy p ptr (fromIntegral sz) + return (Record fp) + + staticPokeIO ptr (Record fp) = do + let sz = recordSize (undefined :: Record fs) + withForeignPtr fp $ \p -> + memCopy ptr p (fromIntegral sz) + + +data Extract = Extract + +instance forall fs typ name rec b l2 i r. + ( rec ~ Record fs -- the record + , b ~ Field name typ -- the current field + , i ~ (rec, HList l2) -- input type + , typ ~ FieldType name fs + , KnownNat (FieldOffset name fs 0) + , StaticStorable typ + , KnownSymbol name + , r ~ (rec, HList ((String,typ) ': l2)) -- result type + ) => Apply Extract (b, i) r where + apply _ (_, (rec,xs)) = + (rec, HCons (symbolValue @name, recordField @name rec) xs) + +-- | Convert a record into a HList +recordToList :: forall fs. + ( HFoldr' Extract (Record fs, HList '[]) fs (Record fs, HList fs) + ) => Record fs -> HList fs +recordToList rec = snd res + where + res :: (Record fs, HList fs) + res = hFoldr' Extract ((rec,HNil) :: (Record fs, HList '[])) (undefined :: HList fs) + + +instance forall fs. + ( HFoldr' Extract (Record fs, HList '[]) fs (Record fs, HList fs) + , Show (HList fs) + ) + => Show (Record fs) + where + show rec = show (recordToList rec :: HList fs) diff --git a/src/lib/Haskus/Binary/Serialize.hs b/src/lib/Haskus/Binary/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Serialize.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Binary serialization of Haskell values +module Haskus.Binary.Serialize + ( Serializable (..) + , Size (..) + ) +where + +import Haskus.Binary.Serialize.Put +import Haskus.Binary.Serialize.Size +import Haskus.Binary.Serialize.Get +import Haskus.Number.Word +import Haskus.Number.Int +import Haskus.Binary.Endianness +import Haskus.Utils.Types + +-- | Size in bytes +data Size + = Exactly Nat -- ^ Exactly the given size + | Dynamic -- ^ Dynamically known size (the size is stored with the object) + +-- | Binary serializable data +class Serializable a where + + -- | Size of the data in bytes + type SizeOf a :: Size + + -- | Sensible to endianness + type Endian a :: Bool + + -- | Dynamic size of the data in bytes + -- + -- The default implementation execute the put method with a PutMonad that + -- only stores the size in bytes. Overload this function if possible! + sizeOf :: a -> Word + sizeOf a = runGetSize (put LittleEndian a) + + -- | Serialize a value + put :: PutMonad m => Endianness -> a -> m () + + -- | Deserialize a value + get :: GetMonad m => Endianness -> m a + +-------------------------------------------- +-- Instances +-------------------------------------------- + +instance Serializable Word8 where + type SizeOf Word8 = 'Exactly 1 + type Endian Word8 = 'False + sizeOf _ = 1 + put _ x = putWord8 x + get _ = getWord8 + +instance Serializable Word16 where + type SizeOf Word16 = 'Exactly 2 + type Endian Word16 = 'True + sizeOf _ = 2 + put LittleEndian x = putWord16LE x + put BigEndian x = putWord16BE x + get LittleEndian = getWord16LE + get BigEndian = getWord16BE + +instance Serializable Word32 where + type SizeOf Word32 = 'Exactly 4 + type Endian Word32 = 'True + sizeOf _ = 4 + put LittleEndian x = putWord32LE x + put BigEndian x = putWord32BE x + get LittleEndian = getWord32LE + get BigEndian = getWord32BE + +instance Serializable Word64 where + type SizeOf Word64 = 'Exactly 8 + type Endian Word64 = 'True + sizeOf _ = 8 + put LittleEndian x = putWord64LE x + put BigEndian x = putWord64BE x + get LittleEndian = getWord64LE + get BigEndian = getWord64BE + +instance Serializable Int8 where + type SizeOf Int8 = 'Exactly 1 + type Endian Int8 = 'False + sizeOf _ = 1 + put _ x = putWord8 (fromIntegral x) + get _ = fromIntegral <$> getWord8 + +instance Serializable Int16 where + type SizeOf Int16 = 'Exactly 2 + type Endian Int16 = 'True + sizeOf _ = 2 + put LittleEndian x = putWord16LE (fromIntegral x) + put BigEndian x = putWord16BE (fromIntegral x) + get LittleEndian = fromIntegral <$> getWord16LE + get BigEndian = fromIntegral <$> getWord16BE + +instance Serializable Int32 where + type SizeOf Int32 = 'Exactly 4 + type Endian Int32 = 'True + sizeOf _ = 4 + put LittleEndian x = putWord32LE (fromIntegral x) + put BigEndian x = putWord32BE (fromIntegral x) + get LittleEndian = fromIntegral <$> getWord32LE + get BigEndian = fromIntegral <$> getWord32BE + +instance Serializable Int64 where + type SizeOf Int64 = 'Exactly 8 + type Endian Int64 = 'True + sizeOf _ = 8 + put LittleEndian x = putWord64LE (fromIntegral x) + put BigEndian x = putWord64BE (fromIntegral x) + get LittleEndian = fromIntegral <$> getWord64LE + get BigEndian = fromIntegral <$> getWord64BE + +instance Serializable a => Serializable (AsBigEndian a) where + type SizeOf (AsBigEndian a) = SizeOf a + type Endian (AsBigEndian a) = 'False + sizeOf (AsBigEndian b) = sizeOf b + put _ (AsBigEndian x) = put BigEndian x + get _ = AsBigEndian <$> get BigEndian + +instance Serializable a => Serializable (AsLittleEndian a) where + type SizeOf (AsLittleEndian a) = SizeOf a + type Endian (AsLittleEndian a) = 'False + sizeOf (AsLittleEndian b) = sizeOf b + put _ (AsLittleEndian x) = put LittleEndian x + get _ = AsLittleEndian <$> get LittleEndian diff --git a/src/lib/Haskus/Binary/Serialize/Buffer.hs b/src/lib/Haskus/Binary/Serialize/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Serialize/Buffer.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} + +-- | Serializer into a mutable buffer +-- +-- >>> let w = do putWord8 0x01 ; putWord32BE 0x23456789 ; putWord32BE 0xAABBCCDD +-- >>> b <- newBuffer 10 +-- >>> void $ runBufferPut b 0 overflowBufferFail w +-- >>> xs <- forM [0..4] (bufferReadWord8IO b) +-- >>> xs == [0x01,0x23,0x45,0x67,0x89] +-- True +-- +-- >>> b <- newBuffer 2 -- small buffer +-- >>> (_,b',_) <- runBufferPut b 0 overflowBufferDouble w +-- >>> xs <- forM [0..4] (bufferReadWord8IO b') +-- >>> xs == [0x01,0x23,0x45,0x67,0x89] +-- True +-- >>> bufferSizeIO b' +-- 16 +-- +module Haskus.Binary.Serialize.Buffer + ( -- * Put + BufferPutT (..) + , BufferPut + , getPutOffset + , getPutBuffer + , setPutOffset + , runBufferPut + , liftBufferPut + -- * Get + , BufferGetT (..) + , BufferGet + , getGetOffset + , getGetBuffer + , setGetOffset + , runBufferGet + , liftBufferGet + -- * Buffer overflow + , OverflowStrategy (..) + , BufferOverflow (..) + , getPutOverflowStrategy + , getGetOverflowStrategy + , overflowBufferFail + , overflowBufferDouble + , overflowBufferDoublePinned + , overflowBufferAdd + , overflowBufferAddPinned + ) +where + +import Haskus.Binary.Serialize.Put +import Haskus.Binary.Serialize.Get +import Haskus.Memory.Buffer +import Haskus.Utils.Monad +import Haskus.Utils.Flow +import Haskus.Utils.Maybe + +import Data.Functor.Identity +import Control.Monad.Trans.State.Strict as S +import Control.Monad.Fail as F +import Control.Monad.Fix + +-- | Action to perform when the buffer isn't large enough to contain the +-- required data (extend the buffer, flush the data, etc.) +-- +-- The returned buffer and offset replace the current ones. +newtype OverflowStrategy m b = OverflowStrategy (BufferOverflow b -> m (b,Word)) + +-- | Buffer overflow strategy: fails when there isn't enough space left +overflowBufferFail :: MonadFail m => OverflowStrategy m b +overflowBufferFail = OverflowStrategy \ex -> do + F.fail $ "Not enough space in the buffer (requiring " + ++ show (overflowRequired ex) ++ " bytes)" + +-- | Buffer extend strategy: double the buffer size each time and copy the +-- original contents in it +overflowBufferDouble :: MonadIO m => OverflowStrategy m BufferM +overflowBufferDouble = OverflowStrategy \ex -> do + sz <- bufferSizeIO (overflowBuffer ex) + let off = overflowOffset ex + req = overflowRequired ex + b = overflowBuffer ex + makeSzs i = i*i : makeSzs (i*i) -- infinite list of doubling sizes + newSz = head <| filter (> req+off) (makeSzs sz) + newB <- newBuffer newSz + copyBuffer b 0 newB 0 off + pure (newB,off) + +-- | Buffer extend strategy: double the buffer size each time and copy the +-- original contents in it +overflowBufferDoublePinned :: MonadIO m => Maybe Word -> OverflowStrategy m BufferMP +overflowBufferDoublePinned malignment = OverflowStrategy \ex -> do + sz <- bufferSizeIO (overflowBuffer ex) + let off = overflowOffset ex + req = overflowRequired ex + b = overflowBuffer ex + makeSzs i = i*i : makeSzs (i*i) -- infinite list of doubling sizes + newSz = head <| filter (> req+off) (makeSzs sz) + newB <- case malignment of + Nothing -> newPinnedBuffer newSz + Just al -> newAlignedPinnedBuffer newSz al + copyBuffer b 0 newB 0 off + pure (newB,off) + +-- | Buffer extend strategy: add the given size each time and copy the +-- original contents in it +overflowBufferAdd :: MonadIO m => Word -> OverflowStrategy m BufferM +overflowBufferAdd addSz = OverflowStrategy \ex -> do + sz <- bufferSizeIO (overflowBuffer ex) + let off = overflowOffset ex + req = overflowRequired ex + b = overflowBuffer ex + makeSzs i = i+addSz : makeSzs (i+addSz) -- infinite list of added sizes + newSz = head <| filter (> req+off) (makeSzs sz) + newB <- newBuffer newSz + copyBuffer b 0 newB 0 off + pure (newB,off) + +-- | Buffer extend strategy: add the given size each time and copy the +-- original contents in it +overflowBufferAddPinned :: MonadIO m => Maybe Word -> Word -> OverflowStrategy m BufferMP +overflowBufferAddPinned malignment addSz = OverflowStrategy \ex -> do + sz <- bufferSizeIO (overflowBuffer ex) + let off = overflowOffset ex + req = overflowRequired ex + b = overflowBuffer ex + makeSzs i = i+addSz : makeSzs (i+addSz) -- infinite list of added sizes + newSz = head <| filter (> req+off) (makeSzs sz) + newB <- case malignment of + Nothing -> newPinnedBuffer newSz + Just al -> newAlignedPinnedBuffer newSz al + copyBuffer b 0 newB 0 off + pure (newB,off) + + + +-- | Buffer extension information +data BufferOverflow b = BufferOverflow + { overflowBuffer :: b -- ^ Current buffer + , overflowOffset :: Word -- ^ Current offset in buffer + , overflowRequired :: Word -- ^ Required size in bytes (don't take into account leftover bytes in the current buffer) + } + +---------------------------------------------------------------------- +-- BufferPut +---------------------------------------------------------------------- + +-- | BufferPutT state +data BufferPutState m b = BufferPutState + { bufferPutBuffer :: !b -- ^ Buffer used for writing + , bufferPutOffset :: !Word -- ^ Current offset + , bufferPutStrat :: !(OverflowStrategy m b) -- ^ Extension strategy + } + +-- | A Put monad than fails when there is not enough space in the target buffer +newtype BufferPutT b m a + = BufferPutT (StateT (BufferPutState m b) m a) + deriving newtype (Functor, Applicative, Monad, MonadFail, MonadFix, MonadIO) + +type BufferPut b a = BufferPutT b Identity a + +-- | Lift into BufferPutT +liftBufferPut :: Monad m => m a -> BufferPutT b m a +liftBufferPut act = BufferPutT (lift act) + +-- | Run a buffer put +runBufferPut :: Monad m => b -> Word -> OverflowStrategy m b -> BufferPutT b m a -> m (a,b,Word) +runBufferPut b off strat (BufferPutT s) = do + (a,s') <- runStateT s (BufferPutState b off strat) + return (a,bufferPutBuffer s',bufferPutOffset s') + +-- | Get current offset +getPutOffset :: Monad m => BufferPutT b m Word +getPutOffset = BufferPutT (bufferPutOffset <$> S.get) + +-- | Get buffer +getPutBuffer :: Monad m => BufferPutT b m b +getPutBuffer = BufferPutT (bufferPutBuffer <$> S.get) + +-- | Set buffer +setPutBuffer :: Monad m => b -> BufferPutT b m () +setPutBuffer v = BufferPutT do + S.modify \s -> s { bufferPutBuffer = v } + + +-- | Get current offset +setPutOffset :: Monad m => Word -> BufferPutT b m () +setPutOffset v = BufferPutT do + S.modify \s -> s { bufferPutOffset = v } + +-- | Get extend strategy +getPutOverflowStrategy :: Monad m => BufferPutT b m (OverflowStrategy m b) +getPutOverflowStrategy = BufferPutT (bufferPutStrat <$> S.get) + + +-- | Helper to put something +putSomething + :: MonadIO m + => Word + -> (Buffer 'Mutable pin fin heap -> Word -> t -> m ()) + -> t + -> BufferPutT (Buffer 'Mutable pin fin heap) m () +{-# INLINABLE putSomething #-} +putSomething sz act v = putSomeThings sz $ Just \b off -> act b off v + +-- | Helper to put some things +putSomeThings + :: MonadIO m + => Word + -> Maybe (Buffer 'Mutable pin fin heap -> Word -> m ()) + -> BufferPutT (Buffer 'Mutable pin fin heap) m () +{-# INLINABLE putSomeThings #-} +putSomeThings sz mact = do + off <- getPutOffset + b <- getPutBuffer + bs <- liftIO (bufferSizeIO b) + let !newOff = off+sz + + if (newOff > bs) + then do -- we need to extend/flush the buffer + OverflowStrategy strat <- getPutOverflowStrategy + (upB,upOff) <- liftBufferPut <| strat <| BufferOverflow + { overflowBuffer = b + , overflowOffset = off + , overflowRequired = sz + } + setPutBuffer upB + setPutOffset upOff + putSomeThings sz mact + + else case mact of + Nothing -> return () -- we only preallocate + Just act -> do -- we write something for real + liftBufferPut (act b off) + setPutOffset newOff + + +instance + ( MonadIO m + ) => PutMonad (BufferPutT (Buffer 'Mutable pin gc heap) m) + where + putWord8 = putSomething 1 bufferWriteWord8IO + putWord16 = putSomething 2 bufferWriteWord16IO + putWord32 = putSomething 4 bufferWriteWord32IO + putWord64 = putSomething 8 bufferWriteWord64IO + + putWord8s xs = putSomeThings (fromIntegral (length xs)) $ Just \b off -> do + forM_ ([off,(off+1)..] `zip` xs) $ \(boff,v) -> do + bufferWriteWord8IO b boff v + + putWord16s xs = putSomeThings (2*fromIntegral (length xs)) $ Just \b off -> do + forM_ ([off,(off+2)..] `zip` xs) $ \(boff,v) -> do + bufferWriteWord16IO b boff v + + putWord32s xs = putSomeThings (4*fromIntegral (length xs)) $ Just \b off -> do + forM_ ([off,(off+4)..] `zip` xs) $ \(boff,v) -> do + bufferWriteWord32IO b boff v + + putWord64s xs = putSomeThings (8*fromIntegral (length xs)) $ Just \b off -> do + forM_ ([off,(off+8)..] `zip` xs) $ \(boff,v) -> do + bufferWriteWord64IO b boff v + + preAllocateAtLeast l = putSomeThings l Nothing + + putBuffer x = do + sz <- liftIO (bufferSizeIO x) + putSomeThings sz $ Just \b off -> copyBuffer x 0 b off sz + +---------------------------------------------------------------------- +-- BufferGet +---------------------------------------------------------------------- + +-- | BufferGetT state +data BufferGetState m b = BufferGetState + { bufferGetBuffer :: !b -- ^ Buffer used for reading + , bufferGetOffset :: !Word -- ^ Current offset + , bufferGetStrat :: !(OverflowStrategy m b) -- ^ Extension stretegy + } + +-- | A Get monad over a Buffer +newtype BufferGetT b m a + = BufferGetT (StateT (BufferGetState m b) m a) + deriving newtype (Functor, Applicative, Monad, MonadFail, MonadFix, MonadIO) + +type BufferGet b a = BufferGetT b Identity a + +instance + ( MonadIO m + ) => GetMonad (BufferGetT (Buffer mut pin gc heap) m) + where + getSkipBytes n = getSomething n \_ _ -> return () + getWord8 = getSomething 1 bufferReadWord8IO + getWord16 = getSomething 2 bufferReadWord16IO + getWord32 = getSomething 4 bufferReadWord32IO + getWord64 = getSomething 8 bufferReadWord64IO + getBuffer sz = getSomething sz \b off -> do + dest <- newBuffer sz + copyBuffer b off dest 0 sz + unsafeBufferFreeze dest + getBufferInto sz dest mdoff = getSomething sz \b off -> do + copyBuffer b off dest (fromMaybe 0 mdoff) sz + +-- | Lift into BufferGetT +liftBufferGet :: Monad m => m a -> BufferGetT b m a +liftBufferGet act = BufferGetT (lift act) + +-- | Run a buffer get +runBufferGet :: Monad m => b -> Word -> OverflowStrategy m b -> BufferGetT b m a -> m (a,b,Word) +runBufferGet b off strat (BufferGetT s) = do + (a,s') <- runStateT s (BufferGetState b off strat) + return (a,bufferGetBuffer s',bufferGetOffset s') + +-- | Get current offset +getGetOffset :: Monad m => BufferGetT b m Word +getGetOffset = BufferGetT (bufferGetOffset <$> S.get) + +-- | Get buffer +getGetBuffer :: Monad m => BufferGetT b m b +getGetBuffer = BufferGetT (bufferGetBuffer <$> S.get) + +-- | Set buffer +setGetBuffer :: Monad m => b -> BufferGetT b m () +setGetBuffer v = BufferGetT do + S.modify \s -> s { bufferGetBuffer = v } + + +-- | Get current offset +setGetOffset :: Monad m => Word -> BufferGetT b m () +setGetOffset v = BufferGetT do + S.modify \s -> s { bufferGetOffset = v } + +-- | Get extend strategy +getGetOverflowStrategy :: Monad m => BufferGetT b m (OverflowStrategy m b) +getGetOverflowStrategy = BufferGetT (bufferGetStrat <$> S.get) + +-- | Helper to get some things +getSomething :: + ( Monad m + , MonadIO m + ) => Word + -> (Buffer mut pin gc heap -> Word -> m a) + -> BufferGetT (Buffer mut pin gc heap) m a +getSomething sz act = do + off <- getGetOffset + b <- getGetBuffer + bsz <- bufferSizeIO b + + let !newOff = off+sz + + if newOff > bsz + then do -- we need to extend the buffer or fail + OverflowStrategy strat <- getGetOverflowStrategy + (upB,upOff) <- liftBufferGet <| strat <| BufferOverflow + { overflowBuffer = b + , overflowOffset = off + , overflowRequired = sz + } + setGetBuffer upB + setGetOffset upOff + getSomething sz act + + else do + setGetOffset newOff + liftBufferGet (act b off) diff --git a/src/lib/Haskus/Binary/Serialize/File.hs b/src/lib/Haskus/Binary/Serialize/File.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Serialize/File.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Haskus.Binary.Serialize.File + ( FileGetState (..) + , FileGetT (..) + , runFileGet + , runFilePathGet + ) +where + +import Haskus.Binary.Serialize.Get +import Haskus.Binary.Storable +import Haskus.Memory.Buffer +import Haskus.Utils.Monad +import Haskus.Utils.Maybe + +import GHC.Exts (Ptr (..)) +import System.IO +import Control.Monad.Trans.State.Strict as S +import Control.Monad.Fail as F +import Control.Monad.Fix + +-- | FileGetT state +data FileGetState = FileGetState + { fileGetHandle :: !Handle + } + +-- | A Get monad over a File +newtype FileGetT m a + = FileGetT (StateT FileGetState m a) + deriving newtype (Functor, Applicative, Monad, MonadFail, MonadFix, MonadIO) + +-- | Get file handle +getHandle :: Monad m => FileGetT m (Handle) +getHandle = FileGetT (gets fileGetHandle) + +-- | Helper to get some things +getSomething :: forall a m. + ( MonadIO m + ) => Word -> (Ptr a -> IO a) -> FileGetT m a +getSomething sz act = do + hdl <- getHandle + liftIO $ allocaBytes sz \p -> do + -- FIXME: handle EOF + _n <- hGetBuf hdl p (fromIntegral sz) + act p + + +instance (MonadIO m) => GetMonad (FileGetT m) where + getSkipBytes n = do + hdl <- getHandle + liftIO $ hSeek hdl RelativeSeek (fromIntegral n) + + getWord8 = getSomething 1 peek + getWord16 = getSomething 2 peek + getWord32 = getSomething 4 peek + getWord64 = getSomething 8 peek + + getBufferInto sz dest mdoff = getSomething sz \(Ptr addr) -> do + let b = BufferE addr sz + copyBuffer b 0 dest (fromMaybe 0 mdoff) sz + + +-- | Run a getter on a file +runFileGet :: Handle -> FileGetT IO a -> IO a +runFileGet hdl (FileGetT s) = do + (a,_s') <- runStateT s (FileGetState hdl) + return a + +-- | Run a getter on a file +runFilePathGet :: FilePath -> FileGetT IO a -> IO a +runFilePathGet path s = withBinaryFile path ReadMode (\hdl -> runFileGet hdl s) diff --git a/src/lib/Haskus/Binary/Serialize/Get.hs b/src/lib/Haskus/Binary/Serialize/Get.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Serialize/Get.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Binary deserialization of Haskell values +module Haskus.Binary.Serialize.Get + ( GetMonad (..) + , getFloat32 + , getFloat32LE + , getFloat32BE + , getFloat64 + , getFloat64LE + , getFloat64BE + , getWord16BE + , getWord32BE + , getWord64BE + , getWord16LE + , getWord32LE + , getWord64LE + , getWord16BEs + , getWord32BEs + , getWord64BEs + , getWord16LEs + , getWord32LEs + , getWord64LEs + ) +where + +import Haskus.Memory.Buffer +import Haskus.Number.Word +import Haskus.Binary.Endianness +import Haskus.Number.Float +import Haskus.Utils.Flow + +import GHC.Exts (IsList(..)) + + +-- | Monad which can read a sequence of bytes +class Monad m => GetMonad m where + -- | Read a Word8 + getWord8 :: m Word8 + -- | Read a Word16 with host endianness + getWord16 :: m Word16 + -- | Read a Word32 with host endianness + getWord32 :: m Word32 + -- | Read a Word64 with host endianness + getWord64 :: m Word64 + + -- | Read some Word8 + getWord8s :: Word -> m [Word8] + getWord8s n = replicateM (fromIntegral n) getWord8 + -- | Read some Word16 with host endianness + getWord16s :: Word -> m [Word16] + getWord16s n = replicateM (fromIntegral n) getWord16 + -- | Read some Word32 with host endianness + getWord32s :: Word -> m [Word32] + getWord32s n = replicateM (fromIntegral n) getWord32 + -- | Read some Word64 with host endianness + getWord64s :: Word -> m [Word64] + getWord64s n = replicateM (fromIntegral n) getWord64 + + -- | Read the given amount of bytes into a new buffer + getBuffer :: Word -> m BufferI + getBuffer n = do + xs <- replicateM (fromIntegral n) getWord8 + return (fromListN (fromIntegral n) xs) + + -- | Read the given amount of bytes into the specified buffer at the + -- optionally specified offset + getBufferInto :: Word -> Buffer 'Mutable pin gc heap -> Maybe Word -> m () + + -- | Skip the given amount of bytes + getSkipBytes :: Word -> m () + + +-- | Get a Float64 with host order +getFloat64 :: GetMonad m => m Float64 +getFloat64 = getWord64 ||> word64ToFloat64 + +-- | Get a Float64 with little-endian order +getFloat64LE :: GetMonad m => m Float64 +getFloat64LE = getWord64LE ||> word64ToFloat64 + +-- | Get a Float64 with big-endian order +getFloat64BE :: GetMonad m => m Float64 +getFloat64BE = getWord64BE ||> word64ToFloat64 + +-- | Get a Float32 with host order +getFloat32 :: GetMonad m => m Float32 +getFloat32 = getWord32 ||> word32ToFloat32 + +-- | Get a Float32 with little-endian order +getFloat32LE :: GetMonad m => m Float32 +getFloat32LE = getWord32LE ||> word32ToFloat32 + +-- | Get a Float32 with big-endian order +getFloat32BE :: GetMonad m => m Float32 +getFloat32BE = getWord32BE ||> word32ToFloat32 + +-- | Read a Word16 with little-endian order +getWord16LE :: GetMonad m => m Word16 +getWord16LE = littleEndianToHost <$> getWord16 +-- | Read a Word32 with little-endian order +getWord32LE :: GetMonad m => m Word32 +getWord32LE = littleEndianToHost <$> getWord32 +-- | Read a Word64 with little-endian order +getWord64LE :: GetMonad m => m Word64 +getWord64LE = littleEndianToHost <$> getWord64 +-- | Read a Word16 with big-endian order +getWord16BE :: GetMonad m => m Word16 +getWord16BE = bigEndianToHost <$> getWord16 +-- | Read a Word32 with big-endian order +getWord32BE :: GetMonad m => m Word32 +getWord32BE = bigEndianToHost <$> getWord32 +-- | Read a Word64 with big-endian order +getWord64BE :: GetMonad m => m Word64 +getWord64BE = bigEndianToHost <$> getWord64 + + +-- | Read some Word16 with little-endian order +getWord16LEs :: GetMonad m => Word -> m [Word16] +getWord16LEs n = fmap littleEndianToHost <$> getWord16s n +-- | Read some Word32 with little-endian order +getWord32LEs :: GetMonad m => Word -> m [Word32] +getWord32LEs n = fmap littleEndianToHost <$> getWord32s n +-- | Read some Word64 with little-endian order +getWord64LEs :: GetMonad m => Word -> m [Word64] +getWord64LEs n = fmap littleEndianToHost <$> getWord64s n + +-- | Read some Word16 with big-endian order +getWord16BEs :: GetMonad m => Word -> m [Word16] +getWord16BEs n = fmap bigEndianToHost <$> getWord16s n +-- | Read some Word32 with big-endian order +getWord32BEs :: GetMonad m => Word -> m [Word32] +getWord32BEs n = fmap bigEndianToHost <$> getWord32s n +-- | Read some Word64 with big-endian order +getWord64BEs :: GetMonad m => Word -> m [Word64] +getWord64BEs n = fmap bigEndianToHost <$> getWord64s n diff --git a/src/lib/Haskus/Binary/Serialize/Put.hs b/src/lib/Haskus/Binary/Serialize/Put.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Serialize/Put.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Binary serialization of Haskell values +module Haskus.Binary.Serialize.Put + ( PutMonad (..) + , putFloat32 + , putFloat32LE + , putFloat32BE + , putFloat64 + , putFloat64LE + , putFloat64BE + , putWord16BE + , putWord32BE + , putWord64BE + , putWord16LE + , putWord32LE + , putWord64LE + , putWord16BEs + , putWord32BEs + , putWord64BEs + , putWord16LEs + , putWord32LEs + , putWord64LEs + ) +where + +import Haskus.Memory.Buffer +import Haskus.Number.Word +import Haskus.Binary.Endianness +import Haskus.Number.Float +import Haskus.Utils.Flow + +-- | Monad which can build a sequence of bytes +class Monad m => PutMonad m where + -- | Write a Word8 + putWord8 :: Word8 -> m () + -- | Write a Word16 + putWord16 :: Word16 -> m () + -- | Write a Word32 + putWord32 :: Word32 -> m () + -- | Write a Word64 + putWord64 :: Word64 -> m () + + -- | Write some Word8 + putWord8s :: [Word8] -> m () + putWord8s xs = forM_ xs putWord8 + + -- | Write some Word16 + putWord16s :: [Word16] -> m () + putWord16s xs = forM_ xs putWord16 + + -- | Write some Word32 + putWord32s :: [Word32] -> m () + putWord32s xs = forM_ xs putWord32 + + -- | Write some Word64 + putWord64s :: [Word64] -> m () + putWord64s xs = forM_ xs putWord64 + + -- | Write the contents of a buffer + putBuffer :: BufferSize (Buffer Immutable pin gc heap) => Buffer Immutable pin gc heap -> m () + + -- | Pre-allocate at least the given amount of bytes + -- + -- This is a hint for the putter to speed up the allocation of memory + preAllocateAtLeast :: Word -> m () + preAllocateAtLeast _ = return () + +-- | Write a Float64 with host order +putFloat64 :: PutMonad m => Float64 -> m () +putFloat64 d = putWord64 (float64ToWord64 d) + +-- | Write a Float64 with little-endian order +putFloat64LE :: PutMonad m => Float64 -> m () +putFloat64LE d = putWord64LE (float64ToWord64 d) + +-- | Write a Float64 with big-endian order +putFloat64BE :: PutMonad m => Float64 -> m () +putFloat64BE d = putWord64BE (float64ToWord64 d) + +-- | Write a Float32 with host order +putFloat32 :: PutMonad m => Float32 -> m () +putFloat32 d = putWord32 (float32ToWord32 d) + +-- | Write a Float32 with little-endian order +putFloat32LE :: PutMonad m => Float32 -> m () +putFloat32LE d = putWord32LE (float32ToWord32 d) + +-- | Write a Float32 with big-endian order +putFloat32BE :: PutMonad m => Float32 -> m () +putFloat32BE d = putWord32BE (float32ToWord32 d) + + +-- | Write a Word16 with little-endian order +putWord16LE :: PutMonad m => Word16 -> m () +putWord16LE x = putWord16 (hostToLittleEndian x) +-- | Write a Word32 with little-endian order +putWord32LE :: PutMonad m => Word32 -> m () +putWord32LE x = putWord32 (hostToLittleEndian x) +-- | Write a Word64 with little-endian order +putWord64LE :: PutMonad m => Word64 -> m () +putWord64LE x = putWord64 (hostToLittleEndian x) + +-- | Write a Word16 with big-endian order +putWord16BE :: PutMonad m => Word16 -> m () +putWord16BE x = putWord16 (hostToBigEndian x) +-- | Write a Word32 with big-endian order +putWord32BE :: PutMonad m => Word32 -> m () +putWord32BE x = putWord32 (hostToBigEndian x) +-- | Write a Word64 with big-endian order +putWord64BE :: PutMonad m => Word64 -> m () +putWord64BE x = putWord64 (hostToBigEndian x) + +-- | Write some Word16 with little-endian order +putWord16LEs :: PutMonad m => [Word16] -> m () +putWord16LEs xs = putWord16s (fmap hostToLittleEndian xs) +-- | Write some Word32 with little-endian order +putWord32LEs :: PutMonad m => [Word32] -> m () +putWord32LEs xs = putWord32s (fmap hostToLittleEndian xs) +-- | Write some Word64 with little-endian order +putWord64LEs :: PutMonad m => [Word64] -> m () +putWord64LEs xs = putWord64s (fmap hostToLittleEndian xs) +-- | Write some Word16 with big-endian order +putWord16BEs :: PutMonad m => [Word16] -> m () +putWord16BEs xs = putWord16s (fmap hostToBigEndian xs) +-- | Write some Word32 with big-endian order +putWord32BEs :: PutMonad m => [Word32] -> m () +putWord32BEs xs = putWord32s (fmap hostToBigEndian xs) +-- | Write some Word64 with big-endian order +putWord64BEs :: PutMonad m => [Word64] -> m () +putWord64BEs xs = putWord64s (fmap hostToBigEndian xs) + diff --git a/src/lib/Haskus/Binary/Serialize/Size.hs b/src/lib/Haskus/Binary/Serialize/Size.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Serialize/Size.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} + +module Haskus.Binary.Serialize.Size + ( GetSize (..) + , runGetSize + ) +where + +import Haskus.Binary.Serialize.Put +import Haskus.Memory.Buffer +import Control.Monad.Trans.State.Strict as S + +newtype GetSize a + = GetSize (State Word a) + deriving newtype (Functor, Applicative, Monad) + +-- | Increment the current size +incSize :: Word -> GetSize () +incSize x = GetSize (state (\s -> ((),s+x))) + +-- | Get the total size +runGetSize :: GetSize a -> Word +runGetSize (GetSize s) = execState s 0 + +instance PutMonad GetSize where + putWord8 _ = incSize 1 + putWord16 _ = incSize 2 + putWord32 _ = incSize 4 + putWord64 _ = incSize 8 + putBuffer b = incSize (bufferSize b) diff --git a/src/lib/Haskus/Binary/Storable.hs b/src/lib/Haskus/Binary/Storable.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Storable.hs @@ -0,0 +1,544 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Storable class +module Haskus.Binary.Storable + ( StaticStorable (..) + , staticPeek + , staticPoke + , staticSizeOf + , staticAlignment + , wordBytes + -- * Storable + , Storable (..) + , peek + , poke + , sizeOf' + , sizeOfT + , sizeOfT' + , alignment' + , alignmentT + , alignmentT' + , peekByteOff + , pokeByteOff + , peekElemOff + , pokeElemOff + , alloca + , allocaBytes + , allocaBytesAligned + , malloc + , with + , withMany + , allocaArray + , mallocArray + , withArray + , withArrayLen + , peekArray + , pokeArray + -- * Padding + , RequiredPadding + , Padding + , PaddingEx + ) +where + +import qualified Foreign.Storable as FS +import Foreign.C.Types (CSize,CChar,CULong,CLong,CUInt,CInt,CUShort,CShort) +import qualified Foreign.Marshal.Alloc as P +import System.IO.Unsafe + +import Haskus.Number.Word +import Haskus.Number.Int +import Haskus.Memory.Ptr +import Haskus.Utils.Types +import Haskus.Utils.Types.Generics +import Haskus.Utils.Flow +import Foreign.Ptr + +-- | A storable data in constant space whose size is known at compile time +class StaticStorable a where + -- | Size of the stored data (in bytes) + type SizeOf a :: Nat + + -- | Alignment requirement (in bytes) + type Alignment a :: Nat + + -- | Peek (read) a value from a memory address + staticPeekIO :: Ptr a -> IO a + + -- | Poke (write) a value at the given memory address + staticPokeIO :: Ptr a -> a -> IO () + +-- | Peek (read) a value from a memory address +staticPeek :: (StaticStorable a, MonadIO m) => Ptr a -> m a +staticPeek p = liftIO (staticPeekIO p) + +-- | Poke (write) a value at the given memory address +staticPoke :: (StaticStorable a, MonadIO m) => Ptr a -> a -> m () +staticPoke p a = liftIO (staticPokeIO p a) + + +-- | Get statically known size +staticSizeOf :: forall a. + ( KnownNat (SizeOf a) + ) => a -> Word +staticSizeOf _ = natValue' @(SizeOf a) + +-- | Get statically known alignment +staticAlignment :: forall a. + ( KnownNat (Alignment a) + ) => a -> Word +staticAlignment _ = natValue' @(Alignment a) + + +-- | Get bytes in host-endianness order +wordBytes :: forall a. + ( Storable a + , KnownNat (SizeOf a) + ) => a -> [Word8] +{-# INLINABLE wordBytes #-} +wordBytes x = unsafePerformIO $ + with x $ \p -> mapM (peekByteOff (castPtr p)) [0..natValue @(SizeOf a) - 1] + + + +-- | Storable data-types +-- +-- Currently we cannot automatically derive a Storable class with type-level +-- naturals for "alignment" and "sizeOf". Instead we define a Storable class +-- isomorphic to the Foreign.Storable's one but with default methods using +-- DefaultSignatures (i.e., the Storable instance can be automatically derived +-- from a Generic instance). +class Storable a where + peekIO :: Ptr a -> IO a + default peekIO :: (Generic a, GStorable (Rep a)) => Ptr a -> IO a + peekIO p = fmap to $ gcPeek 0 (castPtr p) + + pokeIO :: Ptr a -> a -> IO () + default pokeIO :: (Generic a, GStorable (Rep a)) => Ptr a -> a -> IO () + pokeIO p x = gcPoke 0 (castPtr p) $ from x + + alignment :: a -> Word + default alignment :: (Generic a, GStorable (Rep a)) => a -> Word + alignment = gcAlignment . from + + sizeOf :: a -> Word + default sizeOf :: (Generic a, GStorable (Rep a)) => a -> Word + sizeOf = gcSizeOf 0 . from + +-- | Peek a value from a pointer +peek :: (Storable a, MonadIO m) => Ptr a -> m a +peek p = liftIO (peekIO p) + +-- | Poke a value to a pointer +poke :: (Storable a, MonadIO m) => Ptr a -> a -> m () +poke p v = liftIO (pokeIO p v) + +-- | Generalized 'sizeOf' +sizeOf' :: (Integral b, Storable a) => a -> b +{-# INLINABLE sizeOf' #-} +sizeOf' = fromIntegral . sizeOf + +-- | SizeOf (for type-application) +sizeOfT :: forall a. (Storable a) => Word +{-# INLINABLE sizeOfT #-} +sizeOfT = sizeOf (undefined :: a) + +-- | SizeOf' (for type-application) +sizeOfT' :: forall a b. (Storable a, Integral b) => b +{-# INLINABLE sizeOfT' #-} +sizeOfT' = sizeOf' (undefined :: a) + +-- | Generalized 'alignment' +alignment' :: (Integral b, Storable a) => a -> b +{-# INLINABLE alignment' #-} +alignment' = fromIntegral . alignment + +-- | Alignment (for type-application) +alignmentT :: forall a. (Storable a) => Word +{-# INLINABLE alignmentT #-} +alignmentT = alignment (undefined :: a) + +-- | Alignment' (for type-application) +alignmentT' :: forall a b. (Storable a, Integral b) => b +{-# INLINABLE alignmentT' #-} +alignmentT' = alignment' (undefined :: a) + +-- | Peek with byte offset +peekByteOff :: (MonadIO m, Storable a) => Ptr a -> Int -> m a +{-# INLINABLE peekByteOff #-} +peekByteOff ptr off = peek (ptr `plusPtr` off) + +-- | Poke with byte offset +pokeByteOff :: (MonadIO m, Storable a) => Ptr a -> Int -> a -> m () +{-# INLINABLE pokeByteOff #-} +pokeByteOff ptr off = poke (ptr `plusPtr` off) + +-- | Peek with element size offset +peekElemOff :: forall a m. (MonadIO m, Storable a) => Ptr a -> Int -> m a +peekElemOff ptr off = peekByteOff ptr (off * sizeOfT' @a) + +-- | Poke with element size offset +pokeElemOff :: (MonadIO m, Storable a) => Ptr a -> Int -> a -> m () +pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf' val) val + +-- | Allocate some bytes +allocaBytes :: MonadInIO m => Word -> (Ptr a -> m b) -> m b +allocaBytes sz = liftWith (P.allocaBytes (fromIntegral sz)) + +-- | Allocate some aligned bytes +allocaBytesAligned :: MonadInIO m => Word -> Word -> (Ptr a -> m b) -> m b +allocaBytesAligned sz align = liftWith (P.allocaBytesAligned (fromIntegral sz) (fromIntegral align)) + +-- | @'alloca' f@ executes the computation @f@, passing as argument +-- a pointer to a temporarily allocated block of memory sufficient to +-- hold values of type @a@. +-- +-- The memory is freed when @f@ terminates (either normally or via an +-- exception), so the pointer passed to @f@ must /not/ be used after this. +-- +alloca :: forall a b m. (MonadInIO m, Storable a) => (Ptr a -> m b) -> m b +{-# INLINABLE alloca #-} +alloca = allocaBytesAligned (sizeOfT' @a) (alignmentT' @a) + +-- | Allocate a block of memory that is sufficient to hold values of type +-- @a@. The size of the area allocated is determined by the 'sizeOf' +-- method from the instance of 'Storable' for the appropriate type. +-- +-- The memory may be deallocated using 'free' or 'finalizerFree' when +-- no longer required. +malloc :: forall a m. (MonadIO m, Storable a) => m (Ptr a) +{-# INLINABLE malloc #-} +malloc = liftIO (P.mallocBytes (fromIntegral (sizeOfT @a))) + +-- | @'with' val f@ executes the computation @f@, passing as argument +-- a pointer to a temporarily allocated block of memory into which +-- @val@ has been marshalled (the combination of 'alloca' and 'poke'). +-- +-- The memory is freed when @f@ terminates (either normally or via an +-- exception), so the pointer passed to @f@ must /not/ be used after this. +with :: (MonadInIO m, Storable a) => a -> (Ptr a -> m b) -> m b +{-# INLINABLE with #-} +with val f = + alloca $ \ptr -> do + poke ptr val + f ptr + +-- | Temporarily allocate space for the given number of elements +-- (like 'alloca', but for multiple elements). +allocaArray :: forall a b m. (MonadInIO m, Storable a) => Word -> (Ptr a -> m b) -> m b +allocaArray size = liftWith (allocaBytesAligned (size * sizeOfT' @a) (alignmentT' @a)) + +-- | Allocate space for the given number of elements +-- (like 'malloc', but for multiple elements). +mallocArray :: forall a m. (MonadIO m, Storable a) => Word -> m (Ptr a) +mallocArray size = liftIO $ P.mallocBytes (fromIntegral (size * sizeOfT @a)) + +-- | Convert an array of given length into a Haskell list. The implementation +-- is tail-recursive and so uses constant stack space. +peekArray :: (MonadIO m, Storable a) => Word -> Ptr a -> m [a] +peekArray size ptr + | size <= 0 = return [] + | otherwise = f (size-1) [] + where + f 0 acc = (:acc) <$> peekElemOff ptr 0 + f n acc = f (n-1) =<< ((:acc) <$> peekElemOff ptr (fromIntegral n)) + +-- | Write the list elements consecutive into memory +pokeArray :: (MonadIO m, Storable a) => Ptr a -> [a] -> m () +pokeArray ptr vals0 = go vals0 0 + where go [] _ = return () + go (val:vals) n = do pokeElemOff ptr n val; go vals (n+1) + +-- | Temporarily store a list of storable values in memory +-- (like 'with', but for multiple elements). +withArray :: (MonadInIO m, Storable a) => [a] -> (Ptr a -> m b) -> m b +withArray vals = withArrayLen vals . const + +-- | Like 'withArray', but the action gets the number of values +-- as an additional parameter +withArrayLen :: (MonadInIO m, Storable a) => [a] -> (Word -> Ptr a -> m b) -> m b +withArrayLen vals f = + allocaArray len $ \ptr -> do + pokeArray ptr vals + f len ptr + where + len = fromIntegral (length vals) + +-- | Replicates a @withXXX@ combinator over a list of objects, yielding a list of +-- marshalled objects +withMany :: (a -> (b -> res) -> res) -- withXXX combinator for one object + -> [a] -- storable objects + -> ([b] -> res) -- action on list of marshalled obj.s + -> res +withMany _ [] f = f [] +withMany withFoo (x:xs) f = withFoo x $ \x' -> + withMany withFoo xs (\xs' -> f (x':xs')) + +class GStorable a where + gcAlignment :: a x -> Word + gcPeek :: Word -> Ptr (a x)-> IO (a x) + gcPoke :: Word -> Ptr (a x) -> a x -> IO () + gcSizeOf :: Word -> a x -> Word + + -- padding before the field to align from the given offset + gcPadding :: Word -> a x -> Word + gcPadding off a = (gcAlignment a - off) `mod` gcAlignment a + +instance GStorable U1 where + gcAlignment _ = 0 + gcPeek _ _ = return U1 + gcPoke _ _ _ = return () + gcSizeOf _ _ = 0 + gcPadding _ _ = 0 + +instance (GStorable a, GStorable b) => GStorable (a :*: b) where + gcAlignment _ = lcm (gcAlignment (undefined :: a x)) + (gcAlignment (undefined :: b y)) + + gcPeek off p = do + a <- gcPeek off $ castPtr p + b <- gcPeek (off + gcSizeOf off a) $ castPtr p + return $ a :*: b + + gcPoke off p (a :*: b) = do + gcPoke off (castPtr p) a + gcPoke (off + gcSizeOf off a) (castPtr p) b + + gcSizeOf off _ = let + a = undefined :: a x + b = undefined :: b y + off2 = off + gcSizeOf off a + in gcSizeOf off a + gcSizeOf off2 b + +instance (GStorable a) => GStorable (M1 i c a) where + gcAlignment (M1 x) = gcAlignment x + gcPeek off p = fmap M1 $ gcPeek off (castPtr p) + gcPoke off p (M1 x) = gcPoke off (castPtr p) x + gcSizeOf off (M1 x) = gcSizeOf off x + gcPadding off (M1 x) = gcPadding off x + +instance (Storable a) => GStorable (K1 i a) where + gcAlignment (K1 x) = alignment x + gcPeek off p = fmap K1 $ peek (castPtr p `plusPtr` fromIntegral (off + gcPadding off (undefined :: K1 i a x))) + gcPoke off p (K1 x) = poke (castPtr p `plusPtr` fromIntegral (off + gcPadding off (undefined :: K1 i a x))) x + gcSizeOf off (K1 x) = gcPadding off (undefined :: K1 i a x) + sizeOf x + + +-- | Generalize FS.peek +fsPeek :: (FS.Storable a, MonadIO m) => Ptr a -> m a +fsPeek = liftIO . FS.peek + +-- | Generalize FS.poke +fsPoke :: (FS.Storable a, MonadIO m) => Ptr a -> a -> m () +fsPoke ptr a = liftIO (FS.poke ptr a) + +instance StaticStorable Word8 where + type SizeOf Word8 = 1 + type Alignment Word8 = 1 + staticPeekIO = fsPeek + staticPokeIO = fsPoke + +instance StaticStorable Word16 where + type SizeOf Word16 = 2 + type Alignment Word16 = 2 + staticPeekIO = fsPeek + staticPokeIO = fsPoke + +instance StaticStorable Word32 where + type SizeOf Word32 = 4 + type Alignment Word32 = 4 + staticPeekIO = fsPeek + staticPokeIO = fsPoke + +instance StaticStorable Word64 where + type SizeOf Word64 = 8 + type Alignment Word64 = 8 + staticPeekIO = fsPeek + staticPokeIO = fsPoke + +instance StaticStorable Int8 where + type SizeOf Int8 = 1 + type Alignment Int8 = 1 + staticPeekIO = fsPeek + staticPokeIO = fsPoke + +instance StaticStorable Int16 where + type SizeOf Int16 = 2 + type Alignment Int16 = 2 + staticPeekIO = fsPeek + staticPokeIO = fsPoke + +instance StaticStorable Int32 where + type SizeOf Int32 = 4 + type Alignment Int32 = 4 + staticPeekIO = fsPeek + staticPokeIO = fsPoke + +instance StaticStorable Int64 where + type SizeOf Int64 = 8 + type Alignment Int64 = 8 + staticPeekIO = fsPeek + staticPokeIO = fsPoke + + +instance Storable Word8 where + sizeOf _ = 1 + alignment _ = 1 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Word16 where + sizeOf _ = 2 + alignment _ = 2 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Word32 where + sizeOf _ = 4 + alignment _ = 4 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Word64 where + sizeOf _ = 8 + alignment _ = 8 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Int8 where + sizeOf _ = 1 + alignment _ = 1 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Int16 where + sizeOf _ = 2 + alignment _ = 2 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Int32 where + sizeOf _ = 4 + alignment _ = 4 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Int64 where + sizeOf _ = 8 + alignment _ = 8 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Float where + sizeOf _ = 4 + alignment _ = 4 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Double where + sizeOf _ = 8 + alignment _ = 8 + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Char where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Word where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable Int where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable (Ptr a) where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable CSize where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable CChar where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable CULong where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable CLong where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable CUInt where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable CInt where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable CUShort where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable CShort where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +instance Storable WordPtr where + sizeOf = fromIntegral . FS.sizeOf + alignment = fromIntegral . FS.alignment + peekIO = fsPeek + pokeIO = fsPoke + +--------------------------- +-- Padding +--------------------------- + +-- | Compute the required padding between a and b to respect b's alignment +type family RequiredPadding a b where + RequiredPadding a b = Padding (SizeOf a) b + +-- | Compute the required padding between the size sz and b to respect b's alignment +type family Padding (sz :: Nat) b where + Padding sz b = PaddingEx (Mod sz (Alignment b)) (Alignment b) + +type family PaddingEx (m :: Nat) (a :: Nat) where + PaddingEx 0 a = 0 + PaddingEx m a = a - m diff --git a/src/lib/Haskus/Binary/Union.hs b/src/lib/Haskus/Binary/Union.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Union.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Union (as in C) +-- +-- Unions are storable and can contain any storable data. +-- +-- Use 'fromUnion' to read an alternative: +-- +-- @ +-- {-# LANGUAGE DataKinds #-} +-- +-- getUnion :: IO (Union '[Word16, Word32, Word64]) +-- getUnion = ... +-- +-- test = do +-- u <- getUnion +-- +-- -- to get one of the member +-- let v = fromUnion u :: Word16 +-- let v = fromUnion u :: Word32 +-- let v = fromUnion u :: Word64 +-- +-- -- This won't compile (Word8 is not a member of the union) +-- let v = fromUnion u :: Word8 +-- @ +-- +-- Use 'toUnion' to create a new union: +-- +-- @ +-- let +-- u2 :: Union '[Word32, Vector 4 Word8] +-- u2 = toUnion (0x12345678 :: Word32) +-- @ +-- +module Haskus.Binary.Union + ( Union + , fromUnion + , toUnion + , toUnionZero + ) +where + +import Haskus.Utils.Types hiding (Union) +import Haskus.Utils.HList +import Haskus.Utils.Flow (when) +import Haskus.Binary.Storable +import Haskus.Memory.Utils (memCopy, memSet) + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign.ForeignPtr +import Foreign.Ptr +import qualified Foreign.Storable as FS + + +-- TODO: rewrite rules +-- poke p (toUnion x) = poke (castPtr p) x +-- +-- (fromUnion <$> peek p) :: IO a = peek (castPtr p) :: IO a + + + +-- | An union +-- +-- We use a list of types as a parameter. +-- +-- The union is just a pointer to a buffer containing the value(s). The size of +-- the buffer is implicitly known from the types in the list. +newtype Union (x :: [*]) = Union (ForeignPtr ()) deriving (Show) + +-- | Retrieve a union member from its type +fromUnion :: (Storable a, Member a l) => Union l -> a +fromUnion (Union fp) = unsafePerformIO $ withForeignPtr fp (peek . castPtr) + +-- | Create a new union from one of the union types +toUnion :: forall a l . (Storable (Union l), Storable a, Member a l) => a -> Union l +toUnion = toUnion' False + +-- | Like 'toUnion' but set the remaining bytes to 0 +toUnionZero :: forall a l . (Storable (Union l), Storable a, Member a l) => a -> Union l +toUnionZero = toUnion' True + + +-- | Create a new union from one of the union types +toUnion' :: forall a l . (Storable (Union l), Storable a, Member a l) => Bool -> a -> Union l +toUnion' zero v = unsafePerformIO $ do + let sz = sizeOfT @(Union l) + fp <- mallocForeignPtrBytes (fromIntegral sz) + withForeignPtr fp $ \p -> do + -- set bytes after the object to 0 + when zero $ do + let psz = sizeOfT @a + memSet (p `plusPtr` fromIntegral psz) (fromIntegral (sz - psz)) 0 + poke (castPtr p) v + return $ Union fp + +type family MapSizeOf fs where + MapSizeOf '[] = '[] + MapSizeOf (x ': xs) = SizeOf x ': MapSizeOf xs + +type family MapAlignment fs where + MapAlignment '[] = '[] + MapAlignment (x ': xs) = Alignment x ': MapAlignment xs + + +instance forall fs. + ( KnownNat (ListMax (MapSizeOf fs)) + , KnownNat (ListMax (MapAlignment fs)) + ) + => StaticStorable (Union fs) + where + type SizeOf (Union fs) = ListMax (MapSizeOf fs) + type Alignment (Union fs) = ListMax (MapAlignment fs) + + staticPeekIO ptr = do + let sz = natValue @(SizeOf (Union fs)) + fp <- mallocForeignPtrBytes sz + withForeignPtr fp $ \p -> + memCopy p (castPtr ptr) (fromIntegral sz) + return (Union fp) + + staticPokeIO ptr (Union fp) = do + withForeignPtr fp $ \p -> + memCopy (castPtr ptr) p (natValue @(SizeOf (Union fs))) + +------------------------------------------------------------------------------------- +-- We use HFoldr' to get the maximum size and alignment of the types in the union +------------------------------------------------------------------------------------- + +data FoldSizeOf = FoldSizeOf +data FoldAlignment = FoldAlignment + +instance (r ~ Word, Storable a) => Apply FoldSizeOf (a, Word) r where + apply _ (_,r) = max r (sizeOfT @a) + +instance (r ~ Word, Storable a) => Apply FoldAlignment (a, Word) r where + apply _ (_,r) = max r (alignmentT @a) + +-- | Get the union size (i.e. the maximum of the types in the union) +unionSize :: forall l . HFoldr' FoldSizeOf Word l Word => Union l -> Word +unionSize _ = hFoldr' FoldSizeOf (0 :: Word) (undefined :: HList l) + +-- | Get the union alignment (i.e. the maximum of the types in the union) +unionAlignment :: forall l . HFoldr' FoldAlignment Word l Word => Union l -> Word +unionAlignment _ = hFoldr' FoldAlignment (0 :: Word) (undefined :: HList l) + + +------------------------------------------------------------------------------------- +-- Finally we can write the Storable instance +------------------------------------------------------------------------------------- + +instance + ( HFoldr' FoldSizeOf Word l Word + , HFoldr' FoldAlignment Word l Word + ) => Storable (Union l) where + sizeOf = unionSize + alignment = unionAlignment + peekIO ptr = do + let sz = sizeOfT' @(Union l) + fp <- mallocForeignPtrBytes sz + withForeignPtr fp $ \p -> + memCopy p (castPtr ptr) (fromIntegral sz) + return (Union fp) + + pokeIO ptr (Union fp) = withForeignPtr fp $ \p -> + memCopy (castPtr ptr) p (sizeOfT' @(Union l)) + + +-- compatibility instance with Foreign.Storable +instance + ( HFoldr' FoldSizeOf Word l Word + , HFoldr' FoldAlignment Word l Word + ) => FS.Storable (Union l) where + sizeOf = fromIntegral . unionSize + alignment = fromIntegral . unionAlignment + peek = peekIO + poke = pokeIO diff --git a/src/lib/Haskus/Binary/Unum.hs b/src/lib/Haskus/Binary/Unum.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Unum.hs @@ -0,0 +1,737 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +#if MIN_VERSION_GLASGOW_HASKELL (8,6,0,0) +{-# LANGUAGE NoStarIsType #-} +#endif + +module Haskus.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.Number.Word +import Haskus.Binary.Bits +import Haskus.Binary.BitField +import Haskus.Utils.Types hiding (Log2) +import Haskus.Utils.HList +import Haskus.Utils.Flow + +import Data.Kind (Type) + +-- | 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 :: [Type]) + + +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. + ( Bits (BackingWord u) + , KnownNat (UnumSize u) + ) => U u -> String +unumBits (U w) = drop (fromIntegral (bitSize w - 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 +{-# INLINABLE 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. + ( Bits (BackingWord u) + , Num (BackingWord u) + , KnownNat (UnumSize u) + ) => U u -> U u +{-# INLINABLE unumNegate #-} +unumNegate (U w) = U (maskDyn s (complement w + 1)) + where + s = unumSize @u + + +-- | Reciprocate a number +unumReciprocate :: forall u. + ( Bits (BackingWord u) + , Num (BackingWord u) + , KnownNat (UnumSize u) + ) => U u -> U u +{-# INLINABLE unumReciprocate #-} +unumReciprocate (U w) = U (w `xor` m + 1) + where + s = unumSize @u + m = makeMaskDyn (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. + ( Bits (SORNBackingWord u) + , KnownNat (UnumSize u) + , s ~ SORNSize u + , KnownNat s + ) => SORN u -> String +sornBits (SORN w) = drop (bitSize 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. + ( Bits (SORNBackingWord u) + , KnownNat (SORNSize u) + ) => SORN u +sornFull = SORN (maskDyn 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. + ( Bits (SORNBackingWord u) + , Bits (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) + , Bits (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)) (maskDyn s (x+1)) + 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 :: + ( Bits (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) + , Bits (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) + , Bits (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) + , Bits (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) + , Bits (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) + , Bits (BackingWord u) + , Bits (SORNBackingWord u) + , Field (BackingWord u) + , KnownNat (SORNSize u) + , Bits (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' = maskDyn 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. + ( Bits (CSORNBackingWord u) + , KnownNat (UnumSize u) + , s ~ CSORNSize u + , KnownNat s + ) => CSORN u -> String +csornBits (CSORN (BitFields w)) = drop (bitSize 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 +{-# INLINABLE 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) + , Bits (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 = maskDyn 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/Binary/Vector.hs b/src/lib/Haskus/Binary/Vector.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Binary/Vector.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +#if MIN_VERSION_GLASGOW_HASKELL (8,6,0,0) +{-# LANGUAGE NoStarIsType #-} +#endif + + +-- | Vector with size in the type +module Haskus.Binary.Vector + ( Vector (..) + , vectorBuffer + , vectorReverse + , take + , drop + , index + , fromList + , fromFilledList + , fromFilledListZ + , toList + , replicate + , concat + , zipWith + ) +where + +import Prelude hiding ( replicate, head, last + , tail, init, map, length, drop, take, concat + , zipWith ) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Haskus.Utils.List as List +import Haskus.Utils.Types +import Haskus.Utils.HList +import Haskus.Utils.Maybe +import Haskus.Utils.Flow +import Haskus.Binary.Storable +import Haskus.Binary.Buffer +import Haskus.Binary.Bits + +import Foreign.Ptr +import Foreign.Marshal.Alloc (mallocBytes) + +-- | 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 + +-- | Reverse a vector +vectorReverse :: (KnownNat n, Storable a) => Vector n a -> Vector n a +vectorReverse = fromJust . fromList . reverse . toList + +-- | Offset of the i-th element in a stored vector +type family ElemOffset a i n where + ElemOffset a i n = Assert (i+1 <=? n) + (i * (SizeOf a)) + (('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 +{-# INLINABLE 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 +{-# INLINABLE 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 +{-# INLINABLE 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) +{-# INLINABLE 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 +{-# INLINABLE 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 +{-# INLINABLE 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] +{-# INLINABLE 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 +{-# INLINABLE 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 `plusPtr` (-1 * vsz * fromIntegral (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 `plusPtr` fromIntegral sz) :: IO (Ptr a)) vs :: IO (Ptr a) + Vector <$> bufferUnsafePackPtr (fromIntegral sz) p + + +-- | Zip two vectors +zipWith :: + ( KnownNat n + , Storable a + , Storable b + , Storable c + ) => (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c +zipWith f u v = fromJust . fromList <| List.zipWith f (toList u) (toList v) + +-- | map +map :: + ( KnownNat n + , Storable a + , Storable b + ) => (a -> b) -> Vector n a -> Vector n b +map f = fromJust . fromList . fmap f . toList + +instance + ( KnownNat n + , Storable a + , Eq a + ) + => Eq (Vector n a) + where + u == v = toList u == toList v + + +instance + ( KnownNat n + , Bitwise a + , Storable a + ) => Bitwise (Vector n a) + where + u .&. v = zipWith (.&.) u v + u .|. v = zipWith (.|.) u v + u `xor` v = zipWith xor u v + + +instance + ( KnownNat (BitSize a) + , FiniteBits a + , KnownNat n + , Storable a + ) => FiniteBits (Vector n a) + where + type BitSize (Vector n a) = n * BitSize a + zeroBits = fromJust (fromList (List.replicate (natValue @n) zeroBits)) + oneBits = fromJust (fromList (List.replicate (natValue @n) oneBits)) + complement u = map complement u + countLeadingZeros = go 0 . toList + where + go !n [] = n + go !n (x:xs) = let c = countLeadingZeros x + in if c == natValue @(BitSize a) + then go (n+c) xs + else n+c + + countTrailingZeros = go 0 . reverse . toList + where + go !n [] = n + go !n (x:xs) = let c = countTrailingZeros x + in if c == natValue @(BitSize a) + then go (n+c) xs + else n+c + +instance + ( Storable a + , ShiftableBits a + , Bitwise a + , FiniteBits a + , KnownNat (BitSize a) + , KnownNat (n * BitSize a) + , KnownNat n + ) => ShiftableBits (Vector n a) + where + shiftL u c = uncheckedShiftL u (c `mod` natValue @(BitSize (Vector n a))) + shiftR u c = uncheckedShiftR u (c `mod` natValue @(BitSize (Vector n a))) + + uncheckedShiftL u c = + let n = natValue @n + sa = natValue @(BitSize a) + go _ 0 _ = [] + go 0 k xs = List.take k xs + go s k xs + | s >= sa = go (s-sa) k (List.tail xs) + | otherwise = + let (x:y:zs) = xs + in ((x `shiftL` s) .|. (y `shiftR` (sa-s))) : go s (k-1) (y:zs) + in fromJust (fromList (go c n (toList u ++ List.repeat zeroBits))) + + uncheckedShiftR u c = + let n = natValue @n + sa = natValue @(BitSize a) + go _ 0 _ = [] + go 0 k xs = List.take k (List.tail xs) + go s k xs + | s >= sa = zeroBits : go (s-sa) (k-1) xs + | otherwise = + let (x:y:zs) = xs + in ((x `shiftL` (sa-s)) .|. (y `shiftR` s)) : go s (k-1) (y:zs) + in fromJust (fromList (go c n (zeroBits : toList u))) + + +instance + ( Storable a + , IndexableBits a + , FiniteBits a + , KnownNat (BitSize a) + , KnownNat n + , Bitwise a + ) => IndexableBits (Vector n a) where + + popCount = sum . fmap popCount . toList + + bit i = let n = natValue @n + sa = natValue @(BitSize a) + (f,r) = i `divMod` sa + toRep = fromIntegral (n - f - 1) + xs = List.replicate toRep zeroBits + ++ [bit r] + ++ List.replicate (fromIntegral f) zeroBits + in fromJust <| fromList <| if i >= n * sa + then List.replicate (fromIntegral n) zeroBits + else xs + + testBit u i = let n = natValue @n + sa = natValue @(BitSize a) + (f,r) = i `divMod` sa + toDrop = fromIntegral (n - f - 1) + in if i >= n * sa + then False + else testBit (List.head (List.drop toDrop (toList u))) r + + +instance + ( Storable a + , Bits a + , KnownNat n + , KnownNat (n * BitSize a) + ) => RotatableBits (Vector n a) diff --git a/src/lib/Haskus/Format/Binary/BitField.hs b/src/lib/Haskus/Format/Binary/BitField.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/BitField.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-# 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 - --- | Bit fields on a base type b -newtype BitFields b (f :: [*]) = BitFields b deriving (Storable) - --- | Get backing word -bitFieldsBits :: BitFields b f -> b -{-# INLINABLE bitFieldsBits #-} -bitFieldsBits (BitFields b) = b - - --- | A field of n bits -newtype BitField (n :: Nat) (name :: Symbol) s = BitField s deriving (Storable) - --- | Get the bit offset of a field from its name -type family Offset (name :: Symbol) fs :: Nat where - Offset name (BitField n name s ': xs) = AddOffset xs - Offset name (BitField n name2 s ': xs) = Offset name xs - -type family AddOffset fs :: Nat where - AddOffset '[] = 0 - AddOffset (BitField n name s ': xs) = n + AddOffset xs - --- | Get the type of a field from its name -type family Output (name :: Symbol) fs :: * where - Output name (BitField n name s ': xs) = s - Output name (BitField n name2 s ': xs) = Output name xs - --- | Get the size of a field from it name -type family Size (name :: Symbol) fs :: Nat where - Size name (BitField n name s ': xs) = n - Size name (BitField n name2 s ': xs) = Size name xs - --- | Get the whole size of a BitFields -type family WholeSize fs :: Nat where - WholeSize '[] = 0 - WholeSize (BitField n name s ': xs) = n + WholeSize xs - -type family BitFieldTypes xs where - BitFieldTypes '[] = '[] - BitFieldTypes (BitField n name s ': xs) = s ': BitFieldTypes xs - -class Field f where - fromField :: Integral b => f -> b - toField :: Integral b => b -> f - -instance Field Bool where - fromField True = 1 - fromField False = 0 - toField 0 = False - toField _ = True - -instance Field Word where - fromField = fromIntegral - toField = fromIntegral - -instance Field Word8 where - fromField = fromIntegral - toField = fromIntegral - -instance Field Word16 where - fromField = fromIntegral - toField = fromIntegral - -instance Field Word32 where - fromField = fromIntegral - toField = fromIntegral - -instance Field Word64 where - fromField = fromIntegral - toField = fromIntegral - -instance Field Int where - fromField = fromIntegral - toField = fromIntegral - -instance Field Int8 where - fromField = fromIntegral - toField = fromIntegral - -instance Field Int16 where - fromField = fromIntegral - toField = fromIntegral - -instance Field Int32 where - fromField = fromIntegral - toField = fromIntegral - -instance Field Int64 where - fromField = fromIntegral - toField = fromIntegral - -instance (FiniteBits b, Integral b, CBitSet a) => Field (BitSet b a) where - fromField = fromIntegral . BitSet.toBits - toField = BitSet.fromBits . fromIntegral - -instance (Integral b, CEnum a) => Field (EnumField b a) where - fromField = fromCEnum . fromEnumField - toField = toEnumField . toCEnum - --- | Get the value of a field -extractField :: forall (name :: Symbol) fields b . - ( KnownNat (Offset name fields) - , KnownNat (Size name fields) - , WholeSize fields ~ BitSize b - , Bits b, Integral b - , Field (Output name fields) - ) => BitFields b fields -> Output name fields -{-# INLINABLE extractField #-} -extractField = extractField' @name - --- | Get the value of a field (without checking sizes) -extractField' :: forall (name :: Symbol) fields b . - ( KnownNat (Offset name fields) - , KnownNat (Size name fields) - , Bits b, Integral b - , Field (Output name fields) - ) => BitFields b fields -> Output name fields -{-# INLINABLE extractField' #-} -extractField' (BitFields w) = toField ((w `shiftR` off) .&. ((1 `shiftL` sz) - 1)) - where - off = natValue @(Offset name fields) - sz = natValue @(Size name fields) - - --- | Set the value of a field -updateField :: forall name fields b . - ( KnownNat (Offset name fields) - , KnownNat (Size name fields) - , WholeSize fields ~ BitSize b - , Bits b, Integral b - , Field (Output name fields) - ) => Output name fields -> BitFields b fields -> BitFields b fields -{-# INLINABLE updateField #-} -updateField = updateField' @name - --- | Set the value of a field (without checking sizes) -updateField' :: forall name fields b . - ( KnownNat (Offset name fields) - , KnownNat (Size name fields) - , Bits b, Integral b - , Field (Output name fields) - ) => Output name fields -> BitFields b fields -> BitFields b fields -{-# INLINABLE updateField' #-} -updateField' value (BitFields w) = BitFields $ ((fromField value `shiftL` off) .&. mask') .|. (w .&. complement mask') - where - off = natValue @(Offset name fields) - sz = natValue @(Size name fields) - mask' = ((1 `shiftL` sz) - 1) `shiftL` off - - --- | Modify the value of a field -withField :: forall name fields b f . - ( KnownNat (Offset name fields) - , KnownNat (Size name fields) - , WholeSize fields ~ BitSize b - , Bits b, Integral b - , f ~ Output name fields - , Field f - ) => (f -> f) -> BitFields b fields -> BitFields b fields -{-# INLINABLE withField #-} -withField = withField' @name - --- | Modify the value of a field (without checking sizes) -withField' :: forall (name :: Symbol) fields b f . - ( KnownNat (Offset name fields) - , KnownNat (Size name fields) - , Bits b, Integral b - , f ~ Output name fields - , Field f - ) => (f -> f) -> BitFields b fields -> BitFields b fields -{-# INLINABLE withField' #-} -withField' f bs = updateField' @name (f v) bs - where - v = extractField' @name bs - - -------------------------------------------------------------------------------------- --- We use HFoldr' to extract each component and create a HList from it. Then we --- convert it into a Tuple -------------------------------------------------------------------------------------- -data Extract = Extract -data Name = Name - -instance forall name bs b l l2 i (n :: Nat) s r w . - ( bs ~ BitFields w l -- the bitfields - , b ~ BitField n name s -- the current field - , i ~ (bs, HList l2) -- input type - , r ~ (bs, HList (Output name l ': l2)) -- result type - , BitSize w ~ WholeSize l - , Integral w, Bits w - , KnownNat (Offset name l) - , KnownNat (Size name l) - , Field (Output name l) - ) => Apply Extract (b, i) r where - apply _ (_, (bs,xs)) = - (bs, HCons (extractField @name bs) xs) - -instance forall name bs b l l2 i (n :: Nat) s r w . - ( bs ~ BitFields w l -- the bitfields - , b ~ BitField n name s -- the current field - , i ~ HList l2 -- input type - , r ~ HList (String ': l2) -- result type - , KnownSymbol name - ) => Apply Name (b, i) r where - apply _ (_, xs) = HCons (symbolValue @name) xs - -fieldValues :: forall l l2 w bs . - ( bs ~ BitFields w l - , HFoldr' Extract (bs, HList '[]) l (bs, HList l2) - ) => bs -> HList l2 -fieldValues bs = snd res - where - res :: (bs, HList l2) - res = hFoldr' Extract ((bs, HNil) :: (bs, HList '[])) (undefined :: HList l) - -fieldNames :: forall l l2 w bs . - ( bs ~ BitFields w l - , HFoldr' Name (HList '[]) l (HList l2) - ) => bs -> HList l2 -fieldNames _ = hFoldr' Name (HNil :: HList '[]) (undefined :: HList l) - --- | Get values in a tuple -matchFields :: forall l l2 w bs t . - ( bs ~ BitFields w l - , HFoldr' Extract (bs, HList '[]) l (bs, HList l2) - , HTuple' l2 t - ) => 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/BitSet.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} - --- | A bit set based on Enum to name the bits. Use bitwise operations and --- minimal storage in a safer way. --- --- Similar to Data.Bitset.Generic from bitset package, but --- --- * We don't have the Num constraint --- * We dont use the deprecated bitSize function --- * We use countTrailingZeros instead of iterating on the --- number of bits --- * We add a typeclass 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 - , enumerateSetBits - , 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 - , IndexableBits b - , Eq b - ) => Show (BitSet b a) - where - show b = "fromList " ++ show (toList b) - --- | Indicate if the set is empty -null :: - ( FiniteBits b - , Eq b - ) => BitSet b a -> Bool -{-# INLINABLE null #-} -null (BitSet b) = b == zeroBits - - --- | Empty bitset -empty :: (FiniteBits b) => BitSet b a -{-# INLINABLE empty #-} -empty = BitSet zeroBits - - --- | Create a BitSet from a single element -singleton :: (IndexableBits b, CBitSet a) => a -> BitSet b a -{-# INLINABLE singleton #-} -singleton e = BitSet $ bit (toBitOffset e) - - --- | Insert an element in the set -insert :: (IndexableBits b, CBitSet a) => BitSet b a -> a -> BitSet b a -{-# INLINABLE insert #-} -insert (BitSet b) e = BitSet $ setBit b (toBitOffset e) - - --- | Remove an element from the set -delete :: (IndexableBits b, CBitSet a) => BitSet b a -> a -> BitSet b a -{-# INLINABLE delete #-} -delete (BitSet b) e = BitSet $ clearBit b (toBitOffset e) - - --- | Unwrap the bitset -toBits :: BitSet b a -> b -toBits (BitSet b) = b - --- | Wrap a bitset -fromBits :: (CBitSet a, FiniteBits b) => b -> BitSet b a -fromBits = BitSet - --- | Test if an element is in the set -member :: - ( CBitSet a - , FiniteBits b - , IndexableBits b - ) => BitSet b a -> a -> Bool -{-# INLINABLE member #-} -member (BitSet b) e = testBit b (toBitOffset e) - - --- | Test if an element is in the set -elem :: - ( CBitSet a - , FiniteBits b - , IndexableBits b - ) => a -> BitSet b a -> Bool -{-# INLINABLE elem #-} -elem e (BitSet b) = testBit b (toBitOffset e) - - --- | Test if an element is not in the set -notMember :: - ( CBitSet a - , FiniteBits b - , IndexableBits b - ) => BitSet b a -> a -> Bool -{-# INLINABLE notMember #-} -notMember b e = not (member b e) - - --- | Retrieve elements in the set -elems :: - ( CBitSet a - , FiniteBits b - , IndexableBits b - , Eq b - ) => BitSet b a -> [a] -elems (BitSet b) = go b - where - go !c - | c == zeroBits = [] - | otherwise = let e = countTrailingZeros c in fromBitOffset e : go (clearBit c e) - --- | Intersection of two sets -intersection :: - ( FiniteBits b - , Bitwise b - ) => BitSet b a -> BitSet b a -> BitSet b a -{-# INLINABLE intersection #-} -intersection (BitSet b1) (BitSet b2) = BitSet (b1 .&. b2) - - --- | Intersection of two sets -union :: - ( FiniteBits b - , Bitwise b - ) => BitSet b a -> BitSet b a -> BitSet b a -{-# INLINABLE union #-} -union (BitSet b1) (BitSet b2) = BitSet (b1 .|. b2) - - --- | Intersection of several sets -unions :: - ( FiniteBits b - , Bitwise b - ) => [BitSet b a] -> BitSet b a -{-# INLINABLE unions #-} -unions = foldl' union empty - - --- | Bit set indexed with a -class CBitSet a where - -- | Return the bit offset of an element - toBitOffset :: a -> Word - default toBitOffset :: Enum a => a -> Word - toBitOffset = fromIntegral . fromEnum - - -- | Return the value associated with a bit offset - fromBitOffset :: Word -> a - default fromBitOffset :: Enum a => Word -> a - fromBitOffset = toEnum . fromIntegral - --- | It can be useful to get the indexes of the set bits -instance CBitSet Int where - toBitOffset = fromIntegral - fromBitOffset = fromIntegral - --- | It can be useful to get the indexes of the set bits -instance CBitSet Word where - toBitOffset = id - fromBitOffset = id - - - --- | Convert a list of enum elements into a bitset Warning: b --- must have enough bits to store the given elements! (we don't --- perform any check, for performance reason) -fromListToBits :: - ( CBitSet a - , FiniteBits b - , IndexableBits b - , Foldable m - ) => m a -> b -fromListToBits = toBits . fromList - --- | Convert a bitset into a list of Enum elements -toListFromBits :: - ( CBitSet a - , FiniteBits b - , IndexableBits b - , Eq b - ) => b -> [a] -toListFromBits = toList . BitSet - --- | Convert a bitset into a list of Enum elements by testing the Enum values --- successively. --- --- The difference with `toListFromBits` is that extra values in the BitSet will --- be ignored. -enumerateSetBits :: - ( CBitSet a - , FiniteBits b - , IndexableBits b - , Eq b - , Bounded a - , Enum a - ) => b -> [a] -enumerateSetBits b = go [] [minBound..] - where - go rs [] = rs - go rs (x:xs) - | member (BitSet b) x = go (x:rs) xs - | otherwise = go rs xs - --- | Convert a set into a list -toList :: - ( CBitSet a - , FiniteBits b - , IndexableBits b - , Eq b - ) => BitSet b a -> [a] -toList = elems - --- | Convert a Foldable into a set -fromList :: - ( CBitSet a - , IndexableBits b - , FiniteBits b - , Foldable m - ) => m a -> BitSet b a -fromList = foldl' insert (BitSet zeroBits) - - -instance - ( FiniteBits b - , IndexableBits b - , CBitSet a - , Eq b - ) => 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} - --- | Operations on bits -module Haskus.Format.Binary.Bits - ( Bits - , FiniteBits (..) - , IndexableBits (..) - , ShiftableBits (..) - , SignedShiftableBits (..) - , RotatableBits (..) - , Bitwise (..) - -- * Bit reversal - , ReversableBits (..) - , reverseBitsGeneric - , reverseLeastBits - -- * Mask - , MaskBits (..) - , Maskable - , maskDyn - , mask - -- * String conversion - , bitsToString - , bitsToStringN - , bitsFromString - -- * Shift - , getBitRange - -- * Various - , bitOffset - , byteOffset - ) -where - -import Haskus.Utils.List (foldl') -import Haskus.Utils.Types -import Haskus.Format.Binary.Bits.Finite -import Haskus.Format.Binary.Bits.Index -import Haskus.Format.Binary.Bits.Reverse -import Haskus.Format.Binary.Bits.Rotate -import Haskus.Format.Binary.Bits.Shift -import Haskus.Format.Binary.Bits.Bitwise -import Haskus.Format.Binary.Bits.Order -import Haskus.Format.Binary.Bits.Mask -import Haskus.Format.Binary.Bits.Helper - -type Bits a = - ( Eq a - , FiniteBits a - , IndexableBits a - , ShiftableBits a - , Bitwise a - , RotatableBits a - , KnownNat (BitSize a) - , MaskBits a - ) - --- | Reverse the @n@ least important bits of the given value. The higher bits --- are set to 0. -reverseLeastBits :: - ( ShiftableBits a - , FiniteBits a - , ReversableBits a - , KnownNat (BitSize a) - ) => Word -> a -> a -reverseLeastBits n value = reverseBits value `uncheckedShiftR` ((bitSize value) - n) - --- | Convert bits into a string composed of '0' and '1' chars -bitsToString :: forall a. - ( FiniteBits a - , IndexableBits a - , KnownNat (BitSize a) - ) => a -> String -bitsToString = bitsToStringN (natValue @(BitSize a)) - --- | Convert a specified amount of bits into a string composed of '0' and '1' chars -bitsToStringN :: forall a. - ( IndexableBits a - ) => Word -> a -> String -bitsToStringN n x = fmap b [n-1, n-2 .. 0] - where - b v = if testBit x v then '1' else '0' - --- | Convert a string of '0' and '1' chars into a word -bitsFromString :: Bits a => String -> a -bitsFromString xs = foldl' b zeroBits (reverse xs `zip` [0..]) - where - b x ('0',i) = clearBit x i - b x ('1',i) = setBit x i - b _ (c,_) = error $ "Invalid character in the string: " ++ [c] - - --- | `getBitRange bo offset n c` takes n bits at offset in c and put them in the --- least-significant bits of the result -getBitRange :: forall b. - ( ShiftableBits b - , ReversableBits b - , FiniteBits b - , KnownNat (BitSize b) - , Bitwise b - , MaskBits b - ) => BitOrder -> Word -> Word -> b -> b -{-# INLINABLE getBitRange #-} -getBitRange bo o n c = case bo of - BB -> maskDyn n $ c `uncheckedShiftR` d - BL -> maskDyn n $ reverseBits c `uncheckedShiftR` o - LB -> maskDyn n $ reverseBits c `uncheckedShiftR` d - LL -> maskDyn n $ c `uncheckedShiftR` o - where - d = bitSize c - n - o - diff --git a/src/lib/Haskus/Format/Binary/Bits/Bitwise.hs b/src/lib/Haskus/Format/Binary/Bits/Bitwise.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Bitwise.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE BangPatterns #-} - --- | Bitwise bit operations -module Haskus.Format.Binary.Bits.Bitwise - ( Bitwise (..) - ) -where - -import Haskus.Format.Binary.Word -import GHC.Exts -import GHC.Num - --- | Bitwise bit operations -class Bitwise a where - -- | Bitwise "and" - (.&.) :: a -> a -> a - - -- | Bitwise "or" - (.|.) :: a -> a -> a - - -- | Bitwise "xor" - xor :: a -> a -> a - - -instance Bitwise Word where - (W# x#) .&. (W# y#) = W# (x# `and#` y#) - (W# x#) .|. (W# y#) = W# (x# `or#` y#) - (W# x#) `xor` (W# y#) = W# (x# `xor#` y#) - -instance Bitwise Word8 where - (W8# x#) .&. (W8# y#) = W8# (x# `and#` y#) - (W8# x#) .|. (W8# y#) = W8# (x# `or#` y#) - (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#) - -instance Bitwise Word16 where - (W16# x#) .&. (W16# y#) = W16# (x# `and#` y#) - (W16# x#) .|. (W16# y#) = W16# (x# `or#` y#) - (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#) - -instance Bitwise Word32 where - (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#) - (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#) - (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#) - -instance Bitwise Word64 where - (W64# x#) .&. (W64# y#) = W64# (x# `and#` y#) - (W64# x#) .|. (W64# y#) = W64# (x# `or#` y#) - (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#) - -instance Bitwise Int where - (I# x#) .&. (I# y#) = I# (x# `andI#` y#) - (I# x#) .|. (I# y#) = I# (x# `orI#` y#) - (I# x#) `xor` (I# y#) = I# (x# `xorI#` y#) - -instance Bitwise Int8 where - (I8# x#) .&. (I8# y#) = I8# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I8# x#) .|. (I8# y#) = I8# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - -instance Bitwise Int16 where - (I16# x#) .&. (I16# y#) = I16# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I16# x#) .|. (I16# y#) = I16# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - -instance Bitwise Int32 where - (I32# x#) .&. (I32# y#) = I32# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I32# x#) .|. (I32# y#) = I32# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - -instance Bitwise Int64 where - (I64# x#) .&. (I64# y#) = I64# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I64# x#) .|. (I64# y#) = I64# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I64# x#) `xor` (I64# y#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - -instance Bitwise Integer where - (.&.) = andInteger - (.|.) = orInteger - xor = xorInteger - -instance Bitwise Natural where - (.&.) = andNatural - (.|.) = orNatural - xor = xorNatural diff --git a/src/lib/Haskus/Format/Binary/Bits/Finite.hs b/src/lib/Haskus/Format/Binary/Bits/Finite.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Finite.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Types with finite bit count -module Haskus.Format.Binary.Bits.Finite - ( FiniteBits (..) - ) -where - -import Haskus.Utils.Types -import Haskus.Format.Binary.Word -import GHC.Exts - -#include "MachDeps.h" - --- | Type representable by a fixed amount of bits -class FiniteBits a where - - -- | Number of bits - type BitSize a :: Nat - - -- | Number of bits (the value is ignored) - bitSize :: (Integral i, KnownNat (BitSize a)) => a -> i - bitSize _ = natValue @(BitSize a) - - -- | All bits set to 0 - zeroBits :: a - - -- | All bits set to 1 - oneBits :: a - oneBits = complement zeroBits - - -- | Count number of zero bits preceding the most significant set bit - countLeadingZeros :: a -> Word - - -- | Count number of zero bits following the least significant set bit - countTrailingZeros :: a -> Word - - -- | Complement - complement :: a -> a - - -instance FiniteBits Word where - type BitSize Word = WORD_SIZE_IN_BITS - zeroBits = 0 - oneBits = maxBound - countLeadingZeros (W# x#) = W# (clz# x#) - countTrailingZeros (W# x#) = W# (ctz# x#) - complement (W# x#) = W# (x# `xor#` mb#) - where !(W# mb#) = maxBound - -instance FiniteBits Word8 where - type BitSize Word8 = 8 - zeroBits = 0 - oneBits = maxBound - countLeadingZeros (W8# x#) = W# (clz8# x#) - countTrailingZeros (W8# x#) = W# (ctz8# x#) - complement (W8# x#) = W8# (x# `xor#` mb#) - where !(W8# mb#) = maxBound - -instance FiniteBits Word16 where - type BitSize Word16 = 16 - zeroBits = 0 - oneBits = maxBound - countLeadingZeros (W16# x#) = W# (clz16# x#) - countTrailingZeros (W16# x#) = W# (ctz16# x#) - complement (W16# x#) = W16# (x# `xor#` mb#) - where !(W16# mb#) = maxBound - -instance FiniteBits Word32 where - type BitSize Word32 = 32 - zeroBits = 0 - oneBits = maxBound - countLeadingZeros (W32# x#) = W# (clz32# x#) - countTrailingZeros (W32# x#) = W# (ctz32# x#) - complement (W32# x#) = W32# (x# `xor#` mb#) - where !(W32# mb#) = maxBound - -instance FiniteBits Word64 where - type BitSize Word64 = 64 - zeroBits = 0 - oneBits = maxBound - countLeadingZeros (W64# x#) = W# (clz64# x#) - countTrailingZeros (W64# x#) = W# (ctz64# x#) - complement (W64# x#) = W64# (x# `xor#` mb#) - where !(W64# mb#) = maxBound - - -instance FiniteBits Int where - type BitSize Int = WORD_SIZE_IN_BITS - zeroBits = 0 - oneBits = (-1) - countLeadingZeros (I# x#) = W# (clz# (int2Word# x#)) - countTrailingZeros (I# x#) = W# (ctz# (int2Word# x#)) - complement (I# x#) = I# (notI# x#) - -instance FiniteBits Int8 where - type BitSize Int8 = 8 - zeroBits = 0 - oneBits = (-1) - countLeadingZeros (I8# x#) = W# (clz8# (int2Word# x#)) - countTrailingZeros (I8# x#) = W# (ctz8# (int2Word# x#)) - complement (I8# x#) = I8# (word2Int# (not# (int2Word# x#))) - -instance FiniteBits Int16 where - type BitSize Int16 = 16 - zeroBits = 0 - oneBits = (-1) - countLeadingZeros (I16# x#) = W# (clz16# (int2Word# x#)) - countTrailingZeros (I16# x#) = W# (ctz16# (int2Word# x#)) - complement (I16# x#) = I16# (word2Int# (not# (int2Word# x#))) - -instance FiniteBits Int32 where - type BitSize Int32 = 32 - zeroBits = 0 - oneBits = (-1) - countLeadingZeros (I32# x#) = W# (clz32# (int2Word# x#)) - countTrailingZeros (I32# x#) = W# (ctz32# (int2Word# x#)) - complement (I32# x#) = I32# (word2Int# (not# (int2Word# x#))) - -instance FiniteBits Int64 where - type BitSize Int64 = 64 - zeroBits = 0 - oneBits = (-1) - countLeadingZeros (I64# x#) = W# (clz64# (int2Word# x#)) - countTrailingZeros (I64# x#) = W# (ctz64# (int2Word# x#)) - complement (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) diff --git a/src/lib/Haskus/Format/Binary/Bits/Get.hs b/src/lib/Haskus/Format/Binary/Bits/Get.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Get.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} - --- | 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, Bits a) => Word -> BitGetState -> a -getBits nbits (BitGetState bs off bo) = rec zeroBits 0 bs off nbits - where - -- w = current result - -- n = number of valid bits in w - -- i = input bytestring - -- o = bit offset in input bytestring - -- r = number of remaining bits to read - rec w _ _ _ 0 = w - rec w n i o r = rec nw (n+nb) (bufferTail i) o' (r-nb) - where - -- current Word8 - c = bufferHead i - -- number of bits to take from the current Word8 - nb = min (8-o) r - -- bits taken from the current Word8 and put in correct order in least-significant bits - tc = fromIntegral $ getBitRange bo o nb c - -- mix new bits with the current result - nw = case bo of - BB -> (w `shiftL` fromIntegral nb) .|. tc - LB -> (w `shiftL` fromIntegral nb) .|. tc - BL -> (tc `shiftL` fromIntegral n) .|. w - LL -> (tc `shiftL` fromIntegral n) .|. w - -- new offset ((o + nb) `mod` 8) - o' = bitOffset (o + nb) - --- | Perform some checks before calling getBits --- --- Check that the number of bits to read is not greater than the first parameter -getBitsChecked :: (Integral a, Bits a, ReversableBits a) => Word -> Word -> BitGetState -> a -{-# INLINABLE getBitsChecked #-} -getBitsChecked m n s - | n > m = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")" - | otherwise = getBits n s - --- | Read the given number of Word8 and return them in a Buffer --- --- Examples: --- @ BB: xxxABCDE FGHIJKLM NOPxxxxx -> ABCDEFGH IJKLMNOP @ --- @ LL: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP @ --- @ BL: xxxPONML KJIHGFED CBAxxxxx -> ABCDEFGH IJKLMNOP @ --- @ LB: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP @ -getBitsBuffer :: Word -> BitGetState -> Buffer -getBitsBuffer n (BitGetState bs o bo) = - if n == 0 - then emptyBuffer - else - let - bs' = bufferUnsafeTake (n+1) bs - bs'' = bufferUnsafeTake n bs - rev = bufferMap reverseBits - in case (o,bo) of - (0,BB) -> bs'' - (0,LL) -> bufferReverse bs'' - (0,LB) -> rev bs'' - (0,BL) -> rev $ bufferReverse bs'' - (_,LL) -> getBitsBuffer n (BitGetState (bufferReverse bs') (8-o) BB) - (_,BL) -> rev . bufferReverse $ getBitsBuffer n (BitGetState bs' o BB) - (_,LB) -> rev . bufferReverse $ getBitsBuffer n (BitGetState bs' o LL) - (_,BB) -> unsafePerformIO $ do - let len = n+1 - ptr <- mallocBytes (fromIntegral len) - let f r i = do - let - w = bufferUnsafeIndex bs (len-i) - w' = (w `shiftL` fromIntegral o) .|. r - r' = w `shiftR` (8-fromIntegral o) - poke (castPtr ptr `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, Bits a, Monad m) => Word -> BitGetT m a -getBitsM n = do - v <- gets (getBits n) - skipBitsM n - return v - --- | Perform some checks before calling getBitsM -getBitsCheckedM :: (Integral a, Bits a, ReversableBits a, Monad m) => Word -> Word -> BitGetT m a -getBitsCheckedM m n = do - v <- gets (getBitsChecked m n) - skipBitsM n - return v - --- | Get a bit and convert it into a Bool -getBitBoolM :: (Monad m) => BitGetT m Bool -getBitBoolM = do - v <- getBitsM 1 - return ((v :: Word) == 1) - --- | Get the given number of Word8 -getBitsBSM :: (Monad m) => Word -> BitGetT m Buffer -getBitsBSM n = do - bs <- gets (getBitsBuffer n) - skipBitsM (8*n) - return bs - --- | Change the current bit ordering --- --- Be careful to change the outer bit ordering (B* to L* or the inverse) only --- on bytes boundaries! Otherwise, you will read the same bits more than once. -changeBitGetOrder :: Monad m => BitOrder -> BitGetT m () -changeBitGetOrder bo = modify (\s -> s { bitGetStateBitOrder = bo }) - --- | Change the bit ordering for the wrapped BitGet --- --- Be careful, this function uses changeBitGetOrder internally. -withBitGetOrder :: Monad m => BitOrder -> BitGetT m a -> BitGetT m a -withBitGetOrder bo m = do - bo' <- gets bitGetStateBitOrder - changeBitGetOrder bo - v <- m - changeBitGetOrder bo' - return v - diff --git a/src/lib/Haskus/Format/Binary/Bits/Helper.hs b/src/lib/Haskus/Format/Binary/Bits/Helper.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Helper.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} - -module Haskus.Format.Binary.Bits.Helper - ( bitOffset - , byteOffset - ) -where - -import Haskus.Format.Binary.Bits.Shift -import Haskus.Format.Binary.Bits.Mask - --- | Compute bit offset (equivalent to x `mod` 8 but faster) -bitOffset :: Word -> Word -{-# INLINABLE bitOffset #-} -bitOffset n = mask @3 n - --- | Compute byte offset (equivalent to x `div` 8 but faster) -byteOffset :: Word -> Word -{-# INLINABLE byteOffset #-} -byteOffset n = n `uncheckedShiftR` 3 diff --git a/src/lib/Haskus/Format/Binary/Bits/Index.hs b/src/lib/Haskus/Format/Binary/Bits/Index.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Index.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} - --- | Bit indexable types -module Haskus.Format.Binary.Bits.Index - ( IndexableBits (..) - ) -where - -import Haskus.Format.Binary.Bits.Shift -import Haskus.Format.Binary.Bits.Bitwise -import Haskus.Format.Binary.Bits.Finite -import Haskus.Format.Binary.Word -import GHC.Exts - --- | Type whose bits are indexable -class IndexableBits a where - -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear. - bit :: Word -> a - default bit :: (Num a, ShiftableBits a) => Word -> a - bit i = 1 `shiftL` i - - -- | @x \`setBit\` i@ is the same as @x .|. bit i@ - setBit :: a -> Word -> a - default setBit :: (Bitwise a) => a -> Word -> a - setBit a i = a .|. bit i - - -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@ - clearBit :: a -> Word -> a - default clearBit :: (FiniteBits a,Bitwise a) => a -> Word -> a - clearBit a i = a .&. complement (bit i) - - -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@ - complementBit :: a -> Word -> a - default complementBit :: (Bitwise a) => a -> Word -> a - complementBit a i = a `xor` bit i - - -- | Return 'True' if the @n@th bit of the argument is 1 - testBit :: a -> Word -> Bool - default testBit :: (Bitwise a, Num a, Eq a) => a -> Word -> Bool - testBit a i = (a .&. bit i) /= 0 - - -- | Return the number of set bits - popCount :: a -> Word - default popCount :: (Bitwise a, Num a, Eq a) => a -> Word - popCount = go 0 - where - go !c 0 = c - go c w = go (c+1) (w .&. (w-1)) - - -instance IndexableBits Word where - popCount (W# x#) = W# (popCnt# x#) - -instance IndexableBits Word8 where - popCount (W8# x#) = W# (popCnt8# x#) - -instance IndexableBits Word16 where - popCount (W16# x#) = W# (popCnt16# x#) - -instance IndexableBits Word32 where - popCount (W32# x#) = W# (popCnt32# x#) - -instance IndexableBits Word64 where - popCount (W64# x#) = W# (popCnt64# x#) - -instance IndexableBits Int where - popCount (I# x#) = W# (popCnt# (int2Word# x#)) - -instance IndexableBits Int8 where - popCount (I8# x#) = W# (popCnt8# (int2Word# x#)) - -instance IndexableBits Int16 where - popCount (I16# x#) = W# (popCnt16# (int2Word# x#)) - -instance IndexableBits Int32 where - popCount (I32# x#) = W# (popCnt32# (int2Word# x#)) - -instance IndexableBits Int64 where - popCount (I64# x#) = W# (popCnt64# (int2Word# x#)) - diff --git a/src/lib/Haskus/Format/Binary/Bits/Mask.hs b/src/lib/Haskus/Format/Binary/Bits/Mask.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Mask.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} - -module Haskus.Format.Binary.Bits.Mask - ( MaskBits (..) - , makeMaskFinite - , makeMask - , maskDyn - , Maskable - , mask - ) -where - -import Haskus.Format.Binary.Bits.Finite -import Haskus.Format.Binary.Bits.Shift -import Haskus.Format.Binary.Bits.Bitwise -import Haskus.Format.Binary.Word -import Haskus.Utils.Types -import GHC.Natural - --- | makeMaskFinite 3 = 00000111 -makeMaskFinite :: forall a. - ( ShiftableBits a - , FiniteBits a - , KnownNat (BitSize a) - , Bitwise a - ) => Word -> a -{-# INLINABLE makeMaskFinite #-} -makeMaskFinite n = complement zeroBits `shiftR` off - where - off = natValue' @(BitSize a) - n - -{-# SPECIALIZE makeMaskFinite :: Word -> Int #-} -{-# SPECIALIZE makeMaskFinite :: Word -> Int8 #-} -{-# SPECIALIZE makeMaskFinite :: Word -> Int16 #-} -{-# SPECIALIZE makeMaskFinite :: Word -> Int32 #-} -{-# SPECIALIZE makeMaskFinite :: Word -> Int64 #-} -{-# SPECIALIZE makeMaskFinite :: Word -> Word #-} -{-# SPECIALIZE makeMaskFinite :: Word -> Word8 #-} -{-# SPECIALIZE makeMaskFinite :: Word -> Word16 #-} -{-# SPECIALIZE makeMaskFinite :: Word -> Word32 #-} -{-# SPECIALIZE makeMaskFinite :: Word -> Word64 #-} - -class MaskBits a where - -- | Make a mask dynamically - makeMaskDyn :: Word -> a - -instance MaskBits Natural where - makeMaskDyn n = mkNatural (replicate (fromIntegral q) c ++ [makeMaskFinite r]) - where - c = complement zeroBits - (q,r) = n `quotRem` 32 - -instance MaskBits Word where makeMaskDyn = makeMaskFinite -instance MaskBits Word8 where makeMaskDyn = makeMaskFinite -instance MaskBits Word16 where makeMaskDyn = makeMaskFinite -instance MaskBits Word32 where makeMaskDyn = makeMaskFinite -instance MaskBits Word64 where makeMaskDyn = makeMaskFinite -instance MaskBits Int where makeMaskDyn = makeMaskFinite -instance MaskBits Int8 where makeMaskDyn = makeMaskFinite -instance MaskBits Int16 where makeMaskDyn = makeMaskFinite -instance MaskBits Int32 where makeMaskDyn = makeMaskFinite -instance MaskBits Int64 where makeMaskDyn = makeMaskFinite - --- | Make a mask statically -makeMask :: forall n a. - ( KnownNat n - , MaskBits a - ) => a -{-# INLINABLE makeMask #-} -makeMask = makeMaskDyn (natValue' @n) - --- | Keep only the n least-significant bits of the given value -maskDyn :: - ( MaskBits a - , Bitwise a - ) => Word -> a -> a -{-# INLINABLE maskDyn #-} -maskDyn n v = v .&. makeMaskDyn n - --- | Keep only the n least-significant bits of the given value -mask :: forall n a. Maskable n a => a -> a -{-# INLINABLE mask #-} -mask v = v .&. makeMask @n - -type Maskable n a = - ( MaskBits a - , Bitwise a - , KnownNat n - ) diff --git a/src/lib/Haskus/Format/Binary/Bits/Order.hs b/src/lib/Haskus/Format/Binary/Bits/Order.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Order.hs +++ /dev/null @@ -1,29 +0,0 @@ --- | 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Put.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - --- | 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 - , Bits a - , ReversableBits a - ) => Word -> a -> BitPutState -> BitPutState -putBits n w s@(BitPutState builder b o bo) = s' - where - -- number of bits that will be stored in the current byte - cn = min (8-o) n - - -- new state - s' = case n of - 0 -> s - _ -> putBits (n-cn) w' (flush (BitPutState builder b' (o+cn) bo)) - - -- new current byte - b' = shl (selectBits w) .|. b - - -- Word containing the remaining (n-cn) bits to store in its LSB - w' = case bo of - BB -> w - BL -> w `shiftR` fromIntegral cn - LL -> w `shiftR` fromIntegral cn - LB -> w - - -- Select bits to store in the current byte. - -- Put them in the correct order and return them in the least-significant - -- bits of the returned value - selectBits :: (Bits a, ReversableBits a, Integral a) => a -> Word8 - selectBits x = fromIntegral $ case bo of - BB -> maskDyn cn $ x `shiftR` fromIntegral (n-cn) - LB -> reverseLeastBits cn $ maskDyn cn $ x `shiftR` fromIntegral (n-cn) - LL -> maskDyn cn x - BL -> reverseLeastBits cn $ maskDyn cn x - - -- shift left at the correct position - shl :: Word8 -> Word8 - shl x = case bo of - BB -> x `shiftL` (8 - fromIntegral o - fromIntegral cn) - BL -> x `shiftL` (8 - fromIntegral o - fromIntegral cn) - LL -> x `shiftL` fromIntegral o - LB -> x `shiftL` fromIntegral o - - -- flush the current byte if it is full - flush s2@(BitPutState b2 w2 o2 bo2) - | o2 == 8 = BitPutState (b2 `mappend` B.fromWord8 w2) 0 0 bo2 - | otherwise = s2 - - --- | Put a Buffer --- --- Examples: 3 bits are already written in the current byte --- @ BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx @ --- @ LL: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC @ --- @ BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx @ --- @ LB: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON @ -putBitsBuffer :: Buffer -> BitPutState -> BitPutState -putBitsBuffer bs s - | isBufferEmpty bs = s - | otherwise = case s of - (BitPutState builder b 0 BB) -> BitPutState (builder `mappend` B.fromBuffer bs) b 0 BB - (BitPutState builder b 0 LL) -> BitPutState (builder `mappend` B.fromBuffer (bufferReverse bs)) b 0 LL - (BitPutState builder b 0 LB) -> BitPutState (builder `mappend` B.fromBuffer (rev bs)) b 0 LB - (BitPutState builder b 0 BL) -> BitPutState (builder `mappend` B.fromBuffer (rev (bufferReverse bs))) b 0 BL - (BitPutState _ _ _ BB) -> putBitsBuffer (bufferUnsafeTail bs) (putBits 8 (bufferUnsafeHead bs) s) - (BitPutState _ _ _ LL) -> putBitsBuffer (bufferUnsafeInit bs) (putBits 8 (bufferUnsafeLast bs) s) - (BitPutState _ _ _ BL) -> putBitsBuffer (bufferUnsafeInit bs) (putBits 8 (bufferUnsafeLast bs) s) - (BitPutState _ _ _ LB) -> putBitsBuffer (bufferUnsafeTail bs) (putBits 8 (bufferUnsafeHead bs) s) - where - rev = bufferMap reverseBits - --- | Flush the current byte -flushIncomplete :: BitPutState -> BitPutState -flushIncomplete s@(BitPutState b w o bo) - | o == 0 = s - | otherwise = BitPutState (b `mappend` B.fromWord8 w) 0 0 bo - --- | Get a buffer list -getBitPutBufferList :: BitPutState -> BufferList -getBitPutBufferList = toBufferList . bitPutStateBuilder . flushIncomplete - --- | Get a Buffer -getBitPutBuffer :: BitPutState -> Buffer -getBitPutBuffer = toBuffer . bitPutStateBuilder . flushIncomplete - --- | BitPut monad transformer -type BitPutT m a = StateT BitPutState m a - --- | BitPut monad -type BitPut a = BitPutT Identity a - --- | Evaluate a BitPut monad -runBitPutT :: Monad m => BitOrder -> BitPutT m a -> m Buffer -runBitPutT bo m = getBitPutBuffer <$> execStateT m (newBitPutState bo) - --- | Evaluate a BitPut monad -runBitPut :: BitOrder -> BitPut a -> Buffer -runBitPut bo m = runIdentity (runBitPutT bo m) - --- | Put bits (monadic) -putBitsM :: (Monad m, Integral a, Bits a, ReversableBits a) => Word -> a -> BitPutT m () -putBitsM n w = modify (putBits n w) - --- | Put a single bit (monadic) -putBitBoolM :: (Monad m) => Bool -> BitPutT m () -putBitBoolM b = putBitsM 1 (if b then 1 else 0 :: Word) - --- | Put a Buffer (monadic) -putBitsBufferM :: Monad m => Buffer -> BitPutT m () -putBitsBufferM bs = modify (putBitsBuffer bs) - --- | Change the current bit ordering --- --- Be careful to change the outer bit ordering (B* to L* or the inverse) only --- on bytes boundaries! Otherwise, you will write the same bits more than once. -changeBitPutOrder :: Monad m => BitOrder -> BitPutT m () -changeBitPutOrder bo = modify (\s -> s { bitPutStateBitOrder = bo }) - --- | Change the bit ordering for the wrapped BitPut --- --- Be careful, this function uses changeBitPutOrder internally. -withBitPutOrder :: Monad m => BitOrder -> BitPutT m a -> BitPutT m a -withBitPutOrder bo m = do - bo' <- gets bitPutStateBitOrder - changeBitPutOrder bo - v <- m - changeBitPutOrder bo' - return v diff --git a/src/lib/Haskus/Format/Binary/Bits/Reverse.hs b/src/lib/Haskus/Format/Binary/Bits/Reverse.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Reverse.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Reverse bits --- --- There are several algorithms performing the same thing here (reversing bits --- into words of different sizes). There are benchmarks for them in the --- "bench" directory. The fastest one for the current architecture should be --- selected below. If you find that another algorithm is faster on your --- architecture, please report it. -module Haskus.Format.Binary.Bits.Reverse - ( - -- * Generic - ReversableBits (..) - , 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.Finite -import Haskus.Format.Binary.Bits.Shift -import Haskus.Format.Binary.Bits.Bitwise -import Haskus.Format.Binary.Bits.Index -import Haskus.Utils.Types (KnownNat) - ---------------------------------------------------- --- Generic and specialized reverseBits ---------------------------------------------------- - - --- | Reverse bits in a Word -reverseBitsGeneric :: - ( FiniteBits a - , Integral a - , ShiftableBits a - , Bitwise a - , KnownNat (BitSize a) - ) => a -> a -reverseBitsGeneric = liftReverseBits reverseBits4Ops - --- | Data whose bits can be reversed -class ReversableBits w where - reverseBits :: w -> w - -instance ReversableBits Word8 where - reverseBits = reverseBits4Ops - -instance ReversableBits Word16 where - reverseBits = reverseBits5LgN - -instance ReversableBits Word32 where - reverseBits = reverseBits5LgN - -instance ReversableBits Word64 where - reverseBits = reverseBits5LgN - -instance ReversableBits Word where - reverseBits = reverseBits5LgN - -instance ReversableBits Int8 where - reverseBits = fromIntegral . reverseBits4Ops . fromIntegral - -instance ReversableBits Int16 where - reverseBits = reverseBits5LgN - -instance ReversableBits Int32 where - reverseBits = reverseBits5LgN - -instance ReversableBits Int64 where - reverseBits = reverseBits5LgN - -instance ReversableBits Int where - reverseBits = reverseBits5LgN - - ---------------------------------------------------- --- Bit reversal algorithms ---------------------------------------------------- - --- Algorithms and explanations adapted from: --- http://graphics.stanford.edu/~seander/bithacks.html#ReverseByteWith64Bits - --- Reverse the bits the obvious way --- ================================ --- --- --- unsigned int v; // input bits to be reversed --- unsigned int r = v; // r will be reversed bits of v; first get LSB of v --- int s = sizeof(v) * CHAR_BIT - 1; // extra shift needed at end --- --- for (v >>= 1; v; v >>= 1) --- { --- r <<= 1; --- r |= v & 1; --- s--; --- } --- r <<= s; // shift when v's highest bits are zero --- --- On October 15, 2004, Michael Hoisie pointed out a bug in the original --- version. Randal E. Bryant suggested removing an extra operation on May 3, --- 2005. Behdad Esfabod suggested a slight change that eliminated one iteration --- of the loop on May 18, 2005. Then, on February 6, 2007, Liyong Zhou --- suggested a better version that loops while v is not 0, so rather than --- iterating over all bits it stops early. - --- | Obvious recursive version -reverseBitsObvious :: forall a. - ( FiniteBits a - , ShiftableBits a - , IndexableBits a - , Bitwise a - , KnownNat (BitSize a) - , Eq a - ) => a -> a -reverseBitsObvious x = rec x (x `shiftR` 1) (bitSize x - 1) - where - rec :: FiniteBits a => a -> a -> Word -> a - rec !r !v !s - | v == zeroBits = r `shiftL` s - | otherwise = rec ((r `shiftL` 1) .|. (v .&. bit 0)) (v `shiftR` 1) (s - 1) - -{-# SPECIALIZE reverseBitsObvious :: Word8 -> Word8 #-} -{-# SPECIALIZE reverseBitsObvious :: Word16 -> Word16 #-} -{-# SPECIALIZE reverseBitsObvious :: Word32 -> Word32 #-} -{-# SPECIALIZE reverseBitsObvious :: Word64 -> Word64 #-} - --- Reverse the bits in a byte with 3 operations (64-bit multiply and modulus division) --- =================================================================================== --- --- unsigned char b; // reverse this (8-bit) byte --- --- b = (b * 0x0202020202ULL & 0x010884422010ULL) % 1023; --- --- The multiply operation creates five separate copies of the 8-bit byte --- pattern to fan-out into a 64-bit value. The AND operation selects the bits --- that are in the correct (reversed) positions, relative to each 10-bit groups --- of bits. The multiply and the AND operations copy the bits from the original --- byte so they each appear in only one of the 10-bit sets. The reversed --- positions of the bits from the original byte coincide with their relative --- positions within any 10-bit set. The last step, which involves modulus --- division by 2^10 - 1, has the effect of merging together each set of 10 bits --- (from positions 0-9, 10-19, 20-29, ...) in the 64-bit value. They do not --- overlap, so the addition steps underlying the modulus division behave like --- or operations. --- --- This method was attributed to Rich Schroeppel in the Programming Hacks --- section of Beeler, M., Gosper, R. W., and Schroeppel, R. HAKMEM. MIT AI Memo --- 239, Feb. 29, 1972. - --- | Reverse bits in a Word8 (3 64-bit operations, modulus division) -reverseBits3Ops :: Word8 -> Word8 -{-# INLINABLE reverseBits3Ops #-} -reverseBits3Ops x = fromIntegral x' - where - !x' = ((fromIntegral x * 0x0202020202 :: Word64) .&. 0x010884422010) `mod` 1023 - - --- Reverse the bits in a byte with 4 operations (64-bit multiply, no division) --- =========================================================================== --- --- unsigned char b; // reverse this (8-bit) byte --- --- b = ((b * 0x80200802ULL) & 0x0884422110ULL) * 0x0101010101ULL >> 32; --- --- The following shows the flow of the bit values with the boolean variables a, --- b, c, d, e, f, g, and h, which comprise an 8-bit byte. Notice how the first --- multiply fans out the bit pattern to multiple copies, while the last --- multiply combines them in the fifth byte from the right. --- --- --- abcd efgh (-> hgfe dcba) --- * 1000 0000 0010 0000 0000 1000 0000 0010 (0x80200802) --- ------------------------------------------------------------------------------------------------- --- 0abc defg h00a bcde fgh0 0abc defg h00a bcde fgh0 --- & 0000 1000 1000 0100 0100 0010 0010 0001 0001 0000 (0x0884422110) --- ------------------------------------------------------------------------------------------------- --- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 --- * 0000 0001 0000 0001 0000 0001 0000 0001 0000 0001 (0x0101010101) --- ------------------------------------------------------------------------------------------------- --- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 --- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 --- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 --- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 --- 0000 d000 h000 0c00 0g00 00b0 00f0 000a 000e 0000 --- ------------------------------------------------------------------------------------------------- --- 0000 d000 h000 dc00 hg00 dcb0 hgf0 dcba hgfe dcba hgfe 0cba 0gfe 00ba 00fe 000a 000e 0000 --- >> 32 --- ------------------------------------------------------------------------------------------------- --- 0000 d000 h000 dc00 hg00 dcb0 hgf0 dcba hgfe dcba --- & 1111 1111 --- ------------------------------------------------------------------------------------------------- --- hgfe dcba --- Note that the last two steps can be combined on some processors because the --- registers can be accessed as bytes; just multiply so that a register stores --- the upper 32 bits of the result and the take the low byte. Thus, it may take --- only 6 operations. --- --- Devised by Sean Anderson, July 13, 2001. - --- | Reverse bits in a Word8 (4 64-bit operations, no division) -reverseBits4Ops :: Word8 -> Word8 -{-# INLINABLE reverseBits4Ops #-} -reverseBits4Ops x = fromIntegral x' - where - !x' = (((fromIntegral x * 0x80200802 :: Word64) .&. 0x0884422110) * 0x0101010101) `shiftR` 32 - - --- Reverse bits using a lookup table --- ================================= - --- | Reverse bits using a lookup table -reverseBitsTable :: Word8 -> Word8 -{-# INLINABLE reverseBitsTable #-} -reverseBitsTable x = bitsTable `bufferIndex` (fromIntegral x) - - --- fill the table by using another method -bitsTable :: Buffer -bitsTable = bufferPackByteList $ fmap reverseBits4Ops [0..255] - --- Reverse the bits in a byte with 7 operations (no 64-bit) --- ======================================================== --- --- b = ((b * 0x0802LU & 0x22110LU) | (b * 0x8020LU & 0x88440LU)) * 0x10101LU >> 16; --- --- Make sure you assign or cast the result to an unsigned char to remove --- garbage in the higher bits. Devised by Sean Anderson, July 13, 2001. Typo --- spotted and correction supplied by Mike Keith, January 3, 2002. - - --- | Reverse bits in a Word8 (7 no 64-bit operations, no division) -reverseBits7Ops :: Word8 -> Word8 -{-# INLINABLE reverseBits7Ops #-} -reverseBits7Ops b' = fromIntegral x' - where - b = fromIntegral b' :: Word32 - !x' = ((((b * 0x0802) .&. 0x22110) .|. ((b * 0x8020) .&. 0x88440)) * 0x10101) `shiftR` 16 - - --- Reverse an N-bit quantity in parallel in 5 * lg(N) operations --- ============================================================= --- --- unsigned int v; // 32-bit word to reverse bit order --- --- // swap odd and even bits --- v = ((v >> 1) & 0x55555555) | ((v & 0x55555555) << 1); --- // swap consecutive pairs --- v = ((v >> 2) & 0x33333333) | ((v & 0x33333333) << 2); --- // swap nibbles ... --- v = ((v >> 4) & 0x0F0F0F0F) | ((v & 0x0F0F0F0F) << 4); --- // swap bytes --- v = ((v >> 8) & 0x00FF00FF) | ((v & 0x00FF00FF) << 8); --- // swap 2-byte long pairs --- v = ( v >> 16 ) | ( v << 16); --- --- The following variation is also O(lg(N)), however it requires more --- operations to reverse v. Its virtue is in taking less slightly memory by --- computing the constants on the fly. --- --- unsigned int s = sizeof(v) * CHAR_BIT; // bit size; must be power of 2 --- unsigned int mask = ~0; --- while ((s >>= 1) > 0) --- { --- mask ^= (mask << s); --- v = ((v >> s) & mask) | ((v << s) & ~mask); --- } --- --- These methods above are best suited to situations where N is large. If you --- use the above with 64-bit ints (or larger), then you need to add more lines --- (following the pattern); otherwise only the lower 32 bits will be reversed --- and the result will be in the lower 32 bits. --- --- See Dr. Dobb's Journal 1983, Edwin Freed's article on Binary Magic Numbers --- for more information. The second variation was suggested by Ken Raeburn on --- September 13, 2005. Veldmeijer mentioned that the first version could do --- without ANDS in the last line on March 19, 2006. - --- | "Parallel" recursive version -reverseBits5LgN :: forall a. - ( FiniteBits a - , ShiftableBits a - , Bitwise a - , KnownNat (BitSize a) - ) => a -> a -reverseBits5LgN x = rec (bitSize x `shiftR` 1) (complement zeroBits) x - where - rec :: FiniteBits a => Word -> a -> a -> a - rec !s !mask !v - | s <= 0 = v - | otherwise = rec (s `shiftR` 1) mask' v' - where - mask' = mask `xor` (mask `shiftL` s) - v' = ((v `shiftR` s) .&. mask') - .|. ((v `shiftL` s) .&. complement mask') - -{-# SPECIALIZE reverseBits5LgN :: Word8 -> Word8 #-} -{-# SPECIALIZE reverseBits5LgN :: Word16 -> Word16 #-} -{-# SPECIALIZE reverseBits5LgN :: Word32 -> Word32 #-} -{-# SPECIALIZE reverseBits5LgN :: Word64 -> Word64 #-} - - - --- | Convert a function working on Word8 to one working on any Word --- --- The number of bits in the Word must be a multiple of 8 -liftReverseBits :: - ( ShiftableBits a - , Bitwise a - , FiniteBits a - , Integral a - , KnownNat (BitSize a) - ) => (Word8 -> Word8) -> a -> a -liftReverseBits f w = rec zeroBits 0 - where - nb = bitSize w `shiftR` 3 -- div 8 - f' = fromIntegral . f . fromIntegral - rec !v !o - | o == nb = v - | otherwise = rec v' (o+1) - where - -- multiplication by 8 replaced with (`shiftL` 3) - v' = v .|. ((f' (w `shiftR` (o `shiftL` 3))) `shiftL` ((nb-1-o) `shiftL` 3)) - -{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word8 -> Word8 #-} -{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word16 -> Word16 #-} -{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word32 -> Word32 #-} -{-# SPECIALIZE liftReverseBits :: (Word8 -> Word8) -> Word64 -> Word64 #-} - diff --git a/src/lib/Haskus/Format/Binary/Bits/Rotate.hs b/src/lib/Haskus/Format/Binary/Bits/Rotate.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Rotate.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} - --- | Bit rotations -module Haskus.Format.Binary.Bits.Rotate - ( RotatableBits (..) - ) -where - -import Haskus.Format.Binary.Bits.Finite -import Haskus.Format.Binary.Bits.Shift -import Haskus.Format.Binary.Bits.Bitwise -import Haskus.Format.Binary.Word -import Haskus.Utils.Types - --- | Types whose bits can be rotated -class RotatableBits a where - - -- | Rotate left if positive, right if negative - rotate :: a -> Int -> a - default rotate :: - ( FiniteBits a - , KnownNat (BitSize a) - ) => a -> Int -> a - rotate a i - | i' > 0 = rotateL a (fromIntegral i') - | i' < 0 = rotateR a (fromIntegral (negate i')) - | otherwise = a - where - i' = i `mod` bitSize a - - -- | Checked left bit rotation - rotateL :: a -> Word -> a - default rotateL :: - ( FiniteBits a - , KnownNat (BitSize a) - ) => a -> Word -> a - rotateL a n = uncheckedRotateL a (n `mod` bitSize a) - - -- | Checked right bit rotation - rotateR :: a -> Word -> a - default rotateR :: - ( FiniteBits a - , KnownNat (BitSize a) - ) => a -> Word -> a - rotateR a n = uncheckedRotateR a (n `mod` bitSize a) - - -- | Unchecked rotate left if positive, right if negative - uncheckedRotate :: a -> Int -> a - uncheckedRotate a i - | i > 0 = uncheckedRotateL a (fromIntegral i) - | i < 0 = uncheckedRotateR a (fromIntegral (negate i)) - | otherwise = a - - -- | Unchecked left bit rotation - uncheckedRotateL :: a -> Word -> a - default uncheckedRotateL :: - ( ShiftableBits a - , FiniteBits a - , KnownNat (BitSize a) - , Bitwise a - ) => a -> Word -> a - uncheckedRotateL a i = (a `uncheckedShiftL` i) .|. (a `uncheckedShiftR` (n-i)) - where n = bitSize a - - - -- | Unchecked right bit rotation - uncheckedRotateR :: a -> Word -> a - default uncheckedRotateR :: - ( ShiftableBits a - , FiniteBits a - , KnownNat (BitSize a) - , Bitwise a - ) => a -> Word -> a - uncheckedRotateR a i = (a `uncheckedShiftL` (n-i)) .|. (a `uncheckedShiftR` i) - where n = bitSize a - - -instance RotatableBits Word -instance RotatableBits Word8 -instance RotatableBits Word16 -instance RotatableBits Word32 -instance RotatableBits Word64 - -instance RotatableBits Int -instance RotatableBits Int8 -instance RotatableBits Int16 -instance RotatableBits Int32 -instance RotatableBits Int64 diff --git a/src/lib/Haskus/Format/Binary/Bits/Shift.hs b/src/lib/Haskus/Format/Binary/Bits/Shift.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Bits/Shift.hs +++ /dev/null @@ -1,323 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE CPP #-} - --- | Bit shifts -module Haskus.Format.Binary.Bits.Shift - ( ShiftableBits (..) - , SignedShiftableBits (..) - ) -where - -import Haskus.Format.Binary.Word -import GHC.Exts -import GHC.Num - -#include "MachDeps.h" - --- | Bit shifts --- --- "Checked" means that there is an additional test to ensure that the shift --- offset is valid (less than the bit count). If you are sure that the offset is --- valid, use the "unchecked" version which should be faster. --- --- To shift signed numbers, see `SignedShiftableBits` class methods. -class ShiftableBits a where - -- | Checked right shift - shiftR :: a -> Word -> a - - -- | Checked left shift - shiftL :: a -> Word -> a - - -- | Unchecked right shift - uncheckedShiftR :: a -> Word -> a - - -- | Unchecked left shift - uncheckedShiftL :: a -> Word -> a - - -- | Checked shift to the left if positive, to the right if negative - shift :: a -> Int -> a - shift a i - | i > 0 = shiftL a (fromIntegral i) - | i < 0 = shiftR a (fromIntegral (negate i)) - | otherwise = a - - -- | Unchecked shift to the left if positive, to the right if negative - uncheckedShift :: a -> Int -> a - uncheckedShift a i - | i > 0 = uncheckedShiftL a (fromIntegral i) - | i < 0 = uncheckedShiftR a (fromIntegral (negate i)) - | otherwise = a - --- | Signed bit shifts --- --- "Signed" means that the sign bit (the higher order bit): --- - propagates to the right during right shifts and --- - keeps its value during left shifts (except when all other bits are 0) --- --- "Checked" means that there is an additional test to ensure that the shift --- offset is valid (less than the bit count). If you are sure that the offset is --- valid, use the "unchecked" version which should be faster. -class SignedShiftableBits a where - -- | Checked signed right shift - signedShiftR :: a -> Word -> a - - -- | Checked signed left shift - signedShiftL :: a -> Word -> a - - -- | Unchecked signed right shift - uncheckedSignedShiftR :: a -> Word -> a - - -- | Unchecked signed left shift - uncheckedSignedShiftL :: a -> Word -> a - - -- | Checked signed shift to the left if positive, to the right if negative - signedShift :: a -> Int -> a - signedShift a i - | i > 0 = signedShiftL a (fromIntegral i) - | i < 0 = signedShiftR a (fromIntegral (negate i)) - | otherwise = a - - -- | Unchecked signed shift to the left if positive, to the right if negative - uncheckedSignedShift :: a -> Int -> a - uncheckedSignedShift a i - | i > 0 = uncheckedSignedShiftL a (fromIntegral i) - | i < 0 = uncheckedSignedShiftR a (fromIntegral (negate i)) - | otherwise = a - - -instance ShiftableBits Word where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (W# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = W# 0## - | otherwise = W# (x# `uncheckedShiftL#` word2Int# i#) - (W# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = W# 0## - | otherwise = W# (x# `uncheckedShiftRL#` word2Int# i#) - (W# x#) `uncheckedShiftL` (W# i#) = W# (x# `uncheckedShiftL#` word2Int# i#) - (W# x#) `uncheckedShiftR` (W# i#) = W# (x# `uncheckedShiftRL#` word2Int# i#) - -instance ShiftableBits Word8 where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (W8# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` 8##) = W8# 0## - | otherwise = W8# (narrow8Word# (x# `uncheckedShiftL#` word2Int# i#)) - - (W8# x#) `uncheckedShiftL` (W# i#) = W8# (narrow8Word# (x# `uncheckedShiftL#` word2Int# i#)) - - (W8# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` 8##) = W8# 0## - | otherwise = W8# (x# `uncheckedShiftRL#` word2Int# i#) - - (W8# x#) `uncheckedShiftR` (W# i#) = W8# (x# `uncheckedShiftRL#` word2Int# i#) - -instance ShiftableBits Word16 where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (W16# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` 16##) = W16# 0## - | otherwise = W16# (narrow16Word# (x# `uncheckedShiftL#` word2Int# i#)) - - (W16# x#) `uncheckedShiftL` (W# i#) = W16# (narrow16Word# (x# `uncheckedShiftL#` word2Int# i#)) - - (W16# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` 16##) = W16# 0## - | otherwise = W16# (x# `uncheckedShiftRL#` word2Int# i#) - - (W16# x#) `uncheckedShiftR` (W# i#) = W16# (x# `uncheckedShiftRL#` word2Int# i#) - -instance ShiftableBits Word32 where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (W32# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` 32##) = W32# 0## - | otherwise = W32# (narrow32Word# (x# `uncheckedShiftL#` word2Int# i#)) - - (W32# x#) `uncheckedShiftL` (W# i#) = W32# (narrow32Word# (x# `uncheckedShiftL#` word2Int# i#)) - - (W32# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` 32##) = W32# 0## - | otherwise = W32# (x# `uncheckedShiftRL#` word2Int# i#) - - (W32# x#) `uncheckedShiftR` (W# i#) = W32# (x# `uncheckedShiftRL#` word2Int# i#) - -instance ShiftableBits Word64 where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (W64# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` 64##) = W64# 0## - | otherwise = W64# (x# `uncheckedShiftL#` word2Int# i#) - - (W64# x#) `uncheckedShiftL` (W# i#) = W64# (x# `uncheckedShiftL#` word2Int# i#) - - (W64# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` 64##) = W64# 0## - | otherwise = W64# (x# `uncheckedShiftRL#` word2Int# i#) - - (W64# x#) `uncheckedShiftR` (W# i#) = W64# (x# `uncheckedShiftRL#` word2Int# i#) - - -instance ShiftableBits Int where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (I# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = I# 0# - | otherwise = I# (x# `uncheckedIShiftL#` word2Int# i#) - - (I# x#) `uncheckedShiftL` (W# i#) = I# (x# `uncheckedIShiftL#` word2Int# i#) - - (I# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = I# 0# - | otherwise = I# (x# `uncheckedIShiftRL#` word2Int# i#) - - (I# x#) `uncheckedShiftR` (W# i#) = I# (x# `uncheckedIShiftRL#` word2Int# i#) - -instance ShiftableBits Int8 where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (I8# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` 8##) = I8# 0# - | otherwise = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#)) - - (I8# x#) `uncheckedShiftL` (W# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#)) - - (I8# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` 8##) = I8# 0# - | otherwise = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) - - (I8# x#) `uncheckedShiftR` (W# i#) = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) - - -instance ShiftableBits Int16 where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (I16# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` 16##) = I16# 0# - | otherwise = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#)) - - (I16# x#) `uncheckedShiftL` (W# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#)) - - (I16# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` 16##) = I16# 0# - | otherwise = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) - - (I16# x#) `uncheckedShiftR` (W# i#) = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) - - -instance ShiftableBits Int32 where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (I32# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` 32##) = I32# 0# - | otherwise = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#)) - - (I32# x#) `uncheckedShiftL` (W# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#)) - - (I32# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` 32##) = I32# 0# - | otherwise = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) - - (I32# x#) `uncheckedShiftR` (W# i#) = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) - -instance ShiftableBits Int64 where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - (I64# x#) `shiftL` (W# i#) - | isTrue# (i# `geWord#` 64##) = I64# 0# - | otherwise = I64# (x# `uncheckedIShiftL#` word2Int# i#) - - (I64# x#) `uncheckedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL#` word2Int# i#) - - (I64# x#) `shiftR` (W# i#) - | isTrue# (i# `geWord#` 64##) = I64# 0# - | otherwise = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#)) - - (I64# x#) `uncheckedShiftR` (W# i#) = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#)) - - -instance SignedShiftableBits Int where - (I# x#) `signedShiftL` (W# i#) = I# (x# `iShiftL#` word2Int# i#) - (I# x#) `signedShiftR` (W# i#) = I# (x# `iShiftRA#` word2Int# i#) - (I# x#) `uncheckedSignedShiftL` (W# i#) = I# (x# `uncheckedIShiftL#` word2Int# i#) - (I# x#) `uncheckedSignedShiftR` (W# i#) = I# (x# `uncheckedIShiftRA#` word2Int# i#) - -instance SignedShiftableBits Int8 where - (I8# x#) `signedShiftL` (W# i#) = I8# (narrow8Int# (x# `iShiftL#` word2Int# i#)) - (I8# x#) `signedShiftR` (W# i#) = I8# (x# `iShiftRA#` word2Int# i#) - (I8# x#) `uncheckedSignedShiftL` (W# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#)) - (I8# x#) `uncheckedSignedShiftR` (W# i#) = I8# (x# `uncheckedIShiftRA#` word2Int# i#) - -instance SignedShiftableBits Int16 where - (I16# x#) `signedShiftL` (W# i#) = I16# (narrow16Int# (x# `iShiftL#` word2Int# i#)) - (I16# x#) `signedShiftR` (W# i#) = I16# (x# `iShiftRA#` word2Int# i#) - (I16# x#) `uncheckedSignedShiftL` (W# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#)) - (I16# x#) `uncheckedSignedShiftR` (W# i#) = I16# (x# `uncheckedIShiftRA#` word2Int# i#) - -instance SignedShiftableBits Int32 where - (I32# x#) `signedShiftL` (W# i#) = I32# (narrow32Int# (x# `iShiftL#` word2Int# i#)) - (I32# x#) `signedShiftR` (W# i#) = I32# (x# `iShiftRA#` word2Int# i#) - (I32# x#) `uncheckedSignedShiftL` (W# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#)) - (I32# x#) `uncheckedSignedShiftR` (W# i#) = I32# (x# `uncheckedIShiftRA#` word2Int# i#) - -instance SignedShiftableBits Int64 where - (I64# x#) `signedShiftL` (W# i#) = I64# (x# `iShiftL#` word2Int# i#) - (I64# x#) `signedShiftR` (W# i#) = I64# (x# `iShiftRA#` word2Int# i#) - (I64# x#) `uncheckedSignedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL#` word2Int# i#) - (I64# x#) `uncheckedSignedShiftR` (W# i#) = I64# (x# `uncheckedIShiftRA#` word2Int# i#) - - - -instance ShiftableBits Integer where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - x `shiftL` (W# i#) = shiftLInteger x (word2Int# i#) - x `shiftR` (W# i#) = shiftRInteger x (word2Int# i#) - - uncheckedShiftL = shiftL - uncheckedShiftR = shiftR - -instance ShiftableBits Natural where - {-# INLINABLE shiftR #-} - {-# INLINABLE shiftL #-} - {-# INLINABLE uncheckedShiftL #-} - {-# INLINABLE uncheckedShiftR #-} - - x `shiftL` (W# i#) = shiftLNatural x (I# (word2Int# i#)) - x `shiftR` (W# i#) = shiftRNatural x (I# (word2Int# i#)) - - uncheckedShiftL = shiftL - uncheckedShiftR = shiftR diff --git a/src/lib/Haskus/Format/Binary/Buffer.hs b/src/lib/Haskus/Format/Binary/Buffer.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Buffer.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-# 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.Helper -import Haskus.Format.Binary.Bits.Bitwise -import Haskus.Format.Binary.Bits.Index -import Haskus.Format.Binary.Bits.Shift -import Haskus.Utils.Memory (memCopy,memSet) -import Haskus.Utils.List as List -import Haskus.Utils.Flow - --- | A buffer -newtype Buffer = Buffer ByteString deriving (Eq,Ord) - -instance Show Buffer where - show b = concatMap bToHex (bufferUnpackByteList b) - where - bToHex x = toHex (x `shiftR` 4) ++ toHex (x .&. 0x0F) - toHex 0xA = "A" - toHex 0xB = "B" - toHex 0xC = "C" - toHex 0xD = "D" - toHex 0xE = "E" - toHex 0xF = "F" - toHex x = show x - -instance Bitwise Buffer where - (.&.) = bufferZipWith (.&.) - (.|.) = bufferZipWith (.|.) - xor = bufferZipWith xor - -instance IndexableBits Buffer where - bit i = bufferPackByteList - (bit r : List.replicate (fromIntegral n) 0) - where - n = byteOffset i - r = bitOffset i - - testBit b i = testBit p r - where - p = bufferIndex b (bufferSize b - n) - n = byteOffset i - r = bitOffset i - - setBit = error "Can't set Buffer bit" - clearBit = error "Can't clear Buffer bit" - - popCount b = sum (fmap popCount (bufferUnpackByteList b)) - - - --- | Duplicate a buffer -bufferDup :: Buffer -> IO Buffer -bufferDup b = withBufferPtr b $ bufferPackPtr (bufferSize b) - --- | Buffer filled with zero -bufferZero :: Word -> Buffer -bufferZero n = unsafePerformIO $ do - p <- mallocBytes (fromIntegral n) - memSet p (fromIntegral n) 0 - bufferUnsafePackPtr n p - --- | Zip two buffers with the given function -bufferZipWith :: (Word8 -> Word8 -> Word8) -> Buffer -> Buffer -> Buffer -bufferZipWith f a b - | bufferSize a /= bufferSize b = error "Non matching buffer sizes" - | otherwise = unsafePerformIO $ do - let sz = fromIntegral (bufferSize a) - pc <- mallocBytes sz - withBufferPtr a $ \pa -> - withBufferPtr b $ \pb -> - forM_ [0..fromIntegral sz-1] $ \off -> do - v <- f <$> peekByteOff pa off - <*> peekByteOff pb off - pokeByteOff pc off (v :: Word8) - bufferUnsafePackPtr (bufferSize a) pc - --- | Unsafe: be careful if you modify the buffer contents or you may break --- referential transparency -withBufferPtr :: Buffer -> (Ptr b -> IO a) -> IO a -withBufferPtr (Buffer bs) f = BS.unsafeUseAsCString bs (f . castPtr) - --- | Test if the buffer is empty -isBufferEmpty :: Buffer -> Bool -isBufferEmpty (Buffer bs) = BS.null bs - --- | Empty buffer -emptyBuffer :: Buffer -emptyBuffer = Buffer BS.empty - --- | Buffer size -bufferSize :: Buffer -> Word -bufferSize (Buffer bs) = - if s < 0 - then error "ByteString with size < 0" - else fromIntegral s - where - s = BS.length bs - --- | Peek a storable -bufferPeekStorable :: forall a. Storable a => Buffer -> a -bufferPeekStorable = snd . bufferPopStorable - --- | Peek a storable at the given offset -bufferPeekStorableAt :: forall a. - ( Storable a - ) - => Buffer -> Word -> a -bufferPeekStorableAt b n - | n + sizeOfT' @a > bufferSize b = error "Invalid buffer index" - | otherwise = unsafePerformIO $ withBufferPtr b $ \p -> - peekByteOff p (fromIntegral n) - - --- | Pop a Storable and return the new buffer -bufferPopStorable :: forall a. Storable a => Buffer -> (Buffer,a) -bufferPopStorable buf - | bufferSize buf < sza = error "bufferRead: out of bounds" - | otherwise = unsafePerformIO $ do - a <- withBufferPtr buf peek - return (bufferDrop sza buf, a) - where - sza = sizeOfT' @a - --- | Poke a buffer -bufferPoke :: Ptr a -> Buffer -> IO () -bufferPoke dest b = bufferUnsafeUsePtr b $ \src sz -> - memCopy dest src (fromIntegral sz) - --- | Map -bufferMap :: (Word8 -> Word8) -> Buffer -> Buffer -bufferMap f (Buffer bs) = Buffer (BS.map f bs) - --- | Reverse -bufferReverse :: Buffer -> Buffer -bufferReverse (Buffer bs) = Buffer (BS.reverse bs) - --- | Drop some bytes O(1) -bufferDrop :: Word -> Buffer -> Buffer -bufferDrop n (Buffer bs) = Buffer $ BS.drop (fromIntegral n) bs - --- | Split on the given Byte values -bufferSplitOn :: Word8 -> Buffer -> [Buffer] -bufferSplitOn n (Buffer bs) = fmap Buffer (BS.split n bs) - --- | Tail -bufferTail :: Buffer -> Buffer -bufferTail (Buffer bs) = Buffer $ BS.tail bs - --- | Append -bufferAppend :: Buffer -> Buffer -> Buffer -bufferAppend (Buffer a) (Buffer b) = Buffer $ BS.append a b - --- | Cons -bufferCons :: Word8 -> Buffer -> Buffer -bufferCons w (Buffer bs) = Buffer $ BS.cons w bs - --- | Snoc -bufferSnoc :: Buffer -> Word8 -> Buffer -bufferSnoc (Buffer bs) w = Buffer $ BS.snoc bs w - - --- | Init -bufferInit :: Buffer -> Buffer -bufferInit (Buffer bs) = Buffer $ BS.init bs - --- | Head -bufferHead :: Buffer -> Word8 -{-# INLINABLE bufferHead #-} -bufferHead (Buffer bs) = BS.head bs - --- | Index -bufferIndex :: Buffer -> Word -> Word8 -{-# INLINABLE bufferIndex #-} -bufferIndex (Buffer bs) n = BS.index bs (fromIntegral n) - --- | Unpack -bufferUnpackByteList :: Buffer -> [Word8] -bufferUnpackByteList (Buffer bs) = BS.unpack bs - --- | Unpack -bufferUnpackByteString :: Buffer -> ByteString -bufferUnpackByteString (Buffer bs) = bs - --- | Take some bytes O(1) -bufferTake :: Word -> Buffer -> Buffer -bufferTake n (Buffer bs) = Buffer $ BS.take (fromIntegral n) bs - --- | Take some bytes O(n) -bufferTakeWhile :: (Word8 -> Bool) -> Buffer -> Buffer -bufferTakeWhile f (Buffer bs) = Buffer $ BS.takeWhile f bs - --- | Take some bytes O(1) -bufferTakeAtMost :: Word -> Buffer -> Buffer -bufferTakeAtMost n buf - | bufferSize buf < n = buf - | otherwise = bufferTake n buf - - --- | Pack a ByteString -bufferPackByteString :: BS.ByteString -> Buffer -bufferPackByteString = Buffer - --- | Pack a list of bytes -bufferPackByteList :: [Word8] -> Buffer -bufferPackByteList = Buffer . BS.pack - --- | Pack a Storable -bufferPackStorable :: forall a. Storable a => a -> Buffer -bufferPackStorable x = Buffer $ unsafePerformIO $ do - p <- malloc - poke p x - BS.unsafePackMallocCStringLen (castPtr p, sizeOfT' @a) - --- | Pack a list of Storable -bufferPackStorableList :: forall a. Storable a => [a] -> Buffer -bufferPackStorableList xs = Buffer $ unsafePerformIO $ do - let lxs = length xs - p <- mallocArray (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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/BufferBuilder.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# 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 (Semigroup,Monoid) - --- | Empty buffer builder -emptyBufferBuilder :: BufferBuilder -emptyBufferBuilder = BufferBuilder mempty - --- | Create a Builder denoting the same sequence of bytes as a strict --- ByteString. The Builder inserts large ByteStrings directly, but copies small --- ones to ensure that the generated chunks are large on average. -fromBuffer :: Buffer -> BufferBuilder -fromBuffer (Buffer bs) = BufferBuilder (B.byteString bs) - --- | Encode a single unsigned byte as-is. -fromWord8 :: Word8 -> BufferBuilder -fromWord8 w = BufferBuilder (B.word8 w) - --- | Execute a Builder and return the generated chunks as a BufferList. The work --- is performed lazily, i.e., only when a chunk of the BufferList is forced. -toBufferList :: BufferBuilder -> BL.BufferList -toBufferList (BufferBuilder b) = BL.BufferList (B.toLazyByteString b) - --- | Execute a Builder and return the generated chunks as a Buffer. -toBuffer :: BufferBuilder -> Buffer -toBuffer = BL.toBuffer . toBufferList diff --git a/src/lib/Haskus/Format/Binary/BufferList.hs b/src/lib/Haskus/Format/Binary/BufferList.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/BufferList.hs +++ /dev/null @@ -1,29 +0,0 @@ --- | 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/Char.hs b/src/lib/Haskus/Format/Binary/Char.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Char.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | Character -module Haskus.Format.Binary.Char - ( Char8 (..) - ) -where - -import Haskus.Format.Binary.Word -import Haskus.Format.Binary.Storable - --- | 8-bit character (ASCII, etc.) -newtype Char8 - = Char8 Word8 - deriving (Show,Eq,Ord,Storable) diff --git a/src/lib/Haskus/Format/Binary/Endianness.hs b/src/lib/Haskus/Format/Binary/Endianness.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Endianness.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} - --- | Byte order ("endianness") --- --- Indicate in which order bytes are stored in memory for multi-bytes types. --- Big-endian means that most-significant bytes come first. Little-endian means --- that least-significant bytes come first. -module Haskus.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.Storable -import Haskus.Format.Binary.Word -import Haskus.Format.Binary.Bits - -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 Word32 - , wordGetter64 :: Get Word64 -- ^ Read a Word64 - } - --- | Word putters -data WordPutters = WordPutters - { wordPutter8 :: Word8 -> Put -- ^ Write a Word8 - , wordPutter16 :: Word16 -> Put -- ^ Write a Word16 - , wordPutter32 :: Word32 -> Put -- ^ Write a Word32 - , wordPutter64 :: Word64 -> Put -- ^ Write a Word64 - } - --- | Get getters for the given endianness -getWordGetters :: Endianness -> WordGetters -getWordGetters e = case e of - LittleEndian -> WordGetters getWord8 getWord16le getWord32le getWord64le - BigEndian -> WordGetters getWord8 getWord16be getWord32be getWord64be - --- | Get putters for the given endianness -getWordPutters :: Endianness -> WordPutters -getWordPutters e = case e of - LittleEndian -> WordPutters putWord8 putWord16le putWord32le putWord64le - BigEndian -> WordPutters putWord8 putWord16be putWord32be putWord64be - - - --- | Size of a machine word -data WordSize - = WordSize32 -- ^ 32-bit - | WordSize64 -- ^ 64-bit - deriving (Show, Eq) - --- | Extended word getters -data ExtendedWordGetters = ExtendedWordGetters - { extwordGetter8 :: Get Word8 -- ^ Read a Word8 - , extwordGetter16 :: Get Word16 -- ^ Read a Word16 - , extwordGetter32 :: Get Word32 -- ^ Read a Word32 - , extwordGetter64 :: Get Word64 -- ^ Read a Word64 - , extwordGetterN :: Get Word64 -- ^ Read a native size word into a Word64 - } - --- | Extended word putters -data ExtendedWordPutters = ExtendedWordPutters - { extwordPutter8 :: Word8 -> Put -- ^ Write a Word8 - , extwordPutter16 :: Word16 -> Put -- ^ Write a Word16 - , extwordPutter32 :: Word32 -> Put -- ^ Write a Word32 - , extwordPutter64 :: Word64 -> Put -- ^ Write a Word64 - , extwordPutterN :: Word64 -> Put -- ^ Write a Word64 into a native size word - } - --- | Return extended getters -getExtendedWordGetters :: Endianness -> WordSize -> ExtendedWordGetters -getExtendedWordGetters endian ws = ExtendedWordGetters gw8 gw16 gw32 gw64 gwN - where - WordGetters gw8 gw16 gw32 gw64 = getWordGetters endian - gwN = case ws of - WordSize64 -> gw64 - WordSize32 -> fromIntegral <$> gw32 - --- | Return extended putters -getExtendedWordPutters :: Endianness -> WordSize -> ExtendedWordPutters -getExtendedWordPutters endian ws = ExtendedWordPutters pw8 pw16 pw32 pw64 pwN - where - WordPutters pw8 pw16 pw32 pw64 = getWordPutters endian - pwN x = case ws of - WordSize64 -> pw64 x - WordSize32 -> if x > 0xffffffff - then error $ "Number too big to be stored in 32-bit word ("++show x++")" - else pw32 (fromIntegral x) - --- | Detect the endianness of the host memory -getHostEndianness :: IO Endianness -getHostEndianness = do - -- Write a 32 bit word and check byte ordering - let magic = 0x01020304 :: Word32 - alloca $ \p -> do - poke p magic - rs <- peekArray 4 (castPtr p :: Ptr Word8) - return $ if rs == [1,2,3,4] then BigEndian else LittleEndian - --- | Detected host endianness --- --- TODO: use targetByteOrder in GHC.ByteOrder (should be introduced in GHC 8.4) -hostEndianness :: Endianness -{-# NOINLINE hostEndianness #-} -hostEndianness = unsafePerformIO getHostEndianness - --- | Reverse bytes in a word -class ByteReversable w where - reverseBytes :: w -> w - - hostToBigEndian :: w -> w - hostToBigEndian w = case hostEndianness of - BigEndian -> w - LittleEndian -> reverseBytes w - - bigEndianToHost :: w -> w - bigEndianToHost w = case hostEndianness of - BigEndian -> w - LittleEndian -> reverseBytes w - - - hostToLittleEndian :: w -> w - hostToLittleEndian w = case hostEndianness of - BigEndian -> reverseBytes w - LittleEndian -> w - - littleEndianToHost :: w -> w - littleEndianToHost w = case hostEndianness of - BigEndian -> reverseBytes w - LittleEndian -> w - -instance ByteReversable Word8 where - reverseBytes = id - -instance ByteReversable Word16 where - reverseBytes = byteSwap16 - -instance ByteReversable Word32 where - reverseBytes = byteSwap32 - -instance ByteReversable Word64 where - reverseBytes = byteSwap64 - - - --- | Force a data to be read/stored as big-endian -newtype AsBigEndian a - = AsBigEndian a - deriving (Eq,Ord,Enum,Num,Integral,Real,Bitwise,FiniteBits,ReversableBits,RotatableBits,ShiftableBits,IndexableBits) - -instance Show a => Show (AsBigEndian a) where - show (AsBigEndian a) = show a - --- | Force a data to be read/stored as little-endian -newtype AsLittleEndian a - = AsLittleEndian a - deriving (Eq,Ord,Enum,Num,Integral,Real,Bitwise,FiniteBits,ReversableBits,RotatableBits,ShiftableBits,IndexableBits) - -instance Show a => Show (AsLittleEndian a) where - show (AsLittleEndian a) = show a - -instance (ByteReversable a, StaticStorable a) => StaticStorable (AsBigEndian a) where - type SizeOf (AsBigEndian a) = SizeOf a - type Alignment (AsBigEndian a) = Alignment a - - staticPeekIO ptr = AsBigEndian . bigEndianToHost <$> staticPeek (castPtr ptr) - staticPokeIO ptr (AsBigEndian v) = staticPoke (castPtr ptr) (hostToBigEndian v) - - -instance (ByteReversable a, Storable a) => Storable (AsBigEndian a) where - sizeOf _ = sizeOfT @a - alignment _ = alignmentT @a - - peekIO ptr = AsBigEndian . bigEndianToHost <$> peek (castPtr ptr) - pokeIO ptr (AsBigEndian v) = poke (castPtr ptr) (hostToBigEndian v) - -instance (ByteReversable a, StaticStorable a) => StaticStorable (AsLittleEndian a) where - type SizeOf (AsLittleEndian a) = SizeOf a - type Alignment (AsLittleEndian a) = Alignment a - - staticPeekIO ptr = AsLittleEndian . bigEndianToHost <$> staticPeekIO (castPtr ptr) - staticPokeIO ptr (AsLittleEndian v) = staticPokeIO (castPtr ptr) (hostToLittleEndian v) - -instance (ByteReversable a, Storable a) => Storable (AsLittleEndian a) where - sizeOf _ = sizeOfT @a - alignment _ = alignmentT @a - - peekIO ptr = AsLittleEndian . bigEndianToHost <$> peek (castPtr ptr) - pokeIO ptr (AsLittleEndian v) = poke (castPtr ptr) (hostToLittleEndian v) diff --git a/src/lib/Haskus/Format/Binary/Enum.hs b/src/lib/Haskus/Format/Binary/Enum.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Enum.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} - --- | Store an Enum in the given backing word type -module Haskus.Format.Binary.Enum - ( EnumField - , CEnum (..) - , fromEnumField - , toEnumField - , makeEnum - , makeEnumMaybe - , makeEnumWithCustom - , dataToTag - ) -where - -import Haskus.Format.Binary.Storable -import Haskus.Format.Binary.Ptr - -import Data.Data -import GHC.Prim -import GHC.Int - ------------------------------------------------------------------------------ --- EnumField b a: directly store the value of enum "a" as a "b" ------------------------------------------------------------------------------ - --- | Store enum `a` as a `b` -newtype EnumField b a - = EnumField b - deriving (Show,Eq,Storable) - -instance - ( Integral b - , StaticStorable b - , CEnum a - ) => StaticStorable (EnumField b a) - where - type SizeOf (EnumField b a) = SizeOf b - type Alignment (EnumField b a) = Alignment b - staticPeekIO p = EnumField <$> staticPeek (castPtr p :: Ptr b) - staticPokeIO p (EnumField v) = staticPoke (castPtr p :: Ptr b) v - --- | Read an enum field -fromEnumField :: (CEnum a, Integral b) => EnumField b a -> a -{-# INLINABLE fromEnumField #-} -fromEnumField (EnumField b) = toCEnum b - --- | Create an enum field -toEnumField :: (CEnum a, Integral b) => a -> EnumField b a -{-# INLINABLE toEnumField #-} -toEnumField = EnumField . fromCEnum - - ------------------------------------------------------------------------------ --- Extended Enum ------------------------------------------------------------------------------ - --- | Extended Enum --- --- By default, use dataToTag and toEnum to convert from and to an Integral. --- --- But it can be overloaded to perform transformation before using --- fromEnum/toEnum. E.g. if values are shifted by 1 compared to Enum values, --- define fromCEnum = (+1) . fromIntegral . dataToTag --- -class CEnum a where - fromCEnum :: Integral b => a -> b - fromCEnum = fromIntegral . dataToTag - - toCEnum :: Integral b => b -> a - default toCEnum :: (Enum a, Integral b) => b -> a - toCEnum = toEnum . fromIntegral - --- | Make an enum with the last constructor taking a parameter for the rest of --- the range --- --- @ --- data T = A | B | C | D Word8 --- --- makeEnumWithCustom :: Int -> T --- makeEnumWithCustom x = case x of --- 0 -> A --- 1 -> B --- 2 -> C --- n -> D (n - 3) --- @ --- -makeEnumWithCustom :: forall a i. (Data a,Integral i) => i -> a -{-# INLINABLE makeEnumWithCustom #-} -makeEnumWithCustom x = - if x' < maxConstrIndex t - then fromConstr (indexConstr t x') - else fromConstrB (fromConstr (toConstr (x' - m))) - (indexConstr t m) - where - m = maxConstrIndex t - x' = fromIntegral x + 1 - t = dataTypeOf (undefined :: a) - --- | Make an enum with the last constructor taking a parameter for the rest of --- the range, but don't build the last constructor --- --- @ --- data T = A | B | C | D Word8 --- --- makeEnumMaybe :: Int -> T --- makeEnumMaybe x = case x of --- 0 -> Just A --- 1 -> Just B --- 2 -> Just C --- n -> Nothing --- @ --- -makeEnumMaybe :: forall a i. (Data a,Integral i) => i -> Maybe a -{-# INLINABLE makeEnumMaybe #-} -makeEnumMaybe x = - if x' < maxConstrIndex t - then Just (fromConstr (indexConstr t x')) - else Nothing - where - x' = fromIntegral x + 1 - t = dataTypeOf (undefined :: a) - --- | Make an enum from a number (0 indexed) -makeEnum :: forall a i. (Data a,Integral i) => i -> a -{-# INLINABLE makeEnum #-} -makeEnum x =fromConstr (indexConstr t x') - where - x' = fromIntegral x + 1 - t = dataTypeOf (undefined :: a) - - --- | Retrieve data tag --- --- >>> data D = A | B | C --- >>> dataToTag B --- 1 -dataToTag :: a -> Int -dataToTag a = I# (dataToTag# a) diff --git a/src/lib/Haskus/Format/Binary/FixedPoint.hs b/src/lib/Haskus/Format/Binary/FixedPoint.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/FixedPoint.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} - --- | 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.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 radix 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Get.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Layout.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# 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 - ( LPath (..) - , PathElem (..) - , lPath - , LPathType - , LPathOffset - , LRoot - , (:->) - , (:#>) - ) -where - -import Haskus.Utils.Types - --- | Path in a layout -data LPath (path :: [PathElem]) = LPath - --- | Layout path element -data PathElem - = LIndex Nat -- ^ Addressing via a numeric index - | LSymbol Symbol -- ^ Addressing via a symbol - --- | Layout path root -type LRoot = LPath '[] - --- | Index in the layout path --- --- Helper for ``ptr --> lPath @p`` --- until -lPath :: forall e. LPath '[e] -lPath = LPath - --- | Type obtained when following path p -type family LPathType p l :: * -type instance LPathType (LPath '[]) l = l - --- | Offset obtained when following path p -type family LPathOffset p l :: Nat -type instance LPathOffset (LPath '[]) l = 0 - - -type family (:->) p (s :: Symbol) where - (:->) (LPath xs) s = LPath (Snoc xs ('LSymbol s)) - -type family (:#>) p (n :: Nat) where - (:#>) (LPath xs) n = LPath (Snoc xs ('LIndex n)) diff --git a/src/lib/Haskus/Format/Binary/Posit.hs b/src/lib/Haskus/Format/Binary/Posit.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Posit.hs +++ /dev/null @@ -1,423 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - --- | Posit (type III unum) -module Haskus.Format.Binary.Posit - ( Posit (..) - , PositKind (..) - , PositK (..) - , positKind - , isZero - , isInfinity - , isPositive - , isNegative - , positAbs - , PositEncoding (..) - , PositFields (..) - , positEncoding - , positFields - , positToRational - , positFromRational - , positApproxFactor - , positDecimalError - , positDecimalAccuracy - , positBinaryError - , positBinaryAccuracy - , floatBinaryAccuracy - ) -where - -import Haskus.Format.Binary.Word -import Haskus.Format.Binary.Bits -import Haskus.Utils.Types -import Haskus.Utils.Tuple -import Haskus.Utils.Flow - -import Data.Ratio -import qualified GHC.Real as Ratio - -newtype Posit (nbits :: Nat) (es :: Nat) = Posit (IntN nbits) - --- | Show posit -instance - ( Bits (IntN n) - , FiniteBits (IntN n) - , Ord (IntN n) - , Num (IntN n) - , KnownNat n - , KnownNat es - , Integral (IntN n) - ) => Show (Posit n es) - where - show p = case positKind p of - SomePosit Zero -> "0" - SomePosit Infinity -> "Infinity" - SomePosit (Value v) -> show (positToRational v) - -data PositKind - = ZeroK - | InfinityK - | NormalK - deriving (Show,Eq) - --- | Kinded Posit --- --- GADT that can be used to ensure at the type level that we deal with --- non-infinite/non-zero Posit values -data PositK k nbits es where - Zero :: PositK 'ZeroK nbits es - Infinity :: PositK 'InfinityK nbits es - Value :: Posit nbits es -> PositK 'NormalK nbits es - -data SomePosit n es where - SomePosit :: PositK k n es -> SomePosit n es - -type PositValue n es = PositK 'NormalK n es - --- | Get the kind of the posit at the type level -positKind :: forall n es. - ( Bits (IntN n) - , KnownNat n - , Eq (IntN n) - ) => Posit n es -> SomePosit n es -positKind p - | isZero p = SomePosit Zero - | isInfinity p = SomePosit Infinity - | otherwise = SomePosit (Value p) - --- | Check if a posit is zero -isZero :: forall n es. - ( Bits (IntN n) - , Eq (IntN n) - , KnownNat n - ) => Posit n es -> Bool -{-# INLINABLE isZero #-} -isZero (Posit i) = i == zeroBits - --- | Check if a posit is infinity -isInfinity :: forall n es. - ( Bits (IntN n) - , Eq (IntN n) - , KnownNat n - ) => Posit n es -> Bool -{-# INLINABLE isInfinity #-} -isInfinity (Posit i) = i == bit (natValue @n - 1) - --- | Check if a posit is positive -isPositive :: forall n es. - ( Bits (IntN n) - , Ord (IntN n) - , KnownNat n - ) => PositValue n es -> Bool -{-# INLINABLE isPositive #-} -isPositive (Value (Posit i)) = i > zeroBits - --- | Check if a posit is negative -isNegative :: forall n es. - ( Bits (IntN n) - , Ord (IntN n) - , KnownNat n - ) => PositValue n es -> Bool -{-# INLINABLE isNegative #-} -isNegative (Value (Posit i)) = i < zeroBits - --- | Posit absolute value -positAbs :: forall n es. - ( Num (IntN n) - , KnownNat n - ) => PositValue n es -> PositValue n es -positAbs (Value (Posit i)) = Value (Posit (abs i)) - - -data PositFields = PositFields - { positNegative :: Bool - , positRegimeBitCount :: Word - , positExponentBitCount :: Word - , positFractionBitCount :: Word - , positRegime :: Int - , positExponent :: Word - , positFraction :: Word - } - deriving (Show) - -data PositEncoding - = PositInfinity - | PositZero - | PositEncoding PositFields - deriving (Show) - -positEncoding :: forall n es. - ( Bits (IntN n) - , Ord (IntN n) - , Num (IntN n) - , KnownNat n - , KnownNat es - , Integral (IntN n) - ) => Posit n es -> PositEncoding -positEncoding p = case positKind p of - SomePosit Zero -> PositZero - SomePosit Infinity -> PositInfinity - SomePosit v@(Value _) -> PositEncoding (positFields v) - --- | Decode posit fields -positFields :: forall n es. - ( Bits (IntN n) - , Ord (IntN n) - , Num (IntN n) - , KnownNat n - , KnownNat es - , Integral (IntN n) - ) => PositValue n es -> PositFields -positFields p = PositFields - { positNegative = isNegative p - , positRegimeBitCount = rs - , positExponentBitCount = es - , positFractionBitCount = fs - , positRegime = regime - , positExponent = expo - , positFraction = frac - } - where - -- get absolute value - Value (Posit v) = positAbs p - - (negativeRegime,regimeLen) = - if v `testBit` (natValue @n - 2) - -- regime has shape 111...[0|end of word], subtract 1 for sign bit - then (False, countLeadingZeros (complement v `clearBit` (natValue @n - 1)) - 1) - -- regime has shape 00000...[1|end of word], subtract 1 for sign bit - else (True, countLeadingZeros v - 1) - - regime = if negativeRegime - then negate (fromIntegral regimeLen) - else fromIntegral regimeLen - 1 -- we encode the 0 regime - - -- length of regime bits (with stop bit) - rs = min (natValue @n - 1) (regimeLen + 1) - - -- real exponent size (regime bits can reduce the size of the exponent) - es = min (natValue @n - rs - 1) (natValue @es) - - -- fraction size - fs = natValue @n - es - rs - 1 - - expo = fromIntegral (maskDyn es (v `shiftR` fs)) - frac = fromIntegral (maskDyn fs v) - - --- | Convert a Posit into a Rational -positToRational :: forall n es. - ( KnownNat n - , KnownNat es - , Eq (IntN n) - , Bits (IntN n) - , Integral (IntN n) - ) => Posit n es -> Rational -positToRational p - | isZero p = 0 Ratio.:% 1 - | isInfinity p = Ratio.infinity - | otherwise = (fromIntegral useed ^^ r) * (2 ^^ e) * (1 + (f % fd)) - where - fields = positFields (Value p) - r = positRegime fields - e = positExponent fields - f = fromIntegral (positFraction fields) - fd = 1 `shiftL` positFractionBitCount fields - useed = 1 `shiftL` (1 `shiftL` natValue @es) :: Integer -- 2^(2^es) - --- | Convert a rational into the approximate Posit -positFromRational :: forall p n es. - ( Posit n es ~ p - , Num (IntN n) - , Bits (IntN n) - , KnownNat es - , KnownNat n - ) => Rational -> Posit n es -positFromRational x = if - | x == 0 -> Posit 0 - | x == Ratio.infinity -> Posit (bit (natValue @n - 1)) - | otherwise -> computeRegime - |> uncurry3 computeExponent - |> uncurry3 computeFraction - |> uncurry computeRounding - |> computeSign - |> Posit - where - useed = fromIntegral (1 `shiftL` (1 `shiftL` es) :: Integer) -- 2^(2^es) - - nbits = natValue @n - es = natValue @es - - -- compute regime bits of the posit, return (y,p,i) - -- y: remaining value to convert, in [1,useed) if there are enough available bits - -- p: current posit bits - -- i: number of set bits in p - computeRegime - | absx >= 1 = regime111 absx 1 2 - | otherwise = regime000 absx 1 - where - absx = abs x - - -- push regime bits 111..1110 - regime111 y p i - | y >= useed && i < nbits = regime111 (y / useed) ((p `uncheckedShiftL` 1) .|. 1) (i+1) - | otherwise = (y, p `uncheckedShiftL` 1, i+1) - - -- push regime bits 000..0001 (or 000...00010 if the full word - -- (including the sign bit) is set) - regime000 y i - | y < 1 && i <= nbits = regime000 (y*useed) (i+1) - | i >= nbits = (y,2,nbits+1) - | otherwise = (y,1,i+1) - - -- compute exponent bits; return (y,p,i) - -- y: remaining value to convert, in [1,2) if there are enough available bits - -- p: current posit bits - -- i: number of set bits in p - computeExponent - | es == 0 = (,,) - | otherwise = go (1 `shiftL` (es - 1)) - where - go e y p i - | i > nbits || e == 0 = (y,p,i) - | y >= pow2e = go (e `uncheckedShiftR` 1) (y / pow2e) ((p `uncheckedShiftL` 1) .|. 1) (i+1) - | otherwise = go (e `uncheckedShiftR` 1) y (p `uncheckedShiftL` 1) (i+1) - where - pow2e = fromIntegral (1 `shiftL` e :: Integer) - - -- compute fraction bits; return (y,p) - -- y: remaining value to convert - -- p: current posit bits - computeFraction y' = go (y'-1) -- subtract hidden bit. Now y is in [0,1) if there are enough available bits - where - go y p i - | i > nbits = (y,p) - | y <= 0 = (y, p `shiftL` (nbits+1-i)) -- add remaining 0s fraction bits - | y2 > 1 = go (y2-1) (p `shiftL` 1 + 1) (i+1) - | otherwise = go y2 (p `shiftL` 1) (i+1) - where - y2 = 2*y - - -- at this stage, p contains an additional fraction bit. - -- We remove it and we round accordingly. - computeRounding y p = - let p' = p `uncheckedShiftR` 1 - in if | not (p `testBit` 0) -> p' -- closer to lower value - | y == 1 || y == 0 -> p' + (if p' `testBit` 0 then 1 else 0) -- tie goes to nearest even - | otherwise -> p' + 1 -- closer to upper value - - - -- fixup the sign bit (and use 2's complement for the other bits) - computeSign p - | x < 0 = negate p - | otherwise = p - - --- | Factor of approximation for a given Rational when encoded as a Posit. --- The closer to 1, the better. --- --- Usage: --- --- positApproxFactor @(Posit 8 2) (52 % 137) --- -positApproxFactor :: forall p n es. - ( Posit n es ~ p - , Num (IntN n) - , Bits (IntN n) - , Integral (IntN n) - , KnownNat es - , KnownNat n - ) => Rational -> Double -positApproxFactor r = fromRational ((positToRational (positFromRational r :: p)) / r) - --- | Compute the decimal error if the given Rational is encoded as a Posit. --- --- Usage: --- --- positDecimalError @(Posit 8 2) (52 % 137) --- -positDecimalError :: forall p n es. - ( Posit n es ~ p - , Num (IntN n) - , Bits (IntN n) - , Integral (IntN n) - , KnownNat es - , KnownNat n - ) => Rational -> Double -positDecimalError r = abs (logBase 10 (positApproxFactor @p r)) - --- | Compute the number of decimals of accuracy if the given Rational is encoded --- as a Posit. --- --- Usage: --- --- positDecimalAccuracy @(Posit 8 2) (52 % 137) --- -positDecimalAccuracy :: forall p n es. - ( Posit n es ~ p - , Num (IntN n) - , Bits (IntN n) - , Integral (IntN n) - , KnownNat es - , KnownNat n - ) => Rational -> Double -positDecimalAccuracy r = -1 * logBase 10 (positDecimalError @p r) - - --- | Compute the binary error if the given Rational is encoded as a Posit. --- --- Usage: --- --- positBinaryError @(Posit 8 2) (52 % 137) --- -positBinaryError :: forall p n es. - ( Posit n es ~ p - , Num (IntN n) - , Bits (IntN n) - , Integral (IntN n) - , KnownNat es - , KnownNat n - ) => Rational -> Double -positBinaryError r = abs (logBase 2 (positApproxFactor @p r)) - --- | Compute the number of bits of accuracy if the given Rational is encoded --- as a Posit. --- --- Usage: --- --- positBinaryAccuracy @(Posit 8 2) (52 % 137) --- -positBinaryAccuracy :: forall p n es. - ( Posit n es ~ p - , Num (IntN n) - , Bits (IntN n) - , Integral (IntN n) - , KnownNat es - , KnownNat n - ) => Rational -> Double -positBinaryAccuracy r = -1 * logBase 2 (positBinaryError @p r) - - --- | Compute the number of bits of accuracy if the given Rational is encoded --- as a Float/Double. --- --- Usage: --- --- floatBinaryAccuracy @Double (52 % 137) --- -floatBinaryAccuracy :: forall f. - ( Fractional f - , Real f - ) => Rational -> Double -floatBinaryAccuracy r = -1 * logBase 2 floatError - where - floatApprox = fromRational (toRational (fromRational r :: f) / r) - floatError = abs (logBase 2 floatApprox) diff --git a/src/lib/Haskus/Format/Binary/Ptr.hs b/src/lib/Haskus/Format/Binary/Ptr.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Ptr.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# 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 Data.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 -{-# INLINABLE 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 - - -- | 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 - (-->) :: forall path l. - ( KnownNat (LPathOffset path l) - ) => p l -> path -> p (LPathType path l) - {-# INLINABLE (-->) #-} - (-->) p _ = castPtr (p `indexPtr` natValue @(LPathOffset path l)) - --- | Generalized version of 'indexPtr' -indexPtr' :: Integral b => Ptr a -> b -> Ptr a -indexPtr' p a = indexPtr p (fromIntegral a) - - -instance PtrLike Ptr where - {-# INLINABLE castPtr #-} - castPtr = coerce - - {-# INLINABLE nullPtr #-} - nullPtr = Ptr.nullPtr - - {-# INLINABLE indexPtr #-} - indexPtr = Ptr.plusPtr - - {-# INLINABLE ptrDistance #-} - ptrDistance = Ptr.minusPtr - - {-# INLINABLE withPtr #-} - withPtr p f = f p - - {-# INLINABLE mallocBytes #-} - mallocBytes = liftIO . Ptr.mallocBytes . fromIntegral - - -instance PtrLike FinalizedPtr where - {-# INLINABLE castPtr #-} - castPtr = coerce - - {-# INLINABLE nullPtr #-} - nullPtr = nullFinalizedPtr - - {-# INLINABLE indexPtr #-} - indexPtr (FinalizedPtr fp o) n - | n >= 0 = FinalizedPtr fp (o+fromIntegral n) - | otherwise = FinalizedPtr fp (o-fromIntegral (abs n)) - - {-# INLINABLE 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) - - {-# INLINABLE withPtr #-} - withPtr = withFinalizedPtr - - {-# INLINABLE 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Put.hs +++ /dev/null @@ -1,78 +0,0 @@ --- | 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Record.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# 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 - , 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 (Mod (RecordSize fs 0) (RecordAlignment fs 1)) - (RecordAlignment fs 1) - --- | Record alignment -type family RecordAlignment (fs :: [*]) a where - RecordAlignment '[] a = a - RecordAlignment (Field name typ ': fs) a = - RecordAlignment fs - (If (a <=? Alignment typ) (Alignment typ) a) - --- | Return offset from a field path -type family FieldPathOffset (fs :: [*]) (path :: [Symbol]) (off :: Nat) where - FieldPathOffset fs '[p] off = off + FieldOffset p fs 0 - FieldPathOffset fs (p ': ps) off - = FieldPathOffset (ExtractRecord (FieldType p fs)) - ps (off + FieldOffset p fs 0) - --- | Return type from a field path -type family FieldPathType (fs :: [*]) (path :: [Symbol]) where - FieldPathType fs '[p] = FieldType p fs - - FieldPathType fs (p ': ps) - = FieldPathType (ExtractRecord (FieldType p fs)) ps - -type family ExtractRecord x where - ExtractRecord (Record fs) = fs - --- | Get record size -recordSize :: forall fs. - ( KnownNat (FullRecordSize fs) - ) => Record fs -> Word -recordSize _ = natValue' @(FullRecordSize fs) - --- | Get record alignment -recordAlignment :: forall fs. - ( KnownNat (RecordAlignment fs 1) - ) => Record fs -> Word -recordAlignment _ = natValue' @(RecordAlignment fs 1) - --- | Get a field offset -recordFieldOffset :: forall (name :: Symbol) fs. - ( KnownNat (FieldOffset name fs 0) - ) => Record fs -> Int -recordFieldOffset _ = natValue @(FieldOffset name fs 0) - --- | Get a field -recordField :: forall (name :: Symbol) a fs. - ( KnownNat (FieldOffset name fs 0) - , a ~ FieldType name fs - , StaticStorable a - ) => Record fs -> a -recordField r@(Record fp) = unsafePerformIO $ - withForeignPtr fp $ \ptr ->do - let ptr' = ptr `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/Serialize.hs b/src/lib/Haskus/Format/Binary/Serialize.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Serialize.hs +++ /dev/null @@ -1,320 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Binary serialization of Haskell values -module Haskus.Format.Binary.Serialize - ( PutMonad (..) - , GetMonad (..) - , Serializable (..) - , Size (..) - -- * Endianness helpers - , putWord16BE - , putWord32BE - , putWord64BE - , putWord16LE - , putWord32LE - , putWord64LE - , putWord16BEs - , putWord32BEs - , putWord64BEs - , putWord16LEs - , putWord32LEs - , putWord64LEs - , getWord16BE - , getWord32BE - , getWord64BE - , getWord16LE - , getWord32LE - , getWord64LE - , getWord16BEs - , getWord32BEs - , getWord64BEs - , getWord16LEs - , getWord32LEs - , getWord64LEs - ) -where - -import Haskus.Memory.Buffer -import Haskus.Format.Binary.Word -import Haskus.Format.Binary.Endianness -import Haskus.Utils.Types -import Haskus.Utils.Monad - -import GHC.Exts (IsList(..)) - --- | Monad which can build a sequence of bytes -class Monad m => PutMonad m where - -- | Write a Word8 - putWord8 :: Word8 -> m () - -- | Write a Word16 - putWord16 :: Word16 -> m () - -- | Write a Word32 - putWord32 :: Word32 -> m () - -- | Write a Word64 - putWord64 :: Word64 -> m () - - -- | Write some Word8 - putWord8s :: [Word8] -> m () - putWord8s xs = forM_ xs putWord8 - - -- | Write some Word16 - putWord16s :: [Word16] -> m () - putWord16s xs = forM_ xs putWord16 - - -- | Write some Word32 - putWord32s :: [Word32] -> m () - putWord32s xs = forM_ xs putWord32 - - -- | Write some Word64 - putWord64s :: [Word64] -> m () - putWord64s xs = forM_ xs putWord64 - - -- | Write the contents of a buffer - putBuffer :: Buffer mut pin gc heap -> m () - - -- | Pre-allocate at least the given amount of bytes - -- - -- This is a hint for the putter to speed up the allocation of memory - preAllocateAtLeast :: Word -> m () - preAllocateAtLeast _ = return () - --- | Monad which can read a sequence of bytes -class Monad m => GetMonad m where - -- | Read a Word8 - getWord8 :: m Word8 - -- | Read a Word16 with host endianness - getWord16 :: m Word16 - -- | Read a Word32 with host endianness - getWord32 :: m Word32 - -- | Read a Word64 with host endianness - getWord64 :: m Word64 - - -- | Read some Word8 - getWord8s :: Word -> m [Word8] - getWord8s n = replicateM (fromIntegral n) getWord8 - -- | Read some Word16 with host endianness - getWord16s :: Word -> m [Word16] - getWord16s n = replicateM (fromIntegral n) getWord16 - -- | Read some Word32 with host endianness - getWord32s :: Word -> m [Word32] - getWord32s n = replicateM (fromIntegral n) getWord32 - -- | Read some Word64 with host endianness - getWord64s :: Word -> m [Word64] - getWord64s n = replicateM (fromIntegral n) getWord64 - - -- | Read the given amount of bytes into a new buffer - getBuffer :: Word -> m BufferI - getBuffer n = do - xs <- replicateM (fromIntegral n) getWord8 - return (fromListN (fromIntegral n) xs) - - -- | Read the given amount of bytes into the specified buffer - getBufferInto :: Word -> Buffer 'Mutable pin gc heap -> m () - --- | Size in bytes -data Size - = Exactly Nat -- ^ Exactly the given size - | AtLeast Nat -- ^ At least the given size - | Dynamic -- ^ Dynamically known size - --- | Binary serializable data -class Serializable a where - - -- | Size of the data in bytes - type SizeOf a :: Size - - -- | Sensible to endianness - type Endian a :: Bool - - -- | Dynamic size of the data in bytes - sizeOf :: a -> Word - - -- | Serialize a value - put :: PutMonad m => Endianness -> a -> m () - - -- | Deserialize a value - get :: GetMonad m => Endianness -> Word -> m a - - --------------------------------------------- --- Helpers for endianness --------------------------------------------- - --- | Write a Word16 with little-endian order -putWord16LE :: PutMonad m => Word16 -> m () -putWord16LE x = putWord16 (hostToLittleEndian x) --- | Write a Word32 with little-endian order -putWord32LE :: PutMonad m => Word32 -> m () -putWord32LE x = putWord32 (hostToLittleEndian x) --- | Write a Word64 with little-endian order -putWord64LE :: PutMonad m => Word64 -> m () -putWord64LE x = putWord64 (hostToLittleEndian x) - --- | Write a Word16 with big-endian order -putWord16BE :: PutMonad m => Word16 -> m () -putWord16BE x = putWord16 (hostToBigEndian x) --- | Write a Word32 with big-endian order -putWord32BE :: PutMonad m => Word32 -> m () -putWord32BE x = putWord32 (hostToBigEndian x) --- | Write a Word64 with big-endian order -putWord64BE :: PutMonad m => Word64 -> m () -putWord64BE x = putWord64 (hostToBigEndian x) - --- | Write some Word16 with little-endian order -putWord16LEs :: PutMonad m => [Word16] -> m () -putWord16LEs xs = putWord16s (fmap hostToLittleEndian xs) --- | Write some Word32 with little-endian order -putWord32LEs :: PutMonad m => [Word32] -> m () -putWord32LEs xs = putWord32s (fmap hostToLittleEndian xs) --- | Write some Word64 with little-endian order -putWord64LEs :: PutMonad m => [Word64] -> m () -putWord64LEs xs = putWord64s (fmap hostToLittleEndian xs) --- | Write some Word16 with big-endian order -putWord16BEs :: PutMonad m => [Word16] -> m () -putWord16BEs xs = putWord16s (fmap hostToBigEndian xs) --- | Write some Word32 with big-endian order -putWord32BEs :: PutMonad m => [Word32] -> m () -putWord32BEs xs = putWord32s (fmap hostToBigEndian xs) --- | Write some Word64 with big-endian order -putWord64BEs :: PutMonad m => [Word64] -> m () -putWord64BEs xs = putWord64s (fmap hostToBigEndian xs) - --- | Read a Word16 with little-endian order -getWord16LE :: GetMonad m => m Word16 -getWord16LE = littleEndianToHost <$> getWord16 --- | Read a Word32 with little-endian order -getWord32LE :: GetMonad m => m Word32 -getWord32LE = littleEndianToHost <$> getWord32 --- | Read a Word64 with little-endian order -getWord64LE :: GetMonad m => m Word64 -getWord64LE = littleEndianToHost <$> getWord64 --- | Read a Word16 with big-endian order -getWord16BE :: GetMonad m => m Word16 -getWord16BE = bigEndianToHost <$> getWord16 --- | Read a Word32 with big-endian order -getWord32BE :: GetMonad m => m Word32 -getWord32BE = bigEndianToHost <$> getWord32 --- | Read a Word64 with big-endian order -getWord64BE :: GetMonad m => m Word64 -getWord64BE = bigEndianToHost <$> getWord64 - - --- | Read some Word16 with little-endian order -getWord16LEs :: GetMonad m => Word -> m [Word16] -getWord16LEs n = fmap littleEndianToHost <$> getWord16s n --- | Read some Word32 with little-endian order -getWord32LEs :: GetMonad m => Word -> m [Word32] -getWord32LEs n = fmap littleEndianToHost <$> getWord32s n --- | Read some Word64 with little-endian order -getWord64LEs :: GetMonad m => Word -> m [Word64] -getWord64LEs n = fmap littleEndianToHost <$> getWord64s n - --- | Read some Word16 with big-endian order -getWord16BEs :: GetMonad m => Word -> m [Word16] -getWord16BEs n = fmap bigEndianToHost <$> getWord16s n --- | Read some Word32 with big-endian order -getWord32BEs :: GetMonad m => Word -> m [Word32] -getWord32BEs n = fmap bigEndianToHost <$> getWord32s n --- | Read some Word64 with big-endian order -getWord64BEs :: GetMonad m => Word -> m [Word64] -getWord64BEs n = fmap bigEndianToHost <$> getWord64s n - - --------------------------------------------- --- Instances --------------------------------------------- - -instance Serializable Word8 where - type SizeOf Word8 = 'Exactly 1 - type Endian Word8 = 'False - sizeOf _ = 1 - put _ x = putWord8 x - get _ _ = getWord8 - -instance Serializable Word16 where - type SizeOf Word16 = 'Exactly 2 - type Endian Word16 = 'True - sizeOf _ = 2 - put LittleEndian x = putWord16LE x - put BigEndian x = putWord16BE x - get LittleEndian _ = getWord16LE - get BigEndian _ = getWord16BE - -instance Serializable Word32 where - type SizeOf Word32 = 'Exactly 4 - type Endian Word32 = 'True - sizeOf _ = 4 - put LittleEndian x = putWord32LE x - put BigEndian x = putWord32BE x - get LittleEndian _ = getWord32LE - get BigEndian _ = getWord32BE - -instance Serializable Word64 where - type SizeOf Word64 = 'Exactly 8 - type Endian Word64 = 'True - sizeOf _ = 8 - put LittleEndian x = putWord64LE x - put BigEndian x = putWord64BE x - get LittleEndian _ = getWord64LE - get BigEndian _ = getWord64BE - -instance Serializable Int8 where - type SizeOf Int8 = 'Exactly 1 - type Endian Int8 = 'False - sizeOf _ = 1 - put _ x = putWord8 (fromIntegral x) - get _ _ = fromIntegral <$> getWord8 - -instance Serializable Int16 where - type SizeOf Int16 = 'Exactly 2 - type Endian Int16 = 'True - sizeOf _ = 2 - put LittleEndian x = putWord16LE (fromIntegral x) - put BigEndian x = putWord16BE (fromIntegral x) - get LittleEndian _ = fromIntegral <$> getWord16LE - get BigEndian _ = fromIntegral <$> getWord16BE - -instance Serializable Int32 where - type SizeOf Int32 = 'Exactly 4 - type Endian Int32 = 'True - sizeOf _ = 4 - put LittleEndian x = putWord32LE (fromIntegral x) - put BigEndian x = putWord32BE (fromIntegral x) - get LittleEndian _ = fromIntegral <$> getWord32LE - get BigEndian _ = fromIntegral <$> getWord32BE - -instance Serializable Int64 where - type SizeOf Int64 = 'Exactly 8 - type Endian Int64 = 'True - sizeOf _ = 8 - put LittleEndian x = putWord64LE (fromIntegral x) - put BigEndian x = putWord64BE (fromIntegral x) - get LittleEndian _ = fromIntegral <$> getWord64LE - get BigEndian _ = fromIntegral <$> getWord64BE - -instance Serializable BufferI where - type SizeOf BufferI = 'Dynamic - type Endian BufferI = 'False - sizeOf b = bufferSize b - put _ x = putBuffer x - get _ sz = getBuffer sz - -instance Serializable a => Serializable (AsBigEndian a) where - type SizeOf (AsBigEndian a) = SizeOf a - type Endian (AsBigEndian a) = 'False - sizeOf (AsBigEndian b) = sizeOf b - put _ (AsBigEndian x) = put BigEndian x - get _ sz = AsBigEndian <$> get BigEndian sz - -instance Serializable a => Serializable (AsLittleEndian a) where - type SizeOf (AsLittleEndian a) = SizeOf a - type Endian (AsLittleEndian a) = 'False - sizeOf (AsLittleEndian b) = sizeOf b - put _ (AsLittleEndian x) = put LittleEndian x - get _ sz = AsLittleEndian <$> get LittleEndian sz diff --git a/src/lib/Haskus/Format/Binary/Serialize/Buffer.hs b/src/lib/Haskus/Format/Binary/Serialize/Buffer.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Serialize/Buffer.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE BangPatterns #-} - --- | Serializer into a mutable buffer --- --- >>> let w = do putWord8 0x01 ; putWord32BE 0x23456789 --- >>> b <- newBuffer 10 --- >>> void $ runBufferPut b 0 w --- >>> xs <- forM [0..4] (bufferReadWord8IO b) --- >>> xs == [0x01,0x23,0x45,0x67,0x89] --- True --- -module Haskus.Format.Binary.Serialize.Buffer - ( BufferPutT (..) - , BufferPut - , getPutOffset - , getPutBuffer - , setPutOffset - , runBufferPut - ) -where - -import Haskus.Format.Binary.Serialize -import Haskus.Memory.Buffer -import Haskus.Utils.Monad - -import Data.Functor.Identity -import Control.Monad.Trans.State as S -import Control.Monad.Fail as F -import Control.Monad.Fix - -data BufferPutState b = BufferPutState - { bufferPutBuffer :: b -- ^ Buffer used for writing - , bufferPutOffset :: Word -- ^ Current offset - } - --- | A Put monad than fails when there is not enough space in the target buffer -newtype BufferPutT b m a - = BufferPutT (StateT (BufferPutState b) m a) - deriving newtype - (Functor, Applicative, Monad, MonadFail, MonadFix, MonadIO, MonadTrans) - -type BufferPut b a = BufferPutT b Identity a - --- | Run a buffer put -runBufferPut :: Monad m => b -> Word -> BufferPutT b m a -> m (a,Word) -runBufferPut b off (BufferPutT s) = do - (a,s') <- runStateT s (BufferPutState b off) - return (a,bufferPutOffset s') - --- | Get current offset -getPutOffset :: Monad m => BufferPutT b m Word -getPutOffset = BufferPutT (bufferPutOffset <$> S.get) - --- | Get buffer -getPutBuffer :: Monad m => BufferPutT b m b -getPutBuffer = BufferPutT (bufferPutBuffer <$> S.get) - --- | Get current offset -setPutOffset :: Monad m => Word -> BufferPutT b m () -setPutOffset v = BufferPutT $ do - S.modify (\s -> s { bufferPutOffset = v }) - - --- | Called when there is not enough space left in the buffer -bufferPutNotEnoughSpace :: (MonadFail m, MonadIO m) => Word -> BufferPutT b m () -bufferPutNotEnoughSpace reqSize = do - F.fail $ "Not enough space in the target buffer (requiring " - ++ show reqSize ++ " bytes)" - --- | Helper to put something -putSomething - :: (MonadIO m, MonadFail m) - => Word - -> (Buffer mut pin fin heap -> Word -> t -> m ()) - -> t - -> BufferPutT (Buffer mut pin fin heap) m () -{-# INLINABLE putSomething #-} -putSomething sz act v = do - off <- getPutOffset - b <- getPutBuffer - bs <- liftIO (bufferSizeIO b) - let !newOff = off+sz - when (newOff > bs) $ bufferPutNotEnoughSpace sz - lift (act b off v) - setPutOffset newOff - --- | Helper to put some things -putSomeThings - :: (MonadIO m, MonadFail m) - => Word - -> (Buffer mut pin fin heap -> Word -> m ()) - -> BufferPutT (Buffer mut pin fin heap) m () -{-# INLINABLE putSomeThings #-} -putSomeThings sz act = do - off <- getPutOffset - b <- getPutBuffer - bs <- liftIO (bufferSizeIO b) - let !newOff = off+sz - when (newOff > bs) $ bufferPutNotEnoughSpace sz - lift (act b off) - setPutOffset newOff - - -instance - ( MonadIO m - , MonadFail m - ) => PutMonad (BufferPutT (Buffer 'Mutable pin gc heap) m) - where - putWord8 = putSomething 1 bufferWriteWord8IO - putWord16 = putSomething 2 bufferWriteWord16IO - putWord32 = putSomething 4 bufferWriteWord32IO - putWord64 = putSomething 8 bufferWriteWord64IO - - putWord8s xs = putSomeThings (fromIntegral (length xs)) $ \b off -> do - forM_ ([off,(off+1)..] `zip` xs) $ \(boff,v) -> do - bufferWriteWord8IO b boff v - - putWord16s xs = putSomeThings (2*fromIntegral (length xs)) $ \b off -> do - forM_ ([off,(off+2)..] `zip` xs) $ \(boff,v) -> do - bufferWriteWord16IO b boff v - - putWord32s xs = putSomeThings (4*fromIntegral (length xs)) $ \b off -> do - forM_ ([off,(off+4)..] `zip` xs) $ \(boff,v) -> do - bufferWriteWord32IO b boff v - - putWord64s xs = putSomeThings (8*fromIntegral (length xs)) $ \b off -> do - forM_ ([off,(off+8)..] `zip` xs) $ \(boff,v) -> do - bufferWriteWord64IO b boff v - - preAllocateAtLeast l = do - off <- getPutOffset - b <- getPutBuffer - bs <- liftIO (bufferSizeIO b) - when (l+off > bs) $ bufferPutNotEnoughSpace l - - putBuffer x = do - sz <- liftIO (bufferSizeIO x) - putSomeThings sz (\b off -> copyBuffer x 0 b off sz) diff --git a/src/lib/Haskus/Format/Binary/Storable.hs b/src/lib/Haskus/Format/Binary/Storable.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Storable.hs +++ /dev/null @@ -1,538 +0,0 @@ -{-# 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 (Mod 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] -{-# INLINABLE wordBytes #-} -wordBytes x = unsafePerformIO $ - with x $ \p -> mapM (peekByteOff (castPtr p)) [0..natValue @(SizeOf a) - 1] - - - --- | Storable data-types --- --- Currently we cannot automatically derive a Storable class with type-level --- naturals for "alignment" and "sizeOf". Instead we define a Storable class --- isomorphic to the Foreign.Storable's one but with default methods using --- DefaultSignatures (i.e., the Storable instance can be automatically derived --- from a Generic instance). -class Storable a where - peekIO :: Ptr a -> IO a - default peekIO :: (Generic a, GStorable (Rep a)) => Ptr a -> IO a - peekIO p = fmap to $ gcPeek 0 (castPtr p) - - pokeIO :: Ptr a -> a -> IO () - default pokeIO :: (Generic a, GStorable (Rep a)) => Ptr a -> a -> IO () - pokeIO p x = gcPoke 0 (castPtr p) $ from x - - alignment :: a -> Word - default alignment :: (Generic a, GStorable (Rep a)) => a -> Word - alignment = gcAlignment . from - - sizeOf :: a -> Word - default sizeOf :: (Generic a, GStorable (Rep a)) => a -> Word - sizeOf = gcSizeOf 0 . from - --- | Peek a value from a pointer -peek :: (Storable a, MonadIO m) => Ptr a -> m a -peek p = liftIO (peekIO p) - --- | Poke a value to a pointer -poke :: (Storable a, MonadIO m) => Ptr a -> a -> m () -poke p v = liftIO (pokeIO p v) - --- | Generalized 'sizeOf' -sizeOf' :: (Integral b, Storable a) => a -> b -{-# INLINABLE sizeOf' #-} -sizeOf' = fromIntegral . sizeOf - --- | SizeOf (for type-application) -sizeOfT :: forall a. (Storable a) => Word -{-# INLINABLE sizeOfT #-} -sizeOfT = sizeOf (undefined :: a) - --- | SizeOf' (for type-application) -sizeOfT' :: forall a b. (Storable a, Integral b) => b -{-# INLINABLE sizeOfT' #-} -sizeOfT' = sizeOf' (undefined :: a) - --- | Generalized 'alignment' -alignment' :: (Integral b, Storable a) => a -> b -{-# INLINABLE alignment' #-} -alignment' = fromIntegral . alignment - --- | Alignment (for type-application) -alignmentT :: forall a. (Storable a) => Word -{-# INLINABLE alignmentT #-} -alignmentT = alignment (undefined :: a) - --- | Alignment' (for type-application) -alignmentT' :: forall a b. (Storable a, Integral b) => b -{-# INLINABLE alignmentT' #-} -alignmentT' = alignment' (undefined :: a) - --- | Peek with byte offset -peekByteOff :: (MonadIO m, Storable a) => Ptr a -> Int -> m a -{-# INLINABLE peekByteOff #-} -peekByteOff ptr off = peek (ptr `indexPtr` off) - --- | Poke with byte offset -pokeByteOff :: (MonadIO m, Storable a) => Ptr a -> Int -> a -> m () -{-# INLINABLE 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 -{-# INLINABLE alloca #-} -alloca = allocaBytesAligned (sizeOfT' @a) (alignmentT' @a) - --- | Allocate a block of memory that is sufficient to hold values of type --- @a@. The size of the area allocated is determined by the 'sizeOf' --- method from the instance of 'Storable' for the appropriate type. --- --- The memory may be deallocated using 'free' or 'finalizerFree' when --- no longer required. -malloc :: forall a m. (MonadIO m, Storable a) => m (Ptr a) -{-# INLINABLE malloc #-} -malloc = liftIO (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 -{-# INLINABLE with #-} -with val f = - alloca $ \ptr -> do - poke ptr val - f ptr - --- | Temporarily allocate space for the given number of elements --- (like 'alloca', but for multiple elements). -allocaArray :: forall a b m. (MonadInIO m, Storable a) => Word -> (Ptr a -> m b) -> m b -allocaArray size = liftWith (allocaBytesAligned (size * sizeOfT' @a) (alignmentT' @a)) - --- | Allocate space for the given number of elements --- (like 'malloc', but for multiple elements). -mallocArray :: forall a m. (MonadIO m, Storable a) => Word -> m (Ptr a) -mallocArray size = 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Union.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Union (as in C) --- --- Unions are storable and can contain any storable data. --- --- Use 'fromUnion' to read an alternative: --- --- @ --- {-# LANGUAGE DataKinds #-} --- --- getUnion :: IO (Union '[Word16, Word32, Word64]) --- getUnion = ... --- --- test = do --- u <- getUnion --- --- -- to get one of the member --- let v = fromUnion u :: Word16 --- let v = fromUnion u :: Word32 --- let v = fromUnion u :: Word64 --- --- -- This won't compile (Word8 is not a member of the union) --- let v = fromUnion u :: Word8 --- @ --- --- Use 'toUnion' to create a new union: --- --- @ --- let --- u2 :: Union '[Word32, Vector 4 Word8] --- u2 = toUnion (0x12345678 :: Word32) --- @ --- -module Haskus.Format.Binary.Union - ( Union - , fromUnion - , toUnion - , toUnionZero - ) -where - -import Haskus.Utils.Memory (memCopy, memSet) -import Haskus.Utils.Types 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, Member a l) => Union l -> a -fromUnion (Union fp) = unsafePerformIO $ withForeignPtr fp (peek . castPtr) - --- | Create a new union from one of the union types -toUnion :: forall a l . (Storable (Union l), Storable a, Member a l) => a -> Union l -toUnion = toUnion' False - --- | Like 'toUnion' but set the remaining bytes to 0 -toUnionZero :: forall a l . (Storable (Union l), Storable a, Member a l) => a -> Union l -toUnionZero = toUnion' True - - --- | Create a new union from one of the union types -toUnion' :: forall a l . (Storable (Union l), Storable a, Member a l) => Bool -> a -> Union l -toUnion' zero v = unsafePerformIO $ do - let sz = sizeOfT @(Union l) - fp <- mallocForeignPtrBytes (fromIntegral sz) - withForeignPtr fp $ \p -> do - -- set bytes after the object to 0 - when zero $ do - let psz = sizeOfT @a - memSet (p `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 (ListMax (MapSizeOf fs)) - , KnownNat (ListMax (MapAlignment fs)) - ) - => StaticStorable (Union fs) - where - type SizeOf (Union fs) = ListMax (MapSizeOf fs) - type Alignment (Union fs) = ListMax (MapAlignment fs) - - staticPeekIO ptr = do - let sz = natValue @(SizeOf (Union fs)) - fp <- mallocForeignPtrBytes sz - withForeignPtr fp $ \p -> - memCopy p (castPtr ptr) (fromIntegral sz) - return (Union fp) - - staticPokeIO ptr (Union fp) = do - withForeignPtr fp $ \p -> - memCopy (castPtr ptr) p (natValue @(SizeOf (Union fs))) - -------------------------------------------------------------------------------------- --- We use HFoldr' to get the maximum size and alignment of the types in the union -------------------------------------------------------------------------------------- - -data FoldSizeOf = FoldSizeOf -data FoldAlignment = FoldAlignment - -instance (r ~ Word, Storable a) => Apply FoldSizeOf (a, Word) r where - apply _ (_,r) = max r (sizeOfT @a) - -instance (r ~ Word, Storable a) => Apply FoldAlignment (a, Word) r where - apply _ (_,r) = max r (alignmentT @a) - --- | Get the union size (i.e. the maximum of the types in the union) -unionSize :: forall l . HFoldr' FoldSizeOf Word l Word => Union l -> Word -unionSize _ = hFoldr' FoldSizeOf (0 :: Word) (undefined :: HList l) - --- | Get the union alignment (i.e. the maximum of the types in the union) -unionAlignment :: forall l . HFoldr' FoldAlignment Word l Word => Union l -> Word -unionAlignment _ = hFoldr' FoldAlignment (0 :: Word) (undefined :: HList l) - - -------------------------------------------------------------------------------------- --- Finally we can write the Storable instance -------------------------------------------------------------------------------------- - -instance - ( HFoldr' FoldSizeOf Word l Word - , HFoldr' FoldAlignment Word l Word - ) => Storable (Union l) where - sizeOf = unionSize - alignment = unionAlignment - peekIO ptr = do - let sz = sizeOfT' @(Union l) - fp <- mallocForeignPtrBytes sz - withForeignPtr fp $ \p -> - memCopy p (castPtr ptr) (fromIntegral sz) - return (Union fp) - - pokeIO ptr (Union fp) = withForeignPtr fp $ \p -> - memCopy (castPtr ptr) p (sizeOfT' @(Union l)) - - --- compatibility instance with Foreign.Storable -instance - ( HFoldr' FoldSizeOf Word l Word - , HFoldr' FoldAlignment Word l Word - ) => FS.Storable (Union l) where - sizeOf = fromIntegral . unionSize - alignment = fromIntegral . unionAlignment - peek = peekIO - poke = pokeIO diff --git a/src/lib/Haskus/Format/Binary/Unum.hs b/src/lib/Haskus/Format/Binary/Unum.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Unum.hs +++ /dev/null @@ -1,737 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -#if MIN_VERSION_GLASGOW_HASKELL (8,6,0,0) -{-# LANGUAGE NoStarIsType #-} -#endif - -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 hiding (Log2) -import Haskus.Utils.HList -import Haskus.Utils.Flow - -import Data.Kind (Type) - --- | 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 :: [Type]) - - -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. - ( Bits (BackingWord u) - , KnownNat (UnumSize u) - ) => U u -> String -unumBits (U w) = drop (fromIntegral (bitSize w - 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 -{-# INLINABLE 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. - ( Bits (BackingWord u) - , Num (BackingWord u) - , KnownNat (UnumSize u) - ) => U u -> U u -{-# INLINABLE unumNegate #-} -unumNegate (U w) = U (maskDyn s (complement w + 1)) - where - s = unumSize @u - - --- | Reciprocate a number -unumReciprocate :: forall u. - ( Bits (BackingWord u) - , Num (BackingWord u) - , KnownNat (UnumSize u) - ) => U u -> U u -{-# INLINABLE unumReciprocate #-} -unumReciprocate (U w) = U (w `xor` m + 1) - where - s = unumSize @u - m = makeMaskDyn (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. - ( Bits (SORNBackingWord u) - , KnownNat (UnumSize u) - , s ~ SORNSize u - , KnownNat s - ) => SORN u -> String -sornBits (SORN w) = drop (bitSize 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. - ( Bits (SORNBackingWord u) - , KnownNat (SORNSize u) - ) => SORN u -sornFull = SORN (maskDyn 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. - ( Bits (SORNBackingWord u) - , Bits (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) - , Bits (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)) (maskDyn s (x+1)) - 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 :: - ( Bits (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) - , Bits (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) - , Bits (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) - , Bits (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) - , Bits (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) - , Bits (BackingWord u) - , Bits (SORNBackingWord u) - , Field (BackingWord u) - , KnownNat (SORNSize u) - , Bits (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' = maskDyn 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. - ( Bits (CSORNBackingWord u) - , KnownNat (UnumSize u) - , s ~ CSORNSize u - , KnownNat s - ) => CSORN u -> String -csornBits (CSORN (BitFields w)) = drop (bitSize 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 -{-# INLINABLE 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) - , Bits (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 = maskDyn 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/VariableLength.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - --- | 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 deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Vector.hs +++ /dev/null @@ -1,352 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -#if MIN_VERSION_GLASGOW_HASKELL (8,6,0,0) -{-# LANGUAGE NoStarIsType #-} -#endif - - --- | Vector with size in the type -module Haskus.Format.Binary.Vector - ( Vector (..) - , vectorBuffer - , vectorReverse - , take - , drop - , index - , fromList - , fromFilledList - , fromFilledListZ - , toList - , replicate - , concat - , zipWith - ) -where - -import Prelude hiding ( replicate, head, last - , tail, init, map, length, drop, take, concat - , zipWith ) -import System.IO.Unsafe (unsafePerformIO) - -import qualified Haskus.Utils.List as List -import Haskus.Utils.Types -import Haskus.Utils.HList -import Haskus.Utils.Maybe -import Haskus.Utils.Flow -import Haskus.Format.Binary.Storable -import Haskus.Format.Binary.Ptr -import Haskus.Format.Binary.Buffer -import Haskus.Format.Binary.Bits - --- | 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 - --- | Reverse a vector -vectorReverse :: (KnownNat n, Storable a) => Vector n a -> Vector n a -vectorReverse = fromJust . fromList . reverse . toList - --- | Offset of the i-th element in a stored vector -type family ElemOffset a i n where - ElemOffset a i n = Assert (i+1 <=? n) - (i * (SizeOf a)) - (('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 -{-# INLINABLE 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 -{-# INLINABLE 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 -{-# INLINABLE 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) -{-# INLINABLE 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 -{-# INLINABLE 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 -{-# INLINABLE 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] -{-# INLINABLE 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 -{-# INLINABLE 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 - - --- | Zip two vectors -zipWith :: - ( KnownNat n - , Storable a - , Storable b - , Storable c - ) => (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c -zipWith f u v = fromJust . fromList <| List.zipWith f (toList u) (toList v) - --- | map -map :: - ( KnownNat n - , Storable a - , Storable b - ) => (a -> b) -> Vector n a -> Vector n b -map f = fromJust . fromList . fmap f . toList - -instance - ( KnownNat n - , Storable a - , Eq a - ) - => Eq (Vector n a) - where - u == v = toList u == toList v - - -instance - ( KnownNat n - , Bitwise a - , Storable a - ) => Bitwise (Vector n a) - where - u .&. v = zipWith (.&.) u v - u .|. v = zipWith (.|.) u v - u `xor` v = zipWith xor u v - - -instance - ( KnownNat (BitSize a) - , FiniteBits a - , KnownNat n - , Storable a - ) => FiniteBits (Vector n a) - where - type BitSize (Vector n a) = n * BitSize a - zeroBits = fromJust (fromList (List.replicate (natValue @n) zeroBits)) - oneBits = fromJust (fromList (List.replicate (natValue @n) oneBits)) - complement u = map complement u - countLeadingZeros = go 0 . toList - where - go !n [] = n - go !n (x:xs) = let c = countLeadingZeros x - in if c == natValue @(BitSize a) - then go (n+c) xs - else n+c - - countTrailingZeros = go 0 . reverse . toList - where - go !n [] = n - go !n (x:xs) = let c = countTrailingZeros x - in if c == natValue @(BitSize a) - then go (n+c) xs - else n+c - -instance - ( Storable a - , ShiftableBits a - , Bitwise a - , FiniteBits a - , KnownNat (BitSize a) - , KnownNat (n * BitSize a) - , KnownNat n - ) => ShiftableBits (Vector n a) - where - shiftL u c = uncheckedShiftL u (c `mod` natValue @(BitSize (Vector n a))) - shiftR u c = uncheckedShiftR u (c `mod` natValue @(BitSize (Vector n a))) - - uncheckedShiftL u c = - let n = natValue @n - sa = natValue @(BitSize a) - go _ 0 _ = [] - go 0 k xs = List.take k xs - go s k xs - | s >= sa = go (s-sa) k (List.tail xs) - | otherwise = - let (x:y:zs) = xs - in ((x `shiftL` s) .|. (y `shiftR` (sa-s))) : go s (k-1) (y:zs) - in fromJust (fromList (go c n (toList u ++ List.repeat zeroBits))) - - uncheckedShiftR u c = - let n = natValue @n - sa = natValue @(BitSize a) - go _ 0 _ = [] - go 0 k xs = List.take k (List.tail xs) - go s k xs - | s >= sa = zeroBits : go (s-sa) (k-1) xs - | otherwise = - let (x:y:zs) = xs - in ((x `shiftL` (sa-s)) .|. (y `shiftR` s)) : go s (k-1) (y:zs) - in fromJust (fromList (go c n (zeroBits : toList u))) - - -instance - ( Storable a - , IndexableBits a - , FiniteBits a - , KnownNat (BitSize a) - , KnownNat n - , Bitwise a - ) => IndexableBits (Vector n a) where - - popCount = sum . fmap popCount . toList - - bit i = let n = natValue @n - sa = natValue @(BitSize a) - (f,r) = i `divMod` sa - toRep = fromIntegral (n - f - 1) - xs = List.replicate toRep zeroBits - ++ [bit r] - ++ List.replicate (fromIntegral f) zeroBits - in fromJust <| fromList <| if i >= n * sa - then List.replicate (fromIntegral n) zeroBits - else xs - - testBit u i = let n = natValue @n - sa = natValue @(BitSize a) - (f,r) = i `divMod` sa - toDrop = fromIntegral (n - f - 1) - in if i >= n * sa - then False - else testBit (List.head (List.drop toDrop (toList u))) r - - -instance - ( Storable a - , Bits a - , KnownNat n - , KnownNat (n * BitSize a) - ) => RotatableBits (Vector n a) diff --git a/src/lib/Haskus/Format/Binary/Word.hs b/src/lib/Haskus/Format/Binary/Word.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Binary/Word.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MagicHash #-} - --- | Unsigned and signed words -module Haskus.Format.Binary.Word - ( WordAtLeast - , IntAtLeast - , WordN - , IntN - -- * Some C types - , CSize(..) - , CUShort - , CShort - , CUInt - , CInt - , CULong - , CLong - -- * Unlifted - , module GHC.Word - , module GHC.Int - , 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.Int -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 - (Assert (n <=? 64) Word64 - ('Text "Cannot find Word with size " ':<>: 'ShowType n) - ))) - --- | Return a Int with at least 'n' bits -type family IntAtLeast (n :: Nat) where - IntAtLeast n = - If (n <=? 8) Int8 - (If (n <=? 16) Int16 - (If (n <=? 32) Int32 - (Assert (n <=? 64) Int64 - ('Text "Cannot find Int with size " ':<>: 'ShowType n) - ))) - --- | Return a Word with exactly 'n' bits -type family WordN (n :: Nat) where - WordN 8 = Word8 - WordN 16 = Word16 - WordN 32 = Word32 - WordN 64 = Word64 - WordN n = TypeError ('Text "Cannot find Word with size " ':<>: 'ShowType n) - --- | Return a Int with exactly 'n' bits -type family IntN (n :: Nat) where - IntN 8 = Int8 - IntN 16 = Int16 - IntN 32 = Int32 - IntN 64 = Int64 - IntN n = TypeError ('Text "Cannot find Int with size " ':<>: 'ShowType n) diff --git a/src/lib/Haskus/Format/Number.hs b/src/lib/Haskus/Format/Number.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Number.hs +++ /dev/null @@ -1,8 +0,0 @@ --- | Numbers -module Haskus.Format.Number - ( module X - ) -where - -import Haskus.Format.Number.BitNat as X -import Haskus.Format.Number.NaturalRange as X diff --git a/src/lib/Haskus/Format/Number/BitNat.hs b/src/lib/Haskus/Format/Number/BitNat.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Number/BitNat.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - --- | Natural numbers -module Haskus.Format.Number.BitNat - ( NatVal (..) - , Widen - , widen - , Narrow - , narrow - , BitNat - , pattern BitNat - , nat - , unsafeMakeW - , safeMakeW - , zeroW - , oneW - , extractW - , compareW - , (.+.) - , (.-.) - , (.*.) - , (./.) - , (.<<.) - , (.>>.) - -- * Internal - , BitNatWord - , MakeW - , toNaturalW - ) -where - -import Haskus.Format.Binary.Word -import Haskus.Format.Binary.Bits -import Haskus.Utils.Types -import Numeric.Natural - --- $setup --- >>> :set -XDataKinds --- >>> :set -XTypeApplications --- >>> :set -XFlexibleContexts --- >>> :set -XTypeFamilies --- >>> :set -XScopedTypeVariables - --- | A natural on `b` bits -newtype BitNat (b :: Nat) - = BitNat' (BitNatWord b) - -pattern BitNat :: forall (n :: Nat). (Integral (BitNatWord n), MakeW n) => Natural -> BitNat n -{-# COMPLETE BitNat #-} -pattern BitNat x <- (toNaturalW -> x) - where - BitNat x = makeW @n x - - --- | Create a natural number with the minimal number of bits required to store --- it --- --- >>> nat @5 --- BitNat @3 5 --- --- >>> nat @0 --- BitNat @1 0 --- --- >>> nat @158748521123465897456465 --- BitNat @78 158748521123465897456465 --- -nat :: forall (v :: Nat) (n :: Nat). - ( n ~ NatBitCount v - , Integral (BitNatWord n) - , MakeW n - , KnownNat v - ) => BitNat n -nat = BitNat @n (natValue @v) - -mapW :: (BitNatWord a -> BitNatWord a) -> BitNat a -> BitNat a -mapW f (BitNat' x) = BitNat' (f x) - -zipWithW :: (BitNatWord a -> BitNatWord a -> BitNatWord b) -> BitNat a -> BitNat a -> BitNat b -zipWithW f (BitNat' x) (BitNat' y) = BitNat' (f x y) - --- | Show instance for naturals -instance (KnownNat b, Integral (BitNatWord b)) => Show (BitNat b) where - showsPrec d x = showParen (d /= 0) - $ showString "BitNat @" - . showsPrec 0 (natValue' @b) - . showString " " - . showsPrec 0 (toNaturalW x) - --- | BitNat backing type -type family BitNatWord b where - BitNatWord 0 = TypeError ('Text "Naturals encoded on 0 bits are not allowed") - BitNatWord b = BitNatWord' (b <=? 8) (b <=? 16) (b <=? 32) (b <=? 64) - -type family BitNatWord' b8 b16 b32 b64 where - BitNatWord' 'True _ _ _ = Word8 - BitNatWord' _ 'True _ _ = Word16 - BitNatWord' _ _ 'True _ = Word32 - BitNatWord' _ _ _ 'True = Word64 - BitNatWord' _ _ _ _ = Natural - -------------------------------------------------- --- Creation -------------------------------------------------- - --- | Zero natural -zeroW :: Num (BitNatWord a) => BitNat a -zeroW = BitNat' 0 - --- | One natural -oneW :: Num (BitNatWord a) => BitNat a -oneW = BitNat' 1 - --- | Convert a BitNat into a Natural -toNaturalW :: Integral (BitNatWord a) => BitNat a -> Natural -toNaturalW (BitNat' x) = fromIntegral x - --- | Create a natural -unsafeMakeW :: forall a. (Maskable a (BitNatWord a)) => BitNatWord a -> BitNat a -unsafeMakeW x = BitNat' (mask @a x) - -type MakeW a = - ( Maskable a (BitNatWord a) - , ShiftableBits (BitNatWord a) - , Show (BitNatWord a) - , Eq (BitNatWord a) - , Num (BitNatWord a) - ) - --- | Create a natural (check overflow) -safeMakeW :: forall a. MakeW a => Natural -> Maybe (BitNat a) -safeMakeW x = - let - x' = fromIntegral x :: BitNatWord a - in case x' `uncheckedShiftR` natValue' @a of - 0 -> Just (unsafeMakeW x') - _ -> Nothing - --- | Create a natural (check overflow and throw on error) -makeW :: forall a. MakeW a => Natural -> BitNat a -makeW x = case safeMakeW x of - Just y -> y - Nothing -> error $ - "`" ++ show x - ++ "` is out of the range of values that can be encoded by a " - ++ show (natValue' @a) - ++ "-bit natural number: [0.." - ++ show (2 ^ (natValue' @a) -1 :: Natural) - ++ "]" - --- | Extract the primitive value -extractW :: BitNat a -> BitNatWord a -extractW (BitNat' a) = a - -------------------------------------------------- --- Widening / Narrowing -------------------------------------------------- - --- | Widen a natural --- --- >>> widen @7 (BitNat @5 25) --- BitNat @7 25 --- -widen :: forall b a. Widen a b => BitNat a -> BitNat b -widen (BitNat' a) = BitNat' (fromIntegral a) - -type Widen a b = - ( Assert (a <=? b) (() :: Constraint) - ('Text "Can't widen a natural of " - ':<>: 'ShowType a - ':<>: 'Text " bits into a natural of " - ':<>: 'ShowType b - ':<>: 'Text " bits" - ) - , Integral (BitNatWord a) - , Integral (BitNatWord b) - ) - --- | Narrow a natural --- --- >>> narrow @3 (BitNat @5 25) --- BitNat @3 1 --- -narrow :: forall b a. Narrow a b => BitNat a -> BitNat b -narrow (BitNat' a) = unsafeMakeW (fromIntegral a) - -type Narrow a b = - ( Assert (b <=? a) (() :: Constraint) - ('Text "Can't narrow a natural of " - ':<>: 'ShowType a - ':<>: 'Text " bits into a natural of " - ':<>: 'ShowType b - ':<>: 'Text " bits" - ) - , Integral (BitNatWord a) - , Integral (BitNatWord b) - , Maskable b (BitNatWord b) - ) - -------------------------------------------------- --- Comparison -------------------------------------------------- - --- | Compare two naturals -compareW :: forall a b. - ( Ord (BitNatWord (Max a b)) - , Widen a (Max a b) - , Widen b (Max a b) - ) => BitNat a -> BitNat b -> Ordering -compareW x y = compare x' y' - where - BitNat' x' = widen @(Max a b) x - BitNat' y' = widen @(Max a b) y - -instance Eq (BitNatWord a) => Eq (BitNat a) where - (BitNat' x) == (BitNat' y) = x == y - -instance Ord (BitNatWord a) => Ord (BitNat a) where - compare (BitNat' x) (BitNat' y) = compare x y - -------------------------------------------------- --- Addition / Subtraction -------------------------------------------------- - --- | Add two Naturals --- --- >>> BitNat @5 25 .+. BitNat @2 3 --- BitNat @6 28 --- -(.+.) :: forall a b m. - ( m ~ (Max a b + 1) - , Widen a m - , Widen b m - , Num (BitNatWord m) - ) => BitNat a -> BitNat b -> BitNat m -(.+.) x y = zipWithW (+) (widen @m x) (widen @m y) - --- | Sub two Naturals --- --- >>> BitNat @5 25 .-. BitNat @2 3 --- Just (BitNat @5 22) --- --- >>> BitNat @5 2 .-. BitNat @2 3 --- Nothing --- -(.-.) :: forall a b m. - ( m ~ Max a b - , Widen a m - , Widen b m - , Num (BitNatWord m) - ) => BitNat a -> BitNat b -> Maybe (BitNat m) -(.-.) (widen @m -> x) (widen @m -> y) = case compare x y of - LT -> Nothing - EQ -> Just zeroW - GT -> Just (zipWithW (-) x y) - --- | Multiply two Naturals --- --- >>> BitNat @5 25 .*. BitNat @2 3 --- BitNat @7 75 --- -(.*.) :: forall a b m. - ( m ~ (a + b) - , Widen a m - , Widen b m - , Num (BitNatWord m) - ) => BitNat a -> BitNat b -> BitNat m -(.*.) x y = zipWithW (*) (widen @m x) (widen @m y) - --- | Divide two Naturals, return (factor,rest) --- --- >>> BitNat @5 25 ./. BitNat @2 3 --- Just (BitNat @5 8,BitNat @2 1) --- --- >>> BitNat @5 25 ./. BitNat @2 0 --- Nothing --- --- > BitNat @2 3 ./. BitNat @5 25 --- Just (BitNat @2 0,BitNat @5 3) --- -(./.) :: forall a b m. - ( m ~ Max a b - , Widen a m - , Widen b m - , Num (BitNatWord (Min a b)) - ) => BitNat a -> BitNat b -> Maybe (BitNat a,BitNat (Min a b)) -(./.) x y - | y == zeroW = Nothing - | otherwise = Just (BitNat' (fromIntegral q), BitNat' (fromIntegral r)) - where - (q,r) = quotRem x' y' - BitNat' x' = widen @m x - BitNat' y' = widen @m y - -------------------------------------------------- --- Shift -------------------------------------------------- - --- | Shift-left naturals --- --- >>> let x = BitNat @5 25 --- >>> x .<<. NatVal @2 --- BitNat @7 100 --- --- >>> show (x .<<. NatVal @2) == show (x .*. BitNat @3 4) --- False --- --- >>> x .<<. NatVal @2 == narrow (x .*. BitNat @3 4) --- True --- -(.<<.) :: forall (s :: Nat) a. - ( ShiftableBits (BitNatWord (a + s)) - , KnownNat s - , Widen a (a+s) - ) => BitNat a -> NatVal s -> BitNat (a + s) -(.<<.) x _ = mapW (`uncheckedShiftL` natValue @s) (widen @(a+s) x) - --- | Shift-right naturals --- --- >>> BitNat @5 25 .>>. NatVal @2 --- BitNat @3 6 --- -(.>>.) :: forall (s :: Nat) a. - ( ShiftableBits (BitNatWord a) - , KnownNat s - , Narrow a (a-s) - ) => BitNat a -> NatVal s -> BitNat (a - s) -(.>>.) x _ = narrow @(a-s) (mapW (`uncheckedShiftR` natValue @s) x) diff --git a/src/lib/Haskus/Format/Number/NaturalRange.hs b/src/lib/Haskus/Format/Number/NaturalRange.hs deleted file mode 100644 --- a/src/lib/Haskus/Format/Number/NaturalRange.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - --- | A natural number in a specified range (fixed and checked at compile-time) -module Haskus.Format.Number.NaturalRange - ( NatRange - , pattern NatRange - , natRange - , safeMakeNatRange - , makeNatRange - , unsafeMakeNatRange - , widenNatRange - , (.++.) - ) -where - -import Haskus.Format.Number.BitNat -import Haskus.Utils.Types -import Numeric.Natural - --- $setup --- >>> :set -XDataKinds --- >>> :set -XTypeApplications --- >>> :set -XFlexibleContexts --- >>> :set -XTypeFamilies --- >>> :set -XScopedTypeVariables - - --- | A natural number in the specified range -newtype NatRange (f :: Nat) (t :: Nat) = NatRange' (BitNat (NatBitCount (t-f+1))) - --- | Show instance for natural range -instance - ( KnownNat (t-f) - , KnownNat t - , KnownNat f - , Num (BitNatWord (NatBitCount (t-f+1))) - , Integral (BitNatWord (NatBitCount (t-f+1))) - ) => Show (NatRange f t) where - showsPrec d x = showParen (d /= 0) - $ showString "NatRange @" - . showsPrec 0 (natValue' @f) - . showString " @" - . showsPrec 0 (natValue' @t) - . showString " " - . showsPrec 0 (toNaturalNatRange x) - -type CheckInRange f t n = - ( Assert (n <=? t) (() :: Constraint) - ('ShowType n - ':<>: 'Text " isn't in the range [" - ':<>: 'ShowType f - ':<>: 'Text "," - ':<>: 'ShowType t - ':<>: 'Text "]" - ) - , Assert (f <=? n) (() :: Constraint) - ('ShowType n - ':<>: 'Text " isn't in the range [" - ':<>: 'ShowType f - ':<>: 'Text "," - ':<>: 'ShowType t - ':<>: 'Text "]" - ) - ) - -type NatRangeBitCount f t = NatBitCount (t-f+1) - -type MakeNatRange f t = - ( Integral (BitNatWord (NatRangeBitCount f t)) - , MakeW (NatRangeBitCount f t) - , KnownNat f - , KnownNat t - , Assert (f <=? t) (() :: Constraint) - ('Text "[" - ':<>: 'ShowType f - ':<>: 'Text "," - ':<>: 'ShowType t - ':<>: 'Text "] isn't a valid range" - ) - ) - --- | Create a value in a Natural range -unsafeMakeNatRange :: forall f t. - ( MakeNatRange f t - ) => Natural -> NatRange f t -unsafeMakeNatRange v = NatRange' (BitNat @(NatRangeBitCount f t) (v - natValue @f)) - --- | Create a value in a Natural range (check validity) -safeMakeNatRange :: forall f t. - ( MakeNatRange f t - ) => Natural -> Maybe (NatRange f t) -safeMakeNatRange v - | v < natValue @f || v > natValue @t = Nothing - | otherwise = Just (unsafeMakeNatRange @f @t v) - --- | Create a value in a Natural range (check validity and throw on error) -makeNatRange :: forall f t. - ( MakeNatRange f t - ) => Natural -> NatRange f t -makeNatRange v = case safeMakeNatRange @f @t v of - Nothing ->error $ show v ++ " isn't in the range [" - ++ show (natValue @f :: Natural) - ++ "," - ++ show (natValue @t :: Natural) - ++ "]" - Just x -> x - - --- | Create a value in a Natural range -natRange :: forall (n :: Nat) f t. - ( MakeNatRange f t - , CheckInRange f t n - , KnownNat n - ) => NatRange f t -natRange = unsafeMakeNatRange (natValue @n) - --- | Convert a NatRange into a Natural -toNaturalNatRange :: forall f t. - ( KnownNat f - , Integral (BitNatWord (NatBitCount (t-f+1))) - ) => NatRange f t -> Natural -toNaturalNatRange (NatRange' x) = natValue @f + toNaturalW x - --- | Natural range pattern --- --- >>> NatRange @10 @12 11 --- NatRange @10 @12 11 --- -pattern NatRange :: forall (f :: Nat) (t :: Nat). - ( MakeNatRange f t - ) => Natural -> NatRange f t -{-# COMPLETE NatRange #-} -pattern NatRange x <- (toNaturalNatRange -> x) - where - NatRange x = makeNatRange @f @t x - - -------------------------------------------------- --- Widening -------------------------------------------------- - --- | Widen a natural --- --- >>> let a = NatRange @18 @100 25 --- >>> widenNatRange @16 @200 a --- NatRange @16 @200 25 --- -widenNatRange :: forall f2 t2 f1 t1. - ( WidenNatRange f1 t1 f2 t2 - ) => NatRange f1 t1 -> NatRange f2 t2 -widenNatRange (NatRange a) = NatRange a - -type WidenNatRange f1 t1 f2 t2 = - ( Assert ((f2 <=? f1) `AndB` (t1 <=? t2)) (() :: Constraint) - ('Text "Can't widen a natural range [" - ':<>: 'ShowType f1 - ':<>: 'Text "," - ':<>: 'ShowType t1 - ':<>: 'Text "] into range [" - ':<>: 'ShowType f2 - ':<>: 'Text "," - ':<>: 'ShowType t2 - ':<>: 'Text "]" - ) - , MakeNatRange f1 t1 - , MakeNatRange f2 t2 - ) - --- | Add two natural ranges --- --- >>> NatRange @2 @4 3 .++. NatRange @7 @17 13 --- NatRange @9 @21 16 --- -(.++.) :: - ( MakeNatRange f1 t1 - , MakeNatRange f2 t2 - , MakeNatRange (f1+f2) (t1+t2) - ) => NatRange f1 t1 -> NatRange f2 t2 -> NatRange (f1+f2) (t1+t2) -(.++.) (NatRange x) (NatRange y) = NatRange (x+y) - diff --git a/src/lib/Haskus/Memory/Allocator/Malloc.hs b/src/lib/Haskus/Memory/Allocator/Malloc.hs --- a/src/lib/Haskus/Memory/Allocator/Malloc.hs +++ b/src/lib/Haskus/Memory/Allocator/Malloc.hs @@ -13,9 +13,7 @@ where import GHC.Exts -import Haskus.Format.Binary.Ptr - ( Ptr (..), nullPtr - ) +import Foreign.Ptr (nullPtr) import Haskus.Utils.Monad import Haskus.Memory.Buffer ( Buffer(..), BufferME, BufferMEF diff --git a/src/lib/Haskus/Memory/Buffer.hs b/src/lib/Haskus/Memory/Buffer.hs --- a/src/lib/Haskus/Memory/Buffer.hs +++ b/src/lib/Haskus/Memory/Buffer.hs @@ -13,11 +13,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} -- | A buffer in memory module Haskus.Memory.Buffer ( Buffer (..) - , TypedBuffer (..) , AnyBuffer (..) -- * Buffer taxonomy , Pinning (..) @@ -73,28 +74,25 @@ , addFinalizer , makeFinalizable , touchBuffer + , touch -- * Conversions , bufferToListIO , BufferToList (..) - -- * Reexport - , module Control.Monad.Primitive ) where -import Haskus.Format.Binary.Word -import Haskus.Format.Binary.Storable -import Haskus.Format.Binary.Ptr +import Haskus.Number.Word +import Haskus.Number.Int +import Haskus.Binary.Storable +import Haskus.Memory.Property +import Haskus.Memory.Utils (memcpy#) import Haskus.Utils.Monad -import qualified Data.Primitive.ByteArray as BA -import qualified Data.Primitive.Types as BA -import Control.Monad.Primitive import Data.IORef -import Unsafe.Coerce +import System.IO.Unsafe import GHC.Prim -import GHC.Weak -import GHC.Exts (toList, IsList(..)) +import GHC.Exts (toList, IsList(..), Ptr (..)) import GHC.Types (IO(..)) -- $setup @@ -103,49 +101,22 @@ -- >>> :set -XFlexibleContexts -- >>> :set -XTypeFamilies -- >>> :set -XScopedTypeVariables --- >>> import Haskus.Format.Binary.Bits - --- | Is the buffer pinned into memory? -data Pinning - = Pinned -- ^ The buffer has a fixed associated memory address - | NotPinned -- ^ The buffer contents can be freely moved to another address - deriving (Show,Eq) - --- | Is the buffer automatically garbage collected? -data Finalization - = Collected -- ^ Automatically collected by the garbage-collector - | Finalized -- ^ Finalizers are run just before the garbage collector - -- collects the buffer entity. The memory used by the buffer - -- may be collected too (Internal heap), explicitly freed by a - -- finalizer or not freed at all. - | NotFinalized -- ^ The buffer contents is not automatically freed and we - -- can't attach finalizers to the buffer. - deriving (Show,Eq) - --- | Allocation heap -data Heap - = Internal -- ^ GHC heap - | External -- ^ External heap - --- | Is the buffer mutable or not? -data Mutability - = Mutable -- ^ Memory cells are mutable - | Immutable -- ^ Memory cells are immutable - deriving (Show,Eq) +-- >>> import Haskus.Binary.Bits +-- | A memory buffer data Buffer (mut :: Mutability) (pin :: Pinning) (fin :: Finalization) (heap :: Heap) where - Buffer :: {-# UNPACK #-} !BA.ByteArray -> BufferI - BufferP :: {-# UNPACK #-} !BA.ByteArray -> BufferP - BufferM :: {-# UNPACK #-} !(BA.MutableByteArray RealWorld) -> BufferM - BufferMP :: {-# UNPACK #-} !(BA.MutableByteArray RealWorld) -> BufferMP - BufferME :: Addr# -> {-# UNPACK #-} !Word -> BufferME - BufferE :: Addr# -> {-# UNPACK #-} !Word -> BufferE - BufferF :: {-# UNPACK #-} !BA.ByteArray -> {-# UNPACK #-} !Finalizers -> BufferF - BufferPF :: {-# UNPACK #-} !BA.ByteArray -> {-# UNPACK #-} !Finalizers -> BufferPF - BufferMF :: {-# UNPACK #-} !(BA.MutableByteArray RealWorld) -> {-# UNPACK #-} !Finalizers -> BufferMF - BufferMPF :: {-# UNPACK #-} !(BA.MutableByteArray RealWorld) -> {-# UNPACK #-} !Finalizers -> BufferMPF - BufferMEF :: Addr# -> {-# UNPACK #-} !Word -> {-# UNPACK #-} !Finalizers -> BufferMEF - BufferEF :: Addr# -> {-# UNPACK #-} !Word -> {-# UNPACK #-} !Finalizers -> BufferEF + Buffer :: !ByteArray# -> BufferI + BufferP :: !ByteArray# -> BufferP + BufferM :: !(MutableByteArray# RealWorld) -> BufferM + BufferMP :: !(MutableByteArray# RealWorld) -> BufferMP + BufferME :: Addr# -> {-# UNPACK #-} !Word -> BufferME + BufferE :: Addr# -> {-# UNPACK #-} !Word -> BufferE + BufferF :: !ByteArray# -> {-# UNPACK #-} !Finalizers -> BufferF + BufferPF :: !ByteArray# -> {-# UNPACK #-} !Finalizers -> BufferPF + BufferMF :: !(MutableByteArray# RealWorld) -> {-# UNPACK #-} !Finalizers -> BufferMF + BufferMPF :: !(MutableByteArray# RealWorld) -> {-# UNPACK #-} !Finalizers -> BufferMPF + BufferMEF :: Addr# -> {-# UNPACK #-} !Word -> {-# UNPACK #-} !Finalizers -> BufferMEF + BufferEF :: Addr# -> {-# UNPACK #-} !Word -> {-# UNPACK #-} !Finalizers -> BufferEF type BufferI = Buffer 'Immutable 'NotPinned 'Collected 'Internal type BufferP = Buffer 'Immutable 'Pinned 'Collected 'Internal @@ -160,9 +131,6 @@ type BufferMEF = Buffer 'Mutable 'Pinned 'Finalized 'External type BufferEF = Buffer 'Immutable 'Pinned 'Finalized 'External --- | A buffer with an additional phantom type indicating its binary format -newtype TypedBuffer (t :: k) mut pin fin heap = TypedBuffer (Buffer mut pin fin heap) - ----------------------------------------------------------------- -- Allocation ----------------------------------------------------------------- @@ -173,18 +141,29 @@ -- newBuffer :: MonadIO m => Word -> m BufferM {-# INLINABLE newBuffer #-} -newBuffer sz = BufferM <$> liftIO (BA.newByteArray (fromIntegral sz)) +newBuffer sz = liftIO $ IO \s -> + case fromIntegral sz of + I# sz# -> case newByteArray# sz# s of + (# s', arr# #) -> (# s', BufferM arr# #) -- | Allocate a buffer (mutable, pinned) newPinnedBuffer :: MonadIO m => Word -> m BufferMP {-# INLINABLE newPinnedBuffer #-} -newPinnedBuffer sz = BufferMP <$> liftIO (BA.newPinnedByteArray (fromIntegral sz)) +newPinnedBuffer sz = liftIO $ IO \s -> + case fromIntegral sz of + I# sz# -> case newPinnedByteArray# sz# s of + (# s', arr# #) -> (# s', BufferMP arr# #) -- | Allocate an aligned buffer (mutable, pinned) newAlignedPinnedBuffer :: MonadIO m => Word -> Word -> m BufferMP {-# INLINABLE newAlignedPinnedBuffer #-} -newAlignedPinnedBuffer sz al = BufferMP <$> liftIO (BA.newAlignedPinnedByteArray (fromIntegral sz) (fromIntegral al)) +newAlignedPinnedBuffer sz al = liftIO $ IO \s -> + case fromIntegral sz of + I# sz# -> case fromIntegral al of + I# al# -> case newAlignedPinnedByteArray# sz# al# s of + (# s', arr# #) -> (# s', BufferMP arr# #) + ----------------------------------------------------------------- -- Finalizers ----------------------------------------------------------------- @@ -198,42 +177,28 @@ [] -> ([f] , True) fs -> (f:fs, False) +-- | Get buffer finalizers +getFinalizers :: Buffer mut pin 'Finalized heap -> Finalizers +getFinalizers b = case b of + BufferMEF _addr _sz fin -> fin + BufferEF _addr _sz fin -> fin + BufferF _ba fin -> fin + BufferPF _ba fin -> fin + BufferMF _ba fin -> fin + BufferMPF _ba fin -> fin + + -- | Add a finalizer. -- -- The latest added finalizers are executed first. Finalizers are not guaranteed -- to run (e.g. if the program exits before the buffer is collected). -- addFinalizer :: MonadIO m => Buffer mut pin 'Finalized heap -> IO () -> m () -addFinalizer b f = case b of - BufferMEF _addr _sz fin@(Finalizers rfs) -> do - wasEmpty <- insertFinalizer fin f - -- add the weak reference to the finalizer IORef (not to Addr#) - when wasEmpty $ void $ liftIO $ mkWeakIORef rfs (runFinalizers fin) - - BufferEF _addr _sz fin@(Finalizers rfs) -> do - wasEmpty <- insertFinalizer fin f - -- add the weak reference to the finalizer IORef (not to Addr#) - when wasEmpty $ void $ liftIO $ mkWeakIORef rfs (runFinalizers fin) - - BufferF ba fin -> do - wasEmpty <- insertFinalizer fin f - -- add the weak reference to the ByteArray - when wasEmpty $ void $ liftIO $ mkWeak ba () (Just (runFinalizers fin)) - - BufferPF ba fin -> do - wasEmpty <- insertFinalizer fin f - -- add the weak reference to the ByteArray - when wasEmpty $ void $ liftIO $ mkWeak ba () (Just (runFinalizers fin)) - - BufferMF ba fin -> do - wasEmpty <- insertFinalizer fin f - -- add the weak reference to the MutableByteArray - when wasEmpty $ void $ liftIO $ mkWeak ba () (Just (runFinalizers fin)) - - BufferMPF ba fin -> do - wasEmpty <- insertFinalizer fin f - -- add the weak reference to the MutableByteArray - when wasEmpty $ void $ liftIO $ mkWeak ba () (Just (runFinalizers fin)) +addFinalizer b f = do + let fin@(Finalizers rfs) = getFinalizers b + wasEmpty <- insertFinalizer fin f + -- add the weak reference to the finalizer IORef (not to Addr#/byteArray#/...) + when wasEmpty $ void $ liftIO $ mkWeakIORef rfs (runFinalizers fin) -- | Internal function used to execute finalizers runFinalizers :: Finalizers -> IO () @@ -261,19 +226,25 @@ {-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferMPF-> m () #-} {-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferMEF-> m () #-} {-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferEF -> m () #-} -touchBuffer (Buffer ba ) = liftIO $ touch ba -touchBuffer (BufferP ba ) = liftIO $ touch ba -touchBuffer (BufferM ba ) = liftIO $ touch ba -touchBuffer (BufferMP ba ) = liftIO $ touch ba -touchBuffer (BufferF ba _fin ) = liftIO $ touch ba -touchBuffer (BufferPF ba _fin ) = liftIO $ touch ba -touchBuffer (BufferMF ba _fin ) = liftIO $ touch ba -touchBuffer (BufferMPF ba _fin ) = liftIO $ touch ba +touchBuffer (Buffer _ba ) = return () +touchBuffer (BufferP _ba ) = return () +touchBuffer (BufferM _ba ) = return () +touchBuffer (BufferMP _ba ) = return () +touchBuffer (BufferF _ba (Finalizers fin)) = liftIO $ touch fin +touchBuffer (BufferPF _ba (Finalizers fin)) = liftIO $ touch fin +touchBuffer (BufferMF _ba (Finalizers fin)) = liftIO $ touch fin +touchBuffer (BufferMPF _ba (Finalizers fin)) = liftIO $ touch fin touchBuffer (BufferME _addr _sz ) = return () touchBuffer (BufferE _addr _sz ) = return () touchBuffer (BufferMEF _addr _sz (Finalizers fin)) = liftIO $ touch fin touchBuffer (BufferEF _addr _sz (Finalizers fin)) = liftIO $ touch fin +-- | Touch a data +touch :: MonadIO m => a -> m () +{-# NOINLINE touch #-} +touch x = liftIO $ IO \s -> case touch# x s of + s' -> (# s', () #) + -- | Make a buffer finalizable -- -- The new buffer liveness is used to trigger finalizers. @@ -314,9 +285,10 @@ where {-# INLINABLE unsafeBufferFreeze #-} unsafeBufferFreeze = \case - BufferM mba -> Buffer <$> liftIO (BA.unsafeFreezeByteArray mba) - BufferMP mba -> BufferP <$> liftIO (BA.unsafeFreezeByteArray mba) + BufferM mba -> liftIO $ IO (\s -> case unsafeFreezeByteArray# mba s of (# s', ba #) -> (# s', Buffer ba #)) + BufferMP mba -> liftIO $ IO (\s -> case unsafeFreezeByteArray# mba s of (# s', ba #) -> (# s', BufferP ba #)) + instance Freezable (Buffer 'Mutable pin fin 'External) (Buffer 'Immutable pin fin 'External) where @@ -338,8 +310,8 @@ where {-# INLINABLE unsafeBufferThaw #-} unsafeBufferThaw = \case - Buffer mba -> BufferM <$> liftIO (BA.unsafeThawByteArray mba) - BufferP mba -> BufferMP <$> liftIO (BA.unsafeThawByteArray mba) + Buffer mba -> pure $ BufferM (unsafeCoerce# mba) + BufferP mba -> pure $ BufferMP (unsafeCoerce# mba) instance Thawable (Buffer 'Immutable pin 'NotFinalized heap) (Buffer 'Mutable pin 'NotFinalized heap) @@ -362,10 +334,10 @@ BufferMEF{} -> True BufferEF {} -> True BufferMPF{} -> True - Buffer ba -> BA.isByteArrayPinned ba - BufferM mba -> BA.isMutableByteArrayPinned mba - BufferF ba _fin -> BA.isByteArrayPinned ba - BufferMF mba _fin -> BA.isMutableByteArrayPinned mba + Buffer ba -> isTrue# (isByteArrayPinned# ba) + BufferM mba -> isTrue# (isMutableByteArrayPinned# mba) + BufferF ba _fin -> isTrue# (isByteArrayPinned# ba) + BufferMF mba _fin -> isTrue# (isMutableByteArrayPinned# mba) -- | Transform type-level NotPinned buffers into type-level Pinned if the buffer -- is dynamically pinned (see `bufferIsDynamicallyPinned`). @@ -381,16 +353,16 @@ BufferMEF{} -> Right b BufferEF {} -> Right b BufferMPF{} -> Right b - Buffer ba -> if BA.isByteArrayPinned ba + Buffer ba -> if isTrue# (isByteArrayPinned# ba) then Right (BufferP ba) else Left b - BufferM mba -> if BA.isMutableByteArrayPinned mba + BufferM mba -> if isTrue# (isMutableByteArrayPinned# mba) then Right (BufferMP mba) else Left b - BufferF ba fin -> if BA.isByteArrayPinned ba + BufferF ba fin -> if isTrue# (isByteArrayPinned# ba) then Right (BufferPF ba fin) else Left b - BufferMF mba fin -> if BA.isMutableByteArrayPinned mba + BufferMF mba fin -> if isTrue# (isMutableByteArrayPinned# mba) then Right (BufferMPF mba fin) else Left b @@ -411,23 +383,19 @@ {-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferMEF-> (Addr# -> m a) -> m a #-} {-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferEF -> (Addr# -> m a) -> m a #-} unsafeWithBufferAddr# b@(BufferP ba) f = do - let !(BA.Addr addr) = BA.byteArrayContents ba - r <- f addr + r <- f (byteArrayContents# ba) touchBuffer b return r unsafeWithBufferAddr# b@(BufferMP ba) f = do - let !(BA.Addr addr) = BA.mutableByteArrayContents ba - r <- f addr + r <- f (byteArrayContents# (unsafeCoerce# ba)) touchBuffer b return r unsafeWithBufferAddr# b@(BufferPF ba _fin) f = do - let !(BA.Addr addr) = BA.byteArrayContents ba - r <- f addr + r <- f (byteArrayContents# ba) touchBuffer b return r unsafeWithBufferAddr# b@(BufferMPF ba _fin) f = do - let !(BA.Addr addr) = BA.mutableByteArrayContents ba - r <- f addr + r <- f (byteArrayContents# (unsafeCoerce# ba)) touchBuffer b return r unsafeWithBufferAddr# (BufferME addr _sz) f = f (addr) @@ -493,35 +461,43 @@ {-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferMEF-> m Word #-} {-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferEF -> m Word #-} bufferSizeIO = \case - BufferM ba -> fromIntegral <$> liftIO (BA.getSizeofMutableByteArray ba) - BufferMP ba -> fromIntegral <$> liftIO (BA.getSizeofMutableByteArray ba) - BufferMF ba _fin -> fromIntegral <$> liftIO (BA.getSizeofMutableByteArray ba) - BufferMPF ba _fin -> fromIntegral <$> liftIO (BA.getSizeofMutableByteArray ba) + BufferM ba -> bufferSizeMBA ba + BufferMP ba -> bufferSizeMBA ba + BufferMF ba _fin -> bufferSizeMBA ba + BufferMPF ba _fin -> bufferSizeMBA ba BufferME _addr sz -> return sz BufferMEF _addr sz _fin -> return sz BufferE _addr sz -> return sz BufferEF _addr sz _fin -> return sz - Buffer ba -> return $ fromIntegral $ BA.sizeofByteArray ba - BufferP ba -> return $ fromIntegral $ BA.sizeofByteArray ba - BufferF ba _fin -> return $ fromIntegral $ BA.sizeofByteArray ba - BufferPF ba _fin -> return $ fromIntegral $ BA.sizeofByteArray ba + Buffer ba -> pure $ bufferSizeBA ba + BufferP ba -> pure $ bufferSizeBA ba + BufferF ba _fin -> pure $ bufferSizeBA ba + BufferPF ba _fin -> pure $ bufferSizeBA ba +bufferSizeMBA :: MonadIO m => MutableByteArray# RealWorld -> m Word +bufferSizeMBA mba = liftIO $ IO \s -> case getSizeofMutableByteArray# mba s of + (# s', i #) -> case int2Word# i of + n -> (# s', W# n #) + +bufferSizeBA :: ByteArray# -> Word +bufferSizeBA ba = W# (int2Word# (sizeofByteArray# ba)) + class BufferSize a where -- | Get buffer size bufferSize :: a -> Word instance BufferSize BufferI where {-# INLINABLE bufferSize #-} - bufferSize (Buffer ba) = fromIntegral $ BA.sizeofByteArray ba + bufferSize (Buffer ba) = bufferSizeBA ba instance BufferSize BufferP where {-# INLINABLE bufferSize #-} - bufferSize (BufferP ba) = fromIntegral $ BA.sizeofByteArray ba + bufferSize (BufferP ba) = bufferSizeBA ba instance BufferSize BufferF where {-# INLINABLE bufferSize #-} - bufferSize (BufferF ba _fin) = fromIntegral $ BA.sizeofByteArray ba + bufferSize (BufferF ba _fin) = bufferSizeBA ba instance BufferSize BufferPF where {-# INLINABLE bufferSize #-} - bufferSize (BufferPF ba _fin) = fromIntegral $ BA.sizeofByteArray ba + bufferSize (BufferPF ba _fin) = bufferSizeBA ba instance BufferSize BufferME where {-# INLINABLE bufferSize #-} bufferSize (BufferME _addr sz) = sz @@ -537,32 +513,50 @@ -- | Get contents as a list of bytes bufferToListIO :: MonadIO m => Buffer mut pin fin heap -> m [Word8] -bufferToListIO = \case - Buffer ba -> return (toList ba) - BufferP ba -> return (toList ba) - BufferF ba _fin -> return (toList ba) - BufferPF ba _fin -> return (toList ba) - BufferM ba -> return (toList (unsafeCoerce ba :: BA.ByteArray)) - BufferMP ba -> return (toList (unsafeCoerce ba :: BA.ByteArray)) - BufferMF ba _fin -> return (toList (unsafeCoerce ba :: BA.ByteArray)) - BufferMPF ba _fin -> return (toList (unsafeCoerce ba :: BA.ByteArray)) - BufferME addr sz -> peekArray sz (Ptr addr) +bufferToListIO b = case b of + Buffer _ba -> pure (toListBuffer b) + BufferP _ba -> pure (toListBuffer b) + BufferF _ba _fin -> pure (toListBuffer b) + BufferPF _ba _fin -> pure (toListBuffer b) + BufferM _ba -> toListBufferIO b + BufferMP _ba -> toListBufferIO b + BufferMF _ba _fin -> toListBufferIO b + BufferMPF _ba _fin -> toListBufferIO b + BufferME addr sz -> peekArray sz (Ptr addr) BufferMEF addr sz _fin -> peekArray sz (Ptr addr) - BufferE addr sz -> peekArray sz (Ptr addr) + BufferE addr sz -> peekArray sz (Ptr addr) BufferEF addr sz _fin -> peekArray sz (Ptr addr) +-- | Convert a buffer into a list of bytes by reading bytes one by one +toListBufferIO :: MonadIO m => Buffer mut pin fin heap -> m [Word8] +toListBufferIO b = do + sz <- bufferSizeIO b + let + go i xs = do + x <- bufferReadWord8IO b i + if i == 0 + then return (x:xs) + else go (i-1) (x:xs) + go (sz-1) [] + +-- | Convert a buffer into a list of bytes by reading bytes one by one +toListBuffer :: BufferSize (Buffer 'Immutable pin fin heap) => Buffer 'Immutable pin fin heap -> [Word8] +toListBuffer b = if sz == 0 then [] else fmap (bufferReadWord8 b) [0..(sz-1)] + where + sz = bufferSize b + class BufferToList a where -- | Get contents as a list of bytes bufferToList :: a -> [Word8] instance BufferToList BufferI where - bufferToList (Buffer ba) = toList ba + bufferToList b = toListBuffer b instance BufferToList BufferP where - bufferToList (BufferP ba) = toList ba + bufferToList b = toListBuffer b instance BufferToList BufferF where - bufferToList (BufferF ba _fin) = toList ba + bufferToList b = toListBuffer b instance BufferToList BufferPF where - bufferToList (BufferPF ba _fin) = toList ba + bufferToList b = toListBuffer b -- | Support for OverloadedLists -- @@ -570,12 +564,22 @@ -- >>> let b = [25,26,27,28] :: BufferI -- instance IsList BufferI where - type Item BufferI = Word8 - toList (Buffer ba) = toList ba - fromList xs = Buffer (fromList xs) - fromListN sz xs = Buffer (fromListN sz xs) + type Item BufferI = Word8 + toList b = toListBuffer b + fromList xs = unsafePerformIO do + let sz = fromIntegral (length xs) + b <- newBuffer sz + forM_ ([0..] `zip` xs) \(i,x) -> do + bufferWriteWord8IO b i x + unsafeBufferFreeze b + fromListN sz xs = unsafePerformIO do + b <- newBuffer (fromIntegral sz) + forM_ ([0..] `zip` xs) \(i,x) -> do + bufferWriteWord8IO b i x + unsafeBufferFreeze b + -- | Read a Word8, offset in bytes -- -- We don't check that the offset is valid @@ -599,18 +603,18 @@ {-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferMEF-> Word -> m Word8 #-} {-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferEF -> Word -> m Word8 #-} bufferReadWord8IO b (fromIntegral -> !(I# off)) = case b of - BufferM (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #) - BufferMP (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #) - BufferMF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #) - BufferMPF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #) - BufferME addr _sz -> liftIO $ IO $ \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #) - BufferMEF addr _sz _fin -> liftIO $ IO $ \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #) - BufferE addr _sz -> liftIO $ IO $ \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #) - BufferEF addr _sz _fin -> liftIO $ IO $ \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #) - Buffer (BA.ByteArray ba) -> return (W8# (indexWord8Array# ba off)) - BufferP (BA.ByteArray ba) -> return (W8# (indexWord8Array# ba off)) - BufferF (BA.ByteArray ba) _fin -> return (W8# (indexWord8Array# ba off)) - BufferPF (BA.ByteArray ba) _fin -> return (W8# (indexWord8Array# ba off)) + BufferM ba -> liftIO $ IO \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #) + BufferMP ba -> liftIO $ IO \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #) + BufferMF ba _fin -> liftIO $ IO \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #) + BufferMPF ba _fin -> liftIO $ IO \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #) + BufferME addr _sz -> liftIO $ IO \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #) + BufferMEF addr _sz _fin -> liftIO $ IO \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #) + BufferE addr _sz -> liftIO $ IO \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #) + BufferEF addr _sz _fin -> liftIO $ IO \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #) + Buffer ba -> return (W8# (indexWord8Array# ba off)) + BufferP ba -> return (W8# (indexWord8Array# ba off)) + BufferF ba _fin -> return (W8# (indexWord8Array# ba off)) + BufferPF ba _fin -> return (W8# (indexWord8Array# ba off)) -- | Read a Word8 in an immutable buffer, offset in bytes -- @@ -629,12 +633,12 @@ {-# SPECIALIZE INLINE bufferReadWord8 :: BufferPF -> Word -> Word8 #-} {-# SPECIALIZE INLINE bufferReadWord8 :: BufferEF -> Word -> Word8 #-} bufferReadWord8 b (fromIntegral -> !(I# off)) = case b of - Buffer (BA.ByteArray ba) -> W8# (indexWord8Array# ba off) - BufferP (BA.ByteArray ba) -> W8# (indexWord8Array# ba off) - BufferF (BA.ByteArray ba) _fin -> W8# (indexWord8Array# ba off) - BufferPF (BA.ByteArray ba) _fin -> W8# (indexWord8Array# ba off) - BufferE addr _sz -> W8# (indexWord8OffAddr# (addr `plusAddr#` off) 0#) - BufferEF addr _sz _fin -> W8# (indexWord8OffAddr# (addr `plusAddr#` off) 0#) + Buffer ba -> W8# (indexWord8Array# ba off) + BufferP ba -> W8# (indexWord8Array# ba off) + BufferF ba _fin -> W8# (indexWord8Array# ba off) + BufferPF ba _fin -> W8# (indexWord8Array# ba off) + BufferE addr _sz -> W8# (indexWord8OffAddr# (addr `plusAddr#` off) 0#) + BufferEF addr _sz _fin -> W8# (indexWord8OffAddr# (addr `plusAddr#` off) 0#) -- | Write a Word8, offset in bytes -- @@ -654,15 +658,12 @@ {-# SPECIALIZE INLINE bufferWriteWord8IO :: MonadIO m => BufferMPF-> Word -> Word8 -> m ()#-} {-# SPECIALIZE INLINE bufferWriteWord8IO :: MonadIO m => BufferMEF-> Word -> Word8 -> m ()#-} bufferWriteWord8IO b (fromIntegral -> !(I# off)) (W8# v) = case b of - BufferM (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #) - BufferMP (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #) - BufferMF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #) - BufferMPF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #) - BufferME addr _sz -> liftIO $ IO $ \s -> case writeWord8OffAddr# addr off v s of s2 -> (# s2 , () #) - BufferMEF addr _sz _fin -> liftIO $ IO $ \s -> case writeWord8OffAddr# addr off v s of s2 -> (# s2 , () #) - - - + BufferM ba -> liftIO $ IO \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #) + BufferMP ba -> liftIO $ IO \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #) + BufferMF ba _fin -> liftIO $ IO \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #) + BufferMPF ba _fin -> liftIO $ IO \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #) + BufferME addr _sz -> liftIO $ IO \s -> case writeWord8OffAddr# addr off v s of s2 -> (# s2 , () #) + BufferMEF addr _sz _fin -> liftIO $ IO \s -> case writeWord8OffAddr# addr off v s of s2 -> (# s2 , () #) -- | Read a Word16, offset in bytes @@ -689,18 +690,18 @@ {-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferMEF-> Word -> m Word16 #-} {-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferEF -> Word -> m Word16 #-} bufferReadWord16IO b (fromIntegral -> !(I# off)) = case b of - BufferM (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #) - BufferMP (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #) - BufferMF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #) - BufferMPF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #) - BufferME addr _sz -> liftIO $ IO $ \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #) - BufferMEF addr _sz _fin -> liftIO $ IO $ \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #) - BufferE addr _sz -> liftIO $ IO $ \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #) - BufferEF addr _sz _fin -> liftIO $ IO $ \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #) - Buffer (BA.ByteArray ba) -> return (W16# (indexWord8ArrayAsWord16# ba off)) - BufferP (BA.ByteArray ba) -> return (W16# (indexWord8ArrayAsWord16# ba off)) - BufferF (BA.ByteArray ba) _fin -> return (W16# (indexWord8ArrayAsWord16# ba off)) - BufferPF (BA.ByteArray ba) _fin -> return (W16# (indexWord8ArrayAsWord16# ba off)) + BufferM ba -> liftIO $ IO \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #) + BufferMP ba -> liftIO $ IO \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #) + BufferMF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #) + BufferMPF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #) + BufferME addr _sz -> liftIO $ IO \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #) + BufferMEF addr _sz _fin -> liftIO $ IO \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #) + BufferE addr _sz -> liftIO $ IO \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #) + BufferEF addr _sz _fin -> liftIO $ IO \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #) + Buffer ba -> return (W16# (indexWord8ArrayAsWord16# ba off)) + BufferP ba -> return (W16# (indexWord8ArrayAsWord16# ba off)) + BufferF ba _fin -> return (W16# (indexWord8ArrayAsWord16# ba off)) + BufferPF ba _fin -> return (W16# (indexWord8ArrayAsWord16# ba off)) -- | Read a Word16 in an immutable buffer, offset in bytes -- @@ -714,12 +715,12 @@ {-# SPECIALIZE INLINE bufferReadWord16 :: BufferPF -> Word -> Word16 #-} {-# SPECIALIZE INLINE bufferReadWord16 :: BufferEF -> Word -> Word16 #-} bufferReadWord16 b (fromIntegral -> !(I# off)) = case b of - Buffer (BA.ByteArray ba) -> W16# (indexWord8ArrayAsWord16# ba off) - BufferP (BA.ByteArray ba) -> W16# (indexWord8ArrayAsWord16# ba off) - BufferF (BA.ByteArray ba) _fin -> W16# (indexWord8ArrayAsWord16# ba off) - BufferPF (BA.ByteArray ba) _fin -> W16# (indexWord8ArrayAsWord16# ba off) - BufferE addr _sz -> W16# (indexWord16OffAddr# (addr `plusAddr#` off) 0#) - BufferEF addr _sz _fin -> W16# (indexWord16OffAddr# (addr `plusAddr#` off) 0#) + Buffer ba -> W16# (indexWord8ArrayAsWord16# ba off) + BufferP ba -> W16# (indexWord8ArrayAsWord16# ba off) + BufferF ba _fin -> W16# (indexWord8ArrayAsWord16# ba off) + BufferPF ba _fin -> W16# (indexWord8ArrayAsWord16# ba off) + BufferE addr _sz -> W16# (indexWord16OffAddr# (addr `plusAddr#` off) 0#) + BufferEF addr _sz _fin -> W16# (indexWord16OffAddr# (addr `plusAddr#` off) 0#) -- | Write a Word16, offset in bytes -- @@ -745,12 +746,12 @@ {-# SPECIALIZE INLINE bufferWriteWord16IO :: MonadIO m => BufferMPF-> Word -> Word16 -> m ()#-} {-# SPECIALIZE INLINE bufferWriteWord16IO :: MonadIO m => BufferMEF-> Word -> Word16 -> m ()#-} bufferWriteWord16IO b (fromIntegral -> !(I# off)) (W16# v) = case b of - BufferM (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #) - BufferMP (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #) - BufferMF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #) - BufferMPF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #) - BufferME addr _sz -> liftIO $ IO $ \s -> case writeWord16OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) - BufferMEF addr _sz _fin -> liftIO $ IO $ \s -> case writeWord16OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) + BufferM ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #) + BufferMP ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #) + BufferMF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #) + BufferMPF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #) + BufferME addr _sz -> liftIO $ IO \s -> case writeWord16OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) + BufferMEF addr _sz _fin -> liftIO $ IO \s -> case writeWord16OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) @@ -778,18 +779,18 @@ {-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferMEF-> Word -> m Word32 #-} {-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferEF -> Word -> m Word32 #-} bufferReadWord32IO b (fromIntegral -> !(I# off)) = case b of - BufferM (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #) - BufferMP (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #) - BufferMF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #) - BufferMPF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #) - BufferME addr _sz -> liftIO $ IO $ \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #) - BufferMEF addr _sz _fin -> liftIO $ IO $ \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #) - BufferE addr _sz -> liftIO $ IO $ \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #) - BufferEF addr _sz _fin -> liftIO $ IO $ \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #) - Buffer (BA.ByteArray ba) -> return (W32# (indexWord8ArrayAsWord32# ba off)) - BufferP (BA.ByteArray ba) -> return (W32# (indexWord8ArrayAsWord32# ba off)) - BufferF (BA.ByteArray ba) _fin -> return (W32# (indexWord8ArrayAsWord32# ba off)) - BufferPF (BA.ByteArray ba) _fin -> return (W32# (indexWord8ArrayAsWord32# ba off)) + BufferM ba -> liftIO $ IO \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #) + BufferMP ba -> liftIO $ IO \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #) + BufferMF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #) + BufferMPF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #) + BufferME addr _sz -> liftIO $ IO \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #) + BufferMEF addr _sz _fin -> liftIO $ IO \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #) + BufferE addr _sz -> liftIO $ IO \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #) + BufferEF addr _sz _fin -> liftIO $ IO \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #) + Buffer ba -> return (W32# (indexWord8ArrayAsWord32# ba off)) + BufferP ba -> return (W32# (indexWord8ArrayAsWord32# ba off)) + BufferF ba _fin -> return (W32# (indexWord8ArrayAsWord32# ba off)) + BufferPF ba _fin -> return (W32# (indexWord8ArrayAsWord32# ba off)) -- | Read a Word32 in an immutable buffer, offset in bytes -- @@ -803,12 +804,12 @@ {-# SPECIALIZE INLINE bufferReadWord32 :: BufferPF -> Word -> Word32 #-} {-# SPECIALIZE INLINE bufferReadWord32 :: BufferEF -> Word -> Word32 #-} bufferReadWord32 b (fromIntegral -> !(I# off)) = case b of - Buffer (BA.ByteArray ba) -> W32# (indexWord8ArrayAsWord32# ba off) - BufferP (BA.ByteArray ba) -> W32# (indexWord8ArrayAsWord32# ba off) - BufferF (BA.ByteArray ba) _fin -> W32# (indexWord8ArrayAsWord32# ba off) - BufferPF (BA.ByteArray ba) _fin -> W32# (indexWord8ArrayAsWord32# ba off) - BufferE addr _sz -> W32# (indexWord32OffAddr# (addr `plusAddr#` off) 0#) - BufferEF addr _sz _fin -> W32# (indexWord32OffAddr# (addr `plusAddr#` off) 0#) + Buffer ba -> W32# (indexWord8ArrayAsWord32# ba off) + BufferP ba -> W32# (indexWord8ArrayAsWord32# ba off) + BufferF ba _fin -> W32# (indexWord8ArrayAsWord32# ba off) + BufferPF ba _fin -> W32# (indexWord8ArrayAsWord32# ba off) + BufferE addr _sz -> W32# (indexWord32OffAddr# (addr `plusAddr#` off) 0#) + BufferEF addr _sz _fin -> W32# (indexWord32OffAddr# (addr `plusAddr#` off) 0#) -- | Write a Word32, offset in bytes -- @@ -829,12 +830,12 @@ {-# SPECIALIZE INLINE bufferWriteWord32IO :: MonadIO m => BufferMPF-> Word -> Word32 -> m ()#-} {-# SPECIALIZE INLINE bufferWriteWord32IO :: MonadIO m => BufferMEF-> Word -> Word32 -> m ()#-} bufferWriteWord32IO b (fromIntegral -> !(I# off)) (W32# v) = case b of - BufferM (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #) - BufferMP (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #) - BufferMF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #) - BufferMPF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #) - BufferME addr _sz -> liftIO $ IO $ \s -> case writeWord32OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) - BufferMEF addr _sz _fin -> liftIO $ IO $ \s -> case writeWord32OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) + BufferM ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #) + BufferMP ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #) + BufferMF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #) + BufferMPF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #) + BufferME addr _sz -> liftIO $ IO \s -> case writeWord32OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) + BufferMEF addr _sz _fin -> liftIO $ IO \s -> case writeWord32OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) -- | Read a Word64, offset in bytes @@ -861,18 +862,18 @@ {-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferMEF-> Word -> m Word64 #-} {-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferEF -> Word -> m Word64 #-} bufferReadWord64IO b (fromIntegral -> !(I# off)) = case b of - BufferM (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #) - BufferMP (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #) - BufferMF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #) - BufferMPF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #) - BufferME addr _sz -> liftIO $ IO $ \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #) - BufferMEF addr _sz _fin -> liftIO $ IO $ \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #) - BufferE addr _sz -> liftIO $ IO $ \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #) - BufferEF addr _sz _fin -> liftIO $ IO $ \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #) - Buffer (BA.ByteArray ba) -> return (W64# (indexWord8ArrayAsWord64# ba off)) - BufferP (BA.ByteArray ba) -> return (W64# (indexWord8ArrayAsWord64# ba off)) - BufferF (BA.ByteArray ba) _fin -> return (W64# (indexWord8ArrayAsWord64# ba off)) - BufferPF (BA.ByteArray ba) _fin -> return (W64# (indexWord8ArrayAsWord64# ba off)) + BufferM ba -> liftIO $ IO \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #) + BufferMP ba -> liftIO $ IO \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #) + BufferMF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #) + BufferMPF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #) + BufferME addr _sz -> liftIO $ IO \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #) + BufferMEF addr _sz _fin -> liftIO $ IO \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #) + BufferE addr _sz -> liftIO $ IO \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #) + BufferEF addr _sz _fin -> liftIO $ IO \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #) + Buffer ba -> return (W64# (indexWord8ArrayAsWord64# ba off)) + BufferP ba -> return (W64# (indexWord8ArrayAsWord64# ba off)) + BufferF ba _fin -> return (W64# (indexWord8ArrayAsWord64# ba off)) + BufferPF ba _fin -> return (W64# (indexWord8ArrayAsWord64# ba off)) -- | Read a Word64 in an immutable buffer, offset in bytes -- @@ -886,12 +887,12 @@ {-# SPECIALIZE INLINE bufferReadWord64 :: BufferPF -> Word -> Word64 #-} {-# SPECIALIZE INLINE bufferReadWord64 :: BufferEF -> Word -> Word64 #-} bufferReadWord64 b (fromIntegral -> !(I# off)) = case b of - Buffer (BA.ByteArray ba) -> W64# (indexWord8ArrayAsWord64# ba off) - BufferP (BA.ByteArray ba) -> W64# (indexWord8ArrayAsWord64# ba off) - BufferF (BA.ByteArray ba) _fin -> W64# (indexWord8ArrayAsWord64# ba off) - BufferPF (BA.ByteArray ba) _fin -> W64# (indexWord8ArrayAsWord64# ba off) - BufferE addr _sz -> W64# (indexWord64OffAddr# (addr `plusAddr#` off) 0#) - BufferEF addr _sz _fin -> W64# (indexWord64OffAddr# (addr `plusAddr#` off) 0#) + Buffer ba -> W64# (indexWord8ArrayAsWord64# ba off) + BufferP ba -> W64# (indexWord8ArrayAsWord64# ba off) + BufferF ba _fin -> W64# (indexWord8ArrayAsWord64# ba off) + BufferPF ba _fin -> W64# (indexWord8ArrayAsWord64# ba off) + BufferE addr _sz -> W64# (indexWord64OffAddr# (addr `plusAddr#` off) 0#) + BufferEF addr _sz _fin -> W64# (indexWord64OffAddr# (addr `plusAddr#` off) 0#) -- | Write a Word64, offset in bytes -- @@ -912,12 +913,12 @@ {-# SPECIALIZE INLINE bufferWriteWord64IO :: MonadIO m => BufferMPF-> Word -> Word64 -> m ()#-} {-# SPECIALIZE INLINE bufferWriteWord64IO :: MonadIO m => BufferMEF-> Word -> Word64 -> m ()#-} bufferWriteWord64IO b (fromIntegral -> !(I# off)) (W64# v) = case b of - BufferM (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #) - BufferMP (BA.MutableByteArray ba) -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #) - BufferMF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #) - BufferMPF (BA.MutableByteArray ba) _fin -> liftIO $ IO $ \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #) - BufferME addr _sz -> liftIO $ IO $ \s -> case writeWord64OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) - BufferMEF addr _sz _fin -> liftIO $ IO $ \s -> case writeWord64OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) + BufferM ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #) + BufferMP ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #) + BufferMF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #) + BufferMPF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #) + BufferME addr _sz -> liftIO $ IO \s -> case writeWord64OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) + BufferMEF addr _sz _fin -> liftIO $ IO \s -> case writeWord64OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #) -- | Copy a buffer into another from/to the given offsets @@ -1022,7 +1023,7 @@ BufferME addr _sz -> toAddr addr BufferMEF addr _sz _f -> toAddr addr - toMba :: BA.MutableByteArray RealWorld -> m () + toMba :: MutableByteArray# RealWorld -> m () toMba mba = case sb of Buffer ba -> baToMba ba mba BufferP ba -> baToMba ba mba @@ -1052,45 +1053,43 @@ BufferMEF addr2 _sz _f -> addrToAddr addr2 addr BufferEF addr2 _sz _f -> addrToAddr addr2 addr - mbaToMba :: BA.MutableByteArray RealWorld -> BA.MutableByteArray RealWorld -> m () - mbaToMba (BA.MutableByteArray mba1) (BA.MutableByteArray mba2) = - liftIO $ IO $ \s -> + mbaToMba :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> m () + mbaToMba mba1 mba2 = + liftIO $ IO \s -> case copyMutableByteArray# mba1 soff mba2 doff cnt s of s2 -> (# s2, () #) - baToMba :: BA.ByteArray -> BA.MutableByteArray RealWorld -> m () - baToMba (BA.ByteArray ba) (BA.MutableByteArray mba) = - liftIO $ IO $ \s -> + baToMba :: ByteArray# -> MutableByteArray# RealWorld -> m () + baToMba ba mba = + liftIO $ IO \s -> case copyByteArray# ba soff mba doff cnt s of s2 -> (# s2, () #) - addrToMba :: Addr# -> BA.MutableByteArray RealWorld -> m () - addrToMba addr (BA.MutableByteArray mba) = - liftIO $ IO $ \s -> + addrToMba :: Addr# -> MutableByteArray# RealWorld -> m () + addrToMba addr mba = + liftIO $ IO \s -> case copyAddrToByteArray# (addr `plusAddr#` soff) mba doff cnt s of s2 -> (# s2, () #) - baToAddr :: BA.ByteArray -> Addr# -> m () - baToAddr (BA.ByteArray ba) addr = - liftIO $ IO $ \s -> + baToAddr :: ByteArray# -> Addr# -> m () + baToAddr ba addr = + liftIO $ IO \s -> case copyByteArrayToAddr# ba soff (addr `plusAddr#` doff) cnt s of s2 -> (# s2, () #) - mbaToAddr :: BA.MutableByteArray RealWorld -> Addr# -> m () - mbaToAddr (BA.MutableByteArray mba) addr = + mbaToAddr :: MutableByteArray# RealWorld -> Addr# -> m () + mbaToAddr mba addr = liftIO $ IO $ \s -> case copyMutableByteArrayToAddr# mba soff (addr `plusAddr#` doff) cnt s of s2 -> (# s2, () #) addrToAddr :: Addr# -> Addr# -> m () addrToAddr addr1 addr2 = - liftIO $ memcpy (addr1 `plusAddr#` soff) - (addr2 `plusAddr#` doff) - cnt + liftIO $ memcpy# (addr1 `plusAddr#` soff) + (addr2 `plusAddr#` doff) + cnt -foreign import ccall unsafe "memcpy" memcpy :: Addr# -> Addr# -> Int# -> IO () - ----------------------------------------------------------------- -- AnyBuffer ----------------------------------------------------------------- diff --git a/src/lib/Haskus/Memory/Embed.hs b/src/lib/Haskus/Memory/Embed.hs --- a/src/lib/Haskus/Memory/Embed.hs +++ b/src/lib/Haskus/Memory/Embed.hs @@ -25,12 +25,12 @@ where import Haskus.Memory.Buffer -import Haskus.Format.Binary.Word -import Haskus.Format.Binary.Ptr +import Haskus.Number.Word import Haskus.Utils.List (intersperse) import Haskus.Utils.Maybe import Haskus.Utils.Monad +import Foreign.Ptr import Language.Haskell.TH import Language.Haskell.TH.Syntax import System.Directory (getFileSize) @@ -244,7 +244,7 @@ liftIO $ unsafeWithBufferPtr buf $ \ptr -> do withBinaryFile tmp WriteMode $ \hdl -> do - hPutBuf hdl (ptr `indexPtr` fromIntegral off) (fromIntegral sz) + hPutBuf hdl (ptr `plusPtr` fromIntegral off) (fromIntegral sz) embedFile' True tmp mut malign Nothing Nothing -- | Embed a unpinned buffer in the executable. Return either a BufferE or a diff --git a/src/lib/Haskus/Memory/Layout.hs b/src/lib/Haskus/Memory/Layout.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Memory/Layout.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE NoStarIsType #-} + +-- | Memory layout +-- +-- Describe a memory region +module Haskus.Memory.Layout + ( LPath (..) + , PathElem (..) + , lPath + , LPathType + , LPathOffset + , LRoot + , (:->) + , (:#>) + -- * Layouts + , CPrimitive (..) + , CArray (..) + , CUArray (..) + , CStruct (..) + , CUnion (..) + ) +where + +import Haskus.Utils.Types + +-- | Path in a layout +data LPath (path :: [PathElem]) = LPath + +-- | Layout path element +data PathElem + = LIndex Nat -- ^ Addressing via a numeric index + | LSymbol Symbol -- ^ Addressing via a symbol + +-- | Layout path root +type LRoot = LPath '[] + +-- | Index in the layout path +-- +-- Helper for ``ptr --> lPath @p`` +-- until +lPath :: forall e. LPath '[e] +lPath = LPath + +-- | Type obtained when following path p +type family LPathType p l :: Type +type instance LPathType (LPath '[]) l = l + +-- | Offset obtained when following path p +type family LPathOffset p l :: Nat +type instance LPathOffset (LPath '[]) l = 0 + + +type family (:->) p (s :: Symbol) where + (:->) (LPath xs) s = LPath (Snoc xs ('LSymbol s)) + +type family (:#>) p (n :: Nat) where + (:#>) (LPath xs) n = LPath (Snoc xs ('LIndex n)) + +--------------------------- +-- Layouts +--------------------------- + +type family CSizeOf a :: Nat +type family CAlignment a :: Nat + +-- | Primitives +-- +-- >>> :kind! CSizeOf (CPrimitive 8 1) +-- CSizeOf (CPrimitive 8 1) :: Nat +-- = 8 +-- +-- >>> :kind! CAlignment (CPrimitive 8 2) +-- CAlignment (CPrimitive 8 2) :: Nat +-- = 2 +-- +data CPrimitive (size :: Nat) (align :: Nat) = CPrimitive +type instance CSizeOf (CPrimitive size align) = size +type instance CAlignment (CPrimitive size align) = align + +-- | Array +-- +-- >>> type S = CArray 10 (CPrimitive 8 8) +-- >>> :kind! CSizeOf S +-- CSizeOf S :: Nat +-- = 80 +-- +-- >>> :kind! CAlignment S +-- CAlignment S :: Nat +-- = 8 +data CArray (n :: Nat) (a :: k) = CArray +type instance CSizeOf (CArray n a) = n * (CSizeOf a) +type instance CAlignment (CArray n a) = CAlignment a + +-- | Unbounded array +-- +-- >>> type S = CUArray (CPrimitive 8 8) +-- >>> :kind! CSizeOf S +-- CSizeOf S :: Nat +-- = (TypeError ...) +-- +-- >>> :kind! CAlignment S +-- CAlignment S :: Nat +-- = 8 +data CUArray (a :: k) = CUArray +type instance CSizeOf (CUArray a) = TypeError ('Text "Cannot apply SizeOf to an unbounded array") +type instance CAlignment (CUArray a) = CAlignment a + +-- | Struct +-- +-- >>> type S = CStruct ['Field "i8" (CPrimitive 1 1), 'Field "i32" (CPrimitive 4 4)] +-- >>> :kind! CSizeOf S +-- CSizeOf S :: Nat +-- = 8 +-- +-- >>> :kind! CAlignment S +-- CAlignment S :: Nat +-- = 4 +data CStruct (fs :: [Field]) = CStruct +type instance CSizeOf (CStruct fs) = CStructSize fs (CMaxAlignment fs 1) 0 +type instance CAlignment (CStruct fs) = CMaxAlignment fs 1 + +type family CStructSize (xs :: [Field]) al sz where + CStructSize '[] al sz = + sz + PaddingEx (sz `Mod` al) al + CStructSize ('Field s t : fs) al sz = CStructSize fs al + (sz + CSizeOf t + PaddingEx (sz `Mod` CAlignment t) (CAlignment t)) + +-- | Union +-- +-- >>> type S = CUnion ['Field "i8" (CPrimitive 1 1), 'Field "i32" (CPrimitive 4 4)] +-- >>> :kind! CSizeOf S +-- CSizeOf S :: Nat +-- = 4 +-- +-- >>> :kind! CAlignment S +-- CAlignment S :: Nat +-- = 4 +data CUnion (fs :: [Field]) = CUnion +type instance CSizeOf (CUnion fs) = CUnionSize fs (CMaxAlignment fs 1) 0 +type instance CAlignment (CUnion fs) = CMaxAlignment fs 1 + +type family CUnionSize (xs :: [Field]) al sz where + CUnionSize '[] al sz = + sz + PaddingEx (sz `Mod` al) al + CUnionSize ('Field s t : fs) al sz = CUnionSize fs al (Max (CSizeOf t) sz) + +-- | Structure field +data Field = Field Symbol Type + +type family PaddingEx (m :: Nat) (a :: Nat) where + PaddingEx 0 a = 0 + PaddingEx m a = a - m + +type family CMaxAlignment (xs :: [Field]) al where + CMaxAlignment '[] al = al + CMaxAlignment ('Field s t : fs) al = + CMaxAlignment fs (Max al (CAlignment t)) + diff --git a/src/lib/Haskus/Memory/Property.hs b/src/lib/Haskus/Memory/Property.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Memory/Property.hs @@ -0,0 +1,37 @@ +-- | Memory properties +module Haskus.Memory.Property + ( Mutability (..) + , Heap (..) + , Pinning (..) + , Finalization (..) + ) +where + +-- | Is the memory mutable or not? +data Mutability + = Mutable -- ^ Memory cells are mutable + | Immutable -- ^ Memory cells are immutable + deriving (Show,Eq) + +-- | Allocation heap +data Heap + = Internal -- ^ GHC heap + | External -- ^ External heap + +-- | Is the buffer pinned into memory? +data Pinning + = Pinned -- ^ The buffer has a fixed associated memory address + | NotPinned -- ^ The buffer contents can be freely moved to another address + deriving (Show,Eq) + +-- | Is the memory automatically garbage collected? +data Finalization + = Collected -- ^ Automatically collected by the garbage-collector + | Finalized -- ^ Finalizers are run just before the garbage collector + -- collects the referencing entity (buffer, pointer...). The + -- memory used by the entity may be collected too (Internal + -- heap), explicitly freed by a finalizer or not freed at all. + | NotFinalized -- ^ The memory is not automatically freed and we + -- can't attach finalizers to the buffer. + deriving (Show,Eq) + diff --git a/src/lib/Haskus/Memory/Ptr.hs b/src/lib/Haskus/Memory/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Memory/Ptr.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} + +-- | 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.Memory.Ptr + ( Pointer (..) + , AnyPointer (..) + , RawPtr + , FinPtr + , PtrI + , PtrM + , PtrIF + , PtrMF + , isNullPtr + , nullPtrI + , nullPtrM + , indexPtr + , distancePtr + , withPtr + , withFinalizedPtr + , allocFinalizedPtr + , allocPtr + , freePtr + + -- * Function pointer + , P.FunPtr + , P.nullFunPtr + , P.castPtrToFunPtr + , P.castFunPtrToPtr + -- * Pointer as a Word + , P.WordPtr + , P.wordPtrToPtr + , P.ptrToWordPtr + ) +where + +import qualified Foreign.Ptr as P +import qualified Foreign.Marshal.Alloc as P +import qualified Foreign.ForeignPtr as FP +import qualified Foreign.ForeignPtr.Unsafe as FP + +import Haskus.Memory.Property +import Haskus.Utils.Monad +import Haskus.Utils.Flow + +-- | A pointer in memory +data Pointer (mut :: Mutability) (fin :: Finalization) where + PtrI :: {-# UNPACK #-} !RawPtr -> PtrI + PtrM :: {-# UNPACK #-} !RawPtr -> PtrM + PtrIF :: {-# UNPACK #-} !FinPtr -> {-# UNPACK #-} !Int -> PtrIF + PtrMF :: {-# UNPACK #-} !FinPtr -> {-# UNPACK #-} !Int -> PtrMF + +type RawPtr = P.Ptr () +type FinPtr = FP.ForeignPtr () + +type PtrI = Pointer 'Immutable 'NotFinalized +type PtrM = Pointer 'Mutable 'NotFinalized +type PtrIF = Pointer 'Immutable 'Finalized +type PtrMF = Pointer 'Mutable 'Finalized + +-- | Wrapper containing any kind of buffer +newtype AnyPointer = AnyPointer (forall mut fin . Pointer mut fin) + +instance Show (Pointer mut fin) where + show = \case + PtrI p -> show p + PtrM p -> show p + PtrIF p o -> show (fToR p `P.plusPtr` o) + PtrMF p o -> show (fToR p `P.plusPtr` o) + +-- | Unsafe Finalized to Raw pointer +fToR :: FinPtr -> RawPtr +fToR = FP.unsafeForeignPtrToPtr + +-- | Test if a pointer is Null +{-# SPECIALIZE INLINE isNullPtr :: PtrI -> Bool #-} +{-# SPECIALIZE INLINE isNullPtr :: PtrM -> Bool #-} +{-# SPECIALIZE INLINE isNullPtr :: PtrIF -> Bool #-} +{-# SPECIALIZE INLINE isNullPtr :: PtrMF -> Bool #-} +isNullPtr :: Pointer mut fin -> Bool +isNullPtr = \case + PtrI p -> p == P.nullPtr + PtrM p -> p == P.nullPtr + PtrIF p 0 -> fToR p == P.nullPtr + PtrIF _ _ -> False + PtrMF p 0 -> fToR p == P.nullPtr + PtrMF _ _ -> False + +-- | Null pointer +nullPtrI :: PtrI +nullPtrI = PtrI P.nullPtr + +-- | Null pointer +nullPtrM :: PtrM +nullPtrM = PtrM P.nullPtr + +-- | Index a pointer +{-# SPECIALIZE INLINE indexPtr :: PtrI -> Int -> PtrI #-} +{-# SPECIALIZE INLINE indexPtr :: PtrM -> Int -> PtrM #-} +{-# SPECIALIZE INLINE indexPtr :: PtrIF -> Int -> PtrIF #-} +{-# SPECIALIZE INLINE indexPtr :: PtrMF -> Int -> PtrMF #-} +indexPtr :: Pointer mut fin -> Int -> Pointer mut fin +indexPtr ptr i = case ptr of + PtrI p -> PtrI (p `P.plusPtr` i) + PtrM p -> PtrM (p `P.plusPtr` i) + PtrIF p o -> PtrIF p (o+i) + PtrMF p o -> PtrMF p (o+i) + +-- | Distance between two pointers +{-# SPECIALIZE INLINE distancePtr :: PtrI -> PtrI -> Int #-} +{-# SPECIALIZE INLINE distancePtr :: PtrM -> PtrM -> Int #-} +{-# SPECIALIZE INLINE distancePtr :: PtrI -> PtrM -> Int #-} +{-# SPECIALIZE INLINE distancePtr :: PtrM -> PtrI -> Int #-} +distancePtr :: Pointer mut0 fin0 -> Pointer mut1 fin1 -> Int +distancePtr p1 p2 = P.minusPtr p1' p2' + o2 - o1 + where + dec :: Pointer mut fin -> (RawPtr,Int) + dec = \case + PtrI p -> (p,0) + PtrM p -> (p,0) + PtrIF p o -> (fToR p,o) + PtrMF p o -> (fToR p,o) + (p1',o1) = dec p1 + (p2',o2) = dec p2 + +-- | Use a finalized pointer as a non finalized pointer +{-# INLINABLE withFinalizedPtr #-} +withFinalizedPtr :: (MonadInIO m) => Pointer mut 'Finalized -> (Pointer mut 'NotFinalized -> m b) -> m b +withFinalizedPtr ptr f = case ptr of + PtrIF p o -> liftWith (FP.withForeignPtr p) <| \r -> + f (PtrI (r `P.plusPtr` o)) + PtrMF p o -> liftWith (FP.withForeignPtr p) <| \r -> + f (PtrM (r `P.plusPtr` o)) + +-- | Use a pointer (finalized or not) as a non finalized pointer +{-# INLINABLE withPtr #-} +withPtr :: (MonadInIO m) => Pointer mut fin -> (Pointer mut 'NotFinalized -> m b) -> m b +withPtr ptr f = case ptr of + PtrI _ -> f ptr + PtrM _ -> f ptr + PtrIF p o -> liftWith (FP.withForeignPtr p) <| \r -> + f (PtrI (r `P.plusPtr` o)) + PtrMF p o -> liftWith (FP.withForeignPtr p) <| \r -> + f (PtrM (r `P.plusPtr` o)) + +-- | Alloc mutable finalized memory +allocFinalizedPtr :: MonadIO m => Word -> m PtrMF +allocFinalizedPtr = liftIO . fmap (`PtrMF` 0) . FP.mallocForeignPtrBytes . fromIntegral + +-- | Alloc mutable non-finalized memory +allocPtr :: MonadIO m => Word -> m PtrM +allocPtr = liftIO . fmap PtrM . P.mallocBytes . fromIntegral + + +-- | Free a non-finalized memory +{-# SPECIALIZE INLINE freePtr :: MonadIO m => PtrI -> m () #-} +{-# SPECIALIZE INLINE freePtr :: MonadIO m => PtrM -> m () #-} +freePtr :: MonadIO m => Pointer mut 'NotFinalized -> m () +freePtr = \case + PtrI p -> liftIO (P.free p) + PtrM p -> liftIO (P.free p) diff --git a/src/lib/Haskus/Memory/Typed.hs b/src/lib/Haskus/Memory/Typed.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Memory/Typed.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} + +-- | Typed memory +-- +-- Pointer-like datatypes with an additional phantom type indicating their +-- memory layout +module Haskus.Memory.Typed + ( BufferT (..) + , PointerT (..) + , PtrT (..) + ) +where + +import Haskus.Memory.Buffer +import Haskus.Memory.Ptr +import GHC.Exts + +-- | Typed pointer +newtype PointerT (t :: k) mut fin = PointerT (Pointer mut fin) + +-- | Typed buffer +newtype BufferT (t :: k) mut pin fin heap = BufferT (Buffer mut pin fin heap) + +-- | Typed raw pointer +newtype PtrT (t :: k) = PtrT (Ptr ()) diff --git a/src/lib/Haskus/Memory/Utils.hs b/src/lib/Haskus/Memory/Utils.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Memory/Utils.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} + +-- | Memory utilities +module Haskus.Memory.Utils + ( memCopy + , memSet + , allocaArrays + , peekArrays + , pokeArrays + , withArrays + , withMaybeOrNull + , memcpy# + ) +where + +import Haskus.Number.Word +import Haskus.Binary.Storable +import Haskus.Utils.Flow + +import Foreign.Ptr +import GHC.Exts + +-- | Copy memory +memCopy :: MonadIO m => Ptr a -> Ptr b -> Word64 -> m () +{-# INLINABLE memCopy #-} +memCopy (Ptr dest) (Ptr src) size = liftIO (memcpy# dest src s) + where + !(I# s) = fromIntegral size + +-- | memcpy +foreign import ccall unsafe "memcpy" memcpy# :: Addr# -> Addr# -> Int# -> IO () + + + +-- | Set memory +memSet :: MonadIO m => Ptr a -> Word64 -> Word8 -> m () +{-# INLINABLE 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/lib/Haskus/Memory/View.hs b/src/lib/Haskus/Memory/View.hs --- a/src/lib/Haskus/Memory/View.hs +++ b/src/lib/Haskus/Memory/View.hs @@ -69,7 +69,7 @@ import Control.Concurrent import Haskus.Utils.Monad -import Haskus.Format.Binary.Word +import Haskus.Number.Word import Haskus.Memory.Buffer -- | The source of a view diff --git a/src/lib/Haskus/Number.hs b/src/lib/Haskus/Number.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number.hs @@ -0,0 +1,8 @@ +-- | Numbers +module Haskus.Number + ( module X + ) +where + +import Haskus.Number.BitNat as X +import Haskus.Number.NaturalRange as X diff --git a/src/lib/Haskus/Number/BitNat.hs b/src/lib/Haskus/Number/BitNat.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/BitNat.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Natural numbers +module Haskus.Number.BitNat + ( NatVal (..) + , Widen + , widen + , Narrow + , narrow + , IsBitNat + , BitNat + , pattern BitNat + , unsafeMakeBitNat + , safeMakeBitNat + , bitNat + , bitNatZero + , bitNatOne + , extractW + , compareW + , (.+.) + , (.-.) + , (.*.) + , (./.) + , BitNatShiftLeft + , BitNatShiftRight + , (.<<.) + , (.>>.) + , bitNatTestBit + , bitNatXor + , bitNatAnd + , bitNatOr + -- * Internal + , BitNatWord + , MakeBitNat + , bitNatToNatural + ) +where + +import Haskus.Number.Word +import Haskus.Binary.Bits +import Haskus.Utils.Types +import Numeric.Natural + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XFlexibleContexts +-- >>> :set -XTypeFamilies +-- >>> :set -XScopedTypeVariables + +-- | A natural on `b` bits +newtype BitNat (b :: Nat) + = BitNat' (BitNatWord b) + +pattern BitNat :: forall (n :: Nat). (Integral (BitNatWord n), MakeBitNat n) => Natural -> BitNat n +{-# COMPLETE BitNat #-} +pattern BitNat x <- (bitNatToNatural -> x) + where + BitNat x = makeW @n x + + +-- | Create a natural number with the minimal number of bits required to store +-- it +-- +-- >>> bitNat @5 +-- BitNat @3 5 +-- +-- >>> bitNat @0 +-- BitNat @1 0 +-- +-- >>> bitNat @158748521123465897456465 +-- BitNat @78 158748521123465897456465 +-- +bitNat :: forall (v :: Nat) (n :: Nat). + ( n ~ NatBitCount v + , Integral (BitNatWord n) + , MakeBitNat n + , KnownNat v + ) => BitNat n +bitNat = BitNat @n (natValue @v) + +mapW :: (BitNatWord a -> BitNatWord a) -> BitNat a -> BitNat a +mapW f (BitNat' x) = BitNat' (f x) + +zipWithW :: (BitNatWord a -> BitNatWord a -> BitNatWord b) -> BitNat a -> BitNat a -> BitNat b +zipWithW f (BitNat' x) (BitNat' y) = BitNat' (f x y) + +-- | Show instance for BitNat +instance (KnownNat b, Integral (BitNatWord b)) => Show (BitNat b) where + showsPrec d x = showParen (d /= 0) + $ showString "BitNat @" + . showsPrec 0 (natValue' @b) + . showString " " + . showsPrec 0 (bitNatToNatural x) + +-- | BitNat backing type +type family BitNatWord b where + BitNatWord 0 = TypeError ('Text "Naturals encoded on 0 bits are not allowed") + BitNatWord b = BitNatWord' (b <=? 8) (b <=? 16) (b <=? 32) (b <=? 64) + +type family BitNatWord' b8 b16 b32 b64 where + BitNatWord' 'True _ _ _ = Word8 + BitNatWord' _ 'True _ _ = Word16 + BitNatWord' _ _ 'True _ = Word32 + BitNatWord' _ _ _ 'True = Word64 + BitNatWord' _ _ _ _ = Natural + +------------------------------------------------- +-- Creation +------------------------------------------------- + +type IsBitNat b = + ( Num (BitNatWord b) + , Integral (BitNatWord b) + , Bitwise (BitNatWord b) + , IndexableBits (BitNatWord b) + ) + +-- | Zero natural +bitNatZero :: Num (BitNatWord a) => BitNat a +bitNatZero = BitNat' 0 + +-- | One natural +bitNatOne :: Num (BitNatWord a) => BitNat a +bitNatOne = BitNat' 1 + +-- | Convert a BitNat into a Natural +bitNatToNatural :: Integral (BitNatWord a) => BitNat a -> Natural +bitNatToNatural (BitNat' x) = fromIntegral x + +-- | Create a natural +unsafeMakeBitNat :: forall a. (Maskable a (BitNatWord a)) => BitNatWord a -> BitNat a +unsafeMakeBitNat x = BitNat' (mask @a x) + +type MakeBitNat a = + ( Maskable a (BitNatWord a) + , ShiftableBits (BitNatWord a) + , Show (BitNatWord a) + , Eq (BitNatWord a) + , Num (BitNatWord a) + ) + +-- | Create a natural (check overflow) +safeMakeBitNat :: forall a. MakeBitNat a => Natural -> Maybe (BitNat a) +safeMakeBitNat x = + let + x' = fromIntegral x :: BitNatWord a + in case x' `uncheckedShiftR` natValue' @a of + 0 -> Just (unsafeMakeBitNat x') + _ -> Nothing + +-- | Create a natural (check overflow and throw on error) +makeW :: forall a. MakeBitNat a => Natural -> BitNat a +makeW x = case safeMakeBitNat x of + Just y -> y + Nothing -> error $ + "`" ++ show x + ++ "` is out of the range of values that can be encoded by a " + ++ show (natValue' @a) + ++ "-bit natural number: [0.." + ++ show (2 ^ (natValue' @a) -1 :: Natural) + ++ "]" + +-- | Extract the primitive value +extractW :: BitNat a -> BitNatWord a +extractW (BitNat' a) = a + +------------------------------------------------- +-- Widening / Narrowing +------------------------------------------------- + +-- | Widen a natural +-- +-- >>> widen @7 (BitNat @5 25) +-- BitNat @7 25 +-- +widen :: forall b a. Widen a b => BitNat a -> BitNat b +widen (BitNat' a) = BitNat' (fromIntegral a) + +type Widen a b = + ( Assert (a <=? b) (() :: Constraint) + ('Text "Can't widen a natural of " + ':<>: 'ShowType a + ':<>: 'Text " bits into a natural of " + ':<>: 'ShowType b + ':<>: 'Text " bits" + ) + , Integral (BitNatWord a) + , Integral (BitNatWord b) + ) + +-- | Narrow a natural +-- +-- >>> narrow @3 (BitNat @5 25) +-- BitNat @3 1 +-- +narrow :: forall b a. Narrow a b => BitNat a -> BitNat b +narrow (BitNat' a) = unsafeMakeBitNat (fromIntegral a) + +type Narrow a b = + ( Assert (b <=? a) (() :: Constraint) + ('Text "Can't narrow a natural of " + ':<>: 'ShowType a + ':<>: 'Text " bits into a natural of " + ':<>: 'ShowType b + ':<>: 'Text " bits" + ) + , Integral (BitNatWord a) + , Integral (BitNatWord b) + , Maskable b (BitNatWord b) + ) + +------------------------------------------------- +-- Comparison +------------------------------------------------- + +-- | Compare two naturals +compareW :: forall a b. + ( Ord (BitNatWord (Max a b)) + , Widen a (Max a b) + , Widen b (Max a b) + ) => BitNat a -> BitNat b -> Ordering +compareW x y = compare x' y' + where + BitNat' x' = widen @(Max a b) x + BitNat' y' = widen @(Max a b) y + +instance Eq (BitNatWord a) => Eq (BitNat a) where + (BitNat' x) == (BitNat' y) = x == y + +instance Ord (BitNatWord a) => Ord (BitNat a) where + compare (BitNat' x) (BitNat' y) = compare x y + +------------------------------------------------- +-- Addition / Subtraction +------------------------------------------------- + +-- | Add two Naturals +-- +-- >>> BitNat @5 25 .+. BitNat @2 3 +-- BitNat @6 28 +-- +(.+.) :: forall a b m. + ( m ~ (Max a b + 1) + , Widen a m + , Widen b m + , Num (BitNatWord m) + ) => BitNat a -> BitNat b -> BitNat m +(.+.) x y = zipWithW (+) (widen @m x) (widen @m y) + +-- | Sub two Naturals +-- +-- >>> BitNat @5 25 .-. BitNat @2 3 +-- Just (BitNat @5 22) +-- +-- >>> BitNat @5 2 .-. BitNat @2 3 +-- Nothing +-- +(.-.) :: forall a b m. + ( m ~ Max a b + , Widen a m + , Widen b m + , Num (BitNatWord m) + ) => BitNat a -> BitNat b -> Maybe (BitNat m) +(.-.) (widen @m -> x) (widen @m -> y) = case compare x y of + LT -> Nothing + EQ -> Just bitNatZero + GT -> Just (zipWithW (-) x y) + +-- | Multiply two Naturals +-- +-- >>> BitNat @5 25 .*. BitNat @2 3 +-- BitNat @7 75 +-- +(.*.) :: forall a b m. + ( m ~ (a + b) + , Widen a m + , Widen b m + , Num (BitNatWord m) + ) => BitNat a -> BitNat b -> BitNat m +(.*.) x y = zipWithW (*) (widen @m x) (widen @m y) + +-- | Divide two Naturals, return (factor,rest) +-- +-- >>> BitNat @5 25 ./. BitNat @2 3 +-- Just (BitNat @5 8,BitNat @2 1) +-- +-- >>> BitNat @5 25 ./. BitNat @2 0 +-- Nothing +-- +-- > BitNat @2 3 ./. BitNat @5 25 +-- Just (BitNat @2 0,BitNat @5 3) +-- +(./.) :: forall a b m. + ( m ~ Max a b + , Widen a m + , Widen b m + , Num (BitNatWord (Min a b)) + ) => BitNat a -> BitNat b -> Maybe (BitNat a,BitNat (Min a b)) +(./.) x y + | y == bitNatZero = Nothing + | otherwise = Just (BitNat' (fromIntegral q), BitNat' (fromIntegral r)) + where + (q,r) = quotRem x' y' + BitNat' x' = widen @m x + BitNat' y' = widen @m y + +------------------------------------------------- +-- Shift +------------------------------------------------- + +type BitNatShiftRight a s = + ( ShiftableBits (BitNatWord a) + , KnownNat s + , Narrow a (a-s) + ) + +type BitNatShiftLeft a s = + ( ShiftableBits (BitNatWord (a+s)) + , KnownNat s + , Widen a (a+s) + ) + +-- | Shift-left naturals +-- +-- >>> let x = BitNat @5 25 +-- >>> x .<<. NatVal @2 +-- BitNat @7 100 +-- +-- >>> show (x .<<. NatVal @2) == show (x .*. BitNat @3 4) +-- False +-- +-- >>> x .<<. NatVal @2 == narrow (x .*. BitNat @3 4) +-- True +-- +(.<<.) :: forall (s :: Nat) a. + ( BitNatShiftLeft a s + ) => BitNat a -> NatVal s -> BitNat (a + s) +(.<<.) x _ = mapW (`uncheckedShiftL` natValue @s) (widen @(a+s) x) + +-- | Shift-right naturals +-- +-- >>> BitNat @5 25 .>>. NatVal @2 +-- BitNat @3 6 +-- +(.>>.) :: forall (s :: Nat) a. + ( BitNatShiftRight a s + ) => BitNat a -> NatVal s -> BitNat (a - s) +(.>>.) x _ = narrow @(a-s) (mapW (`uncheckedShiftR` natValue @s) x) + + +-- | Test a bit +bitNatTestBit :: + ( IndexableBits (BitNatWord a) + ) => BitNat a -> Word -> Bool +bitNatTestBit (BitNat' b) i = testBit b i + +-- | Xor +bitNatXor :: forall a. + ( IsBitNat a + ) => BitNat a -> BitNat a -> BitNat a +bitNatXor (BitNat' a) (BitNat' b) = BitNat' (a `xor` b) + +-- | And +bitNatAnd :: forall a. + ( IsBitNat a + ) => BitNat a -> BitNat a -> BitNat a +bitNatAnd (BitNat' a) (BitNat' b) = BitNat' (a .&. b) + +-- | Or +bitNatOr :: forall a. + ( IsBitNat a + ) => BitNat a -> BitNat a -> BitNat a +bitNatOr (BitNat' a) (BitNat' b) = BitNat' (a .|. b) diff --git a/src/lib/Haskus/Number/FixedPoint.hs b/src/lib/Haskus/Number/FixedPoint.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/FixedPoint.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Fixed-point numbers +module Haskus.Number.FixedPoint + ( FixedPoint (..) + , getFixedPointBase + , fromFixedPointBase + , toFixedPoint + , fromFixedPoint + ) +where + +import Haskus.Binary.BitField +import Haskus.Binary.Bits +import Haskus.Binary.Storable +import Haskus.Utils.Types +import Data.Coerce +import Data.Ratio + +-- | Unsigned fixed-point number +-- * `w` is the backing type +-- * `i` is the number of bits for the integer part (before the radix point) +-- * `f` is the number of bits for the fractional part (after the radix point) +-- +-- >>> :set -XDataKinds +-- >>> import Data.Word +-- >>> fromIntegral 0 :: FixedPoint Word32 16 16 +-- 0 % 1 +-- +-- >>> fromIntegral 10 :: FixedPoint Word32 16 16 +-- 10 % 1 +newtype FixedPoint w (i :: Nat) (f :: Nat) = FixedPoint (BitFields w + '[ BitField i "integer" w + , BitField f "fractional" w + ]) + deriving (Storable) + +-- | Get base value +getFixedPointBase :: FixedPoint w i f -> w +getFixedPointBase (FixedPoint (BitFields w)) = w + +-- | Set base value +fromFixedPointBase :: forall w i f. w -> FixedPoint w i f +fromFixedPointBase w = FixedPoint @w @i @f (BitFields w) + +instance + ( BitSize w ~ (i + f) + , Num w + , FiniteBits w + , Bits w + , KnownNat i + , KnownNat f + , Field w + , Integral w + ) => Num (FixedPoint w i f) where + (+) = coerce ((+) :: w -> w -> w) + (-) = coerce ((-) :: w -> w -> w) + negate = error "Can't negate unsigned fixed-point nubmer" + abs = id + signum = error "Can't call signum on unsigned fixed-point number" + (*) = error "Fixed-point number multiplication not implemented yet" + fromInteger x = toFixedPoint (toRational x) + + +instance + ( BitSize w ~ (i + f) + , Integral w + , FiniteBits w + , Bits w + , Field w + , KnownNat i + , KnownNat f + ) => Real (FixedPoint w i f) where + toRational fp = fromIntegral (getFixedPointBase fp) % (2^(natValue' @f)) + +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) + +instance forall w n d. + ( Integral w + , Bits w + , Field w + , BitSize w ~ (n + d) + , KnownNat n + , KnownNat d + ) => Ord (FixedPoint w n d) where + + compare x y = compare (getFixedPointBase x) (getFixedPointBase y) + x > y = getFixedPointBase x > getFixedPointBase y + x >= y = getFixedPointBase x >= getFixedPointBase y + x < y = getFixedPointBase x < getFixedPointBase y + x <= y = getFixedPointBase x <= getFixedPointBase y + +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) where + + show w = show (toRational w) + +-- | 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/Number/Float.hs b/src/lib/Haskus/Number/Float.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/Float.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | IEEE754 floating-point numbers +module Haskus.Number.Float + ( Float32 + , Float64 + , float32ToWord32 + , float64ToWord64 + , word32ToFloat32 + , word64ToFloat64 + ) +where + +import Haskus.Number.Word +import GHC.Float +import GHC.ST +import GHC.Prim + +type Float32 = Float +type Float64 = Double + + +-- | Convert a Word32 into a Float32 +word32ToFloat32 :: Word32 -> Float32 +{-# INLINE word32ToFloat32 #-} +word32ToFloat32 (W32# x) = runST $ ST $ \s1 -> + case newByteArray# 4# s1 of { (# s2, mbarr #) -> + case writeWord32Array# mbarr 0# x s2 of { s3 -> + case readFloatArray# mbarr 0# s3 of { (# s4, f #) -> + (# s4, F# f #) }}} + +-- | Convert a Float32 into a Word32 +float32ToWord32 :: Float32 -> Word32 +{-# INLINE float32ToWord32 #-} +float32ToWord32 (F# x) = runST $ ST $ \s1 -> + case newByteArray# 4# s1 of { (# s2, mbarr #) -> + case writeFloatArray# mbarr 0# x s2 of { s3 -> + case readWord32Array# mbarr 0# s3 of { (# s4, w #) -> + (# s4, W32# w #) }}} + +-- | Convert a Word64 into a Float64 +word64ToFloat64 :: Word64 -> Float64 +{-# INLINE word64ToFloat64 #-} +word64ToFloat64 (W64# x) = runST $ ST $ \s1 -> + case newByteArray# 8# s1 of { (# s2, mbarr #) -> + case writeWord64Array# mbarr 0# x s2 of { s3 -> + case readDoubleArray# mbarr 0# s3 of { (# s4, f #) -> + (# s4, D# f #) }}} + +-- | Convert a Word64 into a Float64 +float64ToWord64 :: Float64 -> Word64 +{-# INLINE float64ToWord64 #-} +float64ToWord64 (D# x) = runST $ ST $ \s1 -> + case newByteArray# 8# s1 of { (# s2, mbarr #) -> + case writeDoubleArray# mbarr 0# x s2 of { s3 -> + case readWord64Array# mbarr 0# s3 of { (# s4, w #) -> + (# s4, W64# w #) }}} diff --git a/src/lib/Haskus/Number/Int.hs b/src/lib/Haskus/Number/Int.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/Int.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MagicHash #-} + +-- | Signed primitive integers +module Haskus.Number.Int + ( IntAtLeast + , IntN + -- * Unlifted + , module GHC.Int + , Int# + , (+#) + , (-#) + , (==#) + , (>#) + , (<#) + , (>=#) + , (<=#) + , isTrue# + ) +where + +import Data.Int +import GHC.Int +import GHC.Exts + +import Haskus.Utils.Types + +-- | Return a Int with at least 'n' bits +type family IntAtLeast (n :: Nat) where + IntAtLeast n = + If (n <=? 8) Int8 + (If (n <=? 16) Int16 + (If (n <=? 32) Int32 + (Assert (n <=? 64) Int64 + ('Text "Cannot find Int with size " ':<>: 'ShowType n) + ))) + +-- | Return a Int with exactly 'n' bits +type family IntN (n :: Nat) where + IntN 8 = Int8 + IntN 16 = Int16 + IntN 32 = Int32 + IntN 64 = Int64 + IntN n = TypeError ('Text "Cannot find Int with size " ':<>: 'ShowType n) diff --git a/src/lib/Haskus/Number/NaturalRange.hs b/src/lib/Haskus/Number/NaturalRange.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/NaturalRange.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | A natural number in a specified range (fixed and checked at compile-time) +module Haskus.Number.NaturalRange + ( NatRange + , pattern NatRange + , natRange + , safeMakeNatRange + , makeNatRange + , unsafeMakeNatRange + , widenNatRange + , (.++.) + ) +where + +import Haskus.Number.BitNat +import Haskus.Utils.Types +import Numeric.Natural + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XFlexibleContexts +-- >>> :set -XTypeFamilies +-- >>> :set -XScopedTypeVariables + + +-- | A natural number in the specified range +newtype NatRange (f :: Nat) (t :: Nat) = NatRange' (BitNat (NatBitCount (t-f+1))) + +-- | Show instance for natural range +instance + ( KnownNat (t-f) + , KnownNat t + , KnownNat f + , Num (BitNatWord (NatBitCount (t-f+1))) + , Integral (BitNatWord (NatBitCount (t-f+1))) + ) => Show (NatRange f t) where + showsPrec d x = showParen (d /= 0) + $ showString "NatRange @" + . showsPrec 0 (natValue' @f) + . showString " @" + . showsPrec 0 (natValue' @t) + . showString " " + . showsPrec 0 (toNaturalNatRange x) + +type CheckInRange f t n = + ( Assert (n <=? t) (() :: Constraint) + ('ShowType n + ':<>: 'Text " isn't in the range [" + ':<>: 'ShowType f + ':<>: 'Text "," + ':<>: 'ShowType t + ':<>: 'Text "]" + ) + , Assert (f <=? n) (() :: Constraint) + ('ShowType n + ':<>: 'Text " isn't in the range [" + ':<>: 'ShowType f + ':<>: 'Text "," + ':<>: 'ShowType t + ':<>: 'Text "]" + ) + ) + +type NatRangeBitCount f t = NatBitCount (t-f+1) + +type MakeNatRange f t = + ( Integral (BitNatWord (NatRangeBitCount f t)) + , MakeBitNat (NatRangeBitCount f t) + , KnownNat f + , KnownNat t + , Assert (f <=? t) (() :: Constraint) + ('Text "[" + ':<>: 'ShowType f + ':<>: 'Text "," + ':<>: 'ShowType t + ':<>: 'Text "] isn't a valid range" + ) + ) + +-- | Create a value in a Natural range +unsafeMakeNatRange :: forall f t. + ( MakeNatRange f t + ) => Natural -> NatRange f t +unsafeMakeNatRange v = NatRange' (BitNat @(NatRangeBitCount f t) (v - natValue @f)) + +-- | Create a value in a Natural range (check validity) +safeMakeNatRange :: forall f t. + ( MakeNatRange f t + ) => Natural -> Maybe (NatRange f t) +safeMakeNatRange v + | v < natValue @f || v > natValue @t = Nothing + | otherwise = Just (unsafeMakeNatRange @f @t v) + +-- | Create a value in a Natural range (check validity and throw on error) +makeNatRange :: forall f t. + ( MakeNatRange f t + ) => Natural -> NatRange f t +makeNatRange v = case safeMakeNatRange @f @t v of + Nothing ->error $ show v ++ " isn't in the range [" + ++ show (natValue @f :: Natural) + ++ "," + ++ show (natValue @t :: Natural) + ++ "]" + Just x -> x + + +-- | Create a value in a Natural range +natRange :: forall (n :: Nat) f t. + ( MakeNatRange f t + , CheckInRange f t n + , KnownNat n + ) => NatRange f t +natRange = unsafeMakeNatRange (natValue @n) + +-- | Convert a NatRange into a Natural +toNaturalNatRange :: forall f t. + ( KnownNat f + , Integral (BitNatWord (NatBitCount (t-f+1))) + ) => NatRange f t -> Natural +toNaturalNatRange (NatRange' x) = natValue @f + bitNatToNatural x + +-- | Natural range pattern +-- +-- >>> NatRange @10 @12 11 +-- NatRange @10 @12 11 +-- +pattern NatRange :: forall (f :: Nat) (t :: Nat). + ( MakeNatRange f t + ) => Natural -> NatRange f t +{-# COMPLETE NatRange #-} +pattern NatRange x <- (toNaturalNatRange -> x) + where + NatRange x = makeNatRange @f @t x + + +------------------------------------------------- +-- Widening +------------------------------------------------- + +-- | Widen a natural +-- +-- >>> let a = NatRange @18 @100 25 +-- >>> widenNatRange @16 @200 a +-- NatRange @16 @200 25 +-- +widenNatRange :: forall f2 t2 f1 t1. + ( WidenNatRange f1 t1 f2 t2 + ) => NatRange f1 t1 -> NatRange f2 t2 +widenNatRange (NatRange a) = NatRange a + +type WidenNatRange f1 t1 f2 t2 = + ( Assert ((f2 <=? f1) `AndB` (t1 <=? t2)) (() :: Constraint) + ('Text "Can't widen a natural range [" + ':<>: 'ShowType f1 + ':<>: 'Text "," + ':<>: 'ShowType t1 + ':<>: 'Text "] into range [" + ':<>: 'ShowType f2 + ':<>: 'Text "," + ':<>: 'ShowType t2 + ':<>: 'Text "]" + ) + , MakeNatRange f1 t1 + , MakeNatRange f2 t2 + ) + +-- | Add two natural ranges +-- +-- >>> NatRange @2 @4 3 .++. NatRange @7 @17 13 +-- NatRange @9 @21 16 +-- +(.++.) :: + ( MakeNatRange f1 t1 + , MakeNatRange f2 t2 + , MakeNatRange (f1+f2) (t1+t2) + ) => NatRange f1 t1 -> NatRange f2 t2 -> NatRange (f1+f2) (t1+t2) +(.++.) (NatRange x) (NatRange y) = NatRange (x+y) + diff --git a/src/lib/Haskus/Number/Posit.hs b/src/lib/Haskus/Number/Posit.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/Posit.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Posit (type III unum) +module Haskus.Number.Posit + ( Posit (..) + , PositKind (..) + , PositK (..) + , positKind + , isZero + , isInfinity + , isPositive + , isNegative + , positAbs + , PositEncoding (..) + , PositFields (..) + , positEncoding + , positFields + , positToRational + , positFromRational + , positApproxFactor + , positDecimalError + , positDecimalAccuracy + , positBinaryError + , positBinaryAccuracy + , floatBinaryAccuracy + ) +where + +import Haskus.Number.Int +import Haskus.Binary.Bits +import Haskus.Utils.Types +import Haskus.Utils.Tuple +import Haskus.Utils.Flow + +import Data.Ratio +import qualified GHC.Real as Ratio + +newtype Posit (nbits :: Nat) (es :: Nat) = Posit (IntN nbits) + +-- | Show posit +instance + ( Bits (IntN n) + , FiniteBits (IntN n) + , Ord (IntN n) + , Num (IntN n) + , KnownNat n + , KnownNat es + , Integral (IntN n) + ) => Show (Posit n es) + where + show p = case positKind p of + SomePosit Zero -> "0" + SomePosit Infinity -> "Infinity" + SomePosit (Value v) -> show (positToRational v) + +data PositKind + = ZeroK + | InfinityK + | NormalK + deriving (Show,Eq) + +-- | Kinded Posit +-- +-- GADT that can be used to ensure at the type level that we deal with +-- non-infinite/non-zero Posit values +data PositK k nbits es where + Zero :: PositK 'ZeroK nbits es + Infinity :: PositK 'InfinityK nbits es + Value :: Posit nbits es -> PositK 'NormalK nbits es + +data SomePosit n es where + SomePosit :: PositK k n es -> SomePosit n es + +type PositValue n es = PositK 'NormalK n es + +-- | Get the kind of the posit at the type level +positKind :: forall n es. + ( Bits (IntN n) + , KnownNat n + , Eq (IntN n) + ) => Posit n es -> SomePosit n es +positKind p + | isZero p = SomePosit Zero + | isInfinity p = SomePosit Infinity + | otherwise = SomePosit (Value p) + +-- | Check if a posit is zero +isZero :: forall n es. + ( Bits (IntN n) + , Eq (IntN n) + , KnownNat n + ) => Posit n es -> Bool +{-# INLINABLE isZero #-} +isZero (Posit i) = i == zeroBits + +-- | Check if a posit is infinity +isInfinity :: forall n es. + ( Bits (IntN n) + , Eq (IntN n) + , KnownNat n + ) => Posit n es -> Bool +{-# INLINABLE isInfinity #-} +isInfinity (Posit i) = i == bit (natValue @n - 1) + +-- | Check if a posit is positive +isPositive :: forall n es. + ( Bits (IntN n) + , Ord (IntN n) + , KnownNat n + ) => PositValue n es -> Bool +{-# INLINABLE isPositive #-} +isPositive (Value (Posit i)) = i > zeroBits + +-- | Check if a posit is negative +isNegative :: forall n es. + ( Bits (IntN n) + , Ord (IntN n) + , KnownNat n + ) => PositValue n es -> Bool +{-# INLINABLE isNegative #-} +isNegative (Value (Posit i)) = i < zeroBits + +-- | Posit absolute value +positAbs :: forall n es. + ( Num (IntN n) + , KnownNat n + ) => PositValue n es -> PositValue n es +positAbs (Value (Posit i)) = Value (Posit (abs i)) + + +data PositFields = PositFields + { positNegative :: Bool + , positRegimeBitCount :: Word + , positExponentBitCount :: Word + , positFractionBitCount :: Word + , positRegime :: Int + , positExponent :: Word + , positFraction :: Word + } + deriving (Show) + +data PositEncoding + = PositInfinity + | PositZero + | PositEncoding PositFields + deriving (Show) + +positEncoding :: forall n es. + ( Bits (IntN n) + , Ord (IntN n) + , Num (IntN n) + , KnownNat n + , KnownNat es + , Integral (IntN n) + ) => Posit n es -> PositEncoding +positEncoding p = case positKind p of + SomePosit Zero -> PositZero + SomePosit Infinity -> PositInfinity + SomePosit v@(Value _) -> PositEncoding (positFields v) + +-- | Decode posit fields +positFields :: forall n es. + ( Bits (IntN n) + , Ord (IntN n) + , Num (IntN n) + , KnownNat n + , KnownNat es + , Integral (IntN n) + ) => PositValue n es -> PositFields +positFields p = PositFields + { positNegative = isNegative p + , positRegimeBitCount = rs + , positExponentBitCount = es + , positFractionBitCount = fs + , positRegime = regime + , positExponent = expo + , positFraction = frac + } + where + -- get absolute value + Value (Posit v) = positAbs p + + (negativeRegime,regimeLen) = + if v `testBit` (natValue @n - 2) + -- regime has shape 111...[0|end of word], subtract 1 for sign bit + then (False, countLeadingZeros (complement v `clearBit` (natValue @n - 1)) - 1) + -- regime has shape 00000...[1|end of word], subtract 1 for sign bit + else (True, countLeadingZeros v - 1) + + regime = if negativeRegime + then negate (fromIntegral regimeLen) + else fromIntegral regimeLen - 1 -- we encode the 0 regime + + -- length of regime bits (with stop bit) + rs = min (natValue @n - 1) (regimeLen + 1) + + -- real exponent size (regime bits can reduce the size of the exponent) + es = min (natValue @n - rs - 1) (natValue @es) + + -- fraction size + fs = natValue @n - es - rs - 1 + + expo = fromIntegral (maskDyn es (v `shiftR` fs)) + frac = fromIntegral (maskDyn fs v) + + +-- | Convert a Posit into a Rational +positToRational :: forall n es. + ( KnownNat n + , KnownNat es + , Eq (IntN n) + , Bits (IntN n) + , Integral (IntN n) + ) => Posit n es -> Rational +positToRational p + | isZero p = 0 Ratio.:% 1 + | isInfinity p = Ratio.infinity + | otherwise = (fromIntegral useed ^^ r) * (2 ^^ e) * (1 + (f % fd)) + where + fields = positFields (Value p) + r = positRegime fields + e = positExponent fields + f = fromIntegral (positFraction fields) + fd = 1 `shiftL` positFractionBitCount fields + useed = 1 `shiftL` (1 `shiftL` natValue @es) :: Integer -- 2^(2^es) + +-- | Convert a rational into the approximate Posit +positFromRational :: forall p n es. + ( Posit n es ~ p + , Num (IntN n) + , Bits (IntN n) + , KnownNat es + , KnownNat n + ) => Rational -> Posit n es +positFromRational x = if + | x == 0 -> Posit 0 + | x == Ratio.infinity -> Posit (bit (natValue @n - 1)) + | otherwise -> computeRegime + |> uncurry3 computeExponent + |> uncurry3 computeFraction + |> uncurry computeRounding + |> computeSign + |> Posit + where + useed = fromIntegral (1 `shiftL` (1 `shiftL` es) :: Integer) -- 2^(2^es) + + nbits = natValue @n + es = natValue @es + + -- compute regime bits of the posit, return (y,p,i) + -- y: remaining value to convert, in [1,useed) if there are enough available bits + -- p: current posit bits + -- i: number of set bits in p + computeRegime + | absx >= 1 = regime111 absx 1 2 + | otherwise = regime000 absx 1 + where + absx = abs x + + -- push regime bits 111..1110 + regime111 y p i + | y >= useed && i < nbits = regime111 (y / useed) ((p `uncheckedShiftL` 1) .|. 1) (i+1) + | otherwise = (y, p `uncheckedShiftL` 1, i+1) + + -- push regime bits 000..0001 (or 000...00010 if the full word + -- (including the sign bit) is set) + regime000 y i + | y < 1 && i <= nbits = regime000 (y*useed) (i+1) + | i >= nbits = (y,2,nbits+1) + | otherwise = (y,1,i+1) + + -- compute exponent bits; return (y,p,i) + -- y: remaining value to convert, in [1,2) if there are enough available bits + -- p: current posit bits + -- i: number of set bits in p + computeExponent + | es == 0 = (,,) + | otherwise = go (1 `shiftL` (es - 1)) + where + go e y p i + | i > nbits || e == 0 = (y,p,i) + | y >= pow2e = go (e `uncheckedShiftR` 1) (y / pow2e) ((p `uncheckedShiftL` 1) .|. 1) (i+1) + | otherwise = go (e `uncheckedShiftR` 1) y (p `uncheckedShiftL` 1) (i+1) + where + pow2e = fromIntegral (1 `shiftL` e :: Integer) + + -- compute fraction bits; return (y,p) + -- y: remaining value to convert + -- p: current posit bits + computeFraction y' = go (y'-1) -- subtract hidden bit. Now y is in [0,1) if there are enough available bits + where + go y p i + | i > nbits = (y,p) + | y <= 0 = (y, p `shiftL` (nbits+1-i)) -- add remaining 0s fraction bits + | y2 > 1 = go (y2-1) (p `shiftL` 1 + 1) (i+1) + | otherwise = go y2 (p `shiftL` 1) (i+1) + where + y2 = 2*y + + -- at this stage, p contains an additional fraction bit. + -- We remove it and we round accordingly. + computeRounding y p = + let p' = p `uncheckedShiftR` 1 + in if | not (p `testBit` 0) -> p' -- closer to lower value + | y == 1 || y == 0 -> p' + (if p' `testBit` 0 then 1 else 0) -- tie goes to nearest even + | otherwise -> p' + 1 -- closer to upper value + + + -- fixup the sign bit (and use 2's complement for the other bits) + computeSign p + | x < 0 = negate p + | otherwise = p + + +-- | Factor of approximation for a given Rational when encoded as a Posit. +-- The closer to 1, the better. +-- +-- Usage: +-- +-- positApproxFactor @(Posit 8 2) (52 % 137) +-- +positApproxFactor :: forall p n es. + ( Posit n es ~ p + , Num (IntN n) + , Bits (IntN n) + , Integral (IntN n) + , KnownNat es + , KnownNat n + ) => Rational -> Double +positApproxFactor r = fromRational ((positToRational (positFromRational r :: p)) / r) + +-- | Compute the decimal error if the given Rational is encoded as a Posit. +-- +-- Usage: +-- +-- positDecimalError @(Posit 8 2) (52 % 137) +-- +positDecimalError :: forall p n es. + ( Posit n es ~ p + , Num (IntN n) + , Bits (IntN n) + , Integral (IntN n) + , KnownNat es + , KnownNat n + ) => Rational -> Double +positDecimalError r = abs (logBase 10 (positApproxFactor @p r)) + +-- | Compute the number of decimals of accuracy if the given Rational is encoded +-- as a Posit. +-- +-- Usage: +-- +-- positDecimalAccuracy @(Posit 8 2) (52 % 137) +-- +positDecimalAccuracy :: forall p n es. + ( Posit n es ~ p + , Num (IntN n) + , Bits (IntN n) + , Integral (IntN n) + , KnownNat es + , KnownNat n + ) => Rational -> Double +positDecimalAccuracy r = -1 * logBase 10 (positDecimalError @p r) + + +-- | Compute the binary error if the given Rational is encoded as a Posit. +-- +-- Usage: +-- +-- positBinaryError @(Posit 8 2) (52 % 137) +-- +positBinaryError :: forall p n es. + ( Posit n es ~ p + , Num (IntN n) + , Bits (IntN n) + , Integral (IntN n) + , KnownNat es + , KnownNat n + ) => Rational -> Double +positBinaryError r = abs (logBase 2 (positApproxFactor @p r)) + +-- | Compute the number of bits of accuracy if the given Rational is encoded +-- as a Posit. +-- +-- Usage: +-- +-- positBinaryAccuracy @(Posit 8 2) (52 % 137) +-- +positBinaryAccuracy :: forall p n es. + ( Posit n es ~ p + , Num (IntN n) + , Bits (IntN n) + , Integral (IntN n) + , KnownNat es + , KnownNat n + ) => Rational -> Double +positBinaryAccuracy r = -1 * logBase 2 (positBinaryError @p r) + + +-- | Compute the number of bits of accuracy if the given Rational is encoded +-- as a Float/Double. +-- +-- Usage: +-- +-- floatBinaryAccuracy @Double (52 % 137) +-- +floatBinaryAccuracy :: forall f. + ( Fractional f + , Real f + ) => Rational -> Double +floatBinaryAccuracy r = -1 * logBase 2 floatError + where + floatApprox = fromRational (toRational (fromRational r :: f) / r) + floatError = abs (logBase 2 floatApprox) diff --git a/src/lib/Haskus/Number/Signed.hs b/src/lib/Haskus/Number/Signed.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/Signed.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | Signed numbers +module Haskus.Number.Signed + ( Signed (..) + , SignedIsZero + , signedIsZero + , SignedFromBitNat + , signedFromBitNat + , SignedNegate + , signedNegate + , SignedPos + , signedPos + , SignedNeg + , signedNeg + ) +where + +import Haskus.Number.BitNat +import Haskus.Binary.Bits +import Haskus.Utils.Types + +-- | A signed number (not in two-complement form) +-- +-- * Bits: ddd..ddds where "s" is the sign bit +-- * Allows symetric positive and negative numbers +-- * Positive and negative zeros are zero +-- +newtype Signed (b :: Nat) + = Signed (BitNat (b+1)) + +-- | Show instance for Signed +instance + ( KnownNat b + , Integral (BitNatWord b) + , IndexableBits (BitNatWord (b+1)) + , Num (BitNatWord (b+1)) + , Eq (BitNatWord (b+1)) + , Integral (BitNatWord (b+1)) + , ShiftableBits (BitNatWord (b+1)) + , Narrow (b+1) ((b+1)-1) + ) => Show (Signed b) + where + showsPrec d x@(Signed b) + | signedIsZero x = showString "0" + | otherwise = + showParen (d /= 0) + $ showString (if signedIsPositive x + then "" + else "-") + . showsPrec 0 (bitNatToNatural (b .>>. NatVal @1)) + +type SignedPos b v = + ( b ~ NatBitCount v + , MakeBitNat b + , KnownNat v + , BitNatShiftLeft b 1 + ) + +-- | Positive signed literal +-- +-- >>> signedPos @5 +-- 5 +-- >>> signedPos @0 +-- 0 +-- +signedPos :: forall (v :: Nat) b. + ( SignedPos b v + ) => Signed b +signedPos = Signed @b (bitNat @v .<<. NatVal @1) + + +type SignedNeg b v = + ( SignedPos b v + , SignedNegate b + ) + +-- | Negative signed literal +-- +-- >>> signedNeg @5 +-- -5 +-- >>> signedNeg @0 +-- 0 +-- +signedNeg :: forall (v :: Nat) b. + ( SignedNeg b v + ) => Signed b +signedNeg = signedNegate (signedPos @v @b) + + +type SignedIsZero b = + ( BitNatShiftRight (b+1) 1 + ) + + +-- | Test for zero +-- +-- >>> signedIsZero (signedNeg @5) +-- False +-- >>> signedIsZero (signedNeg @0) +-- True +-- +signedIsZero :: forall b. + ( SignedIsZero b + ) => Signed b -> Bool +signedIsZero (Signed b) = (b .>>. NatVal @1 == bitNatZero) + +type SignedIsPositive b = + ( IndexableBits (BitNatWord (b+1)) + ) + +-- | Test if positive +-- +-- >>> signedIsPositive (signedPos @5) +-- True +-- >>> signedIsPositive (signedPos @0) +-- True +-- >>> signedIsPositive (signedNeg @5) +-- False +-- +signedIsPositive :: forall b. + ( SignedIsPositive b + ) => Signed b -> Bool +signedIsPositive (Signed b) = not (bitNatTestBit b 0) + + +type SignedFromBitNat b = + ( ShiftableBits (BitNatWord (b+1)) + , Widen b (b+1) + ) + +-- | Create from a BitNat +-- +-- >>> signedFromBitNat (bitNat @18) +-- 18 +-- +signedFromBitNat :: forall b. + ( SignedFromBitNat b + ) => BitNat b -> Signed b +signedFromBitNat b = Signed (b .<<. NatVal @1) + + +type SignedNegate b = + ( IsBitNat (b+1) + ) + +-- | Negate a signed number +-- +-- >>> signedNegate (signedPos @5) +-- -5 +-- >>> signedNegate (signedNeg @5) +-- 5 +-- +signedNegate :: + ( SignedNegate b + ) => Signed b -> Signed b +signedNegate (Signed b)= Signed (b `bitNatXor` bitNatOne) diff --git a/src/lib/Haskus/Number/SignedSafe.hs b/src/lib/Haskus/Number/SignedSafe.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/SignedSafe.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Signed safe numbers +module Haskus.Number.SignedSafe + ( Signed (..) + , signedIsZero + , signedIsNaN + , signedFromBitNat + , signedNegate + , signedPos + , signedNeg + ) +where + +import Haskus.Number.BitNat +import Haskus.Binary.Bits +import Haskus.Utils.Types +import Prelude hiding (isNaN) + +-- | A signed number (not in two-complement form) +-- +-- * Bits: ddd..ddds where "s" is the sign bit +-- * Allows symetric positive and negative numbers +-- * Negative zero is NaN +-- +newtype Signed (b :: Nat) + = Signed (BitNat (b+1)) + +-- | Show instance for Signed +instance + ( KnownNat b + , Integral (BitNatWord b) + , IndexableBits (BitNatWord (b+1)) + , Num (BitNatWord (b+1)) + , Eq (BitNatWord (b+1)) + , Integral (BitNatWord (b+1)) + , ShiftableBits (BitNatWord (b+1)) + , Narrow (b+1) ((b+1)-1) + ) => Show (Signed b) + where + showsPrec d x@(Signed b) + | signedIsNaN x = showString "NaN" + | otherwise = + showParen (d /= 0) + $ showString (if signedIsPositive x + then "" + else "-") + . showsPrec 0 (bitNatToNatural (b .>>. NatVal @1)) + +-- | Positive signed literal +-- +-- >>> signedPos @5 +-- 5 +-- >>> signedPos @0 +-- 0 +-- +signedPos :: forall (v :: Nat) b. + ( b ~ NatBitCount v + , MakeBitNat b + , Bitwise (BitNatWord b) + , Integral (BitNatWord (b+1)) + , KnownNat v + , ShiftableBits (BitNatWord (b+1)) + , Widen b (b+1) + ) => Signed b +signedPos = Signed @b (bitNat @v .<<. NatVal @1) + +-- | Negative signed literal +-- +-- >>> signedNeg @5 +-- -5 +-- >>> signedNeg @0 +-- 0 +-- +signedNeg :: forall (v :: Nat) b. + ( b ~ NatBitCount v + , MakeBitNat b + , Bitwise (BitNatWord b) + , KnownNat v + , Widen b (b+1) + , ShiftableBits (BitNatWord (b+1)) + , IsBitNat (b+1) + ) => Signed b +signedNeg = if signedIsZero k then k else signedNegate k + where + k = signedPos @v @b + + +-- | Test for zero +-- +-- >>> signedIsZero (signedNeg @5) +-- False +-- >>> signedIsZero (signedNeg @0) +-- True +-- +signedIsZero :: + ( Num (BitNatWord (b+1)) + , Eq (BitNatWord (b+1)) + ) => Signed b -> Bool +signedIsZero (Signed b) = b == bitNatZero + +-- | Test for NaN +-- +-- >>> signedIsNaN (signedPos @5) +-- False +-- >>> signedIsNaN (signedPos @0) +-- False +-- +signedIsNaN :: + ( Num (BitNatWord (b+1)) + , Eq (BitNatWord (b+1)) + ) => Signed b -> Bool +signedIsNaN (Signed b) = b == bitNatOne + +-- | Test if positive +-- +-- >>> signedIsPositive (signedPos @5) +-- True +-- >>> signedIsPositive (signedPos @0) +-- True +-- >>> signedIsPositive (signedNeg @5) +-- False +-- +signedIsPositive :: + ( IndexableBits (BitNatWord (b+1)) + ) => Signed b -> Bool +signedIsPositive (Signed b) = not (bitNatTestBit b 0) + + +-- | Create from a BitNat +-- +-- >>> signedFromBitNat (bitNat @18) +-- 18 +-- +signedFromBitNat :: + ( ShiftableBits (BitNatWord (b+1)) + , Widen b (b+1) + ) => BitNat b -> Signed b +signedFromBitNat b = Signed (b .<<. NatVal @1) + +-- | Negate a signed number +-- +-- >>> signedNegate (signedPos @5) +-- -5 +-- >>> signedNegate (signedNeg @5) +-- 5 +-- +signedNegate :: + ( IsBitNat (b+1) + ) => Signed b -> Signed b +signedNegate s + | signedIsNaN s = s + | otherwise = case s of + Signed b -> Signed (b `bitNatXor` bitNatOne) diff --git a/src/lib/Haskus/Number/VariableLength.hs b/src/lib/Haskus/Number/VariableLength.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/VariableLength.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Variable length encodings +-- +-- * 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) +module Haskus.Number.VariableLength + ( fromULEB128 + , toULEB128 + , getULEB128 + , putULEB128 + , getSLEB128 + , putSLEB128 + , getLEB128Buffer + ) +where + +import Haskus.Number.Word +import Haskus.Number.Int +import Haskus.Binary.Get +import Haskus.Binary.Put +import Haskus.Binary.Bits +import Haskus.Binary.Bits.Put +import Haskus.Binary.Bits.Order +import Haskus.Binary.Buffer + +-- | Convert a stream of ULEB 128 bytes into an Integral +-- +-- >>> :set -XBinaryLiterals +-- >>> import Control.Monad.Trans.State +-- >>> getNext = do { ~(x:xs) <- get; put xs; pure x } +-- >>> let x = evalState (fromULEB128 getNext) [0b10000001, 0b01111111] :: Word64 +-- >>> x == 0b11111110000001 +-- True +fromULEB128 :: (Bits a, Monad m, Integral a) => m Word8 -> m a +fromULEB128 getW8 = go 0 0 + where + go acc n = do + a <- getW8 + let + w = fromIntegral (a .&. 0x7f) + acc' = w `shiftL` n .|. acc + if not (testBit a 7) + then return acc' + else go acc' (n+7) + +-- | Convert an Integral into a stream of ULEB128 bytes +-- +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> let f = toULEB128 (putStr . (++ " ") . bitsToString) +-- >>> f (0b1001001010101010 :: Word64) +-- 10101010 10100101 00000010 +toULEB128 :: (Bits a, Monad m, Integral a) => (Word8 -> m ()) -> a -> m () +toULEB128 putW8 = goFirst + where + goFirst 0 = putW8 0 + goFirst n = go n + + go 0 = pure () + go x = do + let + r = x `shiftR` 7 + w = fromIntegral (x .&. 0x7f) + w' = if r == 0 then w else setBit w 7 + putW8 w' + go r + +-- | Get an unsigned word in Little Endian Base 128 +getULEB128 :: (Integral a, Bits a) => Get a +getULEB128 = fromULEB128 getWord8 + +-- | Put an unsigned word in Little Endian Base 128 +putULEB128 :: (Integral a, Bits a) => a -> Put +putULEB128 = toULEB128 putWord8 + + +-- | 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/Number/Word.hs b/src/lib/Haskus/Number/Word.hs new file mode 100644 --- /dev/null +++ b/src/lib/Haskus/Number/Word.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MagicHash #-} + +-- | Unsigned primitive words +module Haskus.Number.Word + ( WordAtLeast + , WordN + -- * Unlifted + , module GHC.Word + , Word# + , plusWord# + , minusWord# + , ltWord# + , leWord# + , gtWord# + , geWord# + , eqWord# + ) +where + +import Data.Word +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 + (Assert (n <=? 64) Word64 + ('Text "Cannot find Word with size " ':<>: 'ShowType n) + ))) + +-- | Return a Word with exactly 'n' bits +type family WordN (n :: Nat) where + WordN 8 = Word8 + WordN 16 = Word16 + WordN 32 = Word32 + WordN 64 = Word64 + WordN n = TypeError ('Text "Cannot find Word with size " ':<>: 'ShowType n) diff --git a/src/lib/Haskus/Utils/Memory.hs b/src/lib/Haskus/Utils/Memory.hs deleted file mode 100644 --- a/src/lib/Haskus/Utils/Memory.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# 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 () -{-# INLINABLE 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 () -{-# INLINABLE 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 --- a/src/tests/Haskus/Tests/Common.hs +++ b/src/tests/Haskus/Tests/Common.hs @@ -13,7 +13,7 @@ import qualified Data.ByteString as BS -import Haskus.Format.Binary.Buffer +import Haskus.Binary.Buffer -- | Ensure a function is bijective isBijective :: Eq a => (a -> a) -> a -> Bool diff --git a/src/tests/Haskus/Tests/Format/Binary/Bits.hs b/src/tests/Haskus/Tests/Format/Binary/Bits.hs --- a/src/tests/Haskus/Tests/Format/Binary/Bits.hs +++ b/src/tests/Haskus/Tests/Format/Binary/Bits.hs @@ -14,17 +14,18 @@ import Haskus.Tests.Common import Haskus.Utils.Flow -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.Binary.Bits.Put +import Haskus.Binary.Bits.Get +import Haskus.Binary.Bits.Order +import Haskus.Binary.Bits.Reverse +import Haskus.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 +import Haskus.Binary.Buffer +import Haskus.Binary.Get +import Haskus.Binary.Put +import Haskus.Number.VariableLength +import Haskus.Number.Word +import Haskus.Number.Int testsBits :: TestTree testsBits = testGroup "Binary bits" $ diff --git a/src/tests/Haskus/Tests/Format/Binary/GetPut.hs b/src/tests/Haskus/Tests/Format/Binary/GetPut.hs --- a/src/tests/Haskus/Tests/Format/Binary/GetPut.hs +++ b/src/tests/Haskus/Tests/Format/Binary/GetPut.hs @@ -8,8 +8,8 @@ import Haskus.Tests.Common -import Haskus.Format.Binary.Get -import Haskus.Format.Binary.Buffer +import Haskus.Binary.Get +import Haskus.Binary.Buffer testsGetPut :: TestTree testsGetPut = testGroup "Get/Put" $ diff --git a/src/tests/Haskus/Tests/Format/Binary/Vector.hs b/src/tests/Haskus/Tests/Format/Binary/Vector.hs --- a/src/tests/Haskus/Tests/Format/Binary/Vector.hs +++ b/src/tests/Haskus/Tests/Format/Binary/Vector.hs @@ -14,9 +14,9 @@ import Haskus.Utils.Maybe import Haskus.Utils.HList -import Haskus.Format.Binary.Vector -import Haskus.Format.Binary.Word -import Haskus.Format.Binary.Bits +import Haskus.Binary.Vector +import Haskus.Number.Word +import Haskus.Binary.Bits v1234 :: Vector 4 Word32 v1234 = fromJust $ fromList [1,2,3,4]