diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog for binary-generic-combinators +## v0.4.3.0 + +- Add `LE` newtype wrapper for little endian (de)serialization. + +## v0.4.2.1 + +- Minor fixes in examples and documentation. + ## v0.4.2.0 - Ensure the modules are compatible with Safe Haskell. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -63,7 +63,7 @@ Consider: ```haskell data JfifSegment - = App0Segment (MatchByte "app0 segment" 0xdb, JfifApp0) + = App0Segment (MatchByte "app0 segment" 0xe0, JfifApp0) | DqtSegment (MatchByte "dqt segment" 0xdb, QuantTable) | SofSegment (MatchByte "sof segment" 0xc0, SofInfo) | DhtSegment (MatchByte "dht segment" 0xc4, HuffmanTable) @@ -82,7 +82,7 @@ {-# LANGUAGE DerivingVia #-} data JfifSegment - = App0Segment (MatchByte "app0 segment" 0xdb, JfifApp0) + = App0Segment (MatchByte "app0 segment" 0xe0, JfifApp0) | DqtSegment (MatchByte "dqt segment" 0xdb, QuantTable) | SofSegment (MatchByte "sof segment" 0xc0, SofInfo) | DhtSegment (MatchByte "dht segment" 0xc4, HuffmanTable) diff --git a/binary-generic-combinators.cabal b/binary-generic-combinators.cabal --- a/binary-generic-combinators.cabal +++ b/binary-generic-combinators.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: e141cc9e5969922ea090f392042d502509c08b87e62ad0fec15e2472ad97061c +-- hash: 3a3c919e506e259e384c033410599dd1b6c49127ebccec2c46eae9bdab9401d8 name: binary-generic-combinators -version: 0.4.2.0 +version: 0.4.3.0 synopsis: Combinators and utilities to make Generic-based deriving of Binary easier and more expressive description: Please see the README on GitHub at category: Data, Parsing @@ -55,6 +55,7 @@ , base >=4.7 && <5 , binary , binary-generic-combinators + , byte-order , generic-arbitrary , hspec default-language: Haskell2010 diff --git a/src/Data/Binary/Combinators.hs b/src/Data/Binary/Combinators.hs --- a/src/Data/Binary/Combinators.hs +++ b/src/Data/Binary/Combinators.hs @@ -28,13 +28,16 @@ , MatchBytes , matchBytes , MatchByte +, LE(..) ) where import Control.Applicative import Control.Monad import Data.Binary -import Data.Binary.Get(lookAhead) +import Data.Binary.Get +import Data.Binary.Put import Data.Functor +import Data.Int import Data.Kind import Data.Proxy import GHC.TypeLits @@ -182,3 +185,49 @@ -- | An alias for 'MatchBytes' when you only need to match a single byte. type MatchByte ctx byte = MatchBytes ctx '[ byte ] + + +-- | An @a@ serialized in little endian byte order. +-- +-- By default, @Binary@ serializes things in big endian byte order. +-- Use this wrapper to get little endian-based serialization. +newtype LE a = LE { getLE :: a } deriving (Eq, Ord) + +instance Show a => Show (LE a) where + show = show . getLE + +instance Arbitrary a => Arbitrary (LE a) where + arbitrary = LE <$> arbitrary + shrink (LE n) = LE <$> shrink n + +instance Binary (LE Word16) where + get = LE <$> getWord16le + put = putWord16le . getLE + +instance Binary (LE Word32) where + get = LE <$> getWord32le + put = putWord32le . getLE + +instance Binary (LE Word64) where + get = LE <$> getWord64le + put = putWord64le . getLE + +instance Binary (LE Int16) where + get = LE <$> getInt16le + put = putInt16le . getLE + +instance Binary (LE Int32) where + get = LE <$> getInt32le + put = putInt32le . getLE + +instance Binary (LE Int64) where + get = LE <$> getInt64le + put = putInt64le . getLE + +instance Binary (LE Float) where + get = LE <$> getFloatle + put = putFloatle . getLE + +instance Binary (LE Double) where + get = LE <$> getDoublele + put = putDoublele . getLE diff --git a/src/Data/Binary/DerivingVia.hs b/src/Data/Binary/DerivingVia.hs --- a/src/Data/Binary/DerivingVia.hs +++ b/src/Data/Binary/DerivingVia.hs @@ -21,7 +21,7 @@ -- and its index in the Haskell ADT is irrelevant: -- -- > data JfifSegment --- > = App0Segment (MatchByte "app0 segment" 0xdb, JfifApp0) +-- > = App0Segment (MatchByte "app0 segment" 0xe0, JfifApp0) -- > | DqtSegment (MatchByte "dqt segment" 0xdb, QuantTable) -- > | SofSegment (MatchByte "sof segment" 0xc0, SofInfo) -- > | DhtSegment (MatchByte "dht segment" 0xc4, HuffmanTable) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,10 +3,12 @@ {-# LANGUAGE DataKinds #-} import Data.Binary +import Data.Int import GHC.Generics import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic +import System.ByteOrder import Data.Binary.Combinators import Data.Binary.DerivingVia @@ -52,16 +54,34 @@ arbitrary = genericArbitrary shrink = genericShrink +idHolds :: (Binary a, Eq a, Show a) => a -> Expectation +idHolds val = decenc val `shouldBe` val + main :: IO () main = hspec $ do describe "Alternatively" $ do it "works for simple types" $ do - let val = SST11 matchBytes in decenc val `shouldBe` val - let val = SST12 matchBytes in decenc val `shouldBe` val + let val = SST11 matchBytes in idHolds val + let val = SST12 matchBytes in idHolds val it "is order-invariant" $ do decode (encode $ SST11 matchBytes) `shouldBe` SST22 matchBytes describe "decode . encode = id" $ do - it "for Many" $ property $ \(xs :: Many Int) -> decenc xs `shouldBe` xs - it "for Some" $ property $ \(xs :: Some Int) -> decenc xs `shouldBe` xs - it "for CountedBy" $ property $ \(xs :: CountedBy Word16 Int) -> decenc xs `shouldBe` xs - it "for complex types" $ property $ \(val :: ComplexType) -> decenc val `shouldBe` val + it "for Many" $ property $ \(xs :: Many Int) -> idHolds xs + it "for Some" $ property $ \(xs :: Some Int) -> idHolds xs + it "for CountedBy" $ property $ \(xs :: CountedBy Word16 Int) -> idHolds xs + it "for complex types" $ property $ \(val :: ComplexType) -> idHolds val + it "for LE Word32" $ property $ \(n :: LE Word32) -> idHolds n + it "for LE Int32" $ property $ \(n :: LE Int32) -> idHolds n + it "for LE Float" $ property $ \(n :: LE Float) -> idHolds n + describe "LE is actually little endian" $ do + it "encoding Word16" $ property $ \(n :: Word16) -> decode (encode $ LE n) `shouldBe` swapBytes n + it "encoding Word32" $ property $ \(n :: Word32) -> decode (encode $ LE n) `shouldBe` swapBytes n + it "encoding Word64" $ property $ \(n :: Word64) -> decode (encode $ LE n) `shouldBe` swapBytes n + it "decoding Word16" $ property $ \(n :: Word16) -> getLE (decode $ encode n) `shouldBe` swapBytes n + it "decoding Word32" $ property $ \(n :: Word32) -> getLE (decode $ encode n) `shouldBe` swapBytes n + it "decoding Word64" $ property $ \(n :: Word64) -> getLE (decode $ encode n) `shouldBe` swapBytes n + +swapBytes :: Bytes a => a -> a +swapBytes n = case targetByteOrder of + LittleEndian -> toBigEndian n + BigEndian -> toLittleEndian n