diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,75 @@ # Revision history for cborg +## 0.2.10.0 + +* Return `TypeUInt64` and `TypeNInt64` from `tokenType` when appropriate, fixing [#324](https://github.com/well-typed/cborg/issues/324) +* Don't rely on `MonadFail Gen` +* Support for GHC 9.8 + +## 0.2.9.0 + +* Fix build with `base >= 4.17` on platforms without unaligned memory operations. +* Fix `Eq`, `Ord`, `Show` and `IsList` instances for `SlicedByteArray` when offset is present +* Fix `toBuilder` and `encodeByteArray` for `SlicedByteArray` when offset is present + +## 0.2.8.0 -- 2022-09-24 + +* Support GHC 9.4 + +* Fix compatibility with primitive 0.7.4.0 + +* Drop GHC 8.0 and 8.2 support + +* Support aeson 2.1 + + +## 0.2.3.1 -- 2020-05-10 + +* Bounds updates for GHC 8.10 + +* `Decoder` is now a `newtype`. + +## 0.2.2.1 -- 2019-12-29 + +* Testsuite updates for GHC 8.8 + +## 0.2.2.0 -- 2019-07-31 + +* Add peekByteOffset for the current ByteOffset in the input byte sequence. + By keeping track of the byte offsets before and after decoding asubterm + (a pattern captured by decodeWithByteSpan) and if the overall input data + is retained then this is enables later retrieving the span of bytes for + the subterm. + +* Add encodePreEncoded function. This allows pre-encoded CBOR data to be + included into an Encoding. This is useful in cases where one has known-valid + encoded CBOR data, e.g. on disk, that you want to include into a larger CBOR + data stream. This makes it possible in such cases to avoid decoding and + re-encoding. + +* Improved test suite property coverage. We now have property coverering most + parts of a commuting diagram, which gives more confidence about what are + the right properties to test and what is enough. + +* Improved test coverage for decoding non-canonical terms + +* Fix a bug in the checks in the canonical decoding of float16 NaNs. There + are multiple bit representations of NaNs and while we were checking this + correctly for float32 and float64 we were not checking this correctly for + the float16 encoding. + +* Improved test coverage for special float values. We now have pretty + comprehensive coverage of round-tripping properties for special float + values, +/- infinity and non-canonical NaNs. + +* Improved the structure of the test suite + +* Use new GHC primitives castWord{32ToFloat,64ToDouble} rather than home grown + +* Support GHC built with integer-simple + +* Support GHC 8.8 + ## 0.2.1.0 -- 2018-10-11 * Bounds bumps and GHC 8.6 compatibility diff --git a/cborg.cabal b/cborg.cabal --- a/cborg.cabal +++ b/cborg.cabal @@ -1,34 +1,46 @@ name: cborg -version: 0.2.1.0 -synopsis: Concise Binary Object Representation +version: 0.2.10.0 +synopsis: Concise Binary Object Representation (CBOR) license: BSD3 license-file: LICENSE.txt author: Duncan Coutts maintainer: duncan@community.haskell.org, ben@smart-cactus.org bug-reports: https://github.com/well-typed/cborg/issues -copyright: 2015-2017 Duncan Coutts, - 2015-2017 Well-Typed LLP, +copyright: 2015-2019 Duncan Coutts, + 2015-2019 Well-Typed LLP, 2015 IRIS Connect Ltd category: Codec build-type: Simple cabal-version: >= 1.10 -tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +tested-with: + GHC == 8.4.4, + GHC == 8.6.5, + GHC == 8.8.3, + GHC == 8.10.7, + GHC == 9.0.1, + GHC == 9.2.2, + GHC == 9.4.2, + GHC == 9.6.1 extra-source-files: ChangeLog.md description: - This package (formerly @binary-serialise-cbor@) provides an efficient - implementation of the Concise Binary Object Representation (CBOR), as - specified by [RFC 7049](https://tools.ietf.org/html/rfc7049). + This package provides an efficient implementation of the Concise + Binary Object Representation (CBOR), as specified by + [RFC 7049](https://tools.ietf.org/html/rfc7049). . If you are looking for a library for serialisation of Haskell values, have a look at the [serialise](/package/serialise) package, which is built upon this library. . - An implementation of the standard bijection between CBOR and JSON is provided - by the [cborg-json](/package/cborg-json) package. Also see [cbor-tool](/package/cbor-tool) - for a convenient command-line utility for working with CBOR data. + An implementation of the standard bijection between CBOR and JSON is + provided by the [cborg-json](/package/cborg-json) package. Also see + [cbor-tool](/package/cbor-tool) for a convenient command-line utility + for working with CBOR data. + . + This package was formerly known as @binary-serialise-cbor@. + extra-source-files: src/cbits/cbor.h tests/test-vectors/appendix_a.json @@ -78,25 +90,32 @@ build-depends: array >= 0.4 && < 0.6, - base >= 4.6 && < 5.0, - bytestring >= 0.10.4 && < 0.11, - containers >= 0.5 && < 0.7, - deepseq >= 1.0 && < 1.5, - ghc-prim >= 0.3.1.0 && < 0.6, + base >= 4.11 && < 4.20, + bytestring >= 0.10.4 && < 0.13, + containers >= 0.5 && < 0.8, + deepseq >= 1.0 && < 1.6, + ghc-prim >= 0.3.1.0 && < 0.12, half >= 0.2.2.3 && < 0.4, - primitive >= 0.5 && < 0.7, - text >= 1.1 && < 1.3 + primitive >= 0.5 && < 0.10, + text >= 1.1 && < 1.3 || >= 2.0 && <2.2 if flag(optimize-gmp) - cpp-options: -DFLAG_OPTIMIZE_GMP - build-depends: - integer-gmp + cpp-options: -DOPTIMIZE_GMP + if impl(ghc >= 9.0) + cpp-options: -DHAVE_GHC_BIGNUM + build-depends: ghc-bignum >= 1.0 && < 2.0 + else + build-depends: integer-gmp >= 1.0 && < 2.0 if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + ghc-options: -Wcompat -Wnoncanonical-monad-instances else - -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 - build-depends: fail == 4.9.*, semigroups == 0.18.* + build-depends: + -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 + fail == 4.9.*, + semigroups >= 0.18 && < 0.21, + -- the `PS` pattern synonym in bytestring 0.11 is unavailable with GHC < 8.0 + bytestring < 0.11 test-suite tests type: exitcode-stdio-1.0 @@ -109,33 +128,44 @@ -threaded -rtsopts "-with-rtsopts=-N2" other-modules: - Tests.CBOR + Tests.UnitTests + Tests.Properties Tests.Boundary + Tests.ByteOffset + Tests.Canonical + Tests.PreEncoded Tests.Regress Tests.Regress.Issue160 Tests.Regress.Issue162 Tests.Regress.FlatTerm Tests.Reference Tests.Reference.Implementation + Tests.Reference.Generators + Tests.Reference.TestVectors + Tests.Term Tests.UTF8 Tests.Util build-depends: array >= 0.4 && < 0.6, - base >= 4.6 && < 5.0, - bytestring >= 0.10.4 && < 0.11, - text >= 1.1 && < 1.3, + base >= 4.11 && < 4.20, + base-orphans, + bytestring >= 0.10.4 && < 0.13, + text >= 1.1 && < 2.2, + primitive >= 0.5 && < 0.10, cborg, - aeson >= 0.7 && < 1.5, - base64-bytestring >= 1.0 && < 1.1, - base16-bytestring >= 0.1 && < 0.2, - deepseq >= 1.0 && < 1.5, - fail >= 4.9.0.0 && < 4.10, + aeson >= 0.7 && < 2.3, + base64-bytestring >= 1.0 && < 1.3, + base16-bytestring >= 1.0 && < 1.1, + deepseq >= 1.0 && < 1.6, half >= 0.2.2.3 && < 0.4, - QuickCheck >= 2.9 && < 2.13, + QuickCheck >= 2.9 && < 2.15, + random, scientific >= 0.3 && < 0.4, - tasty >= 0.11 && < 1.2, + tasty >= 0.11 && < 1.6, tasty-hunit >= 0.9 && < 0.11, tasty-quickcheck >= 0.8 && < 0.11, - vector >= 0.10 && < 0.13 - + vector >= 0.10 && < 0.14 + if !impl(ghc >= 8.0) + build-depends: + fail >= 4.9.0.0 && < 4.10 diff --git a/src/Codec/CBOR/ByteArray/Internal.hs b/src/Codec/CBOR/ByteArray/Internal.hs --- a/src/Codec/CBOR/ByteArray/Internal.hs +++ b/src/Codec/CBOR/ByteArray/Internal.hs @@ -41,9 +41,10 @@ -> a foldrByteArray f z off0 len ba = go off0 where + len' = len + off0 go !off - | off == len = z - | otherwise = + | off >= len' = z + | otherwise = let x = Prim.indexByteArray ba off in f x (go (off+1)) diff --git a/src/Codec/CBOR/ByteArray/Sliced.hs b/src/Codec/CBOR/ByteArray/Sliced.hs --- a/src/Codec/CBOR/ByteArray/Sliced.hs +++ b/src/Codec/CBOR/ByteArray/Sliced.hs @@ -35,7 +35,9 @@ import System.IO.Unsafe import qualified Data.Primitive.ByteArray as Prim +#if !MIN_VERSION_primitive(0,7,0) import Data.Primitive.Types (Addr(..)) +#endif import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Short as BSS @@ -66,7 +68,11 @@ $ BS.unsafePackCStringFinalizer ptr (sizeofSlicedByteArray sba) (touch pinned) where pinned = toPinned sba +#if MIN_VERSION_primitive(0,7,0) + !(Ptr addr#) = Prim.byteArrayContents pinned +#else !(Addr addr#) = Prim.byteArrayContents pinned +#endif ptr = Ptr addr# toPinned :: SlicedByteArray -> Prim.ByteArray @@ -78,7 +84,7 @@ Prim.unsafeFreezeByteArray ba' toBuilder :: SlicedByteArray -> BSB.Builder -toBuilder = \(SBA ba off len) -> BSB.builder (go ba off len) +toBuilder = \(SBA ba off len) -> BSB.builder (go ba off (len + off)) where go ba !ip !ipe !k (BSB.BufferRange op ope) | inpRemaining <= outRemaining = do @@ -127,9 +133,10 @@ | otherwise = let (!) :: Prim.ByteArray -> Int -> Word8 (!) = Prim.indexByteArray + -- len1 and len2 are known to be equal at this point + len1' = len1 + off1 go i1 i2 - | i1 == len1 && i2 == len2 = True - | i1 == len1 || i2 == len2 = False + | i1 == len1' = True | (arr1 ! i1) == (arr2 ! i2) = go (i1+1) (i2+1) | otherwise = False in go off1 off2 @@ -144,10 +151,12 @@ | otherwise = let (!) :: Prim.ByteArray -> Int -> Word8 (!) = Prim.indexByteArray + len1' = len1 + off1 + len2' = len2 + off2 go i1 i2 - | i1 == len1 && i2 == len2 = EQ - | i1 == len1 || i2 == len2 = len1 `compare` len2 - | EQ <- o = go (i1+1) (i2+1) - | otherwise = o + | i1 == len1' && i2 == len2' = EQ + | i1 == len1' || i2 == len2' = len1 `compare` len2 + | EQ <- o = go (i1+1) (i2+1) + | otherwise = o where o = (arr1 ! i1) `compare` (arr2 ! i2) in go off1 off2 diff --git a/src/Codec/CBOR/Decoding.hs b/src/Codec/CBOR/Decoding.hs --- a/src/Codec/CBOR/Decoding.hs +++ b/src/Codec/CBOR/Decoding.hs @@ -13,7 +13,7 @@ -- Portability : non-portable (GHC extensions) -- -- High level API for decoding values that were encoded with the --- "Codec.CBOR.Encoding" module, using a @'Monad'@ +-- "Codec.CBOR.Encoding" module, using a 'Monad' -- based interface. -- module Codec.CBOR.Decoding @@ -68,9 +68,14 @@ -- ** Inspecting the token type , peekTokenType -- :: Decoder s TokenType - , peekAvailable -- :: Decoder s Int , TokenType(..) + -- ** Special operations + , peekAvailable -- :: Decoder s Int + , ByteOffset + , peekByteOffset -- :: Decoder s ByteOffset + , decodeWithByteSpan + -- ** Canonical CBOR -- $canonical , decodeWordCanonical -- :: Decoder s Word @@ -101,12 +106,6 @@ , decodeWordCanonicalOf -- :: Word -> Decoder s () , decodeListLenCanonicalOf -- :: Int -> Decoder s () -{- - -- ** Special operations - , ignoreTerms - , decodeTrace --} - -- * Sequence operations , decodeSequenceLenIndef -- :: ... , decodeSequenceLenN -- :: ... @@ -130,12 +129,12 @@ -- | A continuation-based decoder, used for decoding values that were -- previously encoded using the "Codec.CBOR.Encoding" --- module. As @'Decoder'@ has a @'Monad'@ instance, you can easily --- write @'Decoder'@s monadically for building your deserialisation +-- module. As 'Decoder' has a 'Monad' instance, you can easily +-- write 'Decoder's monadically for building your deserialisation -- logic. -- -- @since 0.2.0.0 -data Decoder s a = Decoder { +newtype Decoder s a = Decoder { runDecoder :: forall r. (a -> ST s (DecodeAction s r)) -> ST s (DecodeAction s r) } @@ -157,19 +156,6 @@ | ConsumeMapLen (Int# -> ST s (DecodeAction s a)) | ConsumeTag (Word# -> ST s (DecodeAction s a)) - | ConsumeWordCanonical (Word# -> ST s (DecodeAction s a)) - | ConsumeWord8Canonical (Word# -> ST s (DecodeAction s a)) - | ConsumeWord16Canonical (Word# -> ST s (DecodeAction s a)) - | ConsumeWord32Canonical (Word# -> ST s (DecodeAction s a)) - | ConsumeNegWordCanonical (Word# -> ST s (DecodeAction s a)) - | ConsumeIntCanonical (Int# -> ST s (DecodeAction s a)) - | ConsumeInt8Canonical (Int# -> ST s (DecodeAction s a)) - | ConsumeInt16Canonical (Int# -> ST s (DecodeAction s a)) - | ConsumeInt32Canonical (Int# -> ST s (DecodeAction s a)) - | ConsumeListLenCanonical (Int# -> ST s (DecodeAction s a)) - | ConsumeMapLenCanonical (Int# -> ST s (DecodeAction s a)) - | ConsumeTagCanonical (Word# -> ST s (DecodeAction s a)) - -- 64bit variants for 32bit machines #if defined(ARCH_32bit) | ConsumeWord64 (Word64# -> ST s (DecodeAction s a)) @@ -178,13 +164,6 @@ | ConsumeListLen64 (Int64# -> ST s (DecodeAction s a)) | ConsumeMapLen64 (Int64# -> ST s (DecodeAction s a)) | ConsumeTag64 (Word64# -> ST s (DecodeAction s a)) - - | ConsumeWord64Canonical (Word64# -> ST s (DecodeAction s a)) - | ConsumeNegWord64Canonical (Word64# -> ST s (DecodeAction s a)) - | ConsumeInt64Canonical (Int64# -> ST s (DecodeAction s a)) - | ConsumeListLen64Canonical (Int64# -> ST s (DecodeAction s a)) - | ConsumeMapLen64Canonical (Int64# -> ST s (DecodeAction s a)) - | ConsumeTag64Canonical (Word64# -> ST s (DecodeAction s a)) #endif | ConsumeInteger (Integer -> ST s (DecodeAction s a)) @@ -197,16 +176,6 @@ | ConsumeBool (Bool -> ST s (DecodeAction s a)) | ConsumeSimple (Word# -> ST s (DecodeAction s a)) - | ConsumeIntegerCanonical (Integer -> ST s (DecodeAction s a)) - | ConsumeFloat16Canonical (Float# -> ST s (DecodeAction s a)) - | ConsumeFloatCanonical (Float# -> ST s (DecodeAction s a)) - | ConsumeDoubleCanonical (Double# -> ST s (DecodeAction s a)) - | ConsumeBytesCanonical (ByteString-> ST s (DecodeAction s a)) - | ConsumeByteArrayCanonical (ByteArray -> ST s (DecodeAction s a)) - | ConsumeStringCanonical (Text -> ST s (DecodeAction s a)) - | ConsumeUtf8ByteArrayCanonical (ByteArray -> ST s (DecodeAction s a)) - | ConsumeSimpleCanonical (Word# -> ST s (DecodeAction s a)) - | ConsumeBytesIndef (ST s (DecodeAction s a)) | ConsumeStringIndef (ST s (DecodeAction s a)) | ConsumeListLenIndef (ST s (DecodeAction s a)) @@ -219,7 +188,45 @@ | PeekTokenType (TokenType -> ST s (DecodeAction s a)) | PeekAvailable (Int# -> ST s (DecodeAction s a)) +#if defined(ARCH_32bit) + | PeekByteOffset (Int64# -> ST s (DecodeAction s a)) +#else + | PeekByteOffset (Int# -> ST s (DecodeAction s a)) +#endif + -- All the canonical variants + | ConsumeWordCanonical (Word# -> ST s (DecodeAction s a)) + | ConsumeWord8Canonical (Word# -> ST s (DecodeAction s a)) + | ConsumeWord16Canonical (Word# -> ST s (DecodeAction s a)) + | ConsumeWord32Canonical (Word# -> ST s (DecodeAction s a)) + | ConsumeNegWordCanonical (Word# -> ST s (DecodeAction s a)) + | ConsumeIntCanonical (Int# -> ST s (DecodeAction s a)) + | ConsumeInt8Canonical (Int# -> ST s (DecodeAction s a)) + | ConsumeInt16Canonical (Int# -> ST s (DecodeAction s a)) + | ConsumeInt32Canonical (Int# -> ST s (DecodeAction s a)) + | ConsumeListLenCanonical (Int# -> ST s (DecodeAction s a)) + | ConsumeMapLenCanonical (Int# -> ST s (DecodeAction s a)) + | ConsumeTagCanonical (Word# -> ST s (DecodeAction s a)) + +#if defined(ARCH_32bit) + | ConsumeWord64Canonical (Word64# -> ST s (DecodeAction s a)) + | ConsumeNegWord64Canonical (Word64# -> ST s (DecodeAction s a)) + | ConsumeInt64Canonical (Int64# -> ST s (DecodeAction s a)) + | ConsumeListLen64Canonical (Int64# -> ST s (DecodeAction s a)) + | ConsumeMapLen64Canonical (Int64# -> ST s (DecodeAction s a)) + | ConsumeTag64Canonical (Word64# -> ST s (DecodeAction s a)) +#endif + + | ConsumeIntegerCanonical (Integer -> ST s (DecodeAction s a)) + | ConsumeFloat16Canonical (Float# -> ST s (DecodeAction s a)) + | ConsumeFloatCanonical (Float# -> ST s (DecodeAction s a)) + | ConsumeDoubleCanonical (Double# -> ST s (DecodeAction s a)) + | ConsumeBytesCanonical (ByteString-> ST s (DecodeAction s a)) + | ConsumeByteArrayCanonical (ByteArray -> ST s (DecodeAction s a)) + | ConsumeStringCanonical (Text -> ST s (DecodeAction s a)) + | ConsumeUtf8ByteArrayCanonical (ByteArray -> ST s (DecodeAction s a)) + | ConsumeSimpleCanonical (Word# -> ST s (DecodeAction s a)) + | Fail String | Done a @@ -282,7 +289,9 @@ {-# INLINE (>>) #-} (>>) = (*>) +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif -- | @since 0.2.0.0 instance Fail.MonadFail (Decoder s) where @@ -295,22 +304,61 @@ liftST :: ST s a -> Decoder s a liftST m = Decoder $ \k -> m >>= k --- | Given a @'Decoder'@, give us the @'DecodeAction'@ +-- | Given a 'Decoder', give us the 'DecodeAction' -- -- @since 0.2.0.0 getDecodeAction :: Decoder s a -> ST s (DecodeAction s a) getDecodeAction (Decoder k) = k (\x -> return (Done x)) +-- Compatibility Shims +toInt8 :: Int# -> Int8 +toInt16 :: Int# -> Int16 +toInt32 :: Int# -> Int32 +toInt64 :: Int# -> Int64 +toWord8 :: Word# -> Word8 +toWord16 :: Word# -> Word16 +toWord32 :: Word# -> Word32 +toWord64 :: Word# -> Word64 +#if MIN_VERSION_ghc_prim(0,8,0) +toInt8 n = I8# (intToInt8# n) +toInt16 n = I16# (intToInt16# n) +toInt32 n = I32# (intToInt32# n) +toWord8 n = W8# (wordToWord8# n) +toWord16 n = W16# (wordToWord16# n) +toWord32 n = W32# (wordToWord32# n) +#if WORD_SIZE_IN_BITS == 64 +#if MIN_VERSION_base(4,17,0) +toInt64 n = I64# (intToInt64# n) +toWord64 n = W64# (wordToWord64# n) +#else +toInt64 n = I64# n +toWord64 n = W64# n +#endif +#else +toInt64 n = I64# (intToInt64# n) +toWord64 n = W64# (wordToWord64# n) +#endif +#else +toInt8 n = I8# n +toInt16 n = I16# n +toInt32 n = I32# n +toInt64 n = I64# n +toWord8 n = W8# n +toWord16 n = W16# n +toWord32 n = W32# n +toWord64 n = W64# n +#endif + -- $canonical -- -- -- -- In general in CBOR there can be multiple representations for the same value, --- for example the integer @0@ represented in 8, 16, 32 or 64 bits. This --- library always encodeds values in the shortest representation but on +-- for example the integer @0@ can be represented in 8, 16, 32 or 64 bits. This +-- library always encoded values in the shortest representation but on -- decoding allows any valid encoding. For some applications it is useful or --- important to only decode the canonical encoding. The decoder primitves here +-- important to only decode the canonical encoding. The decoder primitives here -- are to allow applications to implement canonical decoding. -- -- It is important to note that achieving a canonical representation is /not/ @@ -324,7 +372,7 @@ -- This /does not/ enforce a canonical encoding. The decoder above will allow -- set elements in any order. The use of @Set.fromList@ forgets the order. -- To enforce that the decoder only accepts the canonical encoding it will --- have to check that the elemets in the list are /strictly/ increasing. +-- have to check that the elements in the list are /strictly/ increasing. -- Similar issues arise in many other data types, wherever there is redundancy -- in the external representation. -- @@ -338,233 +386,233 @@ -- Read input tokens of various types -- --- | Decode a @'Word'@. +-- | Decode a 'Word'. -- -- @since 0.2.0.0 decodeWord :: Decoder s Word decodeWord = Decoder (\k -> return (ConsumeWord (\w# -> k (W# w#)))) {-# INLINE decodeWord #-} --- | Decode a @'Word8'@. +-- | Decode a 'Word8'. -- -- @since 0.2.0.0 decodeWord8 :: Decoder s Word8 -decodeWord8 = Decoder (\k -> return (ConsumeWord8 (\w# -> k (W8# w#)))) +decodeWord8 = Decoder (\k -> return (ConsumeWord8 (\w# -> k (toWord8 w#)))) {-# INLINE decodeWord8 #-} --- | Decode a @'Word16'@. +-- | Decode a 'Word16'. -- -- @since 0.2.0.0 decodeWord16 :: Decoder s Word16 -decodeWord16 = Decoder (\k -> return (ConsumeWord16 (\w# -> k (W16# w#)))) +decodeWord16 = Decoder (\k -> return (ConsumeWord16 (\w# -> k (toWord16 w#)))) {-# INLINE decodeWord16 #-} --- | Decode a @'Word32'@. +-- | Decode a 'Word32'. -- -- @since 0.2.0.0 decodeWord32 :: Decoder s Word32 -decodeWord32 = Decoder (\k -> return (ConsumeWord32 (\w# -> k (W32# w#)))) +decodeWord32 = Decoder (\k -> return (ConsumeWord32 (\w# -> k (toWord32 w#)))) {-# INLINE decodeWord32 #-} --- | Decode a @'Word64'@. +-- | Decode a 'Word64'. -- -- @since 0.2.0.0 decodeWord64 :: Decoder s Word64 {-# INLINE decodeWord64 #-} decodeWord64 = #if defined(ARCH_64bit) - Decoder (\k -> return (ConsumeWord (\w# -> k (W64# w#)))) + Decoder (\k -> return (ConsumeWord (\w# -> k (toWord64 w#)))) #else - Decoder (\k -> return (ConsumeWord64 (\w64# -> k (W64# w64#)))) + Decoder (\k -> return (ConsumeWord64 (\w64# -> k (toWord64 w64#)))) #endif --- | Decode a negative @'Word'@. +-- | Decode a negative 'Word'. -- -- @since 0.2.0.0 decodeNegWord :: Decoder s Word decodeNegWord = Decoder (\k -> return (ConsumeNegWord (\w# -> k (W# w#)))) {-# INLINE decodeNegWord #-} --- | Decode a negative @'Word64'@. +-- | Decode a negative 'Word64'. -- -- @since 0.2.0.0 decodeNegWord64 :: Decoder s Word64 {-# INLINE decodeNegWord64 #-} decodeNegWord64 = #if defined(ARCH_64bit) - Decoder (\k -> return (ConsumeNegWord (\w# -> k (W64# w#)))) + Decoder (\k -> return (ConsumeNegWord (\w# -> k (toWord64 w#)))) #else - Decoder (\k -> return (ConsumeNegWord64 (\w64# -> k (W64# w64#)))) + Decoder (\k -> return (ConsumeNegWord64 (\w64# -> k (toWord64 w64#)))) #endif --- | Decode an @'Int'@. +-- | Decode an 'Int'. -- -- @since 0.2.0.0 decodeInt :: Decoder s Int decodeInt = Decoder (\k -> return (ConsumeInt (\n# -> k (I# n#)))) {-# INLINE decodeInt #-} --- | Decode an @'Int8'@. +-- | Decode an 'Int8'. -- -- @since 0.2.0.0 decodeInt8 :: Decoder s Int8 -decodeInt8 = Decoder (\k -> return (ConsumeInt8 (\w# -> k (I8# w#)))) +decodeInt8 = Decoder (\k -> return (ConsumeInt8 (\w# -> k (toInt8 w#)))) {-# INLINE decodeInt8 #-} --- | Decode an @'Int16'@. +-- | Decode an 'Int16'. -- -- @since 0.2.0.0 decodeInt16 :: Decoder s Int16 -decodeInt16 = Decoder (\k -> return (ConsumeInt16 (\w# -> k (I16# w#)))) +decodeInt16 = Decoder (\k -> return (ConsumeInt16 (\w# -> k (toInt16 w#)))) {-# INLINE decodeInt16 #-} --- | Decode an @'Int32'@. +-- | Decode an 'Int32'. -- -- @since 0.2.0.0 decodeInt32 :: Decoder s Int32 -decodeInt32 = Decoder (\k -> return (ConsumeInt32 (\w# -> k (I32# w#)))) +decodeInt32 = Decoder (\k -> return (ConsumeInt32 (\w# -> k (toInt32 w#)))) {-# INLINE decodeInt32 #-} --- | Decode an @'Int64'@. +-- | Decode an 'Int64'. -- -- @since 0.2.0.0 decodeInt64 :: Decoder s Int64 {-# INLINE decodeInt64 #-} decodeInt64 = #if defined(ARCH_64bit) - Decoder (\k -> return (ConsumeInt (\n# -> k (I64# n#)))) + Decoder (\k -> return (ConsumeInt (\n# -> k (toInt64 n#)))) #else - Decoder (\k -> return (ConsumeInt64 (\n64# -> k (I64# n64#)))) + Decoder (\k -> return (ConsumeInt64 (\n64# -> k (toInt64 n64#)))) #endif --- | Decode canonical representation of a @'Word'@. +-- | Decode canonical representation of a 'Word'. -- -- @since 0.2.0.0 decodeWordCanonical :: Decoder s Word decodeWordCanonical = Decoder (\k -> return (ConsumeWordCanonical (\w# -> k (W# w#)))) {-# INLINE decodeWordCanonical #-} --- | Decode canonical representation of a @'Word8'@. +-- | Decode canonical representation of a 'Word8'. -- -- @since 0.2.0.0 decodeWord8Canonical :: Decoder s Word8 -decodeWord8Canonical = Decoder (\k -> return (ConsumeWord8Canonical (\w# -> k (W8# w#)))) +decodeWord8Canonical = Decoder (\k -> return (ConsumeWord8Canonical (\w# -> k (toWord8 w#)))) {-# INLINE decodeWord8Canonical #-} --- | Decode canonical representation of a @'Word16'@. +-- | Decode canonical representation of a 'Word16'. -- -- @since 0.2.0.0 decodeWord16Canonical :: Decoder s Word16 -decodeWord16Canonical = Decoder (\k -> return (ConsumeWord16Canonical (\w# -> k (W16# w#)))) +decodeWord16Canonical = Decoder (\k -> return (ConsumeWord16Canonical (\w# -> k (toWord16 w#)))) {-# INLINE decodeWord16Canonical #-} --- | Decode canonical representation of a @'Word32'@. +-- | Decode canonical representation of a 'Word32'. -- -- @since 0.2.0.0 decodeWord32Canonical :: Decoder s Word32 -decodeWord32Canonical = Decoder (\k -> return (ConsumeWord32Canonical (\w# -> k (W32# w#)))) +decodeWord32Canonical = Decoder (\k -> return (ConsumeWord32Canonical (\w# -> k (toWord32 w#)))) {-# INLINE decodeWord32Canonical #-} --- | Decode canonical representation of a @'Word64'@. +-- | Decode canonical representation of a 'Word64'. -- -- @since 0.2.0.0 decodeWord64Canonical :: Decoder s Word64 {-# INLINE decodeWord64Canonical #-} decodeWord64Canonical = #if defined(ARCH_64bit) - Decoder (\k -> return (ConsumeWordCanonical (\w# -> k (W64# w#)))) + Decoder (\k -> return (ConsumeWordCanonical (\w# -> k (toWord64 w#)))) #else - Decoder (\k -> return (ConsumeWord64Canonical (\w64# -> k (W64# w64#)))) + Decoder (\k -> return (ConsumeWord64Canonical (\w64# -> k (toWord64 w64#)))) #endif --- | Decode canonical representation of a negative @'Word'@. +-- | Decode canonical representation of a negative 'Word'. -- -- @since 0.2.0.0 decodeNegWordCanonical :: Decoder s Word decodeNegWordCanonical = Decoder (\k -> return (ConsumeNegWordCanonical (\w# -> k (W# w#)))) {-# INLINE decodeNegWordCanonical #-} --- | Decode canonical representation of a negative @'Word64'@. +-- | Decode canonical representation of a negative 'Word64'. -- -- @since 0.2.0.0 decodeNegWord64Canonical :: Decoder s Word64 {-# INLINE decodeNegWord64Canonical #-} decodeNegWord64Canonical = #if defined(ARCH_64bit) - Decoder (\k -> return (ConsumeNegWordCanonical (\w# -> k (W64# w#)))) + Decoder (\k -> return (ConsumeNegWordCanonical (\w# -> k (toWord64 w#)))) #else - Decoder (\k -> return (ConsumeNegWord64Canonical (\w64# -> k (W64# w64#)))) + Decoder (\k -> return (ConsumeNegWord64Canonical (\w64# -> k (toWord64 w64#)))) #endif --- | Decode canonical representation of an @'Int'@. +-- | Decode canonical representation of an 'Int'. -- -- @since 0.2.0.0 decodeIntCanonical :: Decoder s Int decodeIntCanonical = Decoder (\k -> return (ConsumeIntCanonical (\n# -> k (I# n#)))) {-# INLINE decodeIntCanonical #-} --- | Decode canonical representation of an @'Int8'@. +-- | Decode canonical representation of an 'Int8'. -- -- @since 0.2.0.0 decodeInt8Canonical :: Decoder s Int8 -decodeInt8Canonical = Decoder (\k -> return (ConsumeInt8Canonical (\w# -> k (I8# w#)))) +decodeInt8Canonical = Decoder (\k -> return (ConsumeInt8Canonical (\w# -> k (toInt8 w#)))) {-# INLINE decodeInt8Canonical #-} --- | Decode canonical representation of an @'Int16'@. +-- | Decode canonical representation of an 'Int16'. -- -- @since 0.2.0.0 decodeInt16Canonical :: Decoder s Int16 -decodeInt16Canonical = Decoder (\k -> return (ConsumeInt16Canonical (\w# -> k (I16# w#)))) +decodeInt16Canonical = Decoder (\k -> return (ConsumeInt16Canonical (\w# -> k (toInt16 w#)))) {-# INLINE decodeInt16Canonical #-} --- | Decode canonical representation of an @'Int32'@. +-- | Decode canonical representation of an 'Int32'. -- -- @since 0.2.0.0 decodeInt32Canonical :: Decoder s Int32 -decodeInt32Canonical = Decoder (\k -> return (ConsumeInt32Canonical (\w# -> k (I32# w#)))) +decodeInt32Canonical = Decoder (\k -> return (ConsumeInt32Canonical (\w# -> k (toInt32 w#)))) {-# INLINE decodeInt32Canonical #-} --- | Decode canonical representation of an @'Int64'@. +-- | Decode canonical representation of an 'Int64'. -- -- @since 0.2.0.0 decodeInt64Canonical :: Decoder s Int64 {-# INLINE decodeInt64Canonical #-} decodeInt64Canonical = #if defined(ARCH_64bit) - Decoder (\k -> return (ConsumeIntCanonical (\n# -> k (I64# n#)))) + Decoder (\k -> return (ConsumeIntCanonical (\n# -> k (toInt64 n#)))) #else - Decoder (\k -> return (ConsumeInt64Canonical (\n64# -> k (I64# n64#)))) + Decoder (\k -> return (ConsumeInt64Canonical (\n64# -> k (toInt64 n64#)))) #endif --- | Decode an @'Integer'@. +-- | Decode an 'Integer'. -- -- @since 0.2.0.0 decodeInteger :: Decoder s Integer decodeInteger = Decoder (\k -> return (ConsumeInteger (\n -> k n))) {-# INLINE decodeInteger #-} --- | Decode a @'Float'@. +-- | Decode a 'Float'. -- -- @since 0.2.0.0 decodeFloat :: Decoder s Float decodeFloat = Decoder (\k -> return (ConsumeFloat (\f# -> k (F# f#)))) {-# INLINE decodeFloat #-} --- | Decode a @'Double'@. +-- | Decode a 'Double'. -- -- @since 0.2.0.0 decodeDouble :: Decoder s Double decodeDouble = Decoder (\k -> return (ConsumeDouble (\f# -> k (D# f#)))) {-# INLINE decodeDouble #-} --- | Decode a string of bytes as a @'ByteString'@. +-- | Decode a string of bytes as a 'ByteString'. -- -- @since 0.2.0.0 decodeBytes :: Decoder s ByteString decodeBytes = Decoder (\k -> return (ConsumeBytes (\bs -> k bs))) {-# INLINE decodeBytes #-} --- | Decode canonical representation of a string of bytes as a @'ByteString'@. +-- | Decode canonical representation of a string of bytes as a 'ByteString'. -- -- @since 0.2.1.0 decodeBytesCanonical :: Decoder s ByteString @@ -601,14 +649,14 @@ decodeByteArrayCanonical = Decoder (\k -> return (ConsumeByteArrayCanonical k)) {-# INLINE decodeByteArrayCanonical #-} --- | Decode a textual string as a piece of @'Text'@. +-- | Decode a textual string as a piece of 'Text'. -- -- @since 0.2.0.0 decodeString :: Decoder s Text decodeString = Decoder (\k -> return (ConsumeString (\str -> k str))) {-# INLINE decodeString #-} --- | Decode canonical representation of a textual string as a piece of @'Text'@. +-- | Decode canonical representation of a textual string as a piece of 'Text'. -- -- @since 0.2.1.0 decodeStringCanonical :: Decoder s Text @@ -691,27 +739,33 @@ decodeMapLenIndef = Decoder (\k -> return (ConsumeMapLenIndef (k ()))) {-# INLINE decodeMapLenIndef #-} --- | Decode an arbitrary tag and return it as a @'Word'@. +-- | Decode an arbitrary tag and return it as a 'Word'. -- -- @since 0.2.0.0 decodeTag :: Decoder s Word decodeTag = Decoder (\k -> return (ConsumeTag (\w# -> k (W# w#)))) {-# INLINE decodeTag #-} --- | Decode an arbitrary 64-bit tag and return it as a @'Word64'@. +-- | Decode an arbitrary 64-bit tag and return it as a 'Word64'. -- -- @since 0.2.0.0 decodeTag64 :: Decoder s Word64 {-# INLINE decodeTag64 #-} decodeTag64 = #if defined(ARCH_64bit) - Decoder (\k -> return (ConsumeTag (\w# -> k (W64# w#)))) + Decoder (\k -> return (ConsumeTag (\w# -> k (W64# +#if MIN_VERSION_base(4,17,0) + (wordToWord64# w#) #else + w# +#endif + )))) +#else Decoder (\k -> return (ConsumeTag64 (\w64# -> k (W64# w64#)))) #endif -- | Decode canonical representation of an arbitrary tag and return it as a --- @'Word'@. +-- 'Word'. -- -- @since 0.2.0.0 decodeTagCanonical :: Decoder s Word @@ -719,15 +773,21 @@ {-# INLINE decodeTagCanonical #-} -- | Decode canonical representation of an arbitrary 64-bit tag and return it as --- a @'Word64'@. +-- a 'Word64'. -- -- @since 0.2.0.0 decodeTag64Canonical :: Decoder s Word64 {-# INLINE decodeTag64Canonical #-} decodeTag64Canonical = #if defined(ARCH_64bit) - Decoder (\k -> return (ConsumeTagCanonical (\w# -> k (W64# w#)))) + Decoder (\k -> return (ConsumeTagCanonical (\w# -> k (W64# +#if MIN_VERSION_base(4,17,0) + (wordToWord64# w#) #else + w# +#endif + )))) +#else Decoder (\k -> return (ConsumeTag64Canonical (\w64# -> k (W64# w64#)))) #endif @@ -745,36 +805,36 @@ decodeNull = Decoder (\k -> return (ConsumeNull (k ()))) {-# INLINE decodeNull #-} --- | Decode a 'simple' CBOR value and give back a @'Word8'@. You +-- | Decode a 'simple' CBOR value and give back a 'Word8'. You -- probably don't ever need to use this. -- -- @since 0.2.0.0 decodeSimple :: Decoder s Word8 -decodeSimple = Decoder (\k -> return (ConsumeSimple (\w# -> k (W8# w#)))) +decodeSimple = Decoder (\k -> return (ConsumeSimple (\w# -> k (toWord8 w#)))) {-# INLINE decodeSimple #-} --- | Decode canonical representation of an @'Integer'@. +-- | Decode canonical representation of an 'Integer'. -- -- @since 0.2.0.0 decodeIntegerCanonical :: Decoder s Integer decodeIntegerCanonical = Decoder (\k -> return (ConsumeIntegerCanonical (\n -> k n))) {-# INLINE decodeIntegerCanonical #-} --- | Decode canonical representation of a half-precision @'Float'@. +-- | Decode canonical representation of a half-precision 'Float'. -- -- @since 0.2.0.0 decodeFloat16Canonical :: Decoder s Float decodeFloat16Canonical = Decoder (\k -> return (ConsumeFloat16Canonical (\f# -> k (F# f#)))) {-# INLINE decodeFloat16Canonical #-} --- | Decode canonical representation of a @'Float'@. +-- | Decode canonical representation of a 'Float'. -- -- @since 0.2.0.0 decodeFloatCanonical :: Decoder s Float decodeFloatCanonical = Decoder (\k -> return (ConsumeFloatCanonical (\f# -> k (F# f#)))) {-# INLINE decodeFloatCanonical #-} --- | Decode canonical representation of a @'Double'@. +-- | Decode canonical representation of a 'Double'. -- -- @since 0.2.0.0 decodeDoubleCanonical :: Decoder s Double @@ -782,18 +842,18 @@ {-# INLINE decodeDoubleCanonical #-} -- | Decode canonical representation of a 'simple' CBOR value and give back a --- @'Word8'@. You probably don't ever need to use this. +-- 'Word8'. You probably don't ever need to use this. -- -- @since 0.2.0.0 decodeSimpleCanonical :: Decoder s Word8 -decodeSimpleCanonical = Decoder (\k -> return (ConsumeSimpleCanonical (\w# -> k (W8# w#)))) +decodeSimpleCanonical = Decoder (\k -> return (ConsumeSimpleCanonical (\w# -> k (toWord8 w#)))) {-# INLINE decodeSimpleCanonical #-} -------------------------------------------------------------- -- Specialised read operations: expect a token with a specific value -- --- | Attempt to decode a word with @'decodeWord'@, and ensure the word +-- | Attempt to decode a word with 'decodeWord', and ensure the word -- is exactly as expected, or fail. -- -- @since 0.2.0.0 @@ -802,7 +862,7 @@ decodeWordOf = decodeWordOfHelper decodeWord {-# INLINE decodeWordOf #-} --- | Attempt to decode a list length using @'decodeListLen'@, and +-- | Attempt to decode a list length using 'decodeListLen', and -- ensure it is exactly the specified length, or fail. -- -- @since 0.2.0.0 @@ -810,7 +870,7 @@ decodeListLenOf = decodeListLenOfHelper decodeListLen {-# INLINE decodeListLenOf #-} --- | Attempt to decode canonical representation of a word with @'decodeWordCanonical'@, +-- | Attempt to decode canonical representation of a word with 'decodeWordCanonical', -- and ensure the word is exactly as expected, or fail. -- -- @since 0.2.0.0 @@ -820,7 +880,7 @@ {-# INLINE decodeWordCanonicalOf #-} -- | Attempt to decode canonical representation of a list length using --- @'decodeListLenCanonical'@, and ensure it is exactly the specified length, or +-- 'decodeListLenCanonical', and ensure it is exactly the specified length, or -- fail. -- -- @since 0.2.0.0 @@ -828,14 +888,14 @@ decodeListLenCanonicalOf = decodeListLenOfHelper decodeListLenCanonical {-# INLINE decodeListLenCanonicalOf #-} -decodeListLenOfHelper :: (Show a, Eq a, Monad m) => m a -> a -> m () +decodeListLenOfHelper :: (Show a, Eq a, Fail.MonadFail m) => m a -> a -> m () decodeListLenOfHelper decodeFun = \len -> do len' <- decodeFun if len == len' then return () else fail $ "expected list of length " ++ show len {-# INLINE decodeListLenOfHelper #-} -decodeWordOfHelper :: (Show a, Eq a, Monad m) => m a -> a -> m () +decodeWordOfHelper :: (Show a, Eq a, Fail.MonadFail m) => m a -> a -> m () decodeWordOfHelper decodeFun = \n -> do n' <- decodeFun if n == n' then return () @@ -846,7 +906,7 @@ -- Branching operations -- | Attempt to decode a token for the length of a finite, known list, --- or an indefinite list. If @'Nothing'@ is returned, then an +-- or an indefinite list. If 'Nothing' is returned, then an -- indefinite length list occurs afterwords. If @'Just' x@ is -- returned, then a list of length @x@ is encoded. -- @@ -860,7 +920,7 @@ {-# INLINE decodeListLenOrIndef #-} -- | Attempt to decode a token for the length of a finite, known map, --- or an indefinite map. If @'Nothing'@ is returned, then an +-- or an indefinite map. If 'Nothing' is returned, then an -- indefinite length map occurs afterwords. If @'Just' x@ is returned, -- then a map of length @x@ is encoded. -- @@ -874,8 +934,8 @@ {-# INLINE decodeMapLenOrIndef #-} -- | Attempt to decode a @Break@ token, and if that was --- successful, return @'True'@. If the token was of any --- other type, return @'False'@. +-- successful, return 'True'. If the token was of any +-- other type, return 'False'. -- -- @since 0.2.0.0 decodeBreakOr :: Decoder s Bool @@ -886,7 +946,7 @@ -- Special operations -- | Peek at the current token we're about to decode, and return a --- @'TokenType'@ specifying what it is. +-- 'TokenType' specifying what it is. -- -- @since 0.2.0.0 peekTokenType :: Decoder s TokenType @@ -901,6 +961,53 @@ peekAvailable = Decoder (\k -> return (PeekAvailable (\len# -> k (I# len#)))) {-# INLINE peekAvailable #-} + +-- | A 0-based offset within the overall byte sequence that makes up the +-- input to the 'Decoder'. +-- +-- This is an 'Int64' since 'Decoder' is incremental and can decode more data +-- than fits in memory at once. This is also compatible with the result type +-- of 'Data.ByteString.Lazy.length'. +-- +type ByteOffset = Int64 + +-- | Get the current 'ByteOffset' in the input byte sequence of the 'Decoder'. +-- +-- The 'Decoder' does not provide any facility to get at the input data +-- directly (since that is tricky with an incremental decoder). The next best +-- is this primitive which can be used to keep track of the offset within the +-- input bytes that makes up the encoded form of a term. +-- +-- By keeping track of the byte offsets before and after decoding a subterm +-- (a pattern captured by 'decodeWithByteSpan') and if the overall input data +-- is retained then this is enables later retrieving the span of bytes for the +-- subterm. +-- +-- @since 0.2.2.0 +peekByteOffset :: Decoder s ByteOffset +peekByteOffset = Decoder (\k -> return (PeekByteOffset (\off# -> k (I64# +#if MIN_VERSION_base(4,17,0) + (intToInt64# off#) +#else + off# +#endif + )))) +{-# INLINE peekByteOffset #-} + +-- | This captures the pattern of getting the byte offsets before and after +-- decoding a subterm. +-- +-- > !before <- peekByteOffset +-- > x <- decode +-- > !after <- peekByteOffset +-- +decodeWithByteSpan :: Decoder s a -> Decoder s (a, ByteOffset, ByteOffset) +decodeWithByteSpan da = do + !before <- peekByteOffset + x <- da + !after <- peekByteOffset + return (x, before, after) + {- expectExactly :: Word -> Decoder (Word :#: s) s expectExactly n = expectExactly_ n done @@ -948,4 +1055,3 @@ go !acc 0 = return $! g acc go !acc n = do !x <- get; go (f acc x) (n-1) {-# INLINE decodeSequenceLenN #-} - diff --git a/src/Codec/CBOR/Encoding.hs b/src/Codec/CBOR/Encoding.hs --- a/src/Codec/CBOR/Encoding.hs +++ b/src/Codec/CBOR/Encoding.hs @@ -10,14 +10,14 @@ -- Portability : non-portable (GHC extensions) -- -- High level API for encoding values, for later serialization into --- CBOR binary format, using a @'Monoid'@ based interface. +-- CBOR binary format, using a 'Monoid' based interface. -- module Codec.CBOR.Encoding ( -- * Encoding implementation Encoding(..) -- :: * , Tokens(..) -- :: * - -- * @'Encoding'@ API for serialisation + -- * 'Encoding' API for serialisation , encodeWord -- :: Word -> Encoding , encodeWord8 -- :: Word8 -> Encoding , encodeWord16 -- :: Word16 -> Encoding @@ -49,6 +49,7 @@ , encodeFloat16 -- :: Float -> Encoding , encodeFloat -- :: Float -> Encoding , encodeDouble -- :: Double -> Encoding + , encodePreEncoded -- :: B.ByteString -> Encoding ) where #include "cbor.h" @@ -67,16 +68,16 @@ import {-# SOURCE #-} qualified Codec.CBOR.FlatTerm as FlatTerm -- | An intermediate form used during serialisation, specified as a --- @'Monoid'@. It supports efficient concatenation, and is equivalent --- to a specialised @'Data.Monoid.Endo' 'Tokens'@ type. +-- 'Monoid'. It supports efficient concatenation, and is equivalent +-- to a specialised 'Data.Monoid.Endo' 'Tokens' type. -- -- It is used for the stage in serialisation where we flatten out the -- Haskell data structure but it is independent of any specific -- external binary or text format. -- --- Traditionally, to build any arbitrary @'Encoding'@ value, you specify +-- Traditionally, to build any arbitrary 'Encoding' value, you specify -- larger structures from smaller ones and append the small ones together --- using @'Data.Monoid.mconcat'@. +-- using 'Data.Monoid.mconcat'. -- -- @since 0.2.0.0 newtype Encoding = Encoding (Tokens -> Tokens) @@ -127,6 +128,9 @@ | TkFloat64 {-# UNPACK #-} !Double Tokens | TkBreak Tokens + -- Special + | TkEncoded {-# UNPACK #-} !B.ByteString Tokens + | TkEnd deriving (Show,Eq) @@ -146,55 +150,55 @@ mconcat = foldr (<>) mempty {-# INLINE mconcat #-} --- | Encode a @'Word'@ in a flattened format. +-- | Encode a 'Word' in a flattened format. -- -- @since 0.2.0.0 encodeWord :: Word -> Encoding encodeWord = Encoding . TkWord --- | Encode a @'Word8'@ in a flattened format. +-- | Encode a 'Word8' in a flattened format. -- -- @since 0.2.0.0 encodeWord8 :: Word8 -> Encoding encodeWord8 = Encoding . TkWord . fromIntegral --- | Encode a @'Word16'@ in a flattened format. +-- | Encode a 'Word16' in a flattened format. -- -- @since 0.2.0.0 encodeWord16 :: Word16 -> Encoding encodeWord16 = Encoding . TkWord . fromIntegral --- | Encode a @'Word32'@ in a flattened format. +-- | Encode a 'Word32' in a flattened format. -- -- @since 0.2.0.0 encodeWord32 :: Word32 -> Encoding encodeWord32 = Encoding . TkWord . fromIntegral --- | Encode a @'Word64'@ in a flattened format. +-- | Encode a 'Word64' in a flattened format. -- -- @since 0.2.0.0 encodeWord64 :: Word64 -> Encoding encodeWord64 = Encoding . TkWord64 --- | Encode an @'Int'@ in a flattened format. +-- | Encode an 'Int' in a flattened format. -- -- @since 0.2.0.0 encodeInt :: Int -> Encoding encodeInt = Encoding . TkInt --- | Encode an @'Int8'@ in a flattened format. +-- | Encode an 'Int8' in a flattened format. -- -- @since 0.2.0.0 encodeInt8 :: Int8 -> Encoding encodeInt8 = Encoding . TkInt . fromIntegral --- | Encode an @'Int16'@ in a flattened format. +-- | Encode an 'Int16' in a flattened format. -- -- @since 0.2.0.0 encodeInt16 :: Int16 -> Encoding encodeInt16 = Encoding . TkInt . fromIntegral --- | Encode an @'Int32'@ in a flattened format. +-- | Encode an 'Int32' in a flattened format. -- -- @since 0.2.0.0 encodeInt32 :: Int32 -> Encoding @@ -213,7 +217,7 @@ encodeInteger :: Integer -> Encoding encodeInteger n = Encoding (TkInteger n) --- | Encode an arbitrary strict @'B.ByteString'@ in +-- | Encode an arbitrary strict 'B.ByteString' in -- a flattened format. -- -- @since 0.2.0.0 @@ -230,13 +234,13 @@ -- indefinite length. In reality, this specifies a stream of many -- occurrences of `encodeBytes`, each specifying a single chunk of the -- overall string. After all the bytes desired have been encoded, you --- should follow it with a break token (see @'encodeBreak'@). +-- should follow it with a break token (see 'encodeBreak'). -- -- @since 0.2.0.0 encodeBytesIndef :: Encoding encodeBytesIndef = Encoding TkBytesBegin --- | Encode a @'T.Text'@ in a flattened format. +-- | Encode a 'T.Text' in a flattened format. -- -- @since 0.2.0.0 encodeString :: T.Text -> Encoding @@ -265,7 +269,7 @@ -- | Encode a token specifying that this is the beginning of an -- indefinite list of unknown size. Tokens representing the list are -- expected afterwords, followed by a break token (see --- @'encodeBreak'@) when the list has ended. +-- 'encodeBreak') when the list has ended. -- -- @since 0.2.0.0 encodeListLenIndef :: Encoding @@ -281,7 +285,7 @@ -- | Encode a token specifying that this is the beginning of an -- indefinite map of unknown size. Tokens representing the map are -- expected afterwords, followed by a break token (see --- @'encodeBreak'@) when the map has ended. +-- 'encodeBreak') when the map has ended. -- -- @since 0.2.0.0 encodeMapLenIndef :: Encoding @@ -294,19 +298,19 @@ encodeBreak :: Encoding encodeBreak = Encoding TkBreak --- | Encode an arbitrary @'Word'@ tag. +-- | Encode an arbitrary 'Word' tag. -- -- @since 0.2.0.0 encodeTag :: Word -> Encoding encodeTag = Encoding . TkTag --- | Encode an arbitrary 64-bit @'Word64'@ tag. +-- | Encode an arbitrary 64-bit 'Word64' tag. -- -- @since 0.2.0.0 encodeTag64 :: Word64 -> Encoding encodeTag64 = Encoding . TkTag64 --- | Encode a @'Bool'@. +-- | Encode a 'Bool'. -- -- @since 0.2.0.0 encodeBool :: Bool -> Encoding @@ -331,20 +335,35 @@ encodeSimple :: Word8 -> Encoding encodeSimple = Encoding . TkSimple --- | Encode a small 16-bit @'Float'@ in a flattened format. +-- | Encode a small 16-bit 'Float' in a flattened format. -- -- @since 0.2.0.0 encodeFloat16 :: Float -> Encoding encodeFloat16 = Encoding . TkFloat16 --- | Encode a full precision @'Float'@ in a flattened format. +-- | Encode a full precision 'Float' in a flattened format. -- -- @since 0.2.0.0 encodeFloat :: Float -> Encoding encodeFloat = Encoding . TkFloat32 --- | Encode a @'Double'@ in a flattened format. +-- | Encode a 'Double' in a flattened format. -- -- @since 0.2.0.0 encodeDouble :: Double -> Encoding encodeDouble = Encoding . TkFloat64 + +-- | Include pre-encoded valid CBOR data into the 'Encoding'. +-- +-- The data is included into the output as-is without any additional wrapper. +-- +-- This should be used with care. The data /must/ be a valid CBOR encoding, but +-- this is /not/ checked. +-- +-- This is useful when you have CBOR data that you know is already valid, e.g. +-- previously validated and stored on disk, and you wish to include it without +-- having to decode and re-encode it. +-- +-- @since 0.2.2.0 +encodePreEncoded :: B.ByteString -> Encoding +encodePreEncoded = Encoding . TkEncoded diff --git a/src/Codec/CBOR/FlatTerm.hs b/src/Codec/CBOR/FlatTerm.hs --- a/src/Codec/CBOR/FlatTerm.hs +++ b/src/Codec/CBOR/FlatTerm.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} -- | -- Module : Codec.CBOR.FlatTerm @@ -11,16 +12,16 @@ -- Stability : experimental -- Portability : non-portable (GHC extensions) -- --- A simpler form than CBOR for writing out @'Enc.Encoding'@ values that allows +-- A simpler form than CBOR for writing out 'Enc.Encoding' values that allows -- easier verification and testing. While this library primarily focuses --- on taking @'Enc.Encoding'@ values (independent of any underlying format) +-- on taking 'Enc.Encoding' values (independent of any underlying format) -- and serializing them into CBOR format, this module offers an alternative --- format called @'FlatTerm'@ for serializing @'Enc.Encoding'@ values. +-- format called 'FlatTerm' for serializing 'Enc.Encoding' values. -- --- The @'FlatTerm'@ form is very simple and internally mirrors the original --- @'Encoding'@ type very carefully. The intention here is that once you --- have @'Enc.Encoding'@ and @'Dec.Decoding'@ values for your types, you can --- round-trip values through @'FlatTerm'@ to catch bugs more easily and with +-- The 'FlatTerm' form is very simple and internally mirrors the original +-- 'Encoding' type very carefully. The intention here is that once you +-- have 'Enc.Encoding' and 'Dec.Decoding' values for your types, you can +-- round-trip values through 'FlatTerm' to catch bugs more easily and with -- a smaller amount of code to look through. -- -- For that reason, this module is primarily useful for client libraries, @@ -36,6 +37,7 @@ , toFlatTerm -- :: Encoding -> FlatTerm , fromFlatTerm -- :: Decoder s a -> FlatTerm -> Either String a , validFlatTerm -- :: FlatTerm -> Bool + , decodeTermToken -- Decoder s TermToken ) where #include "cbor.h" @@ -43,6 +45,7 @@ import Codec.CBOR.Encoding (Encoding(..)) import qualified Codec.CBOR.Encoding as Enc import Codec.CBOR.Decoding as Dec +import qualified Codec.CBOR.Read as Read import qualified Codec.CBOR.ByteArray as BA import qualified Codec.CBOR.ByteArray.Sliced as BAS @@ -52,6 +55,9 @@ import GHC.Word (Word64(W64#)) import GHC.Exts (Word64#, Int64#) #endif +#if MIN_VERSION_ghc_prim(0,8,0) +import GHC.Exts (word8ToWord#) +#endif import GHC.Word (Word(W#), Word8(W8#)) import GHC.Exts (Int(I#), Int#, Word#, Float#, Double#) import GHC.Float (Float(F#), Double(D#), float2Double) @@ -60,19 +66,23 @@ import Data.Text (Text) import qualified Data.Text.Encoding as TE import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Control.Monad.ST +import qualified Control.Monad.ST.Lazy as ST.Lazy +import Prelude hiding (encodeFloat, decodeFloat) + -------------------------------------------------------------------------------- --- | A "flat" representation of an @'Enc.Encoding'@ value, +-- | A \"flat\" representation of an 'Enc.Encoding' value, -- useful for round-tripping and writing tests. -- -- @since 0.2.0.0 type FlatTerm = [TermToken] --- | A concrete encoding of @'Enc.Encoding'@ values, one --- which mirrors the original @'Enc.Encoding'@ type closely. +-- | A concrete encoding of 'Enc.Encoding' values, one +-- which mirrors the original 'Enc.Encoding' type closely. -- -- @since 0.2.0.0 data TermToken @@ -98,11 +108,11 @@ -------------------------------------------------------------------------------- --- | Convert an arbitrary @'Enc.Encoding'@ into a @'FlatTerm'@. +-- | Convert an arbitrary 'Enc.Encoding' into a 'FlatTerm'. -- -- @since 0.2.0.0 -toFlatTerm :: Encoding -- ^ The input @'Enc.Encoding'@. - -> FlatTerm -- ^ The resulting @'FlatTerm'@. +toFlatTerm :: Encoding -- ^ The input 'Enc.Encoding'. + -> FlatTerm -- ^ The resulting 'FlatTerm'. toFlatTerm (Encoding tb) = convFlatTerm (tb Enc.TkEnd) convFlatTerm :: Enc.Tokens -> FlatTerm @@ -141,17 +151,143 @@ convFlatTerm (Enc.TkFloat32 f ts) = TkFloat32 f : convFlatTerm ts convFlatTerm (Enc.TkFloat64 f ts) = TkFloat64 f : convFlatTerm ts convFlatTerm (Enc.TkBreak ts) = TkBreak : convFlatTerm ts +convFlatTerm (Enc.TkEncoded bs ts) = decodePreEncoded bs + ++ convFlatTerm ts convFlatTerm Enc.TkEnd = [] -------------------------------------------------------------------------------- --- | Given a @'Dec.Decoder'@, decode a @'FlatTerm'@ back into +decodePreEncoded :: BS.ByteString -> FlatTerm +decodePreEncoded bs0 = + ST.Lazy.runST (provideInput bs0) + where + provideInput :: BS.ByteString -> ST.Lazy.ST s FlatTerm + provideInput bs + | BS.null bs = return [] + | otherwise = do + next <- ST.Lazy.strictToLazyST $ do + -- This will always be a 'Partial' here because decodeTermToken + -- always starts by requesting initial input. Only decoders that + -- fail or return a value without looking at their input can give + -- a different initial result. + result <- Read.deserialiseIncremental decodeTermToken + let + k = + case result of + Read.Partial a -> a + _ -> error "Failed to get a Partial" + k (Just bs) + collectOutput next + + collectOutput :: Read.IDecode s TermToken -> ST.Lazy.ST s FlatTerm + collectOutput (Read.Fail _ _ err) = +#if MIN_VERSION_base(4,17,0) + error +#else + fail +#endif + + $ "toFlatTerm: encodePreEncoded " + ++ "used with invalid CBOR: " + ++ show err + collectOutput (Read.Partial k) = ST.Lazy.strictToLazyST (k Nothing) + >>= collectOutput + collectOutput (Read.Done bs' _ x) = do xs <- provideInput bs' + return (x : xs) + +decodeTermToken :: Decoder s TermToken +decodeTermToken = do + tkty <- peekTokenType + case tkty of + TypeUInt -> do w <- decodeWord + return $! fromWord w + where + fromWord :: Word -> TermToken + fromWord w + | w <= fromIntegral (maxBound :: Int) + = TkInt (fromIntegral w) + | otherwise = TkInteger (fromIntegral w) + + TypeUInt64 -> do w <- decodeWord64 + return $! fromWord64 w + where + fromWord64 w + | w <= fromIntegral (maxBound :: Int) + = TkInt (fromIntegral w) + | otherwise = TkInteger (fromIntegral w) + + TypeNInt -> do w <- decodeNegWord + return $! fromNegWord w + where + fromNegWord w + | w <= fromIntegral (maxBound :: Int) + = TkInt (-1 - fromIntegral w) + | otherwise = TkInteger (-1 - fromIntegral w) + + TypeNInt64 -> do w <- decodeNegWord64 + return $! fromNegWord64 w + where + fromNegWord64 w + | w <= fromIntegral (maxBound :: Int) + = TkInt (-1 - fromIntegral w) + | otherwise = TkInteger (-1 - fromIntegral w) + + TypeInteger -> do !x <- decodeInteger + return (TkInteger x) + TypeFloat16 -> do !x <- decodeFloat + return (TkFloat16 x) + TypeFloat32 -> do !x <- decodeFloat + return (TkFloat32 x) + TypeFloat64 -> do !x <- decodeDouble + return (TkFloat64 x) + + TypeBytes -> do !x <- decodeBytes + return (TkBytes x) + TypeBytesIndef -> do decodeBytesIndef + return TkBytesBegin + TypeString -> do !x <- decodeString + return (TkString x) + TypeStringIndef -> do decodeStringIndef + return TkStringBegin + + TypeListLen -> do !x <- decodeListLen + return $! TkListLen (fromIntegral x) + TypeListLen64 -> do !x <- decodeListLen + return $! TkListLen (fromIntegral x) + TypeListLenIndef -> do decodeListLenIndef + return TkListBegin + TypeMapLen -> do !x <- decodeMapLen + return $! TkMapLen (fromIntegral x) + TypeMapLen64 -> do !x <- decodeMapLen + return $! TkMapLen (fromIntegral x) + TypeMapLenIndef -> do decodeMapLenIndef + return TkMapBegin + + TypeTag -> do !x <- decodeTag + return $! TkTag (fromIntegral x) + TypeTag64 -> do !x <- decodeTag64 + return $! TkTag (fromIntegral x) + + TypeBool -> do !x <- decodeBool + return (TkBool x) + TypeNull -> do decodeNull + return TkNull + TypeSimple -> do !x <- decodeSimple + return (TkSimple x) + TypeBreak -> do _ <- decodeBreakOr + return TkBreak + TypeInvalid -> fail "invalid token encoding" + + +-------------------------------------------------------------------------------- + +-- | Given a 'Dec.Decoder', decode a 'FlatTerm' back into -- an ordinary value, or return an error. -- -- @since 0.2.0.0 fromFlatTerm :: (forall s. Decoder s a) - -- ^ A @'Dec.Decoder'@ for a serialised value. - -> FlatTerm -- ^ The serialised @'FlatTerm'@. + -- ^ A 'Dec.Decoder' for a serialised value. + -> FlatTerm -- ^ The serialised 'FlatTerm'. -> Either String a -- ^ The deserialised value, or an error. fromFlatTerm decoder ft = runST (getDecodeAction decoder >>= go ft) @@ -328,7 +464,15 @@ go ts@(tk:_) (PeekTokenType k) = k (tokenTypeOf tk) >>= go ts go ts (PeekTokenType _) = unexpected "peekTokenType" ts + + -- We don't have real bytes so we have to give these two operations + -- different interpretations: remaining tokens and just 0 for offsets. go ts (PeekAvailable k) = k (unI# (length ts)) >>= go ts +#if defined(ARCH_32bit) + go ts (PeekByteOffset k)= k (unI64# 0) >>= go ts +#else + go ts (PeekByteOffset k)= k 0# >>= go ts +#endif go _ (Fail msg) = return $ Left msg go [] (Done x) = return $ Right x @@ -415,37 +559,40 @@ unexpected name [] = return $ Left $ name ++ ": unexpected end of input" unexpected name (tok:_) = return $ Left $ name ++ ": unexpected token " ++ show tok --- | Map a @'TermToken'@ to the underlying CBOR @'TokenType'@ +-- | Map a 'TermToken' to the underlying CBOR 'TokenType' tokenTypeOf :: TermToken -> TokenType tokenTypeOf (TkInt n) - | n >= 0 = TypeUInt - | otherwise = TypeNInt -tokenTypeOf TkInteger{} = TypeInteger -tokenTypeOf TkBytes{} = TypeBytes -tokenTypeOf TkBytesBegin{} = TypeBytesIndef -tokenTypeOf TkString{} = TypeString -tokenTypeOf TkStringBegin{} = TypeStringIndef -tokenTypeOf TkListLen{} = TypeListLen -tokenTypeOf TkListBegin{} = TypeListLenIndef -tokenTypeOf TkMapLen{} = TypeMapLen -tokenTypeOf TkMapBegin{} = TypeMapLenIndef -tokenTypeOf TkTag{} = TypeTag -tokenTypeOf TkBool{} = TypeBool -tokenTypeOf TkNull = TypeNull -tokenTypeOf TkBreak = TypeBreak -tokenTypeOf TkSimple{} = TypeSimple -tokenTypeOf TkFloat16{} = TypeFloat16 -tokenTypeOf TkFloat32{} = TypeFloat32 -tokenTypeOf TkFloat64{} = TypeFloat64 + | n >= 0 = TypeUInt + | otherwise = TypeNInt +tokenTypeOf (TkInteger n) -- See https://github.com/well-typed/cborg/issues/324 + | 0 <= n && n <= 0xffffffffffffffff = TypeUInt64 -- 0xffffffffffffffff == 2^64 - 1 + | -0xffffffffffffffff <= n && n < 0 = TypeNInt64 + | otherwise = TypeInteger +tokenTypeOf TkBytes{} = TypeBytes +tokenTypeOf TkBytesBegin{} = TypeBytesIndef +tokenTypeOf TkString{} = TypeString +tokenTypeOf TkStringBegin{} = TypeStringIndef +tokenTypeOf TkListLen{} = TypeListLen +tokenTypeOf TkListBegin{} = TypeListLenIndef +tokenTypeOf TkMapLen{} = TypeMapLen +tokenTypeOf TkMapBegin{} = TypeMapLenIndef +tokenTypeOf TkTag{} = TypeTag +tokenTypeOf TkBool{} = TypeBool +tokenTypeOf TkNull = TypeNull +tokenTypeOf TkBreak = TypeBreak +tokenTypeOf TkSimple{} = TypeSimple +tokenTypeOf TkFloat16{} = TypeFloat16 +tokenTypeOf TkFloat32{} = TypeFloat32 +tokenTypeOf TkFloat64{} = TypeFloat64 -------------------------------------------------------------------------------- --- | Ensure a @'FlatTerm'@ is internally consistent and was created in a valid +-- | Ensure a 'FlatTerm' is internally consistent and was created in a valid -- manner. -- -- @since 0.2.0.0 -validFlatTerm :: FlatTerm -- ^ The input @'FlatTerm'@ - -> Bool -- ^ @'True'@ if valid, @'False'@ otherwise. +validFlatTerm :: FlatTerm -- ^ The input 'FlatTerm' + -> Bool -- ^ 'True' if valid, 'False' otherwise. validFlatTerm ts = either (const False) (const True) $ do ts' <- validateTerm TopLevelSingle ts @@ -454,7 +601,7 @@ _ -> Left "trailing data" -- | A data type used for tracking the position we're at --- as we traverse a @'FlatTerm'@ and make sure it's valid. +-- as we traverse a 'FlatTerm' and make sure it's valid. data Loc = TopLevelSingle | TopLevelSequence | InString Int Loc @@ -468,7 +615,7 @@ | InTagged Word64 Loc deriving Show --- | Validate an arbitrary @'FlatTerm'@ at an arbitrary location. +-- | Validate an arbitrary 'FlatTerm' at an arbitrary location. validateTerm :: Loc -> FlatTerm -> Either String FlatTerm validateTerm _loc (TkInt _ : ts) = return ts validateTerm _loc (TkInteger _ : ts) = return ts @@ -562,8 +709,8 @@ minInt32 = fromIntegral (minBound :: Int32) maxWord32 = fromIntegral (maxBound :: Word32) --- | Do a careful check to ensure an @'Int'@ is in the --- range of a @'Word32'@. +-- | Do a careful check to ensure an 'Int' is in the +-- range of a 'Word32'. intIsValidWord32 :: Int -> Bool intIsValidWord32 n = b1 && b2 where @@ -585,7 +732,11 @@ unW# (W# w#) = w# unW8# :: Word8 -> Word# +#if MIN_VERSION_ghc_prim(0,8,0) +unW8# (W8# w#) = word8ToWord# w# +#else unW8# (W8# w#) = w# +#endif unF# :: Float -> Float# unF# (F# f#) = f# diff --git a/src/Codec/CBOR/Magic.hs b/src/Codec/CBOR/Magic.hs --- a/src/Codec/CBOR/Magic.hs +++ b/src/Codec/CBOR/Magic.hs @@ -26,7 +26,7 @@ , grabWord32 -- :: Ptr () -> Word , grabWord64 -- :: Ptr () -> Word64 - -- * @'ByteString'@ utilities + -- * 'ByteString' utilities , eatTailWord8 -- :: ByteString -> Word , eatTailWord16 -- :: ByteString -> Word , eatTailWord32 -- :: ByteString -> Word @@ -48,12 +48,17 @@ -- int*ToInt conversions are missing because they are not needed. - , word8ToInt -- :: Int8 -> Int - , word16ToInt -- :: Int16 -> Int - , word32ToInt -- :: Int32 -> Int - , word64ToInt -- :: Int64 -> Int + , word8ToInt -- :: Word8 -> Int + , word16ToInt -- :: Word16 -> Int + , word32ToInt -- :: Word32 -> Int + , word64ToInt -- :: Word64 -> Int - , intToInt64 -- :: Int -> Int64 + , intToWord -- :: Int -> Word + , intToInt64 -- :: Int -> Int64 + + , intToWord64 -- :: Int -> Word64 + , int64ToWord64 -- :: Int64 -> Word64 + #if defined(ARCH_32bit) , word8ToInt64 -- :: Word8 -> Int64 , word16ToInt64 -- :: Word16 -> Int64 @@ -65,7 +70,7 @@ , word32ToWord64 -- :: Word32 -> Word64 #endif - -- * @'Integer'@ utilities + -- * 'Integer' utilities , nintegerFromBytes -- :: ByteString -> Integer , uintegerFromBytes -- :: ByteString -> Integer @@ -87,24 +92,31 @@ import GHC.IO (IO(IO), unsafeDupablePerformIO) import GHC.Word import GHC.Int +#if MIN_VERSION_base(4,11,0) +import GHC.Float (castWord32ToFloat, castWord64ToDouble) +#endif import Foreign.Ptr #if defined(OPTIMIZE_GMP) +#if defined(HAVE_GHC_BIGNUM) +import qualified GHC.Num.Integer as BigNum +#else import qualified GHC.Integer.GMP.Internals as Gmp #endif +#endif import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS -import Data.Primitive.ByteArray as Prim +import Data.Primitive.ByteArray as Prim hiding (copyByteArrayToPtr, copyPtrToMutableByteArray) import Foreign.ForeignPtr (withForeignPtr) import Foreign.C (CUShort) import qualified Numeric.Half as Half -#if !defined(HAVE_BYTESWAP_PRIMOPS) || !defined(MEM_UNALIGNED_OPS) +#if !defined(HAVE_BYTESWAP_PRIMOPS) || !defined(MEM_UNALIGNED_OPS) || !defined(OPTIMIZE_GMP) import Data.Bits ((.|.), unsafeShiftL) #endif @@ -117,19 +129,19 @@ -------------------------------------------------------------------------------- --- | Grab a 8-bit @'Word'@ given a @'Ptr'@ to some address. +-- | Grab a 8-bit 'Word' given a 'Ptr' to some address. grabWord8 :: Ptr () -> Word8 {-# INLINE grabWord8 #-} --- | Grab a 16-bit @'Word'@ given a @'Ptr'@ to some address. +-- | Grab a 16-bit 'Word' given a 'Ptr' to some address. grabWord16 :: Ptr () -> Word16 {-# INLINE grabWord16 #-} --- | Grab a 32-bit @'Word'@ given a @'Ptr'@ to some address. +-- | Grab a 32-bit 'Word' given a 'Ptr' to some address. grabWord32 :: Ptr () -> Word32 {-# INLINE grabWord32 #-} --- | Grab a 64-bit @'Word64'@ given a @'Ptr'@ to some address. +-- | Grab a 64-bit 'Word64' given a 'Ptr' to some address. grabWord64 :: Ptr () -> Word64 {-# INLINE grabWord64 #-} @@ -147,12 +159,21 @@ -- On x86 machines with GHC 7.10, we have byteswap primitives -- available to make this conversion very fast. +#if MIN_VERSION_ghc_prim(0,8,0) +grabWord16 (Ptr ip#) = W16# (wordToWord16# (byteSwap16# (word16ToWord# (indexWord16OffAddr# ip# 0#)))) +grabWord32 (Ptr ip#) = W32# (wordToWord32# (byteSwap32# (word32ToWord# (indexWord32OffAddr# ip# 0#)))) +#else grabWord16 (Ptr ip#) = W16# (narrow16Word# (byteSwap16# (indexWord16OffAddr# ip# 0#))) grabWord32 (Ptr ip#) = W32# (narrow32Word# (byteSwap32# (indexWord32OffAddr# ip# 0#))) +#endif #if defined(ARCH_64bit) +#if MIN_VERSION_base(4,17,0) +grabWord64 (Ptr ip#) = W64# (wordToWord64# (byteSwap# (word64ToWord# (indexWord64OffAddr# ip# 0#)))) +#else grabWord64 (Ptr ip#) = W64# (byteSwap# (indexWord64OffAddr# ip# 0#)) +#endif #else -grabWord64 (Ptr ip#) = W64# (byteSwap64# (indexWord64OffAddr# ip# 0#)) +grabWord64 (Ptr ip#) = W64# (byteSwap64# (word64ToWord# (indexWord64OffAddr# ip# 0#))) #endif #elif defined(MEM_UNALIGNED_OPS) && \ @@ -174,8 +195,14 @@ case indexWord8OffAddr# ip# 0# of w0# -> case indexWord8OffAddr# ip# 1# of - w1# -> W16# w0# `unsafeShiftL` 8 .|. - W16# w1# + w1# -> w16 w0# `unsafeShiftL` 8 .|. + w16 w1# + where +#if MIN_VERSION_ghc_prim(0,8,0) + w16 w# = W16# (wordToWord16# (word8ToWord# w#)) +#else + w16 w# = W16# w# +#endif grabWord32 (Ptr ip#) = case indexWord8OffAddr# ip# 0# of @@ -185,10 +212,16 @@ case indexWord8OffAddr# ip# 2# of w2# -> case indexWord8OffAddr# ip# 3# of - w3# -> W32# w0# `unsafeShiftL` 24 .|. - W32# w1# `unsafeShiftL` 16 .|. - W32# w2# `unsafeShiftL` 8 .|. - W32# w3# + w3# -> w32 w0# `unsafeShiftL` 24 .|. + w32 w1# `unsafeShiftL` 16 .|. + w32 w2# `unsafeShiftL` 8 .|. + w32 w3# + where +#if MIN_VERSION_ghc_prim(0,8,0) + w32 w# = W32# (wordToWord32# (word8ToWord# w#)) +#else + w32 w# = W32# w# +#endif grabWord64 (Ptr ip#) = case indexWord8OffAddr# ip# 0# of @@ -206,63 +239,75 @@ case indexWord8OffAddr# ip# 6# of w6# -> case indexWord8OffAddr# ip# 7# of - w7# -> w w0# `unsafeShiftL` 56 .|. - w w1# `unsafeShiftL` 48 .|. - w w2# `unsafeShiftL` 40 .|. - w w3# `unsafeShiftL` 32 .|. - w w4# `unsafeShiftL` 24 .|. - w w5# `unsafeShiftL` 16 .|. - w w6# `unsafeShiftL` 8 .|. - w w7# + w7# -> w64 w0# `unsafeShiftL` 56 .|. + w64 w1# `unsafeShiftL` 48 .|. + w64 w2# `unsafeShiftL` 40 .|. + w64 w3# `unsafeShiftL` 32 .|. + w64 w4# `unsafeShiftL` 24 .|. + w64 w5# `unsafeShiftL` 16 .|. + w64 w6# `unsafeShiftL` 8 .|. + w64 w7# where -#if defined(ARCH_64bit) - w w# = W64# w# +#if MIN_VERSION_ghc_prim(0,8,0) + toWord :: Word8# -> Word# + toWord w# = word8ToWord# w# #else - w w# = W64# (wordToWord64# w#) + toWord :: Word# -> Word# + toWord w# = w# #endif +#if WORD_SIZE_IN_BITS == 64 +#if MIN_VERSION_base(4,17,0) +-- case taken from Codec.CBOR.Decoding + w64 w# = W64# (wordToWord64# (toWord w#)) +#else + w64 w# = W64# (toWord w#) #endif +#else + w64 w# = W64# (wordToWord64# (toWord w#)) +#endif +#endif -------------------------------------------------------------------------------- -- ByteString shennanigans --- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the --- resulting byte(s) as an 8-bit word value. The input @'ByteString'@ MUST be at +-- | Take the tail of a 'ByteString' (i.e. drop the first byte) and read the +-- resulting byte(s) as an 8-bit word value. The input 'ByteString' MUST be at -- least 2 bytes long: one byte to drop from the front, and one to read as a --- @'Word'@ value. This is not checked, and failure to ensure this will result +-- 'Word' value. This is not checked, and failure to ensure this will result -- in undefined behavior. eatTailWord8 :: ByteString -> Word8 eatTailWord8 xs = withBsPtr grabWord8 (BS.unsafeTail xs) {-# INLINE eatTailWord8 #-} --- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the --- resulting byte(s) as a 16-bit word value. The input @'ByteString'@ MUST be at +-- | Take the tail of a 'ByteString' (i.e. drop the first byte) and read the +-- resulting byte(s) as a 16-bit word value. The input 'ByteString' MUST be at -- least 3 bytes long: one byte to drop from the front, and two to read as a --- 16-bit @'Word'@ value. This is not checked, and failure to ensure this will +-- 16-bit 'Word' value. This is not checked, and failure to ensure this will -- result in undefined behavior. eatTailWord16 :: ByteString -> Word16 eatTailWord16 xs = withBsPtr grabWord16 (BS.unsafeTail xs) {-# INLINE eatTailWord16 #-} --- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the --- resulting byte(s) as a 32-bit word value. The input @'ByteString'@ MUST be at +-- | Take the tail of a 'ByteString' (i.e. drop the first byte) and read the +-- resulting byte(s) as a 32-bit word value. The input 'ByteString' MUST be at -- least 5 bytes long: one byte to drop from the front, and four to read as a --- 32-bit @'Word'@ value. This is not checked, and failure to ensure this will +-- 32-bit 'Word' value. This is not checked, and failure to ensure this will -- result in undefined behavior. eatTailWord32 :: ByteString -> Word32 eatTailWord32 xs = withBsPtr grabWord32 (BS.unsafeTail xs) {-# INLINE eatTailWord32 #-} --- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the --- resulting byte(s) as a 64-bit word value. The input @'ByteString'@ MUST be at +-- | Take the tail of a 'ByteString' (i.e. drop the first byte) and read the +-- resulting byte(s) as a 64-bit word value. The input 'ByteString' MUST be at -- least 9 bytes long: one byte to drop from the front, and eight to read as a --- 64-bit @'Word64'@ value. This is not checked, and failure to ensure this will +-- 64-bit 'Word64' value. This is not checked, and failure to ensure this will -- result in undefined behavior. eatTailWord64 :: ByteString -> Word64 eatTailWord64 xs = withBsPtr grabWord64 (BS.unsafeTail xs) {-# INLINE eatTailWord64 #-} --- | Unsafely take a @'Ptr'@ to a @'ByteString'@ and do unholy things +-- | Unsafely take a 'Ptr' to a 'ByteString' and do unholy things -- with it. withBsPtr :: (Ptr b -> a) -> ByteString -> a withBsPtr f (BS.PS x off _) = @@ -273,7 +318,7 @@ -------------------------------------------------------------------------------- -- Half floats --- | Convert a @'Word16'@ to a half-sized @'Float'@. +-- | Convert a 'Word16' to a half-sized 'Float'. wordToFloat16 :: Word16 -> Float wordToFloat16 = \x -> Half.fromHalf (Half.Half (cast x)) where @@ -281,7 +326,7 @@ cast = fromIntegral {-# INLINE wordToFloat16 #-} --- | Convert a half-sized @'Float'@ to a @'Word'@. +-- | Convert a half-sized 'Float' to a 'Word'. floatToWord16 :: Float -> Word16 floatToWord16 = \x -> cast (Half.getHalf (Half.toHalf x)) where @@ -296,25 +341,23 @@ -- endian issues. A little endian machine cannot read a big-endian float direct -- from memory, so we read a word, bswap it and then convert to float. -- --- Currently there are no primops for casting word <-> float, see +-- Prior to base 4.11, there are no primops for casting word <-> float, see -- https://ghc.haskell.org/trac/ghc/ticket/4092 -- --- In this implementation, we're avoiding doing the extra indirection (and --- closure allocation) of the runSTRep stuff, but we have to be very careful --- here, we cannot allow the "constant" newByteArray# 8# realWorld# to be --- floated out and shared and aliased across multiple concurrent calls. So we --- do manual worker/wrapper with the worker not being inlined. +-- In our fallback implementation, we're avoiding doing the extra indirection +-- (and closure allocation) of the runSTRep stuff, but we have to be very +-- careful here, we cannot allow the "constant" newByteArray# 8# realWorld# to +-- be floated out and shared and aliased across multiple concurrent calls. +-- So we do manual worker/wrapper with the worker not being inlined. --- | Cast a @'Word32'@ to a @'Float'@. +-- | Cast a 'Word32' to a 'Float'. wordToFloat32 :: Word32 -> Float +#if MIN_VERSION_base(4,11,0) +wordToFloat32 = GHC.Float.castWord32ToFloat +#else wordToFloat32 (W32# w#) = F# (wordToFloat32# w#) {-# INLINE wordToFloat32 #-} --- | Cast a @'Word64'@ to a @'Float'@. -wordToFloat64 :: Word64 -> Double -wordToFloat64 (W64# w#) = D# (wordToFloat64# w#) -{-# INLINE wordToFloat64 #-} - -- | Cast an unboxed word to an unboxed float. wordToFloat32# :: Word# -> Float# wordToFloat32# w# = @@ -325,7 +368,16 @@ case readFloatArray# mba# 0# s'' of (# _, f# #) -> f# {-# NOINLINE wordToFloat32# #-} +#endif +-- | Cast a 'Word64' to a 'Float'. +wordToFloat64 :: Word64 -> Double +#if MIN_VERSION_base(4,11,0) +wordToFloat64 = GHC.Float.castWord64ToDouble +#else +wordToFloat64 (W64# w#) = D# (wordToFloat64# w#) +{-# INLINE wordToFloat64 #-} + -- | Cast an unboxed word to an unboxed double. #if defined(ARCH_64bit) wordToFloat64# :: Word# -> Double# @@ -340,6 +392,7 @@ case readDoubleArray# mba# 0# s'' of (# _, f# #) -> f# {-# NOINLINE wordToFloat64# #-} +#endif -------------------------------------------------------------------------------- -- Casting words and ints @@ -377,6 +430,35 @@ intToInt64 = fromIntegral {-# INLINE intToInt64 #-} +intToWord :: Int -> Word +intToWord = fromIntegral +{-# INLINE intToWord #-} + +intToWord64 :: Int -> Word64 +intToWord64 = fromIntegral +{-# INLINE intToWord64 #-} + +int64ToWord64 :: Int64 -> Word64 +int64ToWord64 = fromIntegral +{-# INLINE int64ToWord64 #-} + +#if MIN_VERSION_ghc_prim(0,8,0) +word8ToWord (W8# w#) = W# (word8ToWord# w#) +word16ToWord (W16# w#) = W# (word16ToWord# w#) +word32ToWord (W32# w#) = W# (word32ToWord# w#) +#if defined(ARCH_64bit) +#if MIN_VERSION_base(4,17,0) +word64ToWord (W64# w#) = W# (word64ToWord# w#) +#else +word64ToWord (W64# w#) = W# w# +#endif +#else +word64ToWord (W64# w64#) = + case isTrue# (w64# `leWord64#` wordToWord64# 0xffffffff##) of + True -> Just (W# (word64ToWord# w64#)) + False -> Nothing +#endif +#else word8ToWord (W8# w#) = W# w# word16ToWord (W16# w#) = W# w# word32ToWord (W32# w#) = W# w# @@ -388,12 +470,25 @@ True -> Just (W# (word64ToWord# w64#)) False -> Nothing #endif +#endif {-# INLINE word8ToWord #-} {-# INLINE word16ToWord #-} {-# INLINE word32ToWord #-} {-# INLINE word64ToWord #-} +#if MIN_VERSION_ghc_prim(0,8,0) +word8ToInt (W8# w#) = I# (word2Int# (word8ToWord# w#)) +word16ToInt (W16# w#) = I# (word2Int# (word16ToWord# w#)) +#if defined(ARCH_64bit) +word32ToInt (W32# w#) = I# (word2Int# (word32ToWord# w#)) +#else +word32ToInt (W32# w#) = + case isTrue# (w# `ltWord#` 0x80000000##) of + True -> Just (I# (word2Int# (word32ToWord# w#))) + False -> Nothing +#endif +#else word8ToInt (W8# w#) = I# (word2Int# w#) word16ToInt (W16# w#) = I# (word2Int# w#) @@ -405,11 +500,22 @@ True -> Just (I# (word2Int# w#)) False -> Nothing #endif +#endif #if defined(ARCH_64bit) word64ToInt (W64# w#) = +#if MIN_VERSION_base(4,17,0) + case isTrue# (word64ToWord# w# `ltWord#` 0x8000000000000000##) of +#else case isTrue# (w# `ltWord#` 0x8000000000000000##) of - True -> Just (I# (word2Int# w#)) +#endif + True -> +#if MIN_VERSION_base(4,17,0) + Just (I# (word2Int# (word64ToWord# w#))) + +#else + Just (I# (word2Int# w#)) +#endif False -> Nothing #else word64ToInt (W64# w#) = @@ -449,11 +555,11 @@ -------------------------------------------------------------------------------- -- Integer utilities --- | Create a negative @'Integer'@ out of a raw @'BS.ByteString'@. +-- | Create a negative 'Integer' out of a raw 'BS.ByteString'. nintegerFromBytes :: BS.ByteString -> Integer nintegerFromBytes bs = -1 - uintegerFromBytes bs --- | Create an @'Integer'@ out of a raw @'BS.ByteString'@. +-- | Create an 'Integer' out of a raw 'BS.ByteString'. uintegerFromBytes :: BS.ByteString -> Integer #if defined(OPTIMIZE_GMP) @@ -466,8 +572,13 @@ let addrOff# = addr# `plusAddr#` off# -- The last parmaeter (`1#`) tells the import function to use big -- endian encoding. - in Gmp.importIntegerFromAddr addrOff# (int2Word# len#) 1# + in +#if defined(HAVE_GHC_BIGNUM) + BigNum.integerFromAddr (int2Word# len#) addrOff# 1# #else + Gmp.importIntegerFromAddr addrOff# (int2Word# len#) 1# +#endif +#else uintegerFromBytes bs = case BS.uncons bs of Nothing -> 0 @@ -483,11 +594,11 @@ -- Mutable counters -- | An efficient, mutable counter. Designed to be used inside --- @'ST'@ or other primitive monads, hence it carries an abstract +-- 'ST' or other primitive monads, hence it carries an abstract -- rank-2 @s@ type parameter. data Counter s = Counter (MutableByteArray# s) --- | Create a new counter with a starting @'Int'@ value. +-- | Create a new counter with a starting 'Int' value. newCounter :: Int -> ST s (Counter s) newCounter (I# n#) = ST (\s -> @@ -497,7 +608,7 @@ s'' -> (# s'', Counter mba# #)) {-# INLINE newCounter #-} --- | Read the current value of a @'Counter'@. +-- | Read the current value of a 'Counter'. readCounter :: Counter s -> ST s Int readCounter (Counter mba#) = ST (\s -> @@ -505,7 +616,7 @@ (# s', n# #) -> (# s', I# n# #)) {-# INLINE readCounter #-} --- | Write a new value into the @'Counter'@. +-- | Write a new value into the 'Counter'. writeCounter :: Counter s -> Int -> ST s () writeCounter (Counter mba#) (I# n#) = ST (\s -> @@ -513,14 +624,14 @@ s' -> (# s', () #)) {-# INLINE writeCounter #-} --- | Increment a @'Counter'@ by one. +-- | Increment a 'Counter' by one. incCounter :: Counter s -> ST s () incCounter c = do x <- readCounter c writeCounter c (x+1) {-# INLINE incCounter #-} --- | Decrement a @'Counter'@ by one. +-- | Decrement a 'Counter' by one. decCounter :: Counter s -> ST s () decCounter c = do x <- readCounter c @@ -530,7 +641,7 @@ -------------------------------------------------------------------------------- -- Array support --- | Copy a @'BS.ByteString'@ and create a primitive @'Prim.ByteArray'@ from it. +-- | Copy a 'BS.ByteString' and create a primitive 'Prim.ByteArray' from it. copyByteStringToByteArray :: BS.ByteString -> Prim.ByteArray copyByteStringToByteArray (BS.PS fp off len) = unsafeDupablePerformIO $ @@ -542,12 +653,12 @@ -- TODO FIXME: can do better here: can do non-copying for larger pinned arrays -- or copy directly into the builder buffer --- | Copy a @'Prim.ByteArray'@ at a certain offset and length into a --- @'BS.ByteString'@. +-- | Copy a 'Prim.ByteArray' at a certain offset and length into a +-- 'BS.ByteString'. copyByteArrayToByteString :: Prim.ByteArray - -- ^ @'Prim.ByteArray'@ to copy from. + -- ^ 'Prim.ByteArray' to copy from. -> Int - -- ^ Offset into the @'Prim.ByteArray'@ to start with. + -- ^ Offset into the 'Prim.ByteArray' to start with. -> Int -- ^ Length of the data to copy. -> BS.ByteString @@ -558,11 +669,11 @@ copyByteArrayToPtr ba off ptr len return (BS.PS fp 0 len) --- | Copy the data pointed to by a @'Ptr'@ into a @'MutableByteArray'. +-- | Copy the data pointed to by a 'Ptr' into a @'MutableByteArray'. copyPtrToMutableByteArray :: Ptr a - -- ^ @'Ptr'@ to buffer to copy from. + -- ^ 'Ptr' to buffer to copy from. -> MutableByteArray RealWorld - -- ^ @'MutableByteArray'@ to copy into. + -- ^ 'MutableByteArray' to copy into. -> Int -- ^ Offset to start copying from. -> Int @@ -573,11 +684,11 @@ case copyAddrToByteArray# addr# mba# off# len# s of s' -> (# s', () #)) --- | Copy a @'ByteArray'@ into a @'Ptr'@ with a given offset and length. +-- | Copy a 'ByteArray' into a 'Ptr' with a given offset and length. copyByteArrayToPtr :: ByteArray - -- ^ @'ByteArray'@ to copy. + -- ^ 'ByteArray' to copy. -> Int - -- ^ Offset into the @'ByteArray'@ of where to start copying. + -- ^ Offset into the 'ByteArray' of where to start copying. -> Ptr a -- ^ Pointer to destination buffer. -> Int diff --git a/src/Codec/CBOR/Pretty.hs b/src/Codec/CBOR/Pretty.hs --- a/src/Codec/CBOR/Pretty.hs +++ b/src/Codec/CBOR/Pretty.hs @@ -28,11 +28,13 @@ import qualified Data.ByteString as S import qualified Data.Text as T +import Codec.CBOR.ByteArray.Sliced import Codec.CBOR.Encoding import Codec.CBOR.Write import qualified Control.Monad.Fail as Fail import Control.Monad (replicateM_) +import GHC.Int (Int64) import Numeric #if !MIN_VERSION_base(4,8,0) import Control.Applicative @@ -42,7 +44,7 @@ newtype PP a = PP (Tokens -> Int -> ShowS -> Either String (Tokens,Int,ShowS,a)) --- | Pretty prints an @'Encoding'@ in an annotated, hexadecimal format +-- | Pretty prints an 'Encoding' in an annotated, hexadecimal format -- that maps CBOR values to their types. The output format is similar -- to the format used on http://cbor.me/. -- @@ -103,7 +105,9 @@ Right (toks', ind', ss', x) -> let PP g' = g x in g' toks' ind' ss' return = pure +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif instance Fail.MonadFail PP where fail s = PP $ \_ _ _ -> Left s @@ -159,49 +163,98 @@ hexRep term str " " case term of - TkInt i TkEnd -> ppTkInt i - TkInteger i TkEnd -> ppTkInteger i - TkWord w TkEnd -> ppTkWord w - TkBytes bs TkEnd -> ppTkBytes bs - TkBytesBegin TkEnd -> ppTkBytesBegin - TkString t TkEnd -> ppTkString t - TkStringBegin TkEnd -> ppTkStringBegin - TkListLen w TkEnd -> ppTkListLen w - TkListBegin TkEnd -> ppTkListBegin - TkMapLen w TkEnd -> ppTkMapLen w - TkMapBegin TkEnd -> ppTkMapBegin - TkBreak TkEnd -> ppTkBreak - TkTag w TkEnd -> ppTkTag w - TkBool b TkEnd -> ppTkBool b - TkNull TkEnd -> ppTkNull - TkSimple w TkEnd -> ppTkSimple w - TkFloat16 f TkEnd -> ppTkFloat16 f - TkFloat32 f TkEnd -> ppTkFloat32 f - TkFloat64 f TkEnd -> ppTkFloat64 f - TkEnd -> str "# End of input" - _ -> fail $ unwords ["pprint: Unexpected token:", show term] + TkInt i TkEnd -> ppTkInt i + TkInt _ _ -> termFailure term + TkInt64 i TkEnd -> ppTkInt64 i + TkInt64 _ _ -> termFailure term + TkInteger i TkEnd -> ppTkInteger i + TkInteger _ _ -> termFailure term + TkWord64 w TkEnd -> ppTkWord64 w + TkWord64 _ _ -> termFailure term + TkWord w TkEnd -> ppTkWord w + TkWord _ _ -> termFailure term + TkBytes bs TkEnd -> ppTkBytes bs + TkBytes _ _ -> termFailure term + TkBytesBegin TkEnd -> ppTkBytesBegin + TkBytesBegin _ -> termFailure term + TkByteArray ba TkEnd -> ppTkByteArray ba + TkByteArray _ _ -> termFailure term + TkUtf8ByteArray ba TkEnd -> ppTkUtf8ByteArray ba + TkUtf8ByteArray _ _ -> termFailure term + TkString t TkEnd -> ppTkString t + TkString _ _ -> termFailure term + TkStringBegin TkEnd -> ppTkStringBegin + TkStringBegin _ -> termFailure term + TkListLen w TkEnd -> ppTkListLen w + TkListLen _ _ -> termFailure term + TkListBegin TkEnd -> ppTkListBegin + TkListBegin _ -> termFailure term + TkMapLen w TkEnd -> ppTkMapLen w + TkMapLen _ _ -> termFailure term + TkMapBegin TkEnd -> ppTkMapBegin + TkMapBegin _ -> termFailure term + TkBreak TkEnd -> ppTkBreak + TkBreak _ -> termFailure term + TkTag w TkEnd -> ppTkTag w + TkTag _ _ -> termFailure term + TkTag64 w TkEnd -> ppTkTag64 w + TkTag64 _ _ -> termFailure term + TkBool b TkEnd -> ppTkBool b + TkBool _ _ -> termFailure term + TkNull TkEnd -> ppTkNull + TkNull _ -> termFailure term + TkUndef TkEnd -> ppTkUndef + TkUndef _ -> termFailure term + TkSimple w TkEnd -> ppTkSimple w + TkSimple _ _ -> termFailure term + TkFloat16 f TkEnd -> ppTkFloat16 f + TkFloat16 _ _ -> termFailure term + TkFloat32 f TkEnd -> ppTkFloat32 f + TkFloat32 _ _ -> termFailure term + TkFloat64 f TkEnd -> ppTkFloat64 f + TkFloat64 _ _ -> termFailure term + TkEncoded _ TkEnd -> ppTkEncoded + TkEncoded _ _ -> termFailure term + TkEnd -> str "# End of input" + where + termFailure t = fail $ unwords ["pprint: Unexpected token:", show t] ppTkInt :: Int -> PP () ppTkInt i = str "# int" >> parens (shown i) +ppTkInt64 :: Int64 -> PP () +ppTkInt64 i = str "# int" >> parens (shown i) + ppTkInteger :: Integer -> PP () ppTkInteger i = str "# integer" >> parens (shown i) +ppTkWord64 :: Word64 -> PP () +ppTkWord64 w = str "# word" >> parens (shown w) + ppTkWord :: Word -> PP () ppTkWord w = str "# word" >> parens (shown w) +ppTkByteArray :: SlicedByteArray -> PP () +ppTkByteArray bs = str "# bytes" >> parens (shown $ sizeofSlicedByteArray bs) + +ppTkUtf8ByteArray :: SlicedByteArray -> PP () +ppTkUtf8ByteArray bs = str "# text" >> parens (shown $ sizeofSlicedByteArray bs) + ppTkBytes :: S.ByteString -> PP () ppTkBytes bs = str "# bytes" >> parens (shown (S.length bs)) ppTkBytesBegin :: PP () ppTkBytesBegin = str "# bytes(*)" >> inc 3 >> indef pprint -ppTkString :: T.Text -> PP () +ppTkString :: T.Text -> PP () ppTkString t = str "# text" >> parens (shown t) ppTkStringBegin:: PP () ppTkStringBegin = str "# text(*)" >> inc 3 >> indef pprint +ppTkEncoded :: PP () +ppTkEncoded = str "# pre-encoded CBOR term" + ppTkListLen :: Word -> PP () ppTkListLen n = do str "# list" @@ -244,7 +297,7 @@ ppTkBreak :: PP () ppTkBreak = str "# break" -ppTkTag :: Word -> PP () +ppTkTag :: Word -> PP () ppTkTag w = do str "# tag" parens (shown w) @@ -252,6 +305,14 @@ pprint dec 3 +ppTkTag64 :: Word64 -> PP () +ppTkTag64 w = do + str "# tag" + parens (shown w) + inc 3 + pprint + dec 3 + ppTkBool :: Bool -> PP () ppTkBool True = str "# bool" >> parens (str "true") ppTkBool False = str "# bool" >> parens (str "false") @@ -259,6 +320,9 @@ ppTkNull :: PP () ppTkNull = str "# null" +ppTkUndef :: PP () +ppTkUndef = str "# undefined" + ppTkSimple :: Word8 -> PP () ppTkSimple w = str "# simple" >> parens (shown w) @@ -297,6 +361,7 @@ unconsToken (TkFloat16 f16 tks) = Just (TkFloat16 f16 TkEnd,tks) unconsToken (TkFloat32 f32 tks) = Just (TkFloat32 f32 TkEnd,tks) unconsToken (TkFloat64 f64 tks) = Just (TkFloat64 f64 TkEnd,tks) +unconsToken (TkEncoded bs tks) = Just (TkEncoded bs TkEnd,tks) unconsToken (TkBreak tks) = Just (TkBreak TkEnd,tks) hexRep :: Tokens -> PP () diff --git a/src/Codec/CBOR/Read.hs b/src/Codec/CBOR/Read.hs --- a/src/Codec/CBOR/Read.hs +++ b/src/Codec/CBOR/Read.hs @@ -9,9 +9,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +#if __GLASGOW_HASKELL__ < 900 -- Bump up from the default 1.5, otherwise our decoder fast path is no good. -- We went over the threshold when we switched to using ST. +-- +-- However, this flag is not supported on GHC 9.0 and later and eye-balling the +-- Core suggests that the new inlining heuristics don't require it. {-# OPTIONS_GHC -funfolding-keeness-factor=2.0 #-} +#endif -- | -- Module : Codec.CBOR.Read @@ -99,8 +104,8 @@ -- of type @a@. data IDecode s a = -- | The decoder has consumed the available input and needs more - -- to continue. Provide @'Just'@ if more input is available and - -- @'Nothing'@ otherwise, and you will get a new @'IDecode'@. + -- to continue. Provide 'Just' if more input is available and + -- 'Nothing' otherwise, and you will get a new 'IDecode'. Partial (Maybe BS.ByteString -> ST s (IDecode s a)) -- | The decoder has successfully finished. Except for the output @@ -109,14 +114,14 @@ | Done !BS.ByteString {-# UNPACK #-} !ByteOffset a -- | The decoder ran into an error. The decoder either used - -- @'fail'@ or was not provided enough input. Contains any + -- 'fail' or was not provided enough input. Contains any -- unconsumed input, the number of bytes consumed, and a - -- @'DeserialiseFailure'@ exception describing the reason why the + -- 'DeserialiseFailure' exception describing the reason why the -- failure occurred. | Fail !BS.ByteString {-# UNPACK #-} !ByteOffset DeserialiseFailure --- | Given a @'Decoder'@ and some @'LBS.ByteString'@ representing --- an encoded CBOR value, return @'Either'@ the decoded CBOR value +-- | Given a 'Decoder' and some 'LBS.ByteString' representing +-- an encoded CBOR value, return 'Either' the decoded CBOR value -- or an error. In addition to the decoded value return any remaining input -- content. -- @@ -128,8 +133,8 @@ fmap f $ runIDecode (deserialiseIncremental d) lbs where f (rest, _, x) = (rest, x) --- | Given a @'Decoder'@ and some @'LBS.ByteString'@ representing --- an encoded CBOR value, return @'Either'@ the decoded CBOR value +-- | Given a 'Decoder' and some 'LBS.ByteString' representing +-- an encoded CBOR value, return 'Either' the decoded CBOR value -- or an error. In addition to the decoded value return any remaining input -- content and the number of bytes consumed. -- @@ -157,7 +162,7 @@ go LBS.Empty (Partial k) = k Nothing >>= go LBS.Empty go (LBS.Chunk bs lbs') (Partial k) = k (Just bs) >>= go lbs' --- | Run a @'Decoder'@ incrementally, returning a continuation +-- | Run a 'Decoder' incrementally, returning a continuation -- representing the result of the incremental decode. -- -- @since 0.2.0.0 @@ -170,9 +175,6 @@ -- A monad for building incremental decoders -- --- | Simple alias for @'Int64'@, used to make types more descriptive. -type ByteOffset = Int64 - newtype IncrementalDecoder s a = IncrementalDecoder { unIncrementalDecoder :: forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r) @@ -245,6 +247,11 @@ | SlowConsumeTokenByteArray {-# UNPACK #-} !ByteString (BA.ByteArray -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int | SlowConsumeTokenString {-# UNPACK #-} !ByteString (T.Text -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int | SlowConsumeTokenUtf8ByteArray {-# UNPACK #-} !ByteString (BA.ByteArray -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int +#if defined(ARCH_32bit) + | SlowPeekByteOffset {-# UNPACK #-} !ByteString (Int64# -> ST s (DecodeAction s a)) +#else + | SlowPeekByteOffset {-# UNPACK #-} !ByteString (Int# -> ST s (DecodeAction s a)) +#endif | SlowDecodeAction {-# UNPACK #-} !ByteString (DecodeAction s a) | SlowFail {-# UNPACK #-} !ByteString String @@ -350,32 +357,32 @@ go_fast !bs da@(ConsumeWordCanonical k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz w@(W# w#) + | isWordCanonical sz w -> k w# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeWord8Canonical k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (W# w#) -> + DecodedToken sz w@(W# w#) -> case gtWord# w# 0xff## of - 0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + 0# | isWordCanonical sz w -> k w# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da go_fast !bs da@(ConsumeWord16Canonical k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (W# w#) -> + DecodedToken sz w@(W# w#) -> case gtWord# w# 0xffff## of - 0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + 0# | isWordCanonical sz w -> k w# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da go_fast !bs da@(ConsumeWord32Canonical k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (W# w#) -> + DecodedToken sz w@(W# w#) -> case w_out_of_range w# of - 0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + 0# | isWordCanonical sz w -> k w# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da where w_out_of_range :: Word# -> Int# @@ -389,39 +396,39 @@ go_fast !bs da@(ConsumeNegWordCanonical k) = case tryConsumeNegWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz w@(W# w#) + | isWordCanonical sz w -> k w# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeIntCanonical k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (I# n#) - | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz n@(I# n#) + | isIntCanonical sz n -> k n# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeInt8Canonical k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (I# n#) -> + DecodedToken sz n@(I# n#) -> case (n# ># 0x7f#) `orI#` (n# <# -0x80#) of - 0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs) + 0# | isIntCanonical sz n -> k n# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da go_fast !bs da@(ConsumeInt16Canonical k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (I# n#) -> + DecodedToken sz n@(I# n#) -> case (n# ># 0x7fff#) `orI#` (n# <# -0x8000#) of - 0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs) + 0# | isIntCanonical sz n -> k n# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da go_fast !bs da@(ConsumeInt32Canonical k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (I# n#) -> + DecodedToken sz n@(I# n#) -> case n_out_of_range n# of - 0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs) + 0# | isIntCanonical sz n -> k n# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da where n_out_of_range :: Int# -> Int# @@ -435,24 +442,24 @@ go_fast !bs da@(ConsumeListLenCanonical k) = case tryConsumeListLen (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (I# n#) - -- List length can't be negative, cast it to Word#. - | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz n@(I# n#) + -- List length can't be negative, cast it to Word. + | isWordCanonical sz (intToWord n) -> k n# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeMapLenCanonical k) = case tryConsumeMapLen (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (I# n#) - -- Map length can't be negative, cast it to Word#. - | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs) - | otherwise -> go_fast_end bs da + DecodedToken sz n@(I# n#) + -- Map length can't be negative, cast it to Word. + | isWordCanonical sz (intToWord n) -> k n# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeTagCanonical k) = case tryConsumeTag (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz w@(W# w#) + | isWordCanonical sz w -> k w# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da #if defined(ARCH_32bit) @@ -489,45 +496,45 @@ go_fast !bs da@(ConsumeWord64Canonical k) = case tryConsumeWord64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (W64# w#) - | isWord64Canonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz w@(W64# w#) + | isWord64Canonical sz w -> k w# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeNegWord64Canonical k) = case tryConsumeNegWord64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (W64# w#) - | isWord64Canonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz w@(W64# w#) + | isWord64Canonical sz w -> k w# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeInt64Canonical k) = case tryConsumeInt64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (I64# i#) - | isInt64Canonical sz i# -> k i# >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz i@(I64# i#) + | isInt64Canonical sz i -> k i# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeListLen64Canonical k) = case tryConsumeListLen64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (I64# i#) + DecodedToken sz i@(I64# i#) -- List length can't be negative, cast it to Word64#. - | isWord64Canonical sz (int64ToWord64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs) - | otherwise -> go_fast_end bs da + | isWord64Canonical sz (int64ToWord64 i) -> k i# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeMapLen64Canonical k) = case tryConsumeMapLen64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (I64# i#) + DecodedToken sz i@(I64# i#) -- Map length can't be negative, cast it to Word64#. - | isWord64Canonical sz (int64ToWord64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs) - | otherwise -> go_fast_end bs da + | isWord64Canonical sz (int64ToWord64 i) -> k i# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeTag64Canonical k) = case tryConsumeTag64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (W64# w#) - | isWord64Canonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz w@(W64# w#) + | isWord64Canonical sz w -> k w# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da #endif @@ -596,9 +603,9 @@ go_fast !bs da@(ConsumeFloat16Canonical k) = case tryConsumeFloat (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (F# f#) - | isFloat16Canonical sz -> k f# >>= go_fast (BS.unsafeDrop sz bs) - | otherwise -> go_fast_end bs da + DecodedToken sz f@(F# f#) + | isFloat16Canonical sz bs f -> k f# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeFloatCanonical k) = case tryConsumeFloat (BS.unsafeHead bs) bs of @@ -650,8 +657,8 @@ case tryConsumeSimple (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) - | otherwise -> go_fast_end bs da + | isSimpleCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeBytesIndef k) = case tryConsumeBytesIndef (BS.unsafeHead bs) of @@ -700,6 +707,7 @@ go_fast !bs (PeekAvailable k) = k (case BS.length bs of I# len# -> len#) >>= go_fast bs +go_fast !bs da@PeekByteOffset{} = go_fast_end bs da go_fast !bs da@D.Fail{} = go_fast_end bs da go_fast !bs da@D.Done{} = go_fast_end bs da @@ -719,6 +727,8 @@ go_fast_end !bs (D.Done x) = return $! FastDone bs x go_fast_end !bs (PeekAvailable k) = k (case BS.length bs of I# len# -> len#) >>= go_fast_end bs +go_fast_end !bs (PeekByteOffset k) = return $! SlowPeekByteOffset bs k + -- the next two cases only need the 1 byte token header go_fast_end !bs da | BS.null bs = return $! SlowDecodeAction bs da @@ -828,31 +838,31 @@ go_fast_end !bs (ConsumeWordCanonical k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word" - DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz w@(W# w#) + | isWordCanonical sz w -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical word" go_fast_end !bs (ConsumeWord8Canonical k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word8" - DecodedToken sz (W# w#) -> case gtWord# w# 0xff## of - 0# | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz w@(W# w#) -> case gtWord# w# 0xff## of + 0# | isWordCanonical sz w -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical word8" _ -> return $! SlowFail bs "expected word8" go_fast_end !bs (ConsumeWord16Canonical k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word16" - DecodedToken sz (W# w#) -> case gtWord# w# 0xffff## of - 0# | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz w@(W# w#) -> case gtWord# w# 0xffff## of + 0# | isWordCanonical sz w -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical word16" _ -> return $! SlowFail bs "expected word16" go_fast_end !bs (ConsumeWord32Canonical k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word32" - DecodedToken sz (W# w#) -> case w_out_of_range w# of - 0# | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz w@(W# w#) -> case w_out_of_range w# of + 0# | isWordCanonical sz w -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical word32" _ -> return $! SlowFail bs "expected word32" where @@ -867,41 +877,41 @@ go_fast_end !bs (ConsumeNegWordCanonical k) = case tryConsumeNegWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected negative int" - DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz w@(W# w#) + | isWordCanonical sz w -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical negative int" go_fast_end !bs (ConsumeIntCanonical k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected int" - DecodedToken sz (I# n#) - | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz n@(I# n#) + | isIntCanonical sz n -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical int" go_fast_end !bs (ConsumeInt8Canonical k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected int8" - DecodedToken sz (I# n#) -> + DecodedToken sz n@(I# n#) -> case (n# ># 0x7f#) `orI#` (n# <# -0x80#) of - 0# | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + 0# | isIntCanonical sz n -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical int8" _ -> return $! SlowFail bs "expected int8" go_fast_end !bs (ConsumeInt16Canonical k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected int16" - DecodedToken sz (I# n#) -> + DecodedToken sz n@(I# n#) -> case (n# ># 0x7fff#) `orI#` (n# <# -0x8000#) of - 0# | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + 0# | isIntCanonical sz n -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical int16" _ -> return $! SlowFail bs "expected int16" go_fast_end !bs (ConsumeInt32Canonical k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected int32" - DecodedToken sz (I# n#) -> + DecodedToken sz n@(I# n#) -> case n_out_of_range n# of - 0# | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + 0# | isIntCanonical sz n -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical int32" _ -> return $! SlowFail bs "expected int32" where @@ -916,24 +926,24 @@ go_fast_end !bs (ConsumeListLenCanonical k) = case tryConsumeListLen (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected list len" - DecodedToken sz (I# n#) + DecodedToken sz n@(I# n#) -- List length can't be negative, cast it to Word#. - | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) - | otherwise -> return $! SlowFail bs "non-canonical list len" + | isWordCanonical sz (intToWord n) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical list len" go_fast_end !bs (ConsumeMapLenCanonical k) = case tryConsumeMapLen (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected map len" - DecodedToken sz (I# n#) + DecodedToken sz n@(I# n#) -- Map length can't be negative, cast it to Word#. - | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) - | otherwise -> return $! SlowFail bs "non-canonical map len" + | isWordCanonical sz (intToWord n) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical map len" go_fast_end !bs (ConsumeTagCanonical k) = case tryConsumeTag (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected tag" - DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz w@(W# w#) + | isWordCanonical sz w -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical tag" #if defined(ARCH_32bit) @@ -970,30 +980,30 @@ go_fast_end !bs (ConsumeWord64Canonical k) = case tryConsumeWord64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word64" - DecodedToken sz (W64# w#) - | isWord64Canonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz w@(W64# w#) + | isWord64Canonical sz w -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical word64" go_fast_end !bs (ConsumeNegWord64Canonical k) = case tryConsumeNegWord64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected negative int" - DecodedToken sz (W64# w#) - | isWord64Canonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz w@(W64# w#) + | isWord64Canonical sz w -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical negative int" go_fast_end !bs (ConsumeInt64Canonical k) = case tryConsumeInt64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected int64" - DecodedToken sz (I64# i#) - | isInt64Canonical sz i# -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz i@(I64# i#) + | isInt64Canonical sz i -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical int64" go_fast_end !bs (ConsumeListLen64Canonical k) = case tryConsumeListLen64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected list len 64" - DecodedToken sz (I64# i#) + DecodedToken sz i@(I64# i#) -- List length can't be negative, cast it to Word64#. - | isWord64Canonical sz (int64ToWord64# i#) -> + | isWord64Canonical sz (int64ToWord64 i) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical list len 64" @@ -1001,9 +1011,9 @@ go_fast_end !bs (ConsumeMapLen64Canonical k) = case tryConsumeMapLen64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected map len 64" - DecodedToken sz (I64# i#) + DecodedToken sz i@(I64# i#) -- Map length can't be negative, cast it to Word64#. - | isWord64Canonical sz (int64ToWord64# i#) -> + | isWord64Canonical sz (int64ToWord64 i) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical map len 64" @@ -1011,8 +1021,8 @@ go_fast_end !bs (ConsumeTag64Canonical k) = case tryConsumeTag64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected tag64" - DecodedToken sz (W64# w#) - | isWord64Canonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz w@(W64# w#) + | isWord64Canonical sz w -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical tag64" #endif @@ -1095,9 +1105,9 @@ go_fast_end !bs (ConsumeFloat16Canonical k) = case tryConsumeFloat (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected float" - DecodedToken sz (F# f#) - | isFloat16Canonical sz -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) - | otherwise -> return $! SlowFail bs "non-canonical float16" + DecodedToken sz f@(F# f#) + | isFloat16Canonical sz bs f -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical float16" go_fast_end !bs (ConsumeFloatCanonical k) = case tryConsumeFloat (BS.unsafeHead bs) bs of @@ -1156,8 +1166,8 @@ case tryConsumeSimple (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected simple" DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) - | otherwise -> return $! SlowFail bs "non-canonical simple" + | isSimpleCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical simple" go_fast_end !bs (ConsumeBytesIndef k) = case tryConsumeBytesIndef (BS.unsafeHead bs) of @@ -1259,6 +1269,18 @@ where !offset' = offset + intToInt64 (BS.length bs - BS.length bs') + SlowPeekByteOffset bs' k -> + lift +#if MIN_VERSION_base(4,17,0) + (k (int64ToInt# off#)) +#else + (k off#) + +#endif + >>= \daz -> go_slow daz bs' offset' + where + !offset'@(I64# off#) = offset + intToInt64 (BS.length bs - BS.length bs') + SlowFail bs' msg -> decodeFail bs' offset' msg where !offset' = offset + intToInt64 (BS.length bs - BS.length bs') @@ -1356,6 +1378,18 @@ let !ba = BA.fromByteString bstr lift (k ba) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) + SlowPeekByteOffset bs_empty k -> + assert (BS.null bs_empty) $ do + lift +#if MIN_VERSION_base(4,17,0) + (k (int64ToInt# off#)) +#else + (k off#) +#endif + >>= \daz -> go_slow daz bs' offset' + where + !(I64# off#) = offset' + SlowFail bs_unconsumed msg -> decodeFail (bs_unconsumed <> bs') offset'' msg where @@ -1482,49 +1516,59 @@ | TooLong Bool {- canonical? -} !Int deriving Show +-- Canoncal NaN floats: +-- +-- In these float/double canonical tests we check NaNs are canonical too. +-- There are lots of bit values representing NaN, for each of the flat types. +-- The rule from CBOR RFC 7049, section 3.9 is that the canonical NaN is the +-- CBOR term f97e00 which is the canonical half-float representation. We do +-- this by testing for the size being 3 (since tryConsumeFloat/Double only +-- return 3 when the header byte is 0xf9) and the 16 bytes being 0x7e00. + {-# INLINE isFloat16Canonical #-} -isFloat16Canonical :: Int -> Bool -isFloat16Canonical sz - | sz == 3 = True - | otherwise = False +isFloat16Canonical :: Int -> BS.ByteString -> Float -> Bool +isFloat16Canonical sz bs f + | sz /= 3 = False + | isNaN f = eatTailWord16 bs == 0x7e00 + | otherwise = True {-# INLINE isFloatCanonical #-} isFloatCanonical :: Int -> BS.ByteString -> Float -> Bool isFloatCanonical sz bs f - | isNaN f = sz == 3 && "\xf9\x7e\x00" `BS.isPrefixOf` bs + | isNaN f = sz == 3 && eatTailWord16 bs == 0x7e00 | otherwise = sz == 5 {-# INLINE isDoubleCanonical #-} isDoubleCanonical :: Int -> BS.ByteString -> Double -> Bool isDoubleCanonical sz bs f - | isNaN f = sz == 3 && "\xf9\x7e\x00" `BS.isPrefixOf` bs + | isNaN f = sz == 3 && eatTailWord16 bs == 0x7e00 | otherwise = sz == 9 {-# INLINE isWordCanonical #-} -isWordCanonical :: Int -> Word# -> Bool -isWordCanonical sz w# - | sz == 2 = isTrue# (w# `gtWord#` 0x17##) - | sz == 3 = isTrue# (w# `gtWord#` 0xff##) - | sz == 5 = isTrue# (w# `gtWord#` 0xffff##) - | sz == 9 = isTrue# (w# `gtWord#` 0xffffffff##) +isWordCanonical :: Int -> Word -> Bool +isWordCanonical sz !w + | sz == 2 = w > 0x17 + | sz == 3 = w > 0xff + | sz == 5 = w > 0xffff + | sz == 9 = w > 0xffffffff | otherwise = True {-# INLINE isIntCanonical #-} -isIntCanonical :: Int -> Int# -> Bool -isIntCanonical sz i# - | isTrue# (i# <# 0#) = isWordCanonical sz (not# w#) - | otherwise = isWordCanonical sz w# +isIntCanonical :: Int -> Int -> Bool +isIntCanonical sz i + | i < 0 = isWordCanonical sz (complement w) + | otherwise = isWordCanonical sz w where - w# = int2Word# i# + w = intToWord i #if defined(ARCH_32bit) {-# INLINE isWord64Canonical #-} -isWord64Canonical :: Int -> Word64# -> Bool -isWord64Canonical sz w# - | sz == 2 = isTrue# (w# `gtWord64#` wordToWord64# 0x17##) - | sz == 3 = isTrue# (w# `gtWord64#` wordToWord64# 0xff##) - | sz == 5 = isTrue# (w# `gtWord64#` wordToWord64# 0xffff##) - | sz == 9 = isTrue# (w# `gtWord64#` wordToWord64# 0xffffffff##) +isWord64Canonical :: Int -> Word64 -> Bool +isWord64Canonical sz w + | sz == 2 = w > 0x17) + | sz == 3 = w > 0xff) + | sz == 5 = w > 0xffff) + | sz == 9 = w > 0xffffffff) | otherwise = True {-# INLINE isInt64Canonical #-} @@ -1536,6 +1580,12 @@ w# = int64ToWord64# i# #endif +{-# INLINE isSimpleCanonical #-} +isSimpleCanonical :: Int -> Word# -> Bool +isSimpleCanonical 2 w# = isTrue# (w# `gtWord#` 0x17##) +isSimpleCanonical _ _ = True -- only size 1 and 2 are possible here + + -- TODO FIXME: check with 7.10 and file ticket: -- a case analysis against 0x00 .. 0xff :: Word8 turns into a huge chain -- of >= tests. It could use a jump table, or at least it could use a binary @@ -1569,11 +1619,11 @@ 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23 - 0x18 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs)) - 0x19 -> DecodedToken 3 (word16ToWord (eatTailWord16 bs)) - 0x1a -> DecodedToken 5 (word32ToWord (eatTailWord32 bs)) + 0x18 -> DecodedToken 2 $! word8ToWord (eatTailWord8 bs) + 0x19 -> DecodedToken 3 $! word16ToWord (eatTailWord16 bs) + 0x1a -> DecodedToken 5 $! word32ToWord (eatTailWord32 bs) #if defined(ARCH_64bit) - 0x1b -> DecodedToken 9 (word64ToWord (eatTailWord64 bs)) + 0x1b -> DecodedToken 9 $! word64ToWord (eatTailWord64 bs) #else 0x1b -> case word64ToWord (eatTailWord64 bs) of Just n -> DecodedToken 9 n @@ -1610,11 +1660,11 @@ 0x35 -> DecodedToken 1 21 0x36 -> DecodedToken 1 22 0x37 -> DecodedToken 1 23 - 0x38 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs)) - 0x39 -> DecodedToken 3 (word16ToWord (eatTailWord16 bs)) - 0x3a -> DecodedToken 5 (word32ToWord (eatTailWord32 bs)) + 0x38 -> DecodedToken 2 $! (word8ToWord (eatTailWord8 bs)) + 0x39 -> DecodedToken 3 $! (word16ToWord (eatTailWord16 bs)) + 0x3a -> DecodedToken 5 $! (word32ToWord (eatTailWord32 bs)) #if defined(ARCH_64bit) - 0x3b -> DecodedToken 9 (word64ToWord (eatTailWord64 bs)) + 0x3b -> DecodedToken 9 $! (word64ToWord (eatTailWord64 bs)) #else 0x3b -> case word64ToWord (eatTailWord64 bs) of Just n -> DecodedToken 9 n @@ -1651,10 +1701,10 @@ 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23 - 0x18 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs)) - 0x19 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs)) + 0x18 -> DecodedToken 2 $! (word8ToInt (eatTailWord8 bs)) + 0x19 -> DecodedToken 3 $! (word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) - 0x1a -> DecodedToken 5 (word32ToInt (eatTailWord32 bs)) + 0x1a -> DecodedToken 5 $! (word32ToInt (eatTailWord32 bs)) #else 0x1a -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 n @@ -1689,10 +1739,10 @@ 0x35 -> DecodedToken 1 (-22) 0x36 -> DecodedToken 1 (-23) 0x37 -> DecodedToken 1 (-24) - 0x38 -> DecodedToken 2 (-1 - word8ToInt (eatTailWord8 bs)) - 0x39 -> DecodedToken 3 (-1 - word16ToInt (eatTailWord16 bs)) + 0x38 -> DecodedToken 2 $! (-1 - word8ToInt (eatTailWord8 bs)) + 0x39 -> DecodedToken 3 $! (-1 - word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) - 0x3a -> DecodedToken 5 (-1 - word32ToInt (eatTailWord32 bs)) + 0x3a -> DecodedToken 5 $! (-1 - word32ToInt (eatTailWord32 bs)) #else 0x3a -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 (-1 - n) @@ -1734,21 +1784,21 @@ 0x16 -> DecodedToken 1 (BigIntToken True 22) 0x17 -> DecodedToken 1 (BigIntToken True 23) - 0x18 -> let !w@(W8# w#) = eatTailWord8 bs + 0x18 -> let !w = eatTailWord8 bs sz = 2 - in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) - 0x19 -> let !w@(W16# w#) = eatTailWord16 bs + in DecodedToken sz (BigIntToken (isWordCanonical sz (word8ToWord w)) $! toInteger w) + 0x19 -> let !w = eatTailWord16 bs sz = 3 - in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) - 0x1a -> let !w@(W32# w#) = eatTailWord32 bs + in DecodedToken sz (BigIntToken (isWordCanonical sz (word16ToWord w)) $! toInteger w) + 0x1a -> let !w = eatTailWord32 bs sz = 5 - in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) - 0x1b -> let !w@(W64# w#) = eatTailWord64 bs + in DecodedToken sz (BigIntToken (isWordCanonical sz (word32ToWord w)) $! toInteger w) + 0x1b -> let !w = eatTailWord64 bs sz = 9 #if defined(ARCH_32bit) - in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (toInteger w)) + in DecodedToken sz (BigIntToken (isWord64Canonical sz (word64ToWord w)) $! toInteger w) #else - in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) + in DecodedToken sz (BigIntToken (isWordCanonical sz (word64ToWord w)) $! toInteger w) #endif -- Negative integers (type 1) @@ -1776,21 +1826,21 @@ 0x35 -> DecodedToken 1 (BigIntToken True (-22)) 0x36 -> DecodedToken 1 (BigIntToken True (-23)) 0x37 -> DecodedToken 1 (BigIntToken True (-24)) - 0x38 -> let !w@(W8# w#) = eatTailWord8 bs + 0x38 -> let !w = eatTailWord8 bs sz = 2 - in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) - 0x39 -> let !w@(W16# w#) = eatTailWord16 bs + in DecodedToken sz (BigIntToken (isWordCanonical sz (word8ToWord w)) $! (-1 - toInteger w)) + 0x39 -> let !w = eatTailWord16 bs sz = 3 - in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) - 0x3a -> let !w@(W32# w#) = eatTailWord32 bs + in DecodedToken sz (BigIntToken (isWordCanonical sz (word16ToWord w)) $! (-1 - toInteger w)) + 0x3a -> let !w = eatTailWord32 bs sz = 5 - in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) - 0x3b -> let !w@(W64# w#) = eatTailWord64 bs + in DecodedToken sz (BigIntToken (isWordCanonical sz (word32ToWord w)) $! (-1 - toInteger w)) + 0x3b -> let !w = eatTailWord64 bs sz = 9 #if defined(ARCH_32bit) - in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (-1 - toInteger w)) + in DecodedToken sz (BigIntToken (isWord64Canonical sz (word64ToWord w)) $! (-1 - toInteger w)) #else - in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) + in DecodedToken sz (BigIntToken (isWordCanonical sz (word64ToWord w)) $! (-1 - toInteger w)) #endif 0xc2 -> readBigUInt bs @@ -1942,10 +1992,10 @@ 0xb5 -> DecodedToken 1 21 0xb6 -> DecodedToken 1 22 0xb7 -> DecodedToken 1 23 - 0xb8 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs)) - 0xb9 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs)) + 0xb8 -> DecodedToken 2 $! (word8ToInt (eatTailWord8 bs)) + 0xb9 -> DecodedToken 3 $! (word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) - 0xba -> DecodedToken 5 (word32ToInt (eatTailWord32 bs)) + 0xba -> DecodedToken 5 $! (word32ToInt (eatTailWord32 bs)) #else 0xba -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 n @@ -2000,10 +2050,10 @@ 0x95 -> DecodedToken 1 21 0x96 -> DecodedToken 1 22 0x97 -> DecodedToken 1 23 - 0x98 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs)) - 0x99 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs)) + 0x98 -> DecodedToken 2 $! (word8ToInt (eatTailWord8 bs)) + 0x99 -> DecodedToken 3 $! (word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) - 0x9a -> DecodedToken 5 (word32ToInt (eatTailWord32 bs)) + 0x9a -> DecodedToken 5 $! (word32ToInt (eatTailWord32 bs)) #else 0x9a -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 n @@ -2045,10 +2095,10 @@ 0xb5 -> DecodedToken 1 21 0xb6 -> DecodedToken 1 22 0xb7 -> DecodedToken 1 23 - 0xb8 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs)) - 0xb9 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs)) + 0xb8 -> DecodedToken 2 $! (word8ToInt (eatTailWord8 bs)) + 0xb9 -> DecodedToken 3 $! (word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) - 0xba -> DecodedToken 5 (word32ToInt (eatTailWord32 bs)) + 0xba -> DecodedToken 5 $! (word32ToInt (eatTailWord32 bs)) #else 0xba -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 n @@ -2090,11 +2140,11 @@ 0xd5 -> DecodedToken 1 21 0xd6 -> DecodedToken 1 22 0xd7 -> DecodedToken 1 23 - 0xd8 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs)) - 0xd9 -> DecodedToken 3 (word16ToWord (eatTailWord16 bs)) - 0xda -> DecodedToken 5 (word32ToWord (eatTailWord32 bs)) + 0xd8 -> DecodedToken 2 $! (word8ToWord (eatTailWord8 bs)) + 0xd9 -> DecodedToken 3 $! (word16ToWord (eatTailWord16 bs)) + 0xda -> DecodedToken 5 $! (word32ToWord (eatTailWord32 bs)) #if defined(ARCH_64bit) - 0xdb -> DecodedToken 9 (word64ToWord (eatTailWord64 bs)) + 0xdb -> DecodedToken 9 $! (word64ToWord (eatTailWord64 bs)) #else 0xdb -> case word64ToWord (eatTailWord64 bs) of Just n -> DecodedToken 9 n @@ -2134,10 +2184,10 @@ 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23 - 0x18 -> DecodedToken 2 (word8ToWord64 (eatTailWord8 bs)) - 0x19 -> DecodedToken 3 (word16ToWord64 (eatTailWord16 bs)) - 0x1a -> DecodedToken 5 (word32ToWord64 (eatTailWord32 bs)) - 0x1b -> DecodedToken 9 (eatTailWord64 bs) + 0x18 -> DecodedToken 2 $! (word8ToWord64 (eatTailWord8 bs)) + 0x19 -> DecodedToken 3 $! (word16ToWord64 (eatTailWord16 bs)) + 0x1a -> DecodedToken 5 $! (word32ToWord64 (eatTailWord32 bs)) + 0x1b -> DecodedToken 9 $! (eatTailWord64 bs) _ -> DecodeFailure {-# INLINE tryConsumeWord64 #-} @@ -2168,10 +2218,10 @@ 0x35 -> DecodedToken 1 21 0x36 -> DecodedToken 1 22 0x37 -> DecodedToken 1 23 - 0x38 -> DecodedToken 2 (word8ToWord64 (eatTailWord8 bs)) - 0x39 -> DecodedToken 3 (word16ToWord64 (eatTailWord16 bs)) - 0x3a -> DecodedToken 5 (word32ToWord64 (eatTailWord32 bs)) - 0x3b -> DecodedToken 9 (eatTailWord64 bs) + 0x38 -> DecodedToken 2 $! (word8ToWord64 (eatTailWord8 bs)) + 0x39 -> DecodedToken 3 $! (word16ToWord64 (eatTailWord16 bs)) + 0x3a -> DecodedToken 5 $! (word32ToWord64 (eatTailWord32 bs)) + 0x3b -> DecodedToken 9 $! (eatTailWord64 bs) _ -> DecodeFailure {-# INLINE tryConsumeNegWord64 #-} @@ -2202,9 +2252,9 @@ 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23 - 0x18 -> DecodedToken 2 (word8ToInt64 (eatTailWord8 bs)) - 0x19 -> DecodedToken 3 (word16ToInt64 (eatTailWord16 bs)) - 0x1a -> DecodedToken 5 (word32ToInt64 (eatTailWord32 bs)) + 0x18 -> DecodedToken 2 $! (word8ToInt64 (eatTailWord8 bs)) + 0x19 -> DecodedToken 3 $! (word16ToInt64 (eatTailWord16 bs)) + 0x1a -> DecodedToken 5 $! (word32ToInt64 (eatTailWord32 bs)) 0x1b -> case word64ToInt64 (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure @@ -2234,9 +2284,9 @@ 0x35 -> DecodedToken 1 (-22) 0x36 -> DecodedToken 1 (-23) 0x37 -> DecodedToken 1 (-24) - 0x38 -> DecodedToken 2 (-1 - word8ToInt64 (eatTailWord8 bs)) - 0x39 -> DecodedToken 3 (-1 - word16ToInt64 (eatTailWord16 bs)) - 0x3a -> DecodedToken 5 (-1 - word32ToInt64 (eatTailWord32 bs)) + 0x38 -> DecodedToken 2 $! (-1 - word8ToInt64 (eatTailWord8 bs)) + 0x39 -> DecodedToken 3 $! (-1 - word16ToInt64 (eatTailWord16 bs)) + 0x3a -> DecodedToken 5 $! (-1 - word32ToInt64 (eatTailWord32 bs)) 0x3b -> case word64ToInt64 (eatTailWord64 bs) of Just n -> DecodedToken 9 (-1 - n) Nothing -> DecodeFailure @@ -2270,9 +2320,9 @@ 0x95 -> DecodedToken 1 21 0x96 -> DecodedToken 1 22 0x97 -> DecodedToken 1 23 - 0x98 -> DecodedToken 2 (word8ToInt64 (eatTailWord8 bs)) - 0x99 -> DecodedToken 3 (word16ToInt64 (eatTailWord16 bs)) - 0x9a -> DecodedToken 5 (word32ToInt64 (eatTailWord32 bs)) + 0x98 -> DecodedToken 2 $! (word8ToInt64 (eatTailWord8 bs)) + 0x99 -> DecodedToken 3 $! (word16ToInt64 (eatTailWord16 bs)) + 0x9a -> DecodedToken 5 $! (word32ToInt64 (eatTailWord32 bs)) 0x9b -> case word64ToInt64 (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure @@ -2306,9 +2356,9 @@ 0xb5 -> DecodedToken 1 21 0xb6 -> DecodedToken 1 22 0xb7 -> DecodedToken 1 23 - 0xb8 -> DecodedToken 2 (word8ToInt64 (eatTailWord8 bs)) - 0xb9 -> DecodedToken 3 (word16ToInt64 (eatTailWord16 bs)) - 0xba -> DecodedToken 5 (word32ToInt64 (eatTailWord32 bs)) + 0xb8 -> DecodedToken 2 $! (word8ToInt64 (eatTailWord8 bs)) + 0xb9 -> DecodedToken 3 $! (word16ToInt64 (eatTailWord16 bs)) + 0xba -> DecodedToken 5 $! (word32ToInt64 (eatTailWord32 bs)) 0xbb -> case word64ToInt64 (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure @@ -2342,10 +2392,10 @@ 0xd5 -> DecodedToken 1 21 0xd6 -> DecodedToken 1 22 0xd7 -> DecodedToken 1 23 - 0xd8 -> DecodedToken 2 (word8ToWord64 (eatTailWord8 bs)) - 0xd9 -> DecodedToken 3 (word16ToWord64 (eatTailWord16 bs)) - 0xda -> DecodedToken 5 (word32ToWord64 (eatTailWord32 bs)) - 0xdb -> DecodedToken 9 (eatTailWord64 bs) + 0xd8 -> DecodedToken 2 $! (word8ToWord64 (eatTailWord8 bs)) + 0xd9 -> DecodedToken 3 $! (word16ToWord64 (eatTailWord16 bs)) + 0xda -> DecodedToken 5 $! (word32ToWord64 (eatTailWord32 bs)) + 0xdb -> DecodedToken 9 $! (eatTailWord64 bs) _ -> DecodeFailure {-# INLINE tryConsumeTag64 #-} #endif @@ -2353,17 +2403,17 @@ {-# INLINE tryConsumeFloat #-} tryConsumeFloat :: Word8 -> ByteString -> DecodedToken Float tryConsumeFloat hdr !bs = case word8ToWord hdr of - 0xf9 -> DecodedToken 3 (wordToFloat16 (eatTailWord16 bs)) - 0xfa -> DecodedToken 5 (wordToFloat32 (eatTailWord32 bs)) + 0xf9 -> DecodedToken 3 $! (wordToFloat16 (eatTailWord16 bs)) + 0xfa -> DecodedToken 5 $! (wordToFloat32 (eatTailWord32 bs)) _ -> DecodeFailure {-# INLINE tryConsumeDouble #-} tryConsumeDouble :: Word8 -> ByteString -> DecodedToken Double tryConsumeDouble hdr !bs = case word8ToWord hdr of - 0xf9 -> DecodedToken 3 (float2Double $ wordToFloat16 (eatTailWord16 bs)) - 0xfa -> DecodedToken 5 (float2Double $ wordToFloat32 (eatTailWord32 bs)) - 0xfb -> DecodedToken 9 (wordToFloat64 (eatTailWord64 bs)) + 0xf9 -> DecodedToken 3 $! (float2Double $ wordToFloat16 (eatTailWord16 bs)) + 0xfa -> DecodedToken 5 $! (float2Double $ wordToFloat32 (eatTailWord32 bs)) + 0xfb -> DecodedToken 9 $! (wordToFloat64 (eatTailWord64 bs)) _ -> DecodeFailure @@ -2404,7 +2454,7 @@ 0xf5 -> DecodedToken 1 21 0xf6 -> DecodedToken 1 22 0xf7 -> DecodedToken 1 23 - 0xf8 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs)) + 0xf8 -> DecodedToken 2 $! (word8ToWord (eatTailWord8 bs)) _ -> DecodeFailure @@ -2466,8 +2516,8 @@ = DecodedToken hdrsz $ TooLong lengthCanonical n where hdrsz = 2 - !n@(I# n#) = word8ToInt (eatTailWord8 bs) - lengthCanonical = isIntCanonical hdrsz n# + !n = word8ToInt (eatTailWord8 bs) + lengthCanonical = isIntCanonical hdrsz n readBytes16 bs | n <= BS.length bs - hdrsz @@ -2479,21 +2529,21 @@ = DecodedToken hdrsz $ TooLong lengthCanonical n where hdrsz = 3 - !n@(I# n#) = word16ToInt (eatTailWord16 bs) - lengthCanonical = isIntCanonical hdrsz n# + !n = word16ToInt (eatTailWord16 bs) + lengthCanonical = isIntCanonical hdrsz n readBytes32 bs = case word32ToInt (eatTailWord32 bs) of #if defined(ARCH_32bit) - Just n@(I# n#) + Just n #else - n@(I# n#) + n #endif | n <= BS.length bs - hdrsz - -> DecodedToken (n+hdrsz) $ Fits (isIntCanonical hdrsz n#) $ + -> DecodedToken (n+hdrsz) $ Fits (isIntCanonical hdrsz n) $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk - | otherwise -> DecodedToken hdrsz $ TooLong (isIntCanonical hdrsz n#) n + | otherwise -> DecodedToken hdrsz $ TooLong (isIntCanonical hdrsz n) n #if defined(ARCH_32bit) Nothing -> DecodeFailure @@ -2502,13 +2552,13 @@ hdrsz = 5 readBytes64 bs = case word64ToInt (eatTailWord64 bs) of - Just n@(I# n#) + Just n | n <= BS.length bs - hdrsz - -> DecodedToken (n+hdrsz) $ Fits (isIntCanonical hdrsz n#) $ + -> DecodedToken (n+hdrsz) $ Fits (isIntCanonical hdrsz n) $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk - | otherwise -> DecodedToken hdrsz $ TooLong (isIntCanonical hdrsz n#) n + | otherwise -> DecodedToken hdrsz $ TooLong (isIntCanonical hdrsz n) n Nothing -> DecodeFailure where diff --git a/src/Codec/CBOR/Term.hs b/src/Codec/CBOR/Term.hs --- a/src/Codec/CBOR/Term.hs +++ b/src/Codec/CBOR/Term.hs @@ -14,18 +14,18 @@ -- CBOR values (ones that, for example, may not have been generated by this -- library). -- --- Using @'decodeTerm'@, you can decode an arbitrary CBOR value given to you --- into a @'Term'@, which represents a CBOR value as an AST. +-- Using 'decodeTerm', you can decode an arbitrary CBOR value given to you +-- into a 'Term', which represents a CBOR value as an AST. -- -- Similarly, if you wanted to encode some value into a CBOR value directly, --- you can wrap it in a @'Term'@ constructor and use @'encodeTerm'@. This +-- you can wrap it in a 'Term' constructor and use 'encodeTerm'. This -- would be useful, as an example, if you needed to serialise some value into --- a CBOR term that is not compatible with that types @'Serialise'@ instance. +-- a CBOR term that is not compatible with that types 'Serialise' instance. -- -- Because this interface gives you the ability to decode or encode any -- arbitrary CBOR term, it can also be seen as an alternative interface to the --- @'Codec.CBOR.Encoding'@ and --- @'Codec.CBOR.Decoding'@ modules. +-- 'Codec.CBOR.Encoding' and +-- 'Codec.CBOR.Decoding' modules. -- module Codec.CBOR.Term ( Term(..) -- :: * @@ -56,9 +56,9 @@ -- essentially a direct reflection of the CBOR abstract syntax tree as a -- Haskell data type. -- --- The @'Term'@ type also comes with a @'Serialise'@ instance, so you can +-- The 'Term' type also comes with a 'Serialise' instance, so you can -- easily use @'decode' :: 'Decoder' 'Term'@ to directly decode any arbitrary --- CBOR value into Haskell with ease, and likewise with @'encode'@. +-- CBOR value into Haskell with ease, and likewise with 'encode'. -- -- @since 0.2.0.0 data Term @@ -84,7 +84,7 @@ -------------------------------------------------------------------------------- -- Main API --- | Encode an arbitrary @'Term'@ into an @'Encoding'@ for later serialization. +-- | Encode an arbitrary 'Term' into an 'Encoding' for later serialization. -- -- @since 0.2.0.0 encodeTerm :: Term -> Encoding @@ -120,7 +120,7 @@ encodeTerm (TFloat f) = encodeFloat f encodeTerm (TDouble f) = encodeDouble f --- | Decode some arbitrary CBOR value into a @'Term'@. +-- | Decode some arbitrary CBOR value into a 'Term'. -- -- @since 0.2.0.0 decodeTerm :: Decoder s Term diff --git a/src/Codec/CBOR/Write.hs b/src/Codec/CBOR/Write.hs --- a/src/Codec/CBOR/Write.hs +++ b/src/Codec/CBOR/Write.hs @@ -4,7 +4,14 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +#include "cbor.h" + +#if defined(OPTIMIZE_GMP) && defined(HAVE_GHC_BIGNUM) +{-# LANGUAGE UnboxedSums #-} +#endif + -- | -- Module : Codec.CBOR.Write -- Copyright : (c) Duncan Coutts 2015-2017 @@ -14,8 +21,7 @@ -- Stability : experimental -- Portability : non-portable (GHC extensions) -- --- Tools for writing out CBOR @'Encoding'@ values in --- a variety of forms. +-- Functions for writing out CBOR 'Encoding' values in a variety of forms. -- module Codec.CBOR.Write ( toBuilder -- :: Encoding -> B.Builder @@ -23,8 +29,6 @@ , toStrictByteString -- :: Encoding -> S.ByteString ) where -#include "cbor.h" - import Data.Bits import Data.Int @@ -44,15 +48,28 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import qualified Data.Text.Encoding as T +#if MIN_VERSION_text(2,0,0) +import qualified Data.Text.Foreign as T +#endif -#if defined(OPTIMIZE_GMP) import Control.Exception.Base (assert) import GHC.Exts +#if defined(OPTIMIZE_GMP) +#if defined(HAVE_GHC_BIGNUM) +import GHC.IO (IO(IO)) +import qualified GHC.Num.Integer +import qualified GHC.Num.BigNat as Gmp +import qualified GHC.Num.BigNat +import GHC.Num.BigNat (BigNat) +#else import qualified GHC.Integer.GMP.Internals as Gmp +import GHC.Integer.GMP.Internals (BigNat) +#endif +#endif + #if __GLASGOW_HASKELL__ < 710 import GHC.Word #endif -#endif import qualified Codec.CBOR.ByteArray.Sliced as BAS import Codec.CBOR.Encoding @@ -60,108 +77,129 @@ -------------------------------------------------------------------------------- --- | Turn an @'Encoding'@ into a lazy @'L.ByteString'@ in CBOR binary +-- | Turn an 'Encoding' into a lazy 'L.ByteString' in CBOR binary -- format. -- -- @since 0.2.0.0 -toLazyByteString :: Encoding -- ^ The @'Encoding'@ of a CBOR value. +toLazyByteString :: Encoding -- ^ The 'Encoding' of a CBOR value. -> L.ByteString -- ^ The encoded CBOR value. toLazyByteString = B.toLazyByteString . toBuilder --- | Turn an @'Encoding'@ into a strict @'S.ByteString'@ in CBOR binary +-- | Turn an 'Encoding' into a strict 'S.ByteString' in CBOR binary -- format. -- -- @since 0.2.0.0 -toStrictByteString :: Encoding -- ^ The @'Encoding'@ of a CBOR value. +toStrictByteString :: Encoding -- ^ The 'Encoding' of a CBOR value. -> S.ByteString -- ^ The encoded value. toStrictByteString = L.toStrict . B.toLazyByteString . toBuilder --- | Turn an @'Encoding'@ into a @'L.ByteString'@ @'B.Builder'@ in CBOR +-- | Turn an 'Encoding' into a 'L.ByteString' 'B.Builder' in CBOR -- binary format. -- -- @since 0.2.0.0 -toBuilder :: Encoding -- ^ The @'Encoding'@ of a CBOR value. - -> B.Builder -- ^ The encoded value as a @'B.Builder'@. +toBuilder :: Encoding -- ^ The 'Encoding' of a CBOR value. + -> B.Builder -- ^ The encoded value as a 'B.Builder'. toBuilder = - \(Encoding vs0) -> BI.builder (step (vs0 TkEnd)) + \(Encoding vs0) -> BI.builder (buildStep (vs0 TkEnd)) + +buildStep :: Tokens + -> (BI.BufferRange -> IO (BI.BuildSignal a)) + -> BI.BufferRange + -> IO (BI.BuildSignal a) +buildStep vs1 k (BI.BufferRange op0 ope0) = + go vs1 op0 where - step vs1 k (BI.BufferRange op0 ope0) = - go vs1 op0 - where - go vs !op - | op `plusPtr` bound <= ope0 = case vs of - TkWord x vs' -> PI.runB wordMP x op >>= go vs' - TkWord64 x vs' -> PI.runB word64MP x op >>= go vs' + go vs !op + | op `plusPtr` bound <= ope0 = case vs of + TkWord x vs' -> PI.runB wordMP x op >>= go vs' + TkWord64 x vs' -> PI.runB word64MP x op >>= go vs' - TkInt x vs' -> PI.runB intMP x op >>= go vs' - TkInt64 x vs' -> PI.runB int64MP x op >>= go vs' + TkInt x vs' -> PI.runB intMP x op >>= go vs' + TkInt64 x vs' -> PI.runB int64MP x op >>= go vs' - TkBytes x vs' -> BI.runBuilderWith (bytesMP x) (step vs' k) (BI.BufferRange op ope0) - TkBytesBegin vs' -> PI.runB bytesBeginMP () op >>= go vs' - TkByteArray x vs' -> BI.runBuilderWith (byteArrayMP x) (step vs' k) (BI.BufferRange op ope0) + TkBytes x vs' -> BI.runBuilderWith + (bytesMP x) (buildStep vs' k) + (BI.BufferRange op ope0) + TkByteArray x vs' -> BI.runBuilderWith + (byteArrayMP x) (buildStep vs' k) + (BI.BufferRange op ope0) - TkUtf8ByteArray x vs' -> BI.runBuilderWith (utf8ByteArrayMP x) (step vs' k) (BI.BufferRange op ope0) - TkString x vs' -> BI.runBuilderWith (stringMP x) (step vs' k) (BI.BufferRange op ope0) - TkStringBegin vs'-> PI.runB stringBeginMP () op >>= go vs' + TkUtf8ByteArray x vs' -> BI.runBuilderWith + (utf8ByteArrayMP x) (buildStep vs' k) + (BI.BufferRange op ope0) + TkString x vs' -> BI.runBuilderWith + (stringMP x) (buildStep vs' k) + (BI.BufferRange op ope0) - TkListLen x vs' -> PI.runB arrayLenMP x op >>= go vs' - TkListBegin vs' -> PI.runB arrayBeginMP () op >>= go vs' + TkBytesBegin vs' -> PI.runB bytesBeginMP () op >>= go vs' + TkStringBegin vs'-> PI.runB stringBeginMP () op >>= go vs' - TkMapLen x vs' -> PI.runB mapLenMP x op >>= go vs' - TkMapBegin vs' -> PI.runB mapBeginMP () op >>= go vs' + TkListLen x vs' -> PI.runB arrayLenMP x op >>= go vs' + TkListBegin vs' -> PI.runB arrayBeginMP () op >>= go vs' - TkTag x vs' -> PI.runB tagMP x op >>= go vs' - TkTag64 x vs' -> PI.runB tag64MP x op >>= go vs' + TkMapLen x vs' -> PI.runB mapLenMP x op >>= go vs' + TkMapBegin vs' -> PI.runB mapBeginMP () op >>= go vs' + TkTag x vs' -> PI.runB tagMP x op >>= go vs' + TkTag64 x vs' -> PI.runB tag64MP x op >>= go vs' + #if defined(OPTIMIZE_GMP) - -- This code is specialized for GMP implementation of Integer. By - -- looking directly at the constructors we can avoid some checks. - -- S# hold an Int, so we can just use intMP. - TkInteger (Gmp.S# i) vs' -> PI.runB intMP (I# i) op >>= go vs' - -- Jp# is guaranteed to be > 0. - TkInteger integer@(Gmp.Jp# bigNat) vs' - | integer <= fromIntegral (maxBound :: Word64) -> - PI.runB word64MP (fromIntegral integer) op >>= go vs' - | otherwise -> - let buffer = BI.BufferRange op ope0 - in BI.runBuilderWith (bigNatMP bigNat) (step vs' k) buffer - -- Jn# is guaranteed to be < 0. - TkInteger integer@(Gmp.Jn# bigNat) vs' - | integer >= -1 - fromIntegral (maxBound :: Word64) -> - PI.runB negInt64MP (fromIntegral (-1 - integer)) op >>= go vs' - | otherwise -> - let buffer = BI.BufferRange op ope0 - in BI.runBuilderWith (negBigNatMP bigNat) (step vs' k) buffer + -- This code is specialized for GMP implementation of Integer. By + -- looking directly at the constructors we can avoid some checks. + -- S# hold an Int, so we can just use intMP. + TkInteger (SmallInt i) vs' -> + PI.runB intMP (I# i) op >>= go vs' + -- PosBigInt is guaranteed to be > 0. + TkInteger integer@(PosBigInt bigNat) vs' + | integer <= fromIntegral (maxBound :: Word64) -> + PI.runB word64MP (fromIntegral integer) op >>= go vs' + | otherwise -> + let buffer = BI.BufferRange op ope0 + in BI.runBuilderWith + (bigNatMP bigNat) (buildStep vs' k) buffer + -- Jn# is guaranteed to be < 0. + TkInteger integer@(NegBigInt bigNat) vs' + | integer >= -1 - fromIntegral (maxBound :: Word64) -> + PI.runB negInt64MP (fromIntegral (-1 - integer)) op >>= go vs' + | otherwise -> + let buffer = BI.BufferRange op ope0 + in BI.runBuilderWith + (negBigNatMP bigNat) (buildStep vs' k) buffer #else - TkInteger x vs' - | x >= 0 - , x <= fromIntegral (maxBound :: Word64) - -> PI.runB word64MP (fromIntegral x) op >>= go vs' - | x < 0 - , x >= -1 - fromIntegral (maxBound :: Word64) - -> PI.runB negInt64MP (fromIntegral (-1 - x)) op >>= go vs' - | otherwise -> BI.runBuilderWith (integerMP x) (step vs' k) (BI.BufferRange op ope0) + TkInteger x vs' + | x >= 0 + , x <= fromIntegral (maxBound :: Word64) + -> PI.runB word64MP (fromIntegral x) op >>= go vs' + | x < 0 + , x >= -1 - fromIntegral (maxBound :: Word64) + -> PI.runB negInt64MP (fromIntegral (-1 - x)) op >>= go vs' + | otherwise -> BI.runBuilderWith + (integerMP x) (buildStep vs' k) + (BI.BufferRange op ope0) #endif - TkBool False vs' -> PI.runB falseMP () op >>= go vs' - TkBool True vs' -> PI.runB trueMP () op >>= go vs' - TkNull vs' -> PI.runB nullMP () op >>= go vs' - TkUndef vs' -> PI.runB undefMP () op >>= go vs' - TkSimple w vs' -> PI.runB simpleMP w op >>= go vs' - TkFloat16 f vs' -> PI.runB halfMP f op >>= go vs' - TkFloat32 f vs' -> PI.runB floatMP f op >>= go vs' - TkFloat64 f vs' -> PI.runB doubleMP f op >>= go vs' - TkBreak vs' -> PI.runB breakMP () op >>= go vs' + TkBool False vs' -> PI.runB falseMP () op >>= go vs' + TkBool True vs' -> PI.runB trueMP () op >>= go vs' + TkNull vs' -> PI.runB nullMP () op >>= go vs' + TkUndef vs' -> PI.runB undefMP () op >>= go vs' + TkSimple w vs' -> PI.runB simpleMP w op >>= go vs' + TkFloat16 f vs' -> PI.runB halfMP f op >>= go vs' + TkFloat32 f vs' -> PI.runB floatMP f op >>= go vs' + TkFloat64 f vs' -> PI.runB doubleMP f op >>= go vs' + TkBreak vs' -> PI.runB breakMP () op >>= go vs' - TkEnd -> k (BI.BufferRange op ope0) + TkEncoded x vs' -> BI.runBuilderWith + (B.byteString x) (buildStep vs' k) + (BI.BufferRange op ope0) - | otherwise = return $ BI.bufferFull bound op (step vs k) + TkEnd -> k (BI.BufferRange op ope0) + | otherwise = return $ BI.bufferFull bound op (buildStep vs k) + -- The maximum size in bytes of the fixed-size encodings bound :: Int bound = 9 - header :: P.BoundedPrim Word8 header = P.liftFixedToBounded P.word8 @@ -384,9 +422,13 @@ stringMP :: T.Text -> B.Builder stringMP t = +#if MIN_VERSION_text(2,0,0) + P.primBounded stringLenMP (fromIntegral $ T.lengthWord8 t) <> T.encodeUtf8Builder t +#else P.primBounded stringLenMP (fromIntegral $ S.length bs) <> B.byteString bs where bs = T.encodeUtf8 t +#endif stringLenMP :: P.BoundedPrim Word stringLenMP = @@ -559,36 +601,101 @@ -- ---------------------------------------- -- -- Implementation optimized for integer-gmp -- -- ---------------------------------------- -- -bigNatMP :: Gmp.BigNat -> B.Builder + +-- Below is where we try to abstract over the differences between the legacy +-- integer-gmp interface and ghc-bignum, shipped in GHC >= 9.0. + +-- | Write the limbs of a 'BigNat' to the given address in big-endian byte +-- ordering. +exportBigNatToAddr :: BigNat -> Addr# -> IO Word + +#if defined(HAVE_GHC_BIGNUM) + +{-# COMPLETE SmallInt, PosBigInt, NegBigInt #-} +pattern SmallInt :: Int# -> Integer +pattern SmallInt n = GHC.Num.Integer.IS n + +pattern PosBigInt, NegBigInt :: GHC.Num.BigNat.BigNat# -> Integer +pattern PosBigInt n = GHC.Num.Integer.IP n +pattern NegBigInt n = GHC.Num.Integer.IN n + +bigNatSizeInBytes :: GHC.Num.BigNat.BigNat -> Word +bigNatSizeInBytes bigNat = + Gmp.bigNatSizeInBase 256 (GHC.Num.BigNat.unBigNat bigNat) + +bigNatMP :: GHC.Num.BigNat.BigNat# -> B.Builder +bigNatMP n = P.primBounded header 0xc2 <> bigNatToBuilder (GHC.Num.BigNat.BN# n) + +negBigNatMP :: GHC.Num.BigNat.BigNat# -> B.Builder +negBigNatMP n = + -- If value `n` is stored in CBOR, it is interpreted as -1 - n. Since BigNat + -- already represents n (note: it's unsigned), we simply decrement it to get + -- the correct encoding. + P.primBounded header 0xc3 + <> bigNatToBuilder (subtractOneBigNat (GHC.Num.BigNat.BN# n)) + where + subtractOneBigNat (GHC.Num.BigNat.BN# nat) = + case GHC.Num.BigNat.bigNatSubWord# nat 1## of + (# | r #) -> GHC.Num.BigNat.BN# r + (# (# #) | #) -> error "subtractOneBigNat: impossible" + +exportBigNatToAddr (GHC.Num.BigNat.BN# b) addr = IO $ \s -> + -- The last parameter (`1#`) makes the export function use big endian encoding. + case GHC.Num.BigNat.bigNatToAddr# b addr 1# s of + (# s', w #) -> (# s', W# w #) +#else /* HAVE_GHC_BIGNUM */ + +{-# COMPLETE SmallInt, PosBigInt, NegBigInt #-} +pattern SmallInt :: Int# -> Integer +pattern SmallInt n = Gmp.S# n + +pattern PosBigInt :: BigNat -> Integer +pattern NegBigInt :: BigNat -> Integer +pattern PosBigInt n = Gmp.Jp# n +pattern NegBigInt n = Gmp.Jn# n + +bigNatSizeInBytes :: BigNat -> Word +bigNatSizeInBytes bigNat = W# (Gmp.sizeInBaseBigNat bigNat 256#) + +bigNatMP :: BigNat -> B.Builder bigNatMP n = P.primBounded header 0xc2 <> bigNatToBuilder n -negBigNatMP :: Gmp.BigNat -> B.Builder +negBigNatMP :: BigNat -> B.Builder negBigNatMP n = -- If value `n` is stored in CBOR, it is interpreted as -1 - n. Since BigNat -- already represents n (note: it's unsigned), we simply decrement it to get -- the correct encoding. P.primBounded header 0xc3 - <> bigNatToBuilder (Gmp.minusBigNatWord n (int2Word# 1#)) + <> bigNatToBuilder (subtractOneBigNat n) + where + subtractOneBigNat m = Gmp.minusBigNatWord m (int2Word# 1#) -bigNatToBuilder :: Gmp.BigNat -> B.Builder +exportBigNatToAddr bigNat addr# = + -- The last parameter (`1#`) makes the export function use big endian encoding. + Gmp.exportBigNatToAddr bigNat addr# 1# +#endif /* HAVE_GHC_BIGNUM */ + +bigNatToBuilder :: BigNat -> B.Builder bigNatToBuilder = bigNatBuilder where - bigNatBuilder :: Gmp.BigNat -> B.Builder + bigNatBuilder :: BigNat -> B.Builder bigNatBuilder bigNat = - let sizeW# = Gmp.sizeInBaseBigNat bigNat 256# - bounded = PI.boudedPrim (I# (word2Int# sizeW#)) (dumpBigNat sizeW#) - in P.primBounded bytesLenMP (W# sizeW#) <> P.primBounded bounded bigNat + let sizeW = bigNatSizeInBytes bigNat +#if MIN_VERSION_bytestring(0,10,12) + bounded = PI.boundedPrim (fromIntegral sizeW) (dumpBigNat sizeW) +#else + bounded = PI.boudedPrim (fromIntegral sizeW) (dumpBigNat sizeW) +#endif + in P.primBounded bytesLenMP sizeW <> P.primBounded bounded bigNat - dumpBigNat :: Word# -> Gmp.BigNat -> Ptr a -> IO (Ptr a) - dumpBigNat sizeW# bigNat ptr@(Ptr addr#) = do - -- The last parameter (`1#`) makes the export function use big endian - -- encoding. - (W# written#) <- Gmp.exportBigNatToAddr bigNat addr# 1# + dumpBigNat :: Word -> BigNat -> Ptr a -> IO (Ptr a) + dumpBigNat (W# sizeW#) bigNat ptr@(Ptr addr#) = do + (W# written#) <- exportBigNatToAddr bigNat addr# let !newPtr = ptr `plusPtr` (I# (word2Int# written#)) sanity = isTrue# (sizeW# `eqWord#` written#) return $ assert sanity newPtr -#else +#else /* OPTIMIZE_GMP */ -- ---------------------- -- -- Generic implementation -- @@ -611,4 +718,4 @@ narrow :: Integer -> Word8 narrow = fromIntegral -#endif +#endif /* OPTIMIZE_GMP */ diff --git a/src/cbits/cbor.h b/src/cbits/cbor.h --- a/src/cbits/cbor.h +++ b/src/cbits/cbor.h @@ -19,24 +19,6 @@ #endif /* -** Determine whether or not we can use more efficient code paths for -** integer-gmp. -*/ - -#if !defined(MIN_VERSION_integer_gmp) -/* -** In case this isn't defined, then just bail. If someone isn't using -** integer-gmp, then it won't be in the dependency list, so this macro -** might not(?) be generated by Cabal. -*/ -#define MIN_VERSION_integer_gmp(x,y,z) 0 -#endif - -#if defined(FLAG_OPTIMIZE_GMP) && MIN_VERSION_integer_gmp(1,0,0) -#define OPTIMIZE_GMP -#endif - -/* ** Establish the word-size of the machine, or fail. */ #if WORD_SIZE_IN_BITS == 64 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,22 +1,30 @@ -module Main - ( main -- :: IO () - ) where -import Test.Tasty (defaultMain, testGroup) +module Main (main) where -import qualified Tests.CBOR as CBOR -import qualified Tests.Boundary as Boundary -import qualified Tests.Regress as Regress -import qualified Tests.Reference as Reference -import qualified Tests.UTF8 as UTF8 +import Test.Tasty (TestTree, defaultMain, testGroup) +import qualified Tests.Reference as Reference +import qualified Tests.UnitTests as UnitTests +import qualified Tests.Properties as Properties +import qualified Tests.Boundary as Boundary +import qualified Tests.ByteOffset as ByteOffset +import qualified Tests.Canonical as Canonical +import qualified Tests.Regress as Regress +import qualified Tests.UTF8 as UTF8 +import qualified Tests.PreEncoded as PreEncoded + main :: IO () -main = - Reference.loadTestCases >>= \tcs -> - defaultMain $ - testGroup "CBOR tests" - [ CBOR.testTree tcs - , Reference.testTree tcs +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "CBOR" + [ Reference.testTree + , UnitTests.testTree + , Properties.testTree + , ByteOffset.testTree , Boundary.testTree + , Canonical.testTree , Regress.testTree , UTF8.testTree + , PreEncoded.testTree ] diff --git a/tests/Tests/ByteOffset.hs b/tests/Tests/ByteOffset.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/ByteOffset.hs @@ -0,0 +1,458 @@ +{-# LANGUAGE DeriveFunctor, BangPatterns #-} + +module Tests.ByteOffset (testTree) where + +import Data.Word +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Control.Exception (throw) +import Control.Applicative + +import Codec.CBOR.Decoding +import Codec.CBOR.Read (deserialiseFromBytes) +import Codec.CBOR.Write (toLazyByteString) +import Codec.CBOR.Term (Term, encodeTerm, decodeTerm) +import qualified Codec.CBOR.Term as Term (Term(..)) + +import Test.Tasty (TestTree, testGroup, localOption) +import Test.Tasty.QuickCheck (testProperty, QuickCheckMaxSize(..)) +import Test.QuickCheck hiding (subterms) + +import qualified Tests.Reference.Implementation as RefImpl +import Tests.Reference.Generators (floatToWord, doubleToWord) +import Tests.Term (eqTerm, canonicaliseTerm) +import Tests.Util + +import Prelude hiding (encodeFloat, decodeFloat) + + +-- | Like a 'Term', but with an annotation on top level terms and every +-- subterm. This is used for tests of 'peekByteOffset' where we annotate a +-- decoded term with the byte range it covers. +-- +data ATerm annotation = ATerm (TermF (ATerm annotation)) annotation + deriving (Show, Eq, Functor) + +-- | Term one-level functor. +-- +data TermF t = TInt Int + | TInteger Integer + | TBytes BS.ByteString + | TBytesI LBS.ByteString + | TString T.Text + | TStringI LT.Text + | TList [t] + | TListI [t] + | TMap [(t, t)] + | TMapI [(t, t)] + | TTagged Word64 t + | TBool Bool + | TNull + | TSimple Word8 + | THalf Float + | TFloat Float + | TDouble Double + deriving (Show, Eq, Functor) + + +testTree :: TestTree +testTree = + testGroup "peekByteOffset" + [ testGroup "ATerm framework" + [ testProperty "isomorphic 1" prop_ATerm_isomorphic + , testProperty "isomorphic 2" prop_ATerm_isomorphic2 + , testProperty "isomorphic 3" prop_ATerm_isomorphic3 + ] + , testProperty "bytes deserialise" prop_peekByteOffset_deserialise + , testProperty "bytes reserialise" prop_peekByteOffset_reserialise + , testProperty "non-canonical encoding" prop_peekByteOffset_noncanonical + , localOption (QuickCheckMaxSize 30) $ + testProperty "same offsets with all 2-splits" prop_peekByteOffset_splits2 + , localOption (QuickCheckMaxSize 20) $ + testProperty "same offsets with all 3-splits" prop_peekByteOffset_splits3 + ] + + +-------------------------------------------------------------------------------- +-- Properties of the framework +-- + +-- | Basic property to check that 'ATerm' is isomorphic to the 'Term'. +-- +prop_ATerm_isomorphic :: Term -> Bool +prop_ATerm_isomorphic t = + t `eqTerm` (convertATermToTerm . convertTermToATerm) t + +-- | Variation on 'prop_ATerm_isomorphic', checking that serialising as a +-- 'Term', deserialising as an 'ATerm' and converting back gives an equivalent +-- term. +-- +prop_ATerm_isomorphic2 :: Term -> Bool +prop_ATerm_isomorphic2 t = + canonicaliseTerm t + `eqTerm` (convertATermToTerm . deserialiseATerm . serialiseTerm) t + +-- | Variation on 'prop_ATerm_isomorphic2', but where we check the terms are +-- equivalent as 'ATerm's. +-- +prop_ATerm_isomorphic3 :: Term -> Bool +prop_ATerm_isomorphic3 t = + (convertTermToATerm . canonicaliseTerm) t + `eqATerm` (fmap (const ()) . deserialiseATerm . serialiseTerm) t + + +-------------------------------------------------------------------------------- +-- Properties of peekByteOffset +-- + +-- | A key consistency property for terms annotated with their bytes: +-- taking those bytes and deserialising them gives the corresponding term +-- +prop_ATerm_deserialise :: ATerm ByteSpan -> Bool +prop_ATerm_deserialise t@(ATerm _ bs) = + deserialiseTerm bs `eqTerm` convertATermToTerm t + +-- | For the case of canonical encodings it is also true for terms annotated +-- with their bytes: taking the term and serialising it gives the bytes. +-- +-- Note this is /only/ expected to hold for canonical encodings. See +-- 'prop_peekByteOffset_noncanonical' for a demonstration of this not holding +-- for non-canonical encodings. +-- +prop_ATerm_reserialise :: ATerm ByteSpan -> Bool +prop_ATerm_reserialise t@(ATerm _ bs) = + serialiseTerm (convertATermToTerm t) == bs + +-- | For an 'ATerm' annotated with its bytes (obtained by decoding a term), +-- 'prop_ATerm_deserialise' should be true for the whole term and all subterms. +-- +prop_peekByteOffset_deserialise :: Term -> Bool +prop_peekByteOffset_deserialise t = + all prop_ATerm_deserialise (subterms t') + where + t' = deserialiseATerm (serialiseTerm t) + +-- | For an 'ATerm' annotated with its bytes (obtained by decoding a canonical +-- term), 'prop_ATerm_serialise' should be true for the whole term and all +-- subterms. +-- +prop_peekByteOffset_reserialise :: Term -> Bool +prop_peekByteOffset_reserialise t = + all prop_ATerm_reserialise (subterms t') + where + t' = deserialiseATerm (serialiseTerm t) + +-- | For an 'ATerm' annotated with its bytes obtained by decoding a +-- /non-canonical/ term, 'prop_ATerm_serialise' should not always hold. +-- +-- This is in some sense the essence of why we want 'peekByteOffset' in the +-- first place: to get the bytes corresponding to a term we have to get the +-- original input bytes since we cannot rely on re-serialising to recover the +-- bytes (at least not without relying on and checking for canonical encodings). +-- +prop_peekByteOffset_noncanonical :: RefImpl.Term -> Property +prop_peekByteOffset_noncanonical t = + not (RefImpl.isCanonicalTerm t) ==> + not (prop_ATerm_reserialise t') + where + t' = deserialiseATerm (RefImpl.serialise t) + +-- | The offsets we get when decoding a term should be the same irrespective of +-- block boundaries in the input data stream. This checks the property for all +-- possible 2-chunk splits of the input data. +-- +prop_peekByteOffset_splits2 :: Term -> Bool +prop_peekByteOffset_splits2 t = + and [ deserialiseATermOffsets lbs' `eqATerm` t' + | lbs' <- splits2 lbs ] + where + lbs = serialiseTerm t + t' = deserialiseATermOffsets lbs + +-- | The offsets we get when decoding a term should be the same irrespective of +-- block boundaries in the input data stream. This checks the property for all +-- possible 3-chunk splits of the input data. +-- +prop_peekByteOffset_splits3 :: Term -> Bool +prop_peekByteOffset_splits3 t = + and [ deserialiseATermOffsets lbs' `eqATerm` t' + | lbs' <- splits3 lbs ] + where + lbs = serialiseTerm t + t' = deserialiseATermOffsets lbs + + +------------------------------------------------------------------------------ + +subterms :: ATerm a -> [ATerm a] +subterms at@(ATerm t0 _) = at : subtermsF t0 + where + subtermsF :: TermF (ATerm a) -> [ATerm a] + subtermsF (TList ts) = concatMap subterms ts + subtermsF (TListI ts) = concatMap subterms ts + subtermsF (TMap ts) = [ t' | (x, y) <- ts + , t' <- subterms x + ++ subterms y ] + subtermsF (TMapI ts) = [ t' | (x, y) <- ts + , t' <- subterms x + ++ subterms y ] + subtermsF (TTagged _ t') = subterms t' + + subtermsF TInt {} = [] + subtermsF TInteger{} = [] + subtermsF TBytes {} = [] + subtermsF TBytesI {} = [] + subtermsF TString {} = [] + subtermsF TStringI{} = [] + subtermsF TBool {} = [] + subtermsF TNull {} = [] + subtermsF TSimple {} = [] + subtermsF THalf {} = [] + subtermsF TFloat {} = [] + subtermsF TDouble {} = [] + + +------------------------------------------------------------------------------ + +serialiseTerm :: Term -> LBS.ByteString +serialiseTerm = toLazyByteString . encodeTerm + +deserialiseTerm :: LBS.ByteString -> Term +deserialiseTerm = either throw snd . deserialiseFromBytes decodeTerm + + +-------------------------------------------------------------------------------- +-- Decoding a term, annotated with its underlying bytes +-- + +type Offsets = (ByteOffset, ByteOffset) +type ByteSpan = LBS.ByteString + +deserialiseATermOffsets :: LBS.ByteString -> ATerm Offsets +deserialiseATermOffsets = either throw snd . deserialiseFromBytes decodeATerm + +deserialiseATerm :: LBS.ByteString -> ATerm ByteSpan +deserialiseATerm lbs = atermOffsetsToBytes lbs (deserialiseATermOffsets lbs) + +atermOffsetsToBytes :: LBS.ByteString -> ATerm Offsets -> ATerm ByteSpan +atermOffsetsToBytes original = + fmap (`slice` original) + where + slice :: (ByteOffset, ByteOffset) -> LBS.ByteString -> LBS.ByteString + slice (n,m) = LBS.take (m-n) . LBS.drop n + + +decodeATerm :: Decoder s (ATerm Offsets) +decodeATerm = do + start <- peekByteOffset + t <- decodeTermFATerm + end <- peekByteOffset + return (ATerm t (start, end)) + +decodeTermFATerm :: Decoder s (TermF (ATerm Offsets)) +decodeTermFATerm = do + tkty <- peekTokenType + case tkty of + TypeUInt -> do w <- decodeWord + return $! fromWord w + where + fromWord :: Word -> TermF (ATerm Offsets) + fromWord w + | w <= fromIntegral (maxBound :: Int) + = TInt (fromIntegral w) + | otherwise = TInteger (fromIntegral w) + + TypeUInt64 -> do w <- decodeWord64 + return $! fromWord64 w + where + fromWord64 w + | w <= fromIntegral (maxBound :: Int) + = TInt (fromIntegral w) + | otherwise = TInteger (fromIntegral w) + + TypeNInt -> do w <- decodeNegWord + return $! fromNegWord w + where + fromNegWord w + | w <= fromIntegral (maxBound :: Int) + = TInt (-1 - fromIntegral w) + | otherwise = TInteger (-1 - fromIntegral w) + + TypeNInt64 -> do w <- decodeNegWord64 + return $! fromNegWord64 w + where + fromNegWord64 w + | w <= fromIntegral (maxBound :: Int) + = TInt (-1 - fromIntegral w) + | otherwise = TInteger (-1 - fromIntegral w) + + TypeInteger -> do !x <- decodeInteger + return (TInteger x) + TypeFloat16 -> do !x <- decodeFloat + return (THalf x) + TypeFloat32 -> do !x <- decodeFloat + return (TFloat x) + TypeFloat64 -> do !x <- decodeDouble + return (TDouble x) + + TypeBytes -> do !x <- decodeBytes + return (TBytes x) + TypeBytesIndef -> decodeBytesIndef >> decodeBytesIndefLen [] + TypeString -> do !x <- decodeString + return (TString x) + TypeStringIndef -> decodeStringIndef >> decodeStringIndefLen [] + + TypeListLen -> decodeListLen >>= flip decodeListN [] + TypeListLen64 -> decodeListLen >>= flip decodeListN [] + TypeListLenIndef -> decodeListLenIndef >> decodeListIndefLen [] + TypeMapLen -> decodeMapLen >>= flip decodeMapN [] + TypeMapLen64 -> decodeMapLen >>= flip decodeMapN [] + TypeMapLenIndef -> decodeMapLenIndef >> decodeMapIndefLen [] + TypeTag -> do !x <- decodeTag64 + !y <- decodeATerm + return (TTagged x y) + TypeTag64 -> do !x <- decodeTag64 + !y <- decodeATerm + return (TTagged x y) + + TypeBool -> do !x <- decodeBool + return (TBool x) + TypeNull -> TNull <$ decodeNull + TypeSimple -> do !x <- decodeSimple + return (TSimple x) + TypeBreak -> fail "unexpected break" + TypeInvalid -> fail "invalid token encoding" + + +decodeBytesIndefLen :: [BS.ByteString] -> Decoder s (TermF (ATerm Offsets)) +decodeBytesIndefLen acc = do + stop <- decodeBreakOr + if stop then return $! TBytesI (LBS.fromChunks (reverse acc)) + else do !bs <- decodeBytes + decodeBytesIndefLen (bs : acc) + + +decodeStringIndefLen :: [T.Text] -> Decoder s (TermF (ATerm Offsets)) +decodeStringIndefLen acc = do + stop <- decodeBreakOr + if stop then return $! TStringI (LT.fromChunks (reverse acc)) + else do !str <- decodeString + decodeStringIndefLen (str : acc) + + +decodeListN :: Int -> [ATerm Offsets] -> Decoder s (TermF (ATerm Offsets)) +decodeListN !n acc = + case n of + 0 -> return $! TList (reverse acc) + _ -> do !t <- decodeATerm + decodeListN (n-1) (t : acc) + + +decodeListIndefLen :: [ATerm Offsets] -> Decoder s (TermF (ATerm Offsets)) +decodeListIndefLen acc = do + stop <- decodeBreakOr + if stop then return $! TListI (reverse acc) + else do !tm <- decodeATerm + decodeListIndefLen (tm : acc) + + +decodeMapN :: Int -> [(ATerm Offsets, ATerm Offsets)] -> Decoder s (TermF (ATerm Offsets)) +decodeMapN !n acc = + case n of + 0 -> return $! TMap (reverse acc) + _ -> do !tm <- decodeATerm + !tm' <- decodeATerm + decodeMapN (n-1) ((tm, tm') : acc) + + +decodeMapIndefLen :: [(ATerm Offsets, ATerm Offsets)] -> Decoder s (TermF (ATerm Offsets)) +decodeMapIndefLen acc = do + stop <- decodeBreakOr + if stop then return $! TMapI (reverse acc) + else do !tm <- decodeATerm + !tm' <- decodeATerm + decodeMapIndefLen ((tm, tm') : acc) + + +-------------------------------------------------------------------------------- +-- Converting between terms and annotated terms + + +convertTermToATerm :: Term -> ATerm () +convertTermToATerm t = ATerm (convertTermToTermF t) () + +convertTermToTermF :: Term -> TermF (ATerm ()) +convertTermToTermF (Term.TList ts) = TList (map convertTermToATerm ts) +convertTermToTermF (Term.TListI ts) = TListI (map convertTermToATerm ts) +convertTermToTermF (Term.TMap ts) = TMap [ ( convertTermToATerm x + , convertTermToATerm y ) + | (x, y) <- ts ] +convertTermToTermF (Term.TMapI ts) = TMapI [ ( convertTermToATerm x + , convertTermToATerm y ) + | (x, y) <- ts ] +convertTermToTermF (Term.TTagged x t) = TTagged x (convertTermToATerm t) + +convertTermToTermF (Term.TInt x) = TInt x +convertTermToTermF (Term.TInteger x) = TInteger x +convertTermToTermF (Term.TBytes x) = TBytes x +convertTermToTermF (Term.TBytesI x) = TBytesI x +convertTermToTermF (Term.TString x) = TString x +convertTermToTermF (Term.TStringI x) = TStringI x +convertTermToTermF (Term.TBool x) = TBool x +convertTermToTermF Term.TNull = TNull +convertTermToTermF (Term.TSimple x) = TSimple x +convertTermToTermF (Term.THalf x) = THalf x +convertTermToTermF (Term.TFloat x) = TFloat x +convertTermToTermF (Term.TDouble x) = TDouble x + +convertATermToTerm :: ATerm a -> Term +convertATermToTerm (ATerm t _ann) = convertTermFToTerm t + +convertTermFToTerm :: TermF (ATerm a) -> Term +convertTermFToTerm (TList ts) = Term.TList (map convertATermToTerm ts) +convertTermFToTerm (TListI ts) = Term.TListI (map convertATermToTerm ts) +convertTermFToTerm (TMap ts) = Term.TMap [ ( convertATermToTerm x + , convertATermToTerm y ) + | (x, y) <- ts ] +convertTermFToTerm (TMapI ts) = Term.TMapI [ ( convertATermToTerm x + , convertATermToTerm y ) + | (x, y) <- ts ] +convertTermFToTerm (TTagged x t) = Term.TTagged x (convertATermToTerm t) +convertTermFToTerm (TInt x) = Term.TInt x +convertTermFToTerm (TInteger x) = Term.TInteger x +convertTermFToTerm (TBytes x) = Term.TBytes x +convertTermFToTerm (TBytesI x) = Term.TBytesI x +convertTermFToTerm (TString x) = Term.TString x +convertTermFToTerm (TStringI x) = Term.TStringI x +convertTermFToTerm (TBool x) = Term.TBool x +convertTermFToTerm TNull = Term.TNull +convertTermFToTerm (TSimple x) = Term.TSimple x +convertTermFToTerm (THalf x) = Term.THalf x +convertTermFToTerm (TFloat x) = Term.TFloat x +convertTermFToTerm (TDouble x) = Term.TDouble x + + +-- NaNs are so annoying... +eqATerm :: Eq a => ATerm a -> ATerm a -> Bool +eqATerm (ATerm t1 ann1) (ATerm t2 ann2) = + ann1 == ann2 && eqATermF t1 t2 + +eqATermF :: Eq a => TermF (ATerm a) -> TermF (ATerm a) -> Bool +eqATermF (TList ts) (TList ts') = and (zipWith eqATerm ts ts') +eqATermF (TListI ts) (TListI ts') = and (zipWith eqATerm ts ts') +eqATermF (TMap ts) (TMap ts') = and (zipWith eqATermPair ts ts') +eqATermF (TMapI ts) (TMapI ts') = and (zipWith eqATermPair ts ts') +eqATermF (TTagged w t) (TTagged w' t') = w == w' && eqATerm t t' +eqATermF (THalf f) (THalf f') = floatToWord f == floatToWord f' +eqATermF (TFloat f) (TFloat f') = floatToWord f == floatToWord f' +eqATermF (TDouble f) (TDouble f') = doubleToWord f == doubleToWord f' +eqATermF a b = a == b + +eqATermPair :: (Eq a, Eq b) + => (ATerm a, ATerm b) + -> (ATerm a, ATerm b) + -> Bool +eqATermPair (a,b) (a',b') = eqATerm a a' && eqATerm b b' + diff --git a/tests/Tests/CBOR.hs b/tests/Tests/CBOR.hs deleted file mode 100644 --- a/tests/Tests/CBOR.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Tests.CBOR - ( testTree -- :: TestTree - ) where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Data.Word -import qualified Numeric.Half as Half - -import Codec.CBOR.Term -import Codec.CBOR.Read -import Codec.CBOR.Write - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -import qualified Tests.Reference.Implementation as RefImpl -import qualified Tests.Reference as TestVector -import Tests.Reference (TestCase(..)) -import Tests.Util - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Control.Exception (throw) - - -externalTestCase :: TestCase -> Assertion -externalTestCase TestCase { encoded, decoded = Left expectedJson } = do - let term = deserialise encoded - actualJson = TestVector.termToJson (toRefTerm term) - reencoded = serialise term - - expectedJson `TestVector.equalJson` actualJson - encoded @=? reencoded - -externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do - let term = deserialise encoded - actualDiagnostic = RefImpl.diagnosticNotation (toRefTerm term) - reencoded = serialise term - - expectedDiagnostic @=? actualDiagnostic - encoded @=? reencoded - -expectedDiagnosticNotation :: String -> [Word8] -> Assertion -expectedDiagnosticNotation expectedDiagnostic encoded = do - let term = deserialise (LBS.pack encoded) - actualDiagnostic = RefImpl.diagnosticNotation (toRefTerm term) - - expectedDiagnostic @=? actualDiagnostic - - --- | The reference implementation satisfies the roundtrip property for most --- examples (all the ones from Appendix A). It does not satisfy the roundtrip --- property in general however, non-canonical over-long int encodings for --- example. --- --- -encodedRoundtrip :: String -> [Word8] -> Assertion -encodedRoundtrip expectedDiagnostic encoded = do - let term = deserialise (LBS.pack encoded) - reencoded = LBS.unpack (serialise term) - - assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded - -prop_encodeDecodeTermRoundtrip :: Term -> Bool -prop_encodeDecodeTermRoundtrip term = - (deserialise . serialise) term `eqTerm` term - -prop_encodeDecodeTermRoundtrip_splits2 :: Term -> Bool -prop_encodeDecodeTermRoundtrip_splits2 term = - and [ deserialise thedata' `eqTerm` term - | let thedata = serialise term - , thedata' <- splits2 thedata ] - -prop_encodeDecodeTermRoundtrip_splits3 :: Term -> Bool -prop_encodeDecodeTermRoundtrip_splits3 term = - and [ deserialise thedata' `eqTerm` term - | let thedata = serialise term - , thedata' <- splits3 thedata ] - -prop_encodeTermMatchesRefImpl :: RefImpl.Term -> Bool -prop_encodeTermMatchesRefImpl term = - let encoded = serialise (fromRefTerm term) - encoded' = RefImpl.serialise (RefImpl.canonicaliseTerm term) - in encoded == encoded' - -prop_encodeTermMatchesRefImpl2 :: Term -> Bool -prop_encodeTermMatchesRefImpl2 term = - let encoded = serialise term - encoded' = RefImpl.serialise (toRefTerm term) - in encoded == encoded' - -prop_decodeTermMatchesRefImpl :: RefImpl.Term -> Bool -prop_decodeTermMatchesRefImpl term0 = - let encoded = RefImpl.serialise (RefImpl.canonicaliseTerm term0) - term = RefImpl.deserialise encoded - term' = deserialise encoded - in term' `eqTerm` fromRefTerm term - ------------------------------------------------------------------------------- - -serialise :: Term -> LBS.ByteString -serialise = toLazyByteString . encodeTerm - -deserialise :: LBS.ByteString -> Term -deserialise = either throw snd . deserialiseFromBytes decodeTerm - ------------------------------------------------------------------------------- - -toRefTerm :: Term -> RefImpl.Term -toRefTerm (TInt n) - | n >= 0 = RefImpl.TUInt (RefImpl.toUInt (fromIntegral n)) - | otherwise = RefImpl.TNInt (RefImpl.toUInt (fromIntegral (-1 - n))) -toRefTerm (TInteger n) -- = RefImpl.TBigInt n - | n >= 0 && n <= fromIntegral (maxBound :: Word64) - = RefImpl.TUInt (RefImpl.toUInt (fromIntegral n)) - | n < 0 && n >= -1 - fromIntegral (maxBound :: Word64) - = RefImpl.TNInt (RefImpl.toUInt (fromIntegral (-1 - n))) - | otherwise = RefImpl.TBigInt n -toRefTerm (TBytes bs) = RefImpl.TBytes (BS.unpack bs) -toRefTerm (TBytesI bs) = RefImpl.TBytess (map BS.unpack (LBS.toChunks bs)) -toRefTerm (TString st) = RefImpl.TString (T.unpack st) -toRefTerm (TStringI st) = RefImpl.TStrings (map T.unpack (LT.toChunks st)) -toRefTerm (TList ts) = RefImpl.TArray (map toRefTerm ts) -toRefTerm (TListI ts) = RefImpl.TArrayI (map toRefTerm ts) -toRefTerm (TMap ts) = RefImpl.TMap [ (toRefTerm x, toRefTerm y) - | (x,y) <- ts ] -toRefTerm (TMapI ts) = RefImpl.TMapI [ (toRefTerm x, toRefTerm y) - | (x,y) <- ts ] -toRefTerm (TTagged w t) = RefImpl.TTagged (RefImpl.toUInt (fromIntegral w)) - (toRefTerm t) -toRefTerm (TBool False) = RefImpl.TFalse -toRefTerm (TBool True) = RefImpl.TTrue -toRefTerm TNull = RefImpl.TNull -toRefTerm (TSimple 23) = RefImpl.TUndef -toRefTerm (TSimple w) = RefImpl.TSimple (fromIntegral w) -toRefTerm (THalf f) = if isNaN f - then RefImpl.TFloat16 RefImpl.canonicalNaN - else RefImpl.TFloat16 (Half.toHalf f) -toRefTerm (TFloat f) = if isNaN f - then RefImpl.TFloat16 RefImpl.canonicalNaN - else RefImpl.TFloat32 f -toRefTerm (TDouble f) = if isNaN f - then RefImpl.TFloat16 RefImpl.canonicalNaN - else RefImpl.TFloat64 f - - -fromRefTerm :: RefImpl.Term -> Term -fromRefTerm (RefImpl.TUInt u) - | n <= fromIntegral (maxBound :: Int) = TInt (fromIntegral n) - | otherwise = TInteger (fromIntegral n) - where n = RefImpl.fromUInt u - -fromRefTerm (RefImpl.TNInt u) - | n <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral n) - | otherwise = TInteger (-1 - fromIntegral n) - where n = RefImpl.fromUInt u - -fromRefTerm (RefImpl.TBigInt n) = TInteger n -fromRefTerm (RefImpl.TBytes bs) = TBytes (BS.pack bs) -fromRefTerm (RefImpl.TBytess bs) = TBytesI (LBS.fromChunks (map BS.pack bs)) -fromRefTerm (RefImpl.TString st) = TString (T.pack st) -fromRefTerm (RefImpl.TStrings st) = TStringI (LT.fromChunks (map T.pack st)) - -fromRefTerm (RefImpl.TArray ts) = TList (map fromRefTerm ts) -fromRefTerm (RefImpl.TArrayI ts) = TListI (map fromRefTerm ts) -fromRefTerm (RefImpl.TMap ts) = TMap [ (fromRefTerm x, fromRefTerm y) - | (x,y) <- ts ] -fromRefTerm (RefImpl.TMapI ts) = TMapI [ (fromRefTerm x, fromRefTerm y) - | (x,y) <- ts ] -fromRefTerm (RefImpl.TTagged w t) = TTagged (RefImpl.fromUInt w) - (fromRefTerm t) -fromRefTerm (RefImpl.TFalse) = TBool False -fromRefTerm (RefImpl.TTrue) = TBool True -fromRefTerm RefImpl.TNull = TNull -fromRefTerm RefImpl.TUndef = TSimple 23 -fromRefTerm (RefImpl.TSimple w) = TSimple w -fromRefTerm (RefImpl.TFloat16 f) = THalf (Half.fromHalf f) -fromRefTerm (RefImpl.TFloat32 f) = if isNaN f - then THalf (Half.fromHalf RefImpl.canonicalNaN) - else TFloat f -fromRefTerm (RefImpl.TFloat64 f) = if isNaN f - then THalf (Half.fromHalf RefImpl.canonicalNaN) - else TDouble f - --- NaNs are so annoying... -eqTerm :: Term -> Term -> Bool -eqTerm (TInt n) (TInteger n') = fromIntegral n == n' -eqTerm (TList ts) (TList ts') = and (zipWith eqTerm ts ts') -eqTerm (TListI ts) (TListI ts') = and (zipWith eqTerm ts ts') -eqTerm (TMap ts) (TMap ts') = and (zipWith eqTermPair ts ts') -eqTerm (TMapI ts) (TMapI ts') = and (zipWith eqTermPair ts ts') -eqTerm (TTagged w t) (TTagged w' t') = w == w' && eqTerm t t' -eqTerm (THalf f) (THalf f') | isNaN f && isNaN f' = True -eqTerm (TFloat f) (TFloat f') | isNaN f && isNaN f' = True -eqTerm (TDouble f) (TDouble f') | isNaN f && isNaN f' = True -eqTerm a b = a == b - -eqTermPair :: (Term, Term) -> (Term, Term) -> Bool -eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b' - - -prop_fromToRefTerm :: RefImpl.Term -> Bool -prop_fromToRefTerm term = toRefTerm (fromRefTerm term) - `RefImpl.eqTerm` RefImpl.canonicaliseTerm term - -prop_toFromRefTerm :: Term -> Bool -prop_toFromRefTerm term = fromRefTerm (toRefTerm term) `eqTerm` term - -instance Arbitrary Term where - arbitrary = fromRefTerm <$> arbitrary - - shrink (TInt n) = [ TInt n' | n' <- shrink n ] - shrink (TInteger n) = [ TInteger n' | n' <- shrink n ] - - shrink (TBytes ws) = [ TBytes (BS.pack ws') | ws' <- shrink (BS.unpack ws) ] - shrink (TBytesI wss) = [ TBytesI (LBS.fromChunks (map BS.pack wss')) - | wss' <- shrink (map BS.unpack (LBS.toChunks wss)) ] - shrink (TString cs) = [ TString (T.pack cs') | cs' <- shrink (T.unpack cs) ] - shrink (TStringI css) = [ TStringI (LT.fromChunks (map T.pack css')) - | css' <- shrink (map T.unpack (LT.toChunks css)) ] - - shrink (TList xs@[x]) = x : [ TList xs' | xs' <- shrink xs ] - shrink (TList xs) = [ TList xs' | xs' <- shrink xs ] - shrink (TListI xs@[x]) = x : [ TListI xs' | xs' <- shrink xs ] - shrink (TListI xs) = [ TListI xs' | xs' <- shrink xs ] - - shrink (TMap xys@[(x,y)]) = x : y : [ TMap xys' | xys' <- shrink xys ] - shrink (TMap xys) = [ TMap xys' | xys' <- shrink xys ] - shrink (TMapI xys@[(x,y)]) = x : y : [ TMapI xys' | xys' <- shrink xys ] - shrink (TMapI xys) = [ TMapI xys' | xys' <- shrink xys ] - - shrink (TTagged w t) = [ TTagged w' t' | (w', t') <- shrink (w, t) - , not (RefImpl.reservedTag (fromIntegral w')) ] - - shrink (TBool _) = [] - shrink TNull = [] - - shrink (TSimple w) = [ TSimple w' | w' <- shrink w - , not (RefImpl.reservedSimple (fromIntegral w)) ] - shrink (THalf _f) = [] - shrink (TFloat f) = [ TFloat f' | f' <- shrink f ] - shrink (TDouble f) = [ TDouble f' | f' <- shrink f ] - --------------------------------------------------------------------------------- --- TestTree API - -testTree :: [TestCase] -> TestTree -testTree testCases = - testGroup "Main implementation" - [ testCase "external test vector" $ - mapM_ externalTestCase testCases - - , testCase "internal test vector" $ do - sequence_ [ do expectedDiagnosticNotation d e - encodedRoundtrip d e - | (d,e) <- TestVector.specTestVector ] - - , --localOption (QuickCheckTests 5000) $ - localOption (QuickCheckMaxSize 150) $ - testGroup "properties" - [ testProperty "from/to reference terms" prop_fromToRefTerm - , testProperty "to/from reference terms" prop_toFromRefTerm - , testProperty "rountrip de/encoding terms" prop_encodeDecodeTermRoundtrip - -- TODO FIXME: need to fix the generation of terms to give - -- better size distribution some get far too big for the - -- splits properties. - , localOption (QuickCheckMaxSize 30) $ - testProperty "decoding with all 2-chunks" prop_encodeDecodeTermRoundtrip_splits2 - , localOption (QuickCheckMaxSize 20) $ - testProperty "decoding with all 3-chunks" prop_encodeDecodeTermRoundtrip_splits3 - , testProperty "encode term matches ref impl 1" prop_encodeTermMatchesRefImpl - , testProperty "encode term matches ref impl 2" prop_encodeTermMatchesRefImpl2 - , testProperty "decoding term matches ref impl" prop_decodeTermMatchesRefImpl - ] - ] diff --git a/tests/Tests/Canonical.hs b/tests/Tests/Canonical.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Canonical.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + +module Tests.Canonical (testTree) where + +import Prelude hiding (decodeFloat, encodeFloat) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import qualified Data.ByteString.Lazy as LBS +import Data.Proxy + +import Codec.CBOR.Read (deserialiseFromBytes) +import Codec.CBOR.Decoding + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck + +import Tests.Properties hiding (testTree) + + +-- | This is a version of 'prop_decodeRefdecodeImp' but where we restrict the +-- encoded input to non-canonical forms. These forms are covered by the +-- original property. This property just ensures that we have good coverage of +-- this case. +-- +prop_decode_nonCanonical :: forall t. Token t => t -> Property +prop_decode_nonCanonical x = + let enc = serialiseRef x + y = deserialiseRef t enc + y' = deserialiseImp t enc + enc' = serialiseImp t y' + isCanonical = enc == enc' + in not isCanonical ==> + -- This property holds without this pre-condition, as demonstrated by + -- prop_decodeRefdecodeImp, but using it ensures we get good coverage + -- of the non-canonical cases + y' `eq` fromRef y + + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | Check that the special checked canonical form decoder primitives work. +-- +-- We decode with the normal and canonical decoder, and check that they agree +-- in the canonical cases, and that the canonical decoder rejects the +-- non-canonical cases. +-- +-- We have a QC coverage check to make sure we are covering enough of both +-- canonical and non-canonical cases. +-- +prop_decodeCanonical :: forall t. Token t + => (forall s. Decoder s (Imp t)) + -> t -> Property +prop_decodeCanonical decodeCanonical x = + classify isCanonical "canonical" $ + case deserialiseFromBytes decodeCanonical enc of + Left _failure -> not isCanonical + Right (trailing, y') -> isCanonical + && eqImp t y y' + && LBS.null trailing + where + enc = serialiseRef x + y = deserialiseImp t enc + -- It is canonical if it re-encodes to the same bytes we decoded + isCanonical = serialiseImp t y == enc + t = Proxy :: Proxy t + + + +prop_decodeCanonical_Word :: TokWord -> Property +prop_decodeCanonical_Word = prop_decodeCanonical decodeWordCanonical + +prop_decodeCanonical_Word8 :: TokWord8 -> Property +prop_decodeCanonical_Word8 = prop_decodeCanonical decodeWord8Canonical + +prop_decodeCanonical_Word16 :: TokWord16 -> Property +prop_decodeCanonical_Word16 = prop_decodeCanonical decodeWord16Canonical + +prop_decodeCanonical_Word32 :: TokWord32 -> Property +prop_decodeCanonical_Word32 = prop_decodeCanonical decodeWord32Canonical + +prop_decodeCanonical_Word64 :: TokWord64 -> Property +prop_decodeCanonical_Word64 = prop_decodeCanonical decodeWord64Canonical + +--prop_decodeCanonical_NegWord :: TokNegWord -> Property +--prop_decodeCanonical_NegWord = prop_decodeCanonical decodeNegWordCanonical + +prop_decodeCanonical_Int :: TokInt -> Property +prop_decodeCanonical_Int = prop_decodeCanonical decodeIntCanonical + +prop_decodeCanonical_Int8 :: TokInt8 -> Property +prop_decodeCanonical_Int8 = prop_decodeCanonical decodeInt8Canonical + +prop_decodeCanonical_Int16 :: TokInt16 -> Property +prop_decodeCanonical_Int16 = prop_decodeCanonical decodeInt16Canonical + +prop_decodeCanonical_Int32 :: TokInt32 -> Property +prop_decodeCanonical_Int32 = prop_decodeCanonical decodeInt32Canonical + +prop_decodeCanonical_Int64 :: TokInt64 -> Property +prop_decodeCanonical_Int64 = prop_decodeCanonical decodeInt64Canonical + +prop_decodeCanonical_Integer :: TokInteger -> Property +prop_decodeCanonical_Integer = prop_decodeCanonical decodeIntegerCanonical + +prop_decodeCanonical_Half :: TokHalf -> Property +prop_decodeCanonical_Half = prop_decodeCanonical decodeFloat16Canonical + +prop_decodeCanonical_Float :: TokFloat -> Property +prop_decodeCanonical_Float = prop_decodeCanonical decodeFloatCanonical + +prop_decodeCanonical_Double :: TokDouble -> Property +prop_decodeCanonical_Double = prop_decodeCanonical decodeDoubleCanonical + +prop_decodeCanonical_Tag :: TokTag -> Property +prop_decodeCanonical_Tag = prop_decodeCanonical decodeTagCanonical + +prop_decodeCanonical_Tag64 :: TokTag64 -> Property +prop_decodeCanonical_Tag64 = prop_decodeCanonical decodeTag64Canonical + +prop_decodeCanonical_Simple :: Simple -> Property +prop_decodeCanonical_Simple = prop_decodeCanonical decodeSimpleCanonical + + +{- + , decodeNegWordCanonical -- :: Decoder s Word + , decodeNegWord64Canonical -- :: Decoder s Word64 + , decodeBytesCanonical -- :: Decoder s ByteString + , decodeByteArrayCanonical -- :: Decoder s ByteArray + , decodeStringCanonical -- :: Decoder s Text + , decodeUtf8ByteArrayCanonical -- :: Decoder s ByteArray + , decodeListLenCanonical -- :: Decoder s Int + , decodeMapLenCanonical -- :: Decoder s Int +-} + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = + testGroup "properties" + [ testGroup "decode non-canonical encoding" + [ testProperty "Word8" (prop_decode_nonCanonical :: TokWord8 -> Property) + , testProperty "Word16" (prop_decode_nonCanonical :: TokWord16 -> Property) + , testProperty "Word32" (prop_decode_nonCanonical :: TokWord32 -> Property) + , testProperty "Word64" (prop_decode_nonCanonical :: TokWord64 -> Property) + , testProperty "Word" (prop_decode_nonCanonical :: TokWord -> Property) +-- , testProperty "NegWord" (prop_decode_nonCanonical :: TokNegWord -> Property) + , testProperty "Int8" (prop_decode_nonCanonical :: TokInt8 -> Property) + , testProperty "Int16" (prop_decode_nonCanonical :: TokInt16 -> Property) + , testProperty "Int32" (prop_decode_nonCanonical :: TokInt32 -> Property) + , testProperty "Int64" (prop_decode_nonCanonical :: TokInt64 -> Property) + , testProperty "Int" (prop_decode_nonCanonical :: TokInt -> Property) + , testProperty "Integer" (prop_decode_nonCanonical :: TokInteger -> Property) + , testProperty "Half" (prop_decode_nonCanonical :: TokHalf -> Property) + , testProperty "Float" (prop_decode_nonCanonical :: TokFloat -> Property) + , testProperty "Double" (prop_decode_nonCanonical :: TokDouble -> Property) + , testProperty "Tag" (prop_decode_nonCanonical :: TokTag -> Property) + , testProperty "Tag64" (prop_decode_nonCanonical :: TokTag64 -> Property) + , testProperty "Simple" (prop_decode_nonCanonical :: Simple -> Property) + , testProperty "Term" (prop_decode_nonCanonical :: Term -> Property) + ] + + , testGroup "canonical decoding" + [ testProperty "Word" prop_decodeCanonical_Word + , testProperty "Word8" prop_decodeCanonical_Word8 + , testProperty "Word16" prop_decodeCanonical_Word16 + , testProperty "Word32" prop_decodeCanonical_Word32 + , testProperty "Word64" prop_decodeCanonical_Word64 + , testProperty "Int" prop_decodeCanonical_Int + , testProperty "Int8" prop_decodeCanonical_Int8 + , testProperty "Int16" prop_decodeCanonical_Int16 + , testProperty "Int32" prop_decodeCanonical_Int32 + , testProperty "Int64" prop_decodeCanonical_Int64 + , testProperty "Integer" prop_decodeCanonical_Integer + , testProperty "Half" prop_decodeCanonical_Half + , testProperty "Float" prop_decodeCanonical_Float + , testProperty "Double" prop_decodeCanonical_Double + , testProperty "Tag" prop_decodeCanonical_Tag + , testProperty "Tag64" prop_decodeCanonical_Tag64 + , testProperty "Simple" prop_decodeCanonical_Simple + ] + ] + diff --git a/tests/Tests/PreEncoded.hs b/tests/Tests/PreEncoded.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/PreEncoded.hs @@ -0,0 +1,95 @@ +module Tests.PreEncoded ( + testTree + ) where + +import Data.Monoid (Monoid(mconcat)) + +import Codec.CBOR.Term (Term, encodeTerm) +import Codec.CBOR.FlatTerm (FlatTerm, toFlatTerm, TermToken(..)) +import Codec.CBOR.Write (toStrictByteString, toLazyByteString) +import Codec.CBOR.Encoding (Encoding, encodePreEncoded) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Tests.Term () -- instance Arbitrary Term +import Tests.Reference.Generators + (canonicalNaN, floatToWord, doubleToWord) + + +-- | Use 'encodePreEncoded' but with a serialised term as the bytes. +-- +encodePreEncoded' :: Term -> Encoding +encodePreEncoded' = encodePreEncoded . toStrictByteString . encodeTerm + + +prop_preEncodedTerm_sameBytes :: Term -> Bool +prop_preEncodedTerm_sameBytes t = + sameBytes + (encodeTerm t) + (encodePreEncoded' t) + + +prop_preEncodedTerm_sameTokens :: Term -> Bool +prop_preEncodedTerm_sameTokens t = + sameTokens + (encodeTerm t) + (encodePreEncoded' t) + + +prop_preEncodedTerms_sameBytes :: [(Term, Bool)] -> Bool +prop_preEncodedTerms_sameBytes ts = + sameBytes + (mconcat [ encodeTerm t | (t, _) <- ts ]) + (mconcat [ if pre then encodePreEncoded' t + else encodeTerm t + | (t, pre) <- ts ]) + +prop_preEncodedTerms_sameTokens :: [(Term, Bool)] -> Bool +prop_preEncodedTerms_sameTokens ts = + sameTokens + (mconcat [ encodeTerm t | (t, _) <- ts ]) + (mconcat [ if pre then encodePreEncoded' t + else encodeTerm t + | (t, pre) <- ts ]) + + +sameBytes :: Encoding -> Encoding -> Bool +sameBytes e1 e2 = toLazyByteString e1 == toLazyByteString e2 + +sameTokens :: Encoding -> Encoding -> Bool +sameTokens e1 e2 = canonicaliseFlatTerm (toFlatTerm e1) + `eqFlatTerm` canonicaliseFlatTerm (toFlatTerm e2) + +canonicaliseFlatTerm :: FlatTerm -> FlatTerm +canonicaliseFlatTerm = map canonicaliseTermToken + +canonicaliseTermToken :: TermToken -> TermToken +canonicaliseTermToken (TkFloat16 f) | isNaN f = TkFloat16 canonicalNaN +canonicaliseTermToken (TkFloat32 f) | isNaN f = TkFloat16 canonicalNaN +canonicaliseTermToken (TkFloat64 f) | isNaN f = TkFloat16 canonicalNaN +canonicaliseTermToken x = x + +eqFlatTerm :: FlatTerm -> FlatTerm -> Bool +eqFlatTerm x y = and (zipWith eqTermToken x y) + +-- NaNs strike again! +eqTermToken :: TermToken -> TermToken -> Bool +eqTermToken (TkFloat16 x) (TkFloat16 y) = floatToWord x == floatToWord y +eqTermToken (TkFloat32 x) (TkFloat32 y) = floatToWord x == floatToWord y +eqTermToken (TkFloat64 x) (TkFloat64 y) = doubleToWord x == doubleToWord y +eqTermToken x y = x == y + + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = + testGroup "pre-encoded" + [ testProperty "single term, same bytes" prop_preEncodedTerm_sameBytes + , testProperty "single term, same tokens" prop_preEncodedTerm_sameTokens + , testProperty "list terms, same bytes" prop_preEncodedTerms_sameBytes + , testProperty "list terms, same tokens" prop_preEncodedTerms_sameTokens + ] + diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Properties.hs @@ -0,0 +1,1263 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Tests.Properties ( + testTree + + -- * Token type class and derived functions + , Token(..) + , serialiseRef + , serialiseImp + , deserialiseRef + , deserialiseImp + + -- * Various test token types + , TokInt + , TokInt8 + , TokInt16 + , TokInt32 + , TokInt64 + , TokInteger + , TokWord + , TokWord8 + , TokWord16 + , TokWord32 + , TokWord64 + , TokHalf + , TokFloat + , TokDouble + , TokTag + , TokTag64 + , Ref.Simple + , Ref.Term + ) where + +import Prelude hiding (decodeFloat, encodeFloat) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Word +import Data.Int +import Data.Bits (complement) +import qualified Numeric.Half as Half +import Data.Function (on) +import Data.Proxy +import Data.Kind (Type) + +import GHC.Exts +import Codec.CBOR.ByteArray +import qualified Codec.CBOR.ByteArray.Sliced as Sliced +import Codec.CBOR.Term +import Codec.CBOR.Read +import Codec.CBOR.Write +import Codec.CBOR.Decoding +import Codec.CBOR.Encoding + +import Test.Tasty (TestTree, testGroup, localOption) +import Test.Tasty.QuickCheck (testProperty, QuickCheckMaxSize(..)) +import Test.QuickCheck +import Test.QuickCheck.Gen (Gen (MkGen)) + +import qualified Tests.Reference.Implementation as Ref +import Tests.Reference.Implementation (UInt(..), lengthUInt) +import Tests.Reference.Generators +import Tests.Term + ( fromRefTerm, toRefTerm, eqTerm, canonicaliseTerm ) +import Tests.Util + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + + +#if MIN_VERSION_bytestring(0,11,1) +import qualified Data.ByteString.Short as SBS +#else +import qualified Data.ByteString.Short.Internal as SBS +#endif + +import qualified Data.Primitive.ByteArray as Prim (ByteArray (..)) +import System.Random.Stateful hiding (genByteString, genShortByteString) + +-- | The CBOR implementation and its reference implementation satisfy all the +-- properties implied in the following commuting diagram. +-- +-- The properties in this module exercise various paths throguh this diagram, +-- and do so for various different types. +-- +-- > canon id +-- > Ref──────────▶Ref───────────▶Ref +-- > │ ▲ ╲ (ref) ╱ │ +-- > │ │ ╲enc dec╱ │ +-- > │ │ ╲ ╱ │ +-- > │from to│ ▶Enc▶ │from +-- > │ │ ╱ ╲ │ +-- > │ │ ╱enc dec╲ │ +-- > ▼ │ ╱ (imp) ╲ ▼ +-- > Imp──────────▶Imp───────────▶Imp +-- > id canon +-- +-- Key +-- +-- * Imp: Implementation token type +-- * Ref: Reference token type +-- * Enc: Encoding (ie bytes) +-- * canon: canonicaliseRef or canonicaliseImp +-- * enc: encodeRef or encodeImp +-- * dec: decodeRef or decodeImp +-- +-- We capture these types and arrows with a type class and an associated type. +-- +class (Eq t, Show t) => Token t where + type Imp t :: Type + + encodeImp :: Proxy t -> Imp t -> Encoding + encodeRef :: Ref.Encoder t + + decodeImp :: forall s. Proxy t -> Decoder s (Imp t) + decodeRef :: Proxy t -> Ref.Decoder t + + canonicaliseImp :: Proxy t -> Imp t -> Imp t + canonicaliseRef :: t -> t + + eqImp :: Proxy t -> Imp t -> Imp t -> Bool + + toRef :: Proxy t -> Imp t -> t + fromRef :: t -> Imp t + + -- defaults + canonicaliseImp _ = id + canonicaliseRef = toRef t . fromRef + where + t = Proxy :: Proxy t + + default eqImp :: Eq (Imp t) => Proxy t -> Imp t -> Imp t -> Bool + eqImp _ = (==) + + +-- A few derived utils + +serialiseRef :: forall t. Token t => t -> LBS.ByteString +serialiseRef = LBS.pack . encodeRef + +serialiseImp :: forall t. Token t => Proxy t -> Imp t -> LBS.ByteString +serialiseImp _ = toLazyByteString . encodeImp t + where + t = Proxy :: Proxy t + +deserialiseRef :: forall t. Token t => Proxy t -> LBS.ByteString -> t +deserialiseRef _ bytes = + case Ref.runDecoder (decodeRef t) (LBS.unpack bytes) of + Just (x, trailing) + | null trailing -> x + | otherwise -> error "deserialiseRef: trailing bytes" + Nothing -> error "deserialiseRef: decode failure" + where + t = Proxy :: Proxy t + +deserialiseImp :: forall t. Token t => Proxy t -> LBS.ByteString -> Imp t +deserialiseImp _ bytes = + case deserialiseFromBytes (decodeImp t) bytes of + Right (trailing, x) + | LBS.null trailing -> x + | otherwise -> error "deserialiseImp: trailing data" + Left _failure -> error "deserialiseImp: decode failure" + where + t = Proxy :: Proxy t + + +-------------------------------------------------------------------------------- +-- Properties +-- + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- > canon +-- > Ref──────────▶Ref . . . . . ▷. +-- > │ ▲ . . . +-- > │ │ . . . +-- > │ │ . . . +-- > │from to│ ▷ ▷ . +-- > │ │ . . . +-- > │ │ . . . +-- > ▼ │ . . ▽ +-- > Imp──────────▶Imp . . . . . ▷. +-- > id +-- +-- > to . id . from = canon_ref +-- +prop_fromRefToRef :: Token t => Proxy t -> t -> Bool +prop_fromRefToRef _ x = + + (toRef t . fromRef) x == canonicaliseRef x + + where + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- > id +-- > . . . . . .▷Ref───────────▶Ref +-- > . ▲ . . │ +-- > . │ . . │ +-- > . │ . . │ +-- > . to│ ▷ ▷ │from +-- > . │ . . │ +-- > . │ . . │ +-- > ▽ │ . . ▼ +-- > . . . . . .▶Imp───────────▶Imp +-- > canon +-- +-- > from . id . to = canon_imp +-- +prop_toRefFromRef :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_toRefFromRef _ x = + + (fromRef . toRef t) x `eq` canonicaliseImp t x + + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This is a round trip property, with the reference implementation of the +-- encoder and decoder. +-- +-- > id +-- > . . . . . .▷Ref───────────▶Ref +-- > . △ ╲ ╱ . +-- > . . ╲enc dec╱ . +-- > . . ╲ ╱ . +-- > . . ▶Enc▶ . +-- > . . . . . +-- > . . . . . +-- > ▽ . . . ▽ +-- > . . . . . . ▷.. . . . . . ▷. +-- +-- > dec_ref . enc_ref = id +-- +prop_encodeRefdecodeRef :: forall t. Token t => Proxy t -> t -> Bool +prop_encodeRefdecodeRef _ x = + + (deserialiseRef t . serialiseRef) x == x + + where + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This is a round trip property, with the production implementation of the +-- encoder and decoder. +-- +-- > . . . . . . ▷. . . . . . .▷. +-- > . △ . . . +-- > . . . . . +-- > . . . . . +-- > . . ▶Enc▶ . +-- > . . ╱ ╲ . +-- > . . ╱enc dec╲ . +-- > ▽ . ╱ ╲ ▽ +-- > . . . . . .▷Imp───────────▶Imp +-- > canon +-- +-- > dec_imp . enc_imp = canon_imp +-- +prop_encodeImpdecodeImp :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_encodeImpdecodeImp _ x = + + (deserialiseImp t . serialiseImp t) x `eq` canonicaliseImp t x + + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | This is the same property as 'prop_encodeImpdecodeImp' but the encoded +-- data is split into two chunks provided as input into the decoder. All +-- possible 2-chunk splits are tried. This checks that the decoder gives the +-- same result irrespective of the chunk boundaries. +-- +prop_encodeImpdecodeImp_splits2 :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_encodeImpdecodeImp_splits2 _ x = + and [ deserialiseImp t enc' `eq` x' + | let enc = serialiseImp t x + x' = canonicaliseImp t x + , enc' <- splits2 enc ] + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | This is the same idea as 'prop_encodeImpdecodeImp_splits2' but with all +-- possible 3-chunk splits of the input data. This test is of course more +-- expensive and so the size of the input must be limited. +-- +prop_encodeImpdecodeImp_splits3 :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_encodeImpdecodeImp_splits3 _ x = + and [ deserialiseImp t enc' `eq` x' + | let enc = serialiseImp t x + x' = canonicaliseImp t x + , enc' <- splits3 enc ] + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This checks that the reference and real implementation produce the same +-- encoded bytes. It starts from a value in the reference implementation. +-- +-- > canon +-- > Ref──────────▶Ref . . . . . ▷. +-- > │ △ ╲ . . +-- > │ . ╲enc . . +-- > │ . ╲ . . +-- > │from . ▶Enc▷ . +-- > │ . ╱ . . +-- > │ . ╱enc . . +-- > ▼ . ╱ . ▽ +-- > Imp──────────▶Imp . . . . . ▷. +-- > id +-- +-- > enc_imp . id . from = enc_ref . canon_ref +-- +prop_encodeRefencodeImp1 :: forall t. Token t => Proxy t -> t -> Bool +prop_encodeRefencodeImp1 _ x = + + (serialiseImp t . fromRef) x == (serialiseRef . canonicaliseRef) x + + where + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This checks that the reference and real implementation produce the same +-- encoded bytes. It starts from a value in the real implementation. +-- +-- > . . . . . .▷Ref . . . . . ▷. +-- > . ▲ ╲ . . +-- > . │ ╲enc . . +-- > . │ ╲ . . +-- > . to│ ▶Enc▷ . +-- > . │ ╱ . . +-- > . │ ╱enc . . +-- > ▽ │ ╱ . ▽ +-- > . . . . . .▷Imp . . . . . ▷. +-- +-- > enc_ref . id . to = enc_imp +-- +prop_encodeRefencodeImp2 :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_encodeRefencodeImp2 _ x = + + (serialiseRef . toRef t) x == serialiseImp t x + + where + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This checks that starting from the same encoding, the reference and real +-- implementation deserialise to equivalent values. +-- +-- > . . . . . .▷Ref . . . . . ▶Ref +-- > . △ ╲ ╱ │ +-- > . . ╲enc dec╱ │ +-- > . . ╲ ╱ │ +-- > . . ▶Enc▶ │from +-- > . . . ╲ │ +-- > . . . dec╲ │ +-- > ▽ . . ╲ ▼ +-- > . . . . . . ▷.. . . . . . ▶Imp +-- +-- > dec_imp . enc_ref = from . dec_ref . enc_ref +-- +prop_decodeRefdecodeImp :: forall t. Token t => Proxy t -> t -> Bool +prop_decodeRefdecodeImp _ x = + + deserialiseImp t enc `eq` (fromRef . deserialiseRef t) enc + + where + enc = serialiseRef x + eq = eqImp t + t = Proxy :: Proxy t + + +-------------------------------------------------------------------------------- +-- Token class instances for unsigned types +-- + +newtype TokWord8 = TokWord8 { unTokWord8 :: UInt } + deriving (Eq, Show) + +instance Token TokWord8 where + type Imp TokWord8 = Word8 + + fromRef = fromIntegral . Ref.fromUInt . unTokWord8 + toRef _ = TokWord8 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord8 + decodeImp _ = decodeWord8 + + encodeRef (TokWord8 n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord8 n) + +instance Arbitrary TokWord8 where + arbitrary = TokWord8 <$> oneof arbitraryUInt_Word8 + +arbitraryUInt_Word8 :: [Gen UInt] +arbitraryUInt_Word8 = [ UIntSmall <$> arbitrarySmall + , UInt8 <$> arbitrarySmall + , UInt8 <$> arbitraryUInt8 + ] + + +newtype TokWord16 = TokWord16 { unTokWord16 :: UInt } + deriving (Eq, Show) + +instance Token TokWord16 where + type Imp TokWord16 = Word16 + + fromRef = fromIntegral . Ref.fromUInt . unTokWord16 + toRef _ = TokWord16 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord16 + decodeImp _ = decodeWord16 + + encodeRef (TokWord16 n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord16 n) + +instance Arbitrary TokWord16 where + arbitrary = TokWord16 <$> oneof arbitraryUInt_Word16 + +arbitraryUInt_Word16 :: [Gen UInt] +arbitraryUInt_Word16 = arbitraryUInt_Word8 + ++ [ UInt16 <$> arbitrarySmall + , UInt16 <$> arbitraryUInt8 + , UInt16 <$> arbitraryUInt16 + ] + + +newtype TokWord32 = TokWord32 { unTokWord32 :: UInt } + deriving (Eq, Show) + +instance Token TokWord32 where + type Imp TokWord32 = Word32 + + fromRef = fromIntegral . Ref.fromUInt . unTokWord32 + toRef _ = TokWord32 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord32 + decodeImp _ = decodeWord32 + + encodeRef (TokWord32 n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord32 n) + +instance Arbitrary TokWord32 where + arbitrary = TokWord32 <$> oneof arbitraryUInt_Word32 + +arbitraryUInt_Word32 :: [Gen UInt] +arbitraryUInt_Word32 = arbitraryUInt_Word16 + ++ [ UInt32 <$> arbitrarySmall + , UInt32 <$> arbitraryUInt8 + , UInt32 <$> arbitraryUInt16 + , UInt32 <$> arbitraryUInt32 + ] + +newtype TokWord64 = TokWord64 { unTokWord64 :: UInt } + deriving (Eq, Show) + +instance Token TokWord64 where + type Imp TokWord64 = Word64 + + fromRef = fromIntegral . Ref.fromUInt . unTokWord64 + toRef _ = TokWord64 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord64 + decodeImp _ = decodeWord64 + + encodeRef (TokWord64 n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord64 n) + +instance Arbitrary TokWord64 where + arbitrary = TokWord64 <$> oneof arbitraryUInt_Word64 + +arbitraryUInt_Word64 :: [Gen UInt] +arbitraryUInt_Word64 = arbitraryUInt_Word32 + ++ [ UInt64 <$> arbitrarySmall + , UInt64 <$> arbitraryUInt8 + , UInt64 <$> arbitraryUInt16 + , UInt64 <$> arbitraryUInt32 + , UInt64 <$> arbitraryUInt64 + ] + + +newtype TokWord = TokWord { unTokWord :: UInt } + deriving (Eq, Show) + +instance Arbitrary TokWord where + arbitrary = TokWord <$> oneof arbitraryUInt_Word + +arbitraryUInt_Word :: [Gen UInt] +arbitraryUInt_Word = arbitraryUInt_Word32 + ++ [ UInt64 <$> arbitrarySmall + , UInt64 <$> arbitraryUInt8 + , UInt64 <$> arbitraryUInt16 + , UInt64 <$> arbitraryUInt32 +#if defined(ARCH_64bit) + , UInt64 <$> arbitraryUInt64 +#endif + ] + +instance Token TokWord where + type Imp TokWord = Word + + fromRef = fromIntegral . Ref.fromUInt . unTokWord + toRef _ = TokWord . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord + decodeImp _ = decodeWord + + encodeRef (TokWord n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord n) + + +-------------------------------------------------------------------------------- +-- Token class instances for signed types +-- + + +data TokInt8 = TokInt8 Bool UInt + deriving (Eq, Show) + +instance Token TokInt8 where + type Imp TokInt8 = Int8 + + fromRef (TokInt8 True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt8 False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt8 True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt8 False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt8 + decodeImp _ = decodeInt8 + + encodeRef (TokInt8 True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt8 False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt8 True n) + Ref.MT1_NegativeInt n -> return (TokInt8 False n) + _ -> fail "decodeRef (TokInt)" + +instance Arbitrary TokInt8 where + arbitrary = TokInt8 <$> arbitrary <*> oneof arbitraryUInt_Int8 + shrink (TokInt8 sign n) = [ TokInt8 sign' n' + | (sign', n') <- shrink (sign, n) ] + +arbitraryUInt_Int8 :: [Gen UInt] +arbitraryUInt_Int8 = [ UIntSmall <$> arbitrarySmall + , UInt8 <$> arbitrarySmall + , UInt8 <$> arbitraryUInt7 + ] + + +data TokInt16 = TokInt16 Bool UInt + deriving (Eq, Show) + +instance Token TokInt16 where + type Imp TokInt16 = Int16 + + fromRef (TokInt16 True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt16 False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt16 True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt16 False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt16 + decodeImp _ = decodeInt16 + + encodeRef (TokInt16 True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt16 False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt16 True n) + Ref.MT1_NegativeInt n -> return (TokInt16 False n) + _ -> fail "decodeRef (TokInt16)" + + +instance Arbitrary TokInt16 where + arbitrary = TokInt16 <$> arbitrary <*> oneof arbitraryUInt_Int16 + +arbitraryUInt_Int16 :: [Gen UInt] +arbitraryUInt_Int16 = arbitraryUInt_Int8 + ++ [ UInt16 <$> arbitrarySmall + , UInt16 <$> arbitraryUInt7 + , UInt16 <$> arbitraryUInt15 + ] + + +data TokInt32 = TokInt32 Bool UInt + deriving (Eq, Show) + +instance Token TokInt32 where + type Imp TokInt32 = Int32 + + fromRef (TokInt32 True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt32 False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt32 True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt32 False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt32 + decodeImp _ = decodeInt32 + + encodeRef (TokInt32 True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt32 False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt32 True n) + Ref.MT1_NegativeInt n -> return (TokInt32 False n) + _ -> fail "decodeRef (TokInt32)" + +instance Arbitrary TokInt32 where + arbitrary = TokInt32 <$> arbitrary <*> oneof arbitraryUInt_Int32 + +arbitraryUInt_Int32 :: [Gen UInt] +arbitraryUInt_Int32 = arbitraryUInt_Int16 + ++ [ UInt32 <$> arbitrarySmall + , UInt32 <$> arbitraryUInt7 + , UInt32 <$> arbitraryUInt15 + , UInt32 <$> arbitraryUInt31 + ] + + +data TokInt64 = TokInt64 Bool UInt + deriving (Eq, Show) + +instance Token TokInt64 where + type Imp TokInt64 = Int64 + + fromRef (TokInt64 True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt64 False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt64 True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt64 False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt64 + decodeImp _ = decodeInt64 + + encodeRef (TokInt64 True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt64 False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt64 True n) + Ref.MT1_NegativeInt n -> return (TokInt64 False n) + _ -> fail "decodeRef (TokInt64)" + +instance Arbitrary TokInt64 where + arbitrary = TokInt64 <$> arbitrary <*> oneof arbitraryUInt_Int64 + +arbitraryUInt_Int64 :: [Gen UInt] +arbitraryUInt_Int64 = arbitraryUInt_Int32 + ++ [ UInt64 <$> arbitrarySmall + , UInt64 <$> arbitraryUInt7 + , UInt64 <$> arbitraryUInt15 + , UInt64 <$> arbitraryUInt31 + , UInt64 <$> arbitraryUInt63 + ] + + +data TokInt = TokInt Bool UInt + deriving (Eq, Show) + +instance Token TokInt where + type Imp TokInt = Int + + fromRef (TokInt True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt + decodeImp _ = decodeInt + + encodeRef (TokInt True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt True n) + Ref.MT1_NegativeInt n -> return (TokInt False n) + _ -> fail "decodeRef (TokInt)" + +instance Arbitrary TokInt where + arbitrary = TokInt <$> arbitrary <*> oneof arbitraryUInt_Int + +arbitraryUInt_Int :: [Gen UInt] +arbitraryUInt_Int = arbitraryUInt_Int32 + ++ [ UInt64 <$> arbitrarySmall + , UInt64 <$> arbitraryUInt7 + , UInt64 <$> arbitraryUInt15 + , UInt64 <$> arbitraryUInt31 +#if defined(ARCH_64bit) + , UInt64 <$> arbitraryUInt63 +#endif + ] + + +data TokInteger = TokIntegerUInt UInt + | TokIntegerNInt UInt + | TokIntegerBig LargeInteger + deriving (Eq, Show) + +instance Arbitrary TokInteger where + arbitrary = oneof [ TokIntegerUInt <$> arbitrary + , TokIntegerNInt <$> arbitrary + , TokIntegerBig <$> arbitrary + ] + + +instance Token TokInteger where + type Imp TokInteger = Integer + + fromRef (TokIntegerUInt n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokIntegerNInt n) = (complement . fromIntegral . Ref.fromUInt) n + fromRef (TokIntegerBig n) = getLargeInteger n + + toRef _ n + | n >= 0 && n <= fromIntegral (maxBound :: Word64) + = TokIntegerUInt ((Ref.toUInt . fromIntegral) n) + + | n < 0 && complement n <= fromIntegral (maxBound :: Word64) + = TokIntegerNInt ((Ref.toUInt . fromIntegral . complement) n) + + | otherwise = TokIntegerBig (LargeInteger n) + + encodeImp _ = encodeInteger + decodeImp _ = decodeInteger + + encodeRef (TokIntegerUInt n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokIntegerNInt n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + encodeRef (TokIntegerBig n) = Ref.encodeTerm (Ref.TBigInt (getLargeInteger n)) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokIntegerUInt n) + Ref.MT1_NegativeInt n -> return (TokIntegerNInt n) + Ref.MT6_Tag tag -> do Ref.TBigInt n <- Ref.decodeTagged tag + return (TokIntegerBig (LargeInteger n)) + _ -> fail "decodeRef (TokInteger)" + + +-------------------------------------------------------------------------------- +-- Arbitrary helpers for integer types +-- + +arbitrarySmall, + arbitraryUInt8, arbitraryUInt16, arbitraryUInt32, arbitraryUInt64, + arbitraryUInt7, arbitraryUInt15, arbitraryUInt31, arbitraryUInt63 + :: (Num n, Random n) => Gen n + +arbitrarySmall = chooseZeroToBound (23 :: Word) +arbitraryUInt8 = chooseZeroToBound (maxBound :: Word8) +arbitraryUInt16 = chooseZeroToBound (maxBound :: Word16) +arbitraryUInt32 = chooseZeroToBound (maxBound :: Word32) +arbitraryUInt64 = chooseZeroToBound (maxBound :: Word64) + +arbitraryUInt7 = chooseZeroToBound (maxBound :: Int8) +arbitraryUInt15 = chooseZeroToBound (maxBound :: Int16) +arbitraryUInt31 = chooseZeroToBound (maxBound :: Int32) +arbitraryUInt63 = chooseZeroToBound (maxBound :: Int64) + +chooseZeroToBound :: (Num a, Random a, Integral a1) => a1 -> Gen a +chooseZeroToBound bound = + frequency [ (9, choose (0, bound')) + , (1, pure bound') ] + where + bound' = fromIntegral bound + + +-------------------------------------------------------------------------------- +-- Token class instances for floating point types +-- + +data TokHalf = TokHalf HalfSpecials + deriving (Eq, Show) + +instance Arbitrary TokHalf where + arbitrary = TokHalf <$> arbitrary + +instance Token TokHalf where + type Imp TokHalf = Float + + eqImp _ = (==) `on` floatToWord + + fromRef (TokHalf (HalfSpecials n)) = Half.fromHalf n + toRef _ = TokHalf + . canonicaliseNaN + . HalfSpecials + . Half.toHalf + + canonicaliseImp _ = Half.fromHalf + . canonicaliseNaN + . Half.toHalf + canonicaliseRef (TokHalf n) = TokHalf (canonicaliseNaN n) + + encodeImp _ = encodeFloat16 + decodeImp _ = decodeFloat + + encodeRef (TokHalf n) = Ref.encodeToken (Ref.MT7_Float16 n) + decodeRef _ = do Ref.MT7_Float16 n <- Ref.decodeToken + return (TokHalf n) + +data TokFloat = TokFloat FloatSpecials + | TokFloatNan + deriving (Eq, Show) + +instance Arbitrary TokFloat where + arbitrary = frequency [(19, TokFloat <$> arbitrary), (1, pure TokFloatNan)] + +instance Token TokFloat where + type Imp TokFloat = Float + + eqImp _ = (==) `on` floatToWord + + fromRef (TokFloat n) = getFloatSpecials n + fromRef TokFloatNan = canonicalNaN + toRef _ n + | isNaN n = TokFloatNan + | otherwise = TokFloat (FloatSpecials n) + + canonicaliseImp _ = canonicaliseNaN + + canonicaliseRef TokFloatNan = TokFloatNan + canonicaliseRef (TokFloat (FloatSpecials n)) + | isNaN n = TokFloatNan + | otherwise = TokFloat (FloatSpecials n) + + encodeImp _ = encodeFloat + decodeImp _ = decodeFloat + + encodeRef (TokFloat n) = Ref.encodeToken (Ref.MT7_Float32 n) + encodeRef TokFloatNan = Ref.encodeToken (Ref.MT7_Float16 canonicalNaN) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT7_Float16 n | isNaN n + -> return TokFloatNan + Ref.MT7_Float32 n -> return (TokFloat n) + _ -> fail "decodeRef (TokFloat)" + + +data TokDouble = TokDouble DoubleSpecials + | TokDoubleNan + deriving (Eq, Show) + +instance Arbitrary TokDouble where + arbitrary = frequency [(19, TokDouble <$> arbitrary), (1, pure TokDoubleNan)] + +instance Token TokDouble where + type Imp TokDouble = Double + + eqImp _ = (==) `on` doubleToWord + + fromRef (TokDouble n) = getDoubleSpecials n + fromRef TokDoubleNan = canonicalNaN + toRef _ n + | isNaN n = TokDoubleNan + | otherwise = TokDouble (DoubleSpecials n) + + canonicaliseImp _ = canonicaliseNaN + canonicaliseRef TokDoubleNan = TokDoubleNan + canonicaliseRef (TokDouble (DoubleSpecials n)) + | isNaN n = TokDoubleNan + | otherwise = TokDouble (DoubleSpecials n) + + encodeImp _ = encodeDouble + decodeImp _ = decodeDouble + + encodeRef (TokDouble n) = Ref.encodeToken (Ref.MT7_Float64 n) + encodeRef TokDoubleNan = Ref.encodeToken (Ref.MT7_Float16 canonicalNaN) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT7_Float16 n | isNaN n + -> return TokDoubleNan + Ref.MT7_Float64 n -> return (TokDouble n) + _ -> fail "decodeRef (TokDouble)" + + +-------------------------------------------------------------------------------- +-- Miscelaneous token class instances +-- + +data TokTag = TokTag { unTokTag :: UInt } + deriving (Eq, Show) + +instance Arbitrary TokTag where + arbitrary = TokTag <$> oneof arbitraryUInt_Word + +instance Token TokTag where + type Imp TokTag = Word + + fromRef = fromIntegral . Ref.fromUInt . unTokTag + toRef _ = TokTag . Ref.toUInt . fromIntegral + + encodeImp _ = encodeTag + decodeImp _ = decodeTag + + encodeRef (TokTag n) = Ref.encodeToken (Ref.MT6_Tag n) + decodeRef _ = do Ref.MT6_Tag n <- Ref.decodeToken + return (TokTag n) + + +data TokTag64 = TokTag64 { unTokTag64 :: UInt } + deriving (Eq, Show) + +instance Arbitrary TokTag64 where + arbitrary = TokTag64 <$> oneof arbitraryUInt_Word64 + +instance Token TokTag64 where + type Imp TokTag64 = Word64 + + fromRef = fromIntegral . Ref.fromUInt . unTokTag64 + toRef _ = TokTag64 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeTag64 + decodeImp _ = decodeTag64 + + encodeRef (TokTag64 n) = Ref.encodeToken (Ref.MT6_Tag n) + decodeRef _ = do Ref.MT6_Tag n <- Ref.decodeToken + return (TokTag64 n) + + + +instance Token Ref.Simple where + type Imp Ref.Simple = Word8 + + fromRef = Ref.fromSimple + toRef _ = Ref.toSimple + + encodeImp _ = encodeSimple + decodeImp _ = decodeSimple + + encodeRef n = Ref.encodeToken (Ref.MT7_Simple n) + decodeRef _ = do Ref.MT7_Simple n <- Ref.decodeToken + return n + + +-------------------------------------------------------------------------------- +-- Token class instances for Term type +-- + +instance Token Ref.Term where + type Imp Ref.Term = Term + + eqImp _ = eqTerm + + fromRef = fromRefTerm + toRef _ = toRefTerm + + canonicaliseImp _ = canonicaliseTerm + canonicaliseRef = Ref.canonicaliseTerm + + encodeImp _ = encodeTerm + decodeImp _ = decodeTerm + + encodeRef = Ref.encodeTerm + decodeRef _ = Ref.decodeTerm + +-------------------------------------------------------------------------------- +-- Token class instances for ByteArray tokens. +-- + +newtype TokByteArray = TokByteArray { unTokByteArray :: [Word8] } + deriving (Eq, Show) + +instance Arbitrary TokByteArray where + arbitrary = TokByteArray <$> arbitrary + +instance Token TokByteArray where + type Imp TokByteArray = Sliced.SlicedByteArray + + eqImp _ = (==) + + fromRef = Sliced.fromByteString . BS.pack . unTokByteArray + toRef _ = TokByteArray . toList + + canonicaliseImp _ = id + canonicaliseRef = id + + encodeImp _ = encodeByteArray + decodeImp _ = toSliced <$> decodeByteArray + + encodeRef (TokByteArray bs) = Ref.encodeToken (Ref.MT2_ByteString (lengthUInt bs) bs) + decodeRef _ = do Ref.MT2_ByteString _n bs <- Ref.decodeToken + -- TODO? check _n == bs + return (TokByteArray bs) + +instance Arbitrary Sliced.SlicedByteArray where + -- Taken from cardano-ledger-binary testlib. + arbitrary = do + NonNegative off <- arbitrary + Positive count <- arbitrary + NonNegative slack <- arbitrary + let len = off + count + slack + ba <- genByteArray len + pure $ Sliced.SBA ba off count + + where + genShortByteString :: Int -> Gen SBS.ShortByteString + genShortByteString n = MkGen (\r _n -> runStateGen_ r (uniformShortByteString n)) + + genByteArray :: Int -> Gen Prim.ByteArray + genByteArray n = do + bss <- genShortByteString n + case bss of + SBS.SBS ba -> pure $ Prim.ByteArray ba + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = + testGroup "properties" + [ testGroup "to . id . from = canon_ref" + [ testProperty "Word8" (prop_fromRefToRef (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_fromRefToRef (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_fromRefToRef (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_fromRefToRef (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_fromRefToRef (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_fromRefToRef (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_fromRefToRef (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_fromRefToRef (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_fromRefToRef (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_fromRefToRef (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_fromRefToRef (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_fromRefToRef (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_fromRefToRef (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_fromRefToRef (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_fromRefToRef (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_fromRefToRef (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_fromRefToRef (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_fromRefToRef (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_fromRefToRef (Proxy :: Proxy Ref.Term)) + , testProperty "ByteArray" (prop_fromRefToRef (Proxy :: Proxy TokByteArray)) + ] + + , testGroup "from . id . to = canon_imp" + [ testProperty "Word8" (prop_toRefFromRef (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_toRefFromRef (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_toRefFromRef (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_toRefFromRef (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_toRefFromRef (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_toRefFromRef (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_toRefFromRef (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_toRefFromRef (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_toRefFromRef (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_toRefFromRef (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_toRefFromRef (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_toRefFromRef (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_toRefFromRef (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_toRefFromRef (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_toRefFromRef (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_toRefFromRef (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_toRefFromRef (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_toRefFromRef (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_toRefFromRef (Proxy :: Proxy Ref.Term)) + , testProperty "ByteArray" (prop_toRefFromRef (Proxy :: Proxy TokByteArray)) + ] + + , testGroup "dec_ref . enc_ref = id" + [ testProperty "Word8" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeRefdecodeRef (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeRefdecodeRef (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeRefdecodeRef (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeRefdecodeRef (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeRefdecodeRef (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeRefdecodeRef (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeRefdecodeRef (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_encodeRefdecodeRef (Proxy :: Proxy Ref.Term)) + , testProperty "ByteArray" (prop_encodeRefdecodeRef (Proxy :: Proxy TokByteArray)) + ] + + , testGroup "dec_imp . enc_imp = canon_imp" + [ testProperty "Word8" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeImpdecodeImp (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeImpdecodeImp (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeImpdecodeImp (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeImpdecodeImp (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeImpdecodeImp (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeImpdecodeImp (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeImpdecodeImp (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_encodeImpdecodeImp (Proxy :: Proxy Ref.Term)) + , testProperty "ByteArray" (prop_encodeImpdecodeImp (Proxy :: Proxy TokByteArray)) + ] + + , testGroup "dec_imp . enc_imp = canon_imp (all 2-splits)" + [ testProperty "Word8" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy Ref.Simple)) + , localOption (QuickCheckMaxSize 100) $ + testProperty "Term" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy Ref.Term)) + , testProperty "ByteArray" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokByteArray)) + ] + + , testGroup "dec_imp . enc_imp = canon_imp (all 3-splits)" + [ testProperty "Word8" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy Ref.Simple)) + , localOption (QuickCheckMaxSize 25) $ + testProperty "Term" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy Ref.Term)) + , testProperty "ByteArray" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokByteArray)) + ] + + , testGroup "enc_imp . from = enc_ref . canon_ref" + [ testProperty "Word8" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeRefencodeImp1 (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_encodeRefencodeImp1 (Proxy :: Proxy Ref.Term)) + , testProperty "ByteArray" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokByteArray)) + ] + + , testGroup "enc_ref . to = enc_imp" + [ testProperty "Word8" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeRefencodeImp2 (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_encodeRefencodeImp2 (Proxy :: Proxy Ref.Term)) + , testProperty "ByteArray" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokByteArray)) + ] + + , testGroup "dec_imp . enc_ref = from . dec_ref . enc_ref" + [ testProperty "Word8" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_decodeRefdecodeImp (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_decodeRefdecodeImp (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_decodeRefdecodeImp (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_decodeRefdecodeImp (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_decodeRefdecodeImp (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_decodeRefdecodeImp (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_decodeRefdecodeImp (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_decodeRefdecodeImp (Proxy :: Proxy Ref.Term)) + , testProperty "ByteArray" (prop_decodeRefdecodeImp (Proxy :: Proxy TokByteArray)) + ] + ] diff --git a/tests/Tests/Reference.hs b/tests/Tests/Reference.hs --- a/tests/Tests/Reference.hs +++ b/tests/Tests/Reference.hs @@ -1,70 +1,46 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -module Tests.Reference - ( TestCase(..) -- :: * - , termToJson -- :: - , equalJson -- :: - , loadTestCases -- :: - , specTestVector -- :: - , testTree -- :: TestTree +module Tests.Reference ( + testTree + , termToJson + , equalJson ) where -import Test.Tasty +import Test.Tasty as Tasty +import Test.Tasty.HUnit import Test.Tasty.QuickCheck import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Base64.URL as Base64url -import qualified Data.ByteString.Base16 as Base16 import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V import Data.Scientific (fromFloatDigits, toRealFloat) import Data.Aeson as Aeson -import Control.Applicative -import Control.Monad +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson.Key as Aeson.Key +#endif import Data.Word import qualified Numeric.Half as Half -import Test.Tasty.HUnit - import Tests.Reference.Implementation as CBOR +import Tests.Reference.Generators + ( HalfSpecials(..), FloatSpecials(..), DoubleSpecials(..) ) +import Tests.Reference.TestVectors -data TestCase = TestCase { - encoded :: !LBS.ByteString, - decoded :: !(Either Aeson.Value String), - roundTrip :: !Bool - } - deriving Show - -instance FromJSON TestCase where - parseJSON = - withObject "cbor test" $ \obj -> do - encoded64 <- T.encodeUtf8 <$> obj .: "cbor" - encoded <- either (fail "invalid base64") return $ - Base64.decode encoded64 - encoded16 <- T.encodeUtf8 <$> obj .: "hex" - let encoded' = fst (Base16.decode encoded16) - when (encoded /= encoded') $ - fail "hex and cbor encoding mismatch in input" - roundTrip <- obj .: "roundtrip" - decoded <- Left <$> obj .: "decoded" - <|> Right <$> obj .: "diagnostic" - return $! TestCase { - encoded = LBS.fromStrict encoded, - roundTrip, - decoded - } +------------------------------------------------------------------------------- +-- Unit tests for test vector from https://github.com/cbor/test-vectors/ +-- -loadTestCases :: IO [TestCase] -loadTestCases = do - content <- LBS.readFile "tests/test-vectors/appendix_a.json" - either fail return (Aeson.eitherDecode' content) +unit_externalTestVector :: [ExternalTestCase] -> Assertion +unit_externalTestVector = mapM_ unit_externalTestCase -externalTestCase :: TestCase -> Assertion -externalTestCase TestCase { encoded, decoded = Left expectedJson } = do +unit_externalTestCase :: ExternalTestCase -> Assertion +unit_externalTestCase ExternalTestCase { + encoded, + decoded = Left expectedJson + } = do let term = deserialise encoded actualJson = termToJson term reencoded = serialise term @@ -72,7 +48,10 @@ expectedJson `equalJson` actualJson encoded @=? reencoded -externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do +unit_externalTestCase ExternalTestCase { + encoded, + decoded = Right expectedDiagnostic + } = do let term = deserialise encoded actualDiagnostic = diagnosticNotation term reencoded = serialise term @@ -93,6 +72,13 @@ equalJson expected actual = expected @=? actual +#if MIN_VERSION_aeson(2,0,0) +stringToJsonKey :: String -> Aeson.Key.Key +stringToJsonKey = Aeson.Key.fromString +#else +stringToJsonKey :: String -> T.Text +stringToJsonKey = T.pack +#endif termToJson :: CBOR.Term -> Aeson.Value termToJson (TUInt n) = Aeson.Number (fromIntegral (fromUInt n)) @@ -104,9 +90,9 @@ termToJson (TStrings css) = Aeson.String (T.pack (concat css)) termToJson (TArray ts) = Aeson.Array (V.fromList (map termToJson ts)) termToJson (TArrayI ts) = Aeson.Array (V.fromList (map termToJson ts)) -termToJson (TMap kvs) = Aeson.object [ (T.pack k, termToJson v) +termToJson (TMap kvs) = Aeson.object [ (stringToJsonKey k, termToJson v) | (TString k,v) <- kvs ] -termToJson (TMapI kvs) = Aeson.object [ (T.pack k, termToJson v) +termToJson (TMapI kvs) = Aeson.object [ (stringToJsonKey k, termToJson v) | (TString k,v) <- kvs ] termToJson (TTagged _ t) = termToJson t termToJson TTrue = Aeson.Bool True @@ -114,16 +100,24 @@ termToJson TNull = Aeson.Null termToJson TUndef = Aeson.Null -- replacement value termToJson (TSimple _) = Aeson.Null -- replacement value -termToJson (TFloat16 f) = Aeson.Number (fromFloatDigits (Half.fromHalf f)) -termToJson (TFloat32 f) = Aeson.Number (fromFloatDigits f) -termToJson (TFloat64 f) = Aeson.Number (fromFloatDigits f) +termToJson (TFloat16 f) = Aeson.Number (fromFloatDigits (Half.fromHalf (getHalfSpecials f))) +termToJson (TFloat32 f) = Aeson.Number (fromFloatDigits (getFloatSpecials f)) +termToJson (TFloat64 f) = Aeson.Number (fromFloatDigits (getDoubleSpecials f)) bytesToBase64Text :: [Word8] -> T.Text bytesToBase64Text = T.decodeLatin1 . Base64url.encode . BS.pack -expectedDiagnosticNotation :: String -> [Word8] -> Assertion -expectedDiagnosticNotation expectedDiagnostic encoded = do - let Just (term, []) = runDecoder decodeTerm encoded + +------------------------------------------------------------------------------- +-- Unit tests for test vector from CBOR spec RFC7049 Appendix A +-- + +unit_expectedDiagnosticNotation :: RFC7049TestCase -> Assertion +unit_expectedDiagnosticNotation RFC7049TestCase { + expectedDiagnostic, + encodedBytes + } = do + let Just (term, []) = runDecoder decodeTerm encodedBytes actualDiagnostic = diagnosticNotation term expectedDiagnostic @=? actualDiagnostic @@ -133,144 +127,30 @@ -- property in general however, non-canonical over-long int encodings for -- example. -- --- -encodedRoundtrip :: String -> [Word8] -> Assertion -encodedRoundtrip expectedDiagnostic encoded = do - let Just (term, []) = runDecoder decodeTerm encoded - reencoded = encodeTerm term +unit_encodedRoundtrip :: RFC7049TestCase -> Assertion +unit_encodedRoundtrip RFC7049TestCase { + expectedDiagnostic, + encodedBytes + } = do + let Just (term, []) = runDecoder decodeTerm encodedBytes + reencodedBytes = encodeTerm term - assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded + assertEqual ("for CBOR: " ++ expectedDiagnostic) encodedBytes reencodedBytes --- | The examples from the CBOR spec RFC7049 Appendix A. --- The diagnostic notation and encoded bytes. --- -specTestVector :: [(String, [Word8])] -specTestVector = - [ ("0", [0x00]) - , ("1", [0x01]) - , ("10", [0x0a]) - , ("23", [0x17]) - , ("24", [0x18, 0x18]) - , ("25", [0x18, 0x19]) - , ("100", [0x18, 0x64]) - , ("1000", [0x19, 0x03, 0xe8]) - , ("1000000", [0x1a, 0x00, 0x0f, 0x42, 0x40]) - , ("1000000000000", [0x1b, 0x00, 0x00, 0x00, 0xe8, 0xd4, 0xa5, 0x10, 0x00]) - , ("18446744073709551615", [0x1b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) - , ("18446744073709551616", [0xc2, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) - , ("-18446744073709551616", [0x3b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) - , ("-18446744073709551617", [0xc3, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) - - , ("-1", [0x20]) - , ("-10", [0x29]) - , ("-100", [0x38, 0x63]) - , ("-1000", [0x39, 0x03, 0xe7]) - - , ("0.0", [0xf9, 0x00, 0x00]) - , ("-0.0", [0xf9, 0x80, 0x00]) - , ("1.0", [0xf9, 0x3c, 0x00]) - , ("1.1", [0xfb, 0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a]) - , ("1.5", [0xf9, 0x3e, 0x00]) - , ("65504.0", [0xf9, 0x7b, 0xff]) - , ("100000.0", [0xfa, 0x47, 0xc3, 0x50, 0x00]) - , ("3.4028234663852886e38", [0xfa, 0x7f, 0x7f, 0xff, 0xff]) - , ("1.0e300", [0xfb, 0x7e, 0x37, 0xe4, 0x3c, 0x88, 0x00, 0x75, 0x9c]) - , ("5.960464477539063e-8", [0xf9, 0x00, 0x01]) - , ("0.00006103515625", [0xf9, 0x04, 0x00]) - , ("-4.0", [0xf9, 0xc4, 0x00]) - , ("-4.1", [0xfb, 0xc0, 0x10, 0x66, 0x66, 0x66, 0x66, 0x66, 0x66]) - - , ("Infinity", [0xf9, 0x7c, 0x00]) - , ("NaN", [0xf9, 0x7e, 0x00]) - , ("-Infinity", [0xf9, 0xfc, 0x00]) - , ("Infinity", [0xfa, 0x7f, 0x80, 0x00, 0x00]) - , ("-Infinity", [0xfa, 0xff, 0x80, 0x00, 0x00]) - , ("Infinity", [0xfb, 0x7f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) - , ("-Infinity", [0xfb, 0xff, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) - - , ("false", [0xf4]) - , ("true", [0xf5]) - , ("null", [0xf6]) - , ("undefined", [0xf7]) - , ("simple(16)", [0xf0]) - , ("simple(24)", [0xf8, 0x18]) - , ("simple(255)", [0xf8, 0xff]) - - , ("0(\"2013-03-21T20:04:00Z\")", - [0xc0, 0x74, 0x32, 0x30, 0x31, 0x33, 0x2d, 0x30, 0x33, 0x2d, 0x32, 0x31, - 0x54, 0x32, 0x30, 0x3a, 0x30, 0x34, 0x3a, 0x30, 0x30, 0x5a]) - , ("1(1363896240)", [0xc1, 0x1a, 0x51, 0x4b, 0x67, 0xb0]) - , ("1(1363896240.5)", [0xc1, 0xfb, 0x41, 0xd4, 0x52, 0xd9, 0xec, 0x20, 0x00, 0x00]) - , ("23(h'01020304')", [0xd7, 0x44, 0x01, 0x02, 0x03, 0x04]) - , ("24(h'6449455446')", [0xd8, 0x18, 0x45, 0x64, 0x49, 0x45, 0x54, 0x46]) - , ("32(\"http://www.example.com\")", - [0xd8, 0x20, 0x76, 0x68, 0x74, 0x74, 0x70, 0x3a, 0x2f, 0x2f, 0x77, 0x77, - 0x77, 0x2e, 0x65, 0x78, 0x61, 0x6d, 0x70, 0x6c, 0x65, 0x2e, 0x63, 0x6f, 0x6d]) - - , ("h''", [0x40]) - , ("h'01020304'", [0x44, 0x01, 0x02, 0x03, 0x04]) - , ("\"\"", [0x60]) - , ("\"a\"", [0x61, 0x61]) - , ("\"IETF\"", [0x64, 0x49, 0x45, 0x54, 0x46]) - , ("\"\\\"\\\\\"", [0x62, 0x22, 0x5c]) - , ("\"\\252\"", [0x62, 0xc3, 0xbc]) - , ("\"\\27700\"", [0x63, 0xe6, 0xb0, 0xb4]) - , ("\"\\65873\"", [0x64, 0xf0, 0x90, 0x85, 0x91]) - - , ("[]", [0x80]) - , ("[1, 2, 3]", [0x83, 0x01, 0x02, 0x03]) - , ("[1, [2, 3], [4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05]) - , ("[1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]", - [0x98, 0x19, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, - 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, - 0x17, 0x18, 0x18, 0x18, 0x19]) - - , ("{}", [0xa0]) - , ("{1: 2, 3: 4}", [0xa2, 0x01, 0x02, 0x03, 0x04]) - , ("{\"a\": 1, \"b\": [2, 3]}", [0xa2, 0x61, 0x61, 0x01, 0x61, 0x62, 0x82, 0x02, 0x03]) - , ("[\"a\", {\"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xa1, 0x61, 0x62, 0x61, 0x63]) - , ("{\"a\": \"A\", \"b\": \"B\", \"c\": \"C\", \"d\": \"D\", \"e\": \"E\"}", - [0xa5, 0x61, 0x61, 0x61, 0x41, 0x61, 0x62, 0x61, 0x42, 0x61, 0x63, 0x61, - 0x43, 0x61, 0x64, 0x61, 0x44, 0x61, 0x65, 0x61, 0x45]) - - , ("(_ h'0102', h'030405')", [0x5f, 0x42, 0x01, 0x02, 0x43, 0x03, 0x04, 0x05, 0xff]) - , ("(_ \"strea\", \"ming\")", [0x7f, 0x65, 0x73, 0x74, 0x72, 0x65, 0x61, 0x64, 0x6d, 0x69, 0x6e, 0x67, 0xff]) - - , ("[_ ]", [0x9f, 0xff]) - , ("[_ 1, [2, 3], [_ 4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff, 0xff]) - , ("[_ 1, [2, 3], [4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05, 0xff]) - , ("[1, [2, 3], [_ 4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff]) - , ("[1, [_ 2, 3], [4, 5]]", [0x83, 0x01, 0x9f, 0x02, 0x03, 0xff, 0x82, 0x04, 0x05]) - , ("[_ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]", - [0x9f, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, - 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, - 0x18, 0x18, 0x18, 0x19, 0xff]) - , ("{_ \"a\": 1, \"b\": [_ 2, 3]}", [0xbf, 0x61, 0x61, 0x01, 0x61, 0x62, 0x9f, 0x02, 0x03, 0xff, 0xff]) - - , ("[\"a\", {_ \"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xbf, 0x61, 0x62, 0x61, 0x63, 0xff]) - , ("{_ \"Fun\": true, \"Amt\": -2}", [0xbf, 0x63, 0x46, 0x75, 0x6e, 0xf5, 0x63, 0x41, 0x6d, 0x74, 0x21, 0xff]) - ] - --- TODO FIXME: test redundant encodings e.g. --- bigint with zero-length bytestring --- bigint with leading zeros --- bigint using indefinate bytestring encoding --- larger than necessary ints, lengths, tags, simple etc - -------------------------------------------------------------------------------- -- TestTree API -testTree :: [TestCase] -> TestTree -testTree testCases = +testTree :: TestTree +testTree = testGroup "Reference implementation" - [ testCase "external test vector" $ - mapM_ externalTestCase testCases - - , testCase "internal test vector" $ do - sequence_ [ do expectedDiagnosticNotation d e - encodedRoundtrip d e - | (d,e) <- specTestVector ] + [ testGroup "internal properties" + [ testProperty "Integer to/from bytes" prop_integerToFromBytes + , testProperty "Word16 to/from network byte order" prop_word16ToFromNet + , testProperty "Word32 to/from network byte order" prop_word32ToFromNet + , testProperty "Word64 to/from network byte order" prop_word64ToFromNet + , testProperty "Numeric.Half to/from Float" prop_halfToFromFloat + ] , testGroup "properties" [ testProperty "encoding/decoding initial byte" prop_InitialByte @@ -283,11 +163,13 @@ testProperty "encoding/decoding terms" prop_Term ] - , testGroup "internal properties" - [ testProperty "Integer to/from bytes" prop_integerToFromBytes - , testProperty "Word16 to/from network byte order" prop_word16ToFromNet - , testProperty "Word32 to/from network byte order" prop_word32ToFromNet - , testProperty "Word64 to/from network byte order" prop_word64ToFromNet - , testProperty "Numeric.Half to/from Float" prop_halfToFromFloat - ] + , testCase "RFC7049 test vector: decode" $ + mapM_ unit_expectedDiagnosticNotation rfc7049TestVector + + , testCase "RFC7049 test vector: roundtrip" $ + mapM_ unit_encodedRoundtrip rfc7049TestVector + + , withExternalTestVector $ \getTestVector -> + testCase "external test vector" $ + getTestVector >>= unit_externalTestVector ] diff --git a/tests/Tests/Reference/Generators.hs b/tests/Tests/Reference/Generators.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Reference/Generators.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Tests.Reference.Generators ( + -- * Integer with a large range + LargeInteger(..) + + -- * Floats with NaNs + , FloatNaN(..) + , canonicaliseNaN + + -- * Floats with special values + , HalfSpecials(..) + , FloatSpecials(..) + , DoubleSpecials(..) + + -- * Floating types to bit representation conversion + , halfToWord + , floatToWord + , doubleToWord + , wordToHalf + , wordToFloat + , wordToDouble + ) where + +import Data.Word +import Numeric (showHex) +import Numeric.Half as Half +import GHC.Float (float2Double) +import Data.Proxy + +import Foreign +import System.IO.Unsafe +import System.Random (Random) + +import Test.QuickCheck + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +-- | QuickCheck generator for large integers +-- +newtype LargeInteger = LargeInteger { getLargeInteger :: Integer } + deriving (Show, Eq) + +instance Arbitrary LargeInteger where + arbitrary = + sized $ \n -> + oneof $ take (1 + n `div` 10) + [ LargeInteger . fromIntegral <$> (arbitrary :: Gen Int8) + , LargeInteger . fromIntegral <$> choose (minBound, maxBound :: Int64) + , LargeInteger . bigger . fromIntegral <$> choose (minBound, maxBound :: Int64) + ] + where + bigger n = n * abs n + +---------------------------------------- +-- Float <-> Integral conversions +-- + +wordToHalf :: Word16 -> Half +wordToHalf = Half.Half . fromIntegral + +wordToFloat :: Word32 -> Float +wordToFloat = toFloat + +wordToDouble :: Word64 -> Double +wordToDouble = toFloat + +toFloat :: (Storable word, Storable float) => word -> float +toFloat w = + unsafeDupablePerformIO $ alloca $ \buf -> do + poke (castPtr buf) w + peek buf + +halfToWord :: Half -> Word16 +halfToWord (Half.Half w) = fromIntegral w + +floatToWord :: Float -> Word32 +floatToWord = fromFloat + +doubleToWord :: Double -> Word64 +doubleToWord = fromFloat + +fromFloat :: (Storable word, Storable float) => float -> word +fromFloat float = + unsafeDupablePerformIO $ alloca $ \buf -> do + poke (castPtr buf) float + peek buf + +--------------------------------------------------- +-- Floats with NaNs +-- + +class RealFloat n => FloatNaN n where + canonicalNaN :: n + +canonicaliseNaN :: FloatNaN n => n -> n +canonicaliseNaN n | isNaN n = canonicalNaN + | otherwise = n + +instance FloatNaN Half where + canonicalNaN = Half 0x7e00 + +instance FloatNaN Float where + canonicalNaN = Half.fromHalf canonicalNaN + +instance FloatNaN Double where + canonicalNaN = float2Double canonicalNaN + + +--------------------------------------------------- +-- Generators for float types with special values +-- + +instance Arbitrary Half where + arbitrary = getHalfSpecials <$> arbitrary + shrink = shrinkRealFrac + +newtype HalfSpecials = HalfSpecials { getHalfSpecials :: Half } + deriving (Ord, Num, Fractional, RealFrac, Real, Floating, RealFloat, FloatNaN) + +newtype FloatSpecials = FloatSpecials { getFloatSpecials :: Float } + deriving (Ord, Num, Fractional, RealFrac, Real, Floating, RealFloat, FloatNaN) + +newtype DoubleSpecials = DoubleSpecials { getDoubleSpecials :: Double } + deriving (Ord, Num, Fractional, RealFrac, Real, Floating, RealFloat, FloatNaN) + +instance Eq HalfSpecials where + HalfSpecials a == HalfSpecials b = halfToWord a == halfToWord b + +instance Eq FloatSpecials where + FloatSpecials a == FloatSpecials b = floatToWord a == floatToWord b + +instance Eq DoubleSpecials where + DoubleSpecials a == DoubleSpecials b = doubleToWord a == doubleToWord b + +instance Show HalfSpecials where + showsPrec p (HalfSpecials n) + | isNaN n = showString "NaN{-0x" . showHex (halfToWord n) . showString "-}" + | otherwise = showsPrec p n + +instance Show FloatSpecials where + showsPrec p (FloatSpecials n) + | isNaN n = showString "NaN{-0x" . showHex (floatToWord n) . showString "-}" + | otherwise = showsPrec p n + +instance Show DoubleSpecials where + showsPrec p (DoubleSpecials n) + | isNaN n = showString "NaN{-0x" . showHex (doubleToWord n) . showString "-}" + | otherwise = showsPrec p n + +instance Arbitrary HalfSpecials where + arbitrary = HalfSpecials <$> frequency [ (2, arbitraryFloating) + , (1, arbitraryFloatSpecials) ] + shrink (HalfSpecials n) = [ HalfSpecials n' | n' <- shrinkRealFrac n ] + +instance Arbitrary FloatSpecials where + arbitrary = FloatSpecials <$> frequency [ (2, arbitraryFloating) + , (1, arbitraryFloatSpecials) ] + shrink (FloatSpecials n) = [ FloatSpecials n' | n' <- shrinkRealFrac n ] + +instance Arbitrary DoubleSpecials where + arbitrary = DoubleSpecials <$> frequency [ (2, arbitraryFloating) + , (1, arbitraryFloatSpecials) ] + shrink (DoubleSpecials n) = [ DoubleSpecials n' | n' <- shrinkRealFrac n ] + + +-- | Generate a float from a uniformly random bit pattern +-- +arbitraryFloating :: forall n. RealFloatIEEE n => Gen n +arbitraryFloating = wordToFloating <$> arbitraryBoundedIntegral + +-- | Generate float special values, see 'IeeeSpecials', +-- +-- In particular we generate more than a single NaN bit pattern so that we can +-- test non-canonical representations. The other special values have a single +-- bit pattern. +-- +arbitraryFloatSpecials :: forall n. (RealFloatIEEE n, Random (FloatWord n)) + => Gen n +arbitraryFloatSpecials = + frequency + [ (1, pure (wordToFloating positiveInfinity)) + , (1, pure (wordToFloating negativeInfinity)) + , (1, pure (wordToFloating negativeZero)) + , (3, wordToFloating <$> choose nanRange) + ] + where + IeeeSpecials {..} = floatIeeeSpecials (Proxy :: Proxy n) + +-- | Special values for IEEE float types, including negative 0, +-- positive and negative infinity and a range of NaN values. +-- +data IeeeSpecials n = IeeeSpecials { + positiveInfinity :: n, + negativeInfinity :: n, + negativeZero :: n, + nanRange :: (n, n) + } + deriving (Eq, Functor, Show) + +-- | The 'IeeeSpecials' values for 'RealFloatIEEE' types (i.e. 'Half', 'Float' +-- and 'Double'). +-- +-- To make sense of the bit-twiddling here, see +-- +-- +-- +-- +-- +floatIeeeSpecials :: RealFloatIEEE n => Proxy n -> IeeeSpecials (FloatWord n) +floatIeeeSpecials p = + IeeeSpecials {..} + where + positiveInfinity = (setBit 0 (exponentBits p) - 1) + `shiftL` significandBits p + negativeInfinity = (setBit 0 (exponentBits p +1) - 1) + `shiftL` significandBits p + negativeZero = setBit 0 (exponentBits p + significandBits p) + nanRange = (positiveInfinity, negativeZero - 1) + +class (RealFloat n, Integral (FloatWord n), Show (FloatWord n), + Bounded (FloatWord n), Bits (FloatWord n)) + => RealFloatIEEE n where + exponentBits :: Proxy n -> Int + significandBits :: Proxy n -> Int + + type FloatWord n :: * + wordToFloating :: FloatWord n -> n +--floatingToWord :: n -> FloatWord n + +instance RealFloatIEEE Half where + exponentBits _ = 5 + significandBits _ = 10 + + type FloatWord Half = Word16 + wordToFloating = wordToHalf +--floatingToWord = halfToWord + +instance RealFloatIEEE Float where + exponentBits _ = 8 + significandBits _ = 23 + + type FloatWord Float = Word32 + wordToFloating = wordToFloat +--floatingToWord = floatToWord + +instance RealFloatIEEE Double where + exponentBits _ = 11 + significandBits _ = 52 + + type FloatWord Double = Word64 + wordToFloating = wordToDouble +--floatingToWord = doubleToWord + diff --git a/tests/Tests/Reference/Implementation.hs b/tests/Tests/Reference/Implementation.hs --- a/tests/Tests/Reference/Implementation.hs +++ b/tests/Tests/Reference/Implementation.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples, RankNTypes, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.CBOR @@ -20,16 +19,23 @@ deserialise, Term(..), - reservedTag, - reservedSimple, - eqTerm, + Token(..), canonicaliseTerm, + isCanonicalTerm, UInt(..), fromUInt, toUInt, canonicaliseUInt, + lengthUInt, + Simple(..), + fromSimple, + toSimple, + reservedSimple, + unassignedSimple, + reservedTag, + Decoder, runDecoder, testDecode, @@ -37,11 +43,11 @@ decodeTerm, decodeTokens, decodeToken, - - canonicalNaN, + decodeTagged, diagnosticNotation, + Encoder, encodeTerm, encodeToken, @@ -58,16 +64,12 @@ prop_word32ToFromNet, prop_word64ToFromNet, prop_halfToFromFloat, - - arbitraryFullRangeIntegral, ) where import qualified Control.Monad.Fail as Fail import Data.Bits import Data.Word -import Data.Int -import Numeric.Half (Half(..)) import qualified Numeric.Half as Half import Data.List import Numeric @@ -77,8 +79,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Monoid ((<>)) -import Foreign -import System.IO.Unsafe import Control.Monad (ap) import Test.QuickCheck.Arbitrary @@ -89,7 +89,9 @@ import Control.Applicative #endif +import Tests.Reference.Generators + serialise :: Term -> LBS.ByteString serialise = LBS.pack . encodeTerm @@ -117,7 +119,9 @@ d >>= f = Decoder (\ws -> case runDecoder d ws of Nothing -> Nothing Just (x, ws') -> runDecoder (f x) ws') +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif instance Fail.MonadFail Decoder where fail _ = Decoder (\_ -> Nothing) @@ -211,6 +215,18 @@ , UInt32 <$> arbitraryBoundedIntegral , UInt64 <$> arbitraryBoundedIntegral ] + shrink (UIntSmall n) = [ UIntSmall n' | n' <- shrink n ] + shrink (UInt8 n) = [ UInt8 n' | n' <- shrink n ] + ++ [ UIntSmall (fromIntegral n) | n <= 23 ] + shrink (UInt16 n) = [ UInt16 n' | n' <- shrink n ] + ++ [ UInt8 (fromIntegral n) + | n <= fromIntegral (maxBound :: Word8) ] + shrink (UInt32 n) = [ UInt32 n' | n' <- shrink n ] + ++ [ UInt16 (fromIntegral n) + | n <= fromIntegral (maxBound :: Word16) ] + shrink (UInt64 n) = [ UInt64 n' | n' <- shrink n ] + ++ [ UInt32 (fromIntegral n) + | n <= fromIntegral (maxBound :: Word32) ] instance Arbitrary AdditionalInformation where arbitrary = @@ -302,6 +318,36 @@ extraused = take (8 - length unused) extra ] +data Simple = SimpleSmall Word -- 0 .. 23 + | SimpleLarge Word8 -- 0 .. 255, but 0..23 are non-canonical + -- and 24..31 are reserved + deriving (Eq, Show) + +fromSimple :: Simple -> Word8 +fromSimple (SimpleSmall w) = fromIntegral w +fromSimple (SimpleLarge w) = w + +toSimple :: Word8 -> Simple +toSimple w | w <= 23 = SimpleSmall (fromIntegral w) + | otherwise = SimpleLarge w + +reservedSimple :: Word8 -> Bool +reservedSimple w = w >= 24 && w <= 31 + +unassignedSimple :: Word8 -> Bool +unassignedSimple w = w < 20 || w > 31 + +instance Arbitrary Simple where + arbitrary = oneof [ SimpleSmall <$> choose (0, 23) + , SimpleLarge <$> choose (0, 31) + , SimpleLarge <$> choose (32, 255) + ] + shrink (SimpleSmall n) = [ SimpleSmall n' | n' <- shrink n ] + shrink (SimpleLarge n) = [ SimpleSmall (fromIntegral n') + | n' <- shrink n, n' <= 23 ] + ++ [ SimpleLarge n' | n' <- shrink n ] + + data Token = MT0_UnsignedInt UInt | MT1_NegativeInt UInt @@ -314,10 +360,10 @@ | MT5_MapLen UInt | MT5_MapLenIndef | MT6_Tag UInt - | MT7_Simple Word8 - | MT7_Float16 Half - | MT7_Float32 Float - | MT7_Float64 Double + | MT7_Simple Simple + | MT7_Float16 HalfSpecials + | MT7_Float32 FloatSpecials + | MT7_Float64 DoubleSpecials | MT7_Break deriving (Show, Eq) @@ -339,9 +385,9 @@ , pure MT5_MapLenIndef , MT6_Tag <$> arbitrary , MT7_Simple <$> arbitrary - , MT7_Float16 . getFloatSpecials <$> arbitrary - , MT7_Float32 . getFloatSpecials <$> arbitrary - , MT7_Float64 . getFloatSpecials <$> arbitrary + , MT7_Float16 <$> arbitrary + , MT7_Float32 <$> arbitrary + , MT7_Float64 <$> arbitrary , pure MT7_Break ] where @@ -436,13 +482,13 @@ -- | 27 | IEEE 754 Double-Precision Float (64 bits follow) | -- | 28-30 | (Unassigned) | -- | 31 | "break" stop code for indefinite-length items | - (MajorType7, AiValue (UIntSmall w)) -> return (MT7_Simple (fromIntegral w)) - (MajorType7, AiValue (UInt8 w)) -> return (MT7_Simple (fromIntegral w)) - (MajorType7, AiValue (UInt16 w)) -> return (MT7_Float16 (wordToHalf w)) - (MajorType7, AiValue (UInt32 w)) -> return (MT7_Float32 (wordToFloat w)) - (MajorType7, AiValue (UInt64 w)) -> return (MT7_Float64 (wordToDouble w)) + (MajorType7, AiValue (UIntSmall w)) -> return (MT7_Simple (SimpleSmall w)) + (MajorType7, AiValue (UInt8 w)) -> return (MT7_Simple (SimpleLarge w)) + (MajorType7, AiValue (UInt16 w)) -> return (MT7_Float16 (HalfSpecials (wordToHalf w))) + (MajorType7, AiValue (UInt32 w)) -> return (MT7_Float32 (FloatSpecials (wordToFloat w))) + (MajorType7, AiValue (UInt64 w)) -> return (MT7_Float64 (DoubleSpecials (wordToDouble w))) (MajorType7, AiIndefLen) -> return (MT7_Break) - _ -> fail "invalid token header" + _ -> Left "invalid token header" encodeToken :: Encoder Token @@ -464,12 +510,16 @@ (MT5_MapLen n) -> (MajorType5, AiValue n, []) MT5_MapLenIndef -> (MajorType5, AiIndefLen, []) (MT6_Tag n) -> (MajorType6, AiValue n, []) - (MT7_Simple n) - | n <= 23 -> (MajorType7, AiValue (UIntSmall (fromIntegral n)), []) - | otherwise -> (MajorType7, AiValue (UInt8 n), []) - (MT7_Float16 f) -> (MajorType7, AiValue (UInt16 (halfToWord f)), []) - (MT7_Float32 f) -> (MajorType7, AiValue (UInt32 (floatToWord f)), []) - (MT7_Float64 f) -> (MajorType7, AiValue (UInt64 (doubleToWord f)), []) + (MT7_Simple + (SimpleSmall n)) -> (MajorType7, AiValue (UIntSmall (fromIntegral n)), []) + (MT7_Simple + (SimpleLarge n)) -> (MajorType7, AiValue (UInt8 n), []) + (MT7_Float16 + (HalfSpecials f)) -> (MajorType7, AiValue (UInt16 (halfToWord f)), []) + (MT7_Float32 + (FloatSpecials f)) -> (MajorType7, AiValue (UInt32 (floatToWord f)), []) + (MT7_Float64 + (DoubleSpecials f))-> (MajorType7, AiValue (UInt64 (doubleToWord f)), []) MT7_Break -> (MajorType7, AiIndefLen, []) @@ -492,14 +542,11 @@ lengthUInt = toUInt . fromIntegral . length decodeUTF8 :: [Word8] -> Either String [Char] -decodeUTF8 = either (fail . show) (return . T.unpack) . T.decodeUtf8' . BS.pack +decodeUTF8 = either (Left . show) (return . T.unpack) . T.decodeUtf8' . BS.pack encodeUTF8 :: [Char] -> [Word8] encodeUTF8 = BS.unpack . T.encodeUtf8 . T.pack -reservedSimple :: Word8 -> Bool -reservedSimple w = w >= 20 && w <= 31 - reservedTag :: Word64 -> Bool reservedTag w = w <= 5 @@ -507,14 +554,7 @@ prop_Token token = let ws = encodeToken token Just (token', []) = runDecoder decodeToken ws - in token `eqToken` token' - --- NaNs are so annoying... -eqToken :: Token -> Token -> Bool -eqToken (MT7_Float16 f) (MT7_Float16 f') | isNaN f && isNaN f' = True -eqToken (MT7_Float32 f) (MT7_Float32 f') | isNaN f && isNaN f' = True -eqToken (MT7_Float64 f) (MT7_Float64 f') | isNaN f && isNaN f' = True -eqToken a b = a == b + in token == token' data Term = TUInt UInt | TNInt UInt @@ -532,10 +572,10 @@ | TFalse | TNull | TUndef - | TSimple Word8 - | TFloat16 Half - | TFloat32 Float - | TFloat64 Double + | TSimple Simple + | TFloat16 HalfSpecials + | TFloat32 FloatSpecials + | TFloat64 DoubleSpecials deriving (Show, Eq) instance Arbitrary Term where @@ -557,7 +597,7 @@ , (1, pure TTrue) , (1, pure TNull) , (1, pure TUndef) - , (1, TSimple <$> arbitrary `suchThat` (not . reservedSimple)) + , (1, TSimple <$> arbitrary `suchThat` (unassignedSimple . fromSimple)) , (1, TFloat16 <$> arbitrary) , (1, TFloat32 <$> arbitrary) , (1, TFloat64 <$> arbitrary) @@ -598,7 +638,8 @@ shrink TNull = [] shrink TUndef = [] - shrink (TSimple w) = [ TSimple w' | w' <- shrink w, not (reservedSimple w) ] + shrink (TSimple n) = [ TSimple n' | n' <- shrink n + , unassignedSimple (fromSimple n') ] shrink (TFloat16 f) = [ TFloat16 f' | f' <- shrink f ] shrink (TFloat32 f) = [ TFloat32 f' | f' <- shrink f ] shrink (TFloat64 f) = [ TFloat64 f' | f' <- shrink f ] @@ -627,11 +668,14 @@ MT6_Tag tag -> decodeTagged tag - MT7_Simple 20 -> return TFalse - MT7_Simple 21 -> return TTrue - MT7_Simple 22 -> return TNull - MT7_Simple 23 -> return TUndef - MT7_Simple w -> return (TSimple w) + MT7_Simple n + | n' == 20 -> return TFalse + | n' == 21 -> return TTrue + | n' == 22 -> return TNull + | n' == 23 -> return TUndef + | otherwise -> return (TSimple n) + where + n' = fromSimple n MT7_Float16 f -> return (TFloat16 f) MT7_Float32 f -> return (TFloat32 f) MT7_Float64 f -> return (TFloat64 f) @@ -779,10 +823,10 @@ <> encodeToken MT7_Break encodeTerm (TTagged tag t) = encodeToken (MT6_Tag tag) <> encodeTerm t -encodeTerm TFalse = encodeToken (MT7_Simple 20) -encodeTerm TTrue = encodeToken (MT7_Simple 21) -encodeTerm TNull = encodeToken (MT7_Simple 22) -encodeTerm TUndef = encodeToken (MT7_Simple 23) +encodeTerm TFalse = encodeToken (MT7_Simple (SimpleSmall 20)) +encodeTerm TTrue = encodeToken (MT7_Simple (SimpleSmall 21)) +encodeTerm TNull = encodeToken (MT7_Simple (SimpleSmall 22)) +encodeTerm TUndef = encodeToken (MT7_Simple (SimpleSmall 23)) encodeTerm (TSimple w) = encodeToken (MT7_Simple w) encodeTerm (TFloat16 f) = encodeToken (MT7_Float16 f) encodeTerm (TFloat32 f) = encodeToken (MT7_Float32 f) @@ -795,22 +839,10 @@ prop_Term term = let ws = encodeTerm term Just (term', []) = runDecoder decodeTerm ws - in term `eqTerm` term' - --- NaNs are so annoying... -eqTerm :: Term -> Term -> Bool -eqTerm (TArray ts) (TArray ts') = and (zipWith eqTerm ts ts') -eqTerm (TArrayI ts) (TArrayI ts') = and (zipWith eqTerm ts ts') -eqTerm (TMap ts) (TMap ts') = and (zipWith eqTermPair ts ts') -eqTerm (TMapI ts) (TMapI ts') = and (zipWith eqTermPair ts ts') -eqTerm (TTagged w t) (TTagged w' t') = w == w' && eqTerm t t' -eqTerm (TFloat16 f) (TFloat16 f') | isNaN f && isNaN f' = True -eqTerm (TFloat32 f) (TFloat32 f') | isNaN f && isNaN f' = True -eqTerm (TFloat64 f) (TFloat64 f') | isNaN f && isNaN f' = True -eqTerm a b = a == b + in term == term' -eqTermPair :: (Term, Term) -> (Term, Term) -> Bool -eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b' +isCanonicalTerm :: Term -> Bool +isCanonicalTerm t = canonicaliseTerm t == t canonicaliseTerm :: Term -> Term canonicaliseTerm (TUInt n) = TUInt (canonicaliseUInt n) @@ -821,13 +853,10 @@ | n < 0 && n >= -1 - fromIntegral (maxBound :: Word64) = TNInt (toUInt (fromIntegral (-1 - n))) | otherwise = TBigInt n -canonicaliseTerm (TFloat16 f) = TFloat16 (canonicaliseHalf f) -canonicaliseTerm (TFloat32 f) = if isNaN f - then TFloat16 canonicalNaN - else TFloat32 f -canonicaliseTerm (TFloat64 f) = if isNaN f - then TFloat16 canonicalNaN - else TFloat64 f +canonicaliseTerm (TSimple n) = TSimple (canonicaliseSimple n) +canonicaliseTerm (TFloat16 f) = canonicaliseFloat TFloat16 f +canonicaliseTerm (TFloat32 f) = canonicaliseFloat TFloat32 f +canonicaliseTerm (TFloat64 f) = canonicaliseFloat TFloat64 f canonicaliseTerm (TBytess wss) = TBytess (filter (not . null) wss) canonicaliseTerm (TStrings css) = TStrings (filter (not . null) css) canonicaliseTerm (TArray ts) = TArray (map canonicaliseTerm ts) @@ -840,16 +869,17 @@ canonicaliseUInt :: UInt -> UInt canonicaliseUInt = toUInt . fromUInt -canonicaliseHalf :: Half -> Half -canonicaliseHalf f - | isNaN f = canonicalNaN - | otherwise = f +canonicaliseSimple :: Simple -> Simple +canonicaliseSimple = toSimple . fromSimple +canonicaliseFloat :: RealFloat t => (t -> Term) -> t -> Term +canonicaliseFloat tfloatNN f + | isNaN f = TFloat16 canonicalNaN + | otherwise = tfloatNN f + canonicaliseTermPair :: (Term, Term) -> (Term, Term) canonicaliseTermPair (x,y) = (canonicaliseTerm x, canonicaliseTerm y) -canonicalNaN :: Half -canonicalNaN = Half 0x7e00 ------------------------------------------------------------------------------- @@ -873,11 +903,11 @@ TFalse -> showString "false" TNull -> showString "null" TUndef -> showString "undefined" - TSimple n -> showString "simple" . surround '(' ')' (shows n) + TSimple n -> showString "simple" . surround '(' ')' (shows (fromSimple n)) -- convert to float to work around https://github.com/ekmett/half/issues/2 - TFloat16 f -> showFloatCompat (float2Double (Half.fromHalf f)) - TFloat32 f -> showFloatCompat (float2Double f) - TFloat64 f -> showFloatCompat f + TFloat16 f -> showFloatCompat (float2Double (Half.fromHalf (getHalfSpecials f))) + TFloat32 f -> showFloatCompat (float2Double (getFloatSpecials f)) + TFloat64 f -> showFloatCompat (getDoubleSpecials f) surround a b x = showChar a . x . showChar b @@ -973,36 +1003,6 @@ word64ToNet (word64FromNet w7 w6 w5 w4 w3 w2 w1 w0) == (w7, w6, w5, w4, w3, w2, w1, w0) -wordToHalf :: Word16 -> Half -wordToHalf = Half.Half . fromIntegral - -wordToFloat :: Word32 -> Float -wordToFloat = toFloat - -wordToDouble :: Word64 -> Double -wordToDouble = toFloat - -toFloat :: (Storable word, Storable float) => word -> float -toFloat w = - unsafeDupablePerformIO $ alloca $ \buf -> do - poke (castPtr buf) w - peek buf - -halfToWord :: Half -> Word16 -halfToWord (Half.Half w) = fromIntegral w - -floatToWord :: Float -> Word32 -floatToWord = fromFloat - -doubleToWord :: Double -> Word64 -doubleToWord = fromFloat - -fromFloat :: (Storable word, Storable float) => float -> word -fromFloat float = - unsafeDupablePerformIO $ alloca $ \buf -> do - poke (castPtr buf) float - peek buf - -- Note: some NaNs do not roundtrip https://github.com/ekmett/half/issues/3 -- but all the others had better prop_halfToFromFloat :: Bool @@ -1011,64 +1011,4 @@ where roundTrip w = w == (Half.getHalf . Half.toHalf . Half.fromHalf . Half.Half $ w) - -instance Arbitrary Half where - arbitrary = Half.Half . fromIntegral <$> (arbitrary :: Gen Word16) - -newtype FloatSpecials n = FloatSpecials { getFloatSpecials :: n } - deriving (Show, Eq) - -instance (Arbitrary n, RealFloat n) => Arbitrary (FloatSpecials n) where - arbitrary = - frequency - [ (7, FloatSpecials <$> arbitrary) - , (1, pure (FloatSpecials (1/0)) ) -- +Infinity - , (1, pure (FloatSpecials (0/0)) ) -- NaN - , (1, pure (FloatSpecials (-1/0)) ) -- -Infinity - ] - -newtype LargeInteger = LargeInteger { getLargeInteger :: Integer } - deriving (Show, Eq) - -instance Arbitrary LargeInteger where - arbitrary = - sized $ \n -> - oneof $ take (1 + n `div` 10) - [ LargeInteger . fromIntegral <$> (arbitrary :: Gen Int8) - , LargeInteger . fromIntegral <$> choose (minBound, maxBound :: Int64) - , LargeInteger . bigger . fromIntegral <$> choose (minBound, maxBound :: Int64) - ] - where - bigger n = n * abs n - - -arbitraryFullRangeIntegral :: forall a. (Bounded a, -#if MIN_VERSION_base(4,7,0) - FiniteBits a, -#else - Bits a, -#endif - Integral a) => Gen a -arbitraryFullRangeIntegral - | isSigned (undefined :: a) - = let maxBits = bitSize' (undefined :: a) - 1 - in sized $ \s -> - let bound = fromIntegral (maxBound :: a) - `shiftR` ((maxBits - s) `max` 0) - in fmap fromInteger $ choose (-bound, bound) - - | otherwise - = let maxBits = bitSize' (undefined :: a) - in sized $ \s -> - let bound = fromIntegral (maxBound :: a) - `shiftR` ((maxBits - s) `max` 0) - in fmap fromInteger $ choose (0, bound) - - where - bitSize' = -#if MIN_VERSION_base(4,7,0) - finiteBitSize -#else - bitSize -#endif diff --git a/tests/Tests/Reference/TestVectors.hs b/tests/Tests/Reference/TestVectors.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Reference/TestVectors.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Tests.Reference.TestVectors ( + -- * RFC7049 test vector + RFC7049TestCase(..) + , rfc7049TestVector + + -- * External test vector + , ExternalTestCase(..) + , loadExternalTestVector + , withExternalTestVector + ) where + +import Test.Tasty as Tasty (TestTree, withResource) + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.Text.Encoding as T +import Data.Aeson as Aeson +import Control.Applicative +import Control.Monad +import Data.Word + + +------------------------------------------------------------ +-- Test vector from https://github.com/cbor/test-vectors/ +-- + +-- | A CBOR encoding unit test case for the data from +-- +-- +data ExternalTestCase = ExternalTestCase { + encoded :: !LBS.ByteString, + decoded :: !(Either Aeson.Value String), + roundTrip :: !Bool + } + deriving Show + +instance FromJSON ExternalTestCase where + parseJSON = + withObject "cbor test" $ \obj -> do + encoded64 <- T.encodeUtf8 <$> obj .: "cbor" + encoded <- either fail return $ + Base64.decode encoded64 + encoded16 <- T.encodeUtf8 <$> obj .: "hex" + let encoded' = Base16.decodeLenient encoded16 + when (encoded /= encoded') $ + fail "hex and cbor encoding mismatch in input" + roundTrip <- obj .: "roundtrip" + decoded <- Left <$> obj .: "decoded" + <|> Right <$> obj .: "diagnostic" + return $! ExternalTestCase { + encoded = LBS.fromStrict encoded, + roundTrip, + decoded + } + +loadExternalTestVector :: IO [ExternalTestCase] +loadExternalTestVector = do + content <- LBS.readFile "tests/test-vectors/appendix_a.json" + either fail return (Aeson.eitherDecode' content) + +withExternalTestVector :: (IO [ExternalTestCase] -> TestTree) -> TestTree +withExternalTestVector = + Tasty.withResource loadExternalTestVector (\_ -> return ()) + + +--------------------------------------------------- +-- Test vector from CBOR spec RFC7049 Appendix A +-- + +-- | A CBOR encoding unit test case consisting of the encoded bytes and +-- corresponding diagnostic notation. +-- +data RFC7049TestCase = RFC7049TestCase { + expectedDiagnostic :: String, + encodedBytes :: [Word8] + } + deriving Show + + +-- | The examples from the CBOR spec RFC7049 Appendix A. +-- +rfc7049TestVector :: [RFC7049TestCase] +rfc7049TestVector = + map (uncurry RFC7049TestCase) + [ ("0", [0x00]) + , ("1", [0x01]) + , ("10", [0x0a]) + , ("23", [0x17]) + , ("24", [0x18, 0x18]) + , ("25", [0x18, 0x19]) + , ("100", [0x18, 0x64]) + , ("1000", [0x19, 0x03, 0xe8]) + , ("1000000", [0x1a, 0x00, 0x0f, 0x42, 0x40]) + , ("1000000000000", [0x1b, 0x00, 0x00, 0x00, 0xe8, 0xd4, 0xa5, 0x10, 0x00]) + + , ("18446744073709551615", [0x1b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) + , ("18446744073709551616", [0xc2, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) + , ("-18446744073709551616", [0x3b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) + , ("-18446744073709551617", [0xc3, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) + + , ("-1", [0x20]) + , ("-10", [0x29]) + , ("-100", [0x38, 0x63]) + , ("-1000", [0x39, 0x03, 0xe7]) + + , ("0.0", [0xf9, 0x00, 0x00]) + , ("-0.0", [0xf9, 0x80, 0x00]) + , ("1.0", [0xf9, 0x3c, 0x00]) + , ("1.1", [0xfb, 0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a]) + , ("1.5", [0xf9, 0x3e, 0x00]) + , ("65504.0", [0xf9, 0x7b, 0xff]) + , ("100000.0", [0xfa, 0x47, 0xc3, 0x50, 0x00]) + , ("3.4028234663852886e38", [0xfa, 0x7f, 0x7f, 0xff, 0xff]) + , ("1.0e300", [0xfb, 0x7e, 0x37, 0xe4, 0x3c, 0x88, 0x00, 0x75, 0x9c]) + , ("5.960464477539063e-8", [0xf9, 0x00, 0x01]) + , ("0.00006103515625", [0xf9, 0x04, 0x00]) + , ("-4.0", [0xf9, 0xc4, 0x00]) + , ("-4.1", [0xfb, 0xc0, 0x10, 0x66, 0x66, 0x66, 0x66, 0x66, 0x66]) + + , ("Infinity", [0xf9, 0x7c, 0x00]) + , ("NaN", [0xf9, 0x7e, 0x00]) + , ("-Infinity", [0xf9, 0xfc, 0x00]) + , ("Infinity", [0xfa, 0x7f, 0x80, 0x00, 0x00]) + , ("-Infinity", [0xfa, 0xff, 0x80, 0x00, 0x00]) + , ("Infinity", [0xfb, 0x7f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) + , ("-Infinity", [0xfb, 0xff, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) + + , ("false", [0xf4]) + , ("true", [0xf5]) + , ("null", [0xf6]) + , ("undefined", [0xf7]) + , ("simple(16)", [0xf0]) + , ("simple(24)", [0xf8, 0x18]) + , ("simple(255)", [0xf8, 0xff]) + + , ("0(\"2013-03-21T20:04:00Z\")", + [0xc0, 0x74, 0x32, 0x30, 0x31, 0x33, 0x2d, 0x30, 0x33, 0x2d, 0x32, 0x31, + 0x54, 0x32, 0x30, 0x3a, 0x30, 0x34, 0x3a, 0x30, 0x30, 0x5a]) + , ("1(1363896240)", [0xc1, 0x1a, 0x51, 0x4b, 0x67, 0xb0]) + , ("1(1363896240.5)", [0xc1, 0xfb, 0x41, 0xd4, 0x52, 0xd9, 0xec, 0x20, 0x00, 0x00]) + , ("23(h'01020304')", [0xd7, 0x44, 0x01, 0x02, 0x03, 0x04]) + , ("24(h'6449455446')", [0xd8, 0x18, 0x45, 0x64, 0x49, 0x45, 0x54, 0x46]) + , ("32(\"http://www.example.com\")", + [0xd8, 0x20, 0x76, 0x68, 0x74, 0x74, 0x70, 0x3a, 0x2f, 0x2f, 0x77, 0x77, + 0x77, 0x2e, 0x65, 0x78, 0x61, 0x6d, 0x70, 0x6c, 0x65, 0x2e, 0x63, 0x6f, 0x6d]) + + , ("h''", [0x40]) + , ("h'01020304'", [0x44, 0x01, 0x02, 0x03, 0x04]) + , ("\"\"", [0x60]) + , ("\"a\"", [0x61, 0x61]) + , ("\"IETF\"", [0x64, 0x49, 0x45, 0x54, 0x46]) + , ("\"\\\"\\\\\"", [0x62, 0x22, 0x5c]) + , ("\"\\252\"", [0x62, 0xc3, 0xbc]) + , ("\"\\27700\"", [0x63, 0xe6, 0xb0, 0xb4]) + , ("\"\\65873\"", [0x64, 0xf0, 0x90, 0x85, 0x91]) + + , ("[]", [0x80]) + , ("[1, 2, 3]", [0x83, 0x01, 0x02, 0x03]) + , ("[1, [2, 3], [4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05]) + , ("[1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]", + [0x98, 0x19, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, + 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, + 0x17, 0x18, 0x18, 0x18, 0x19]) + + , ("{}", [0xa0]) + , ("{1: 2, 3: 4}", [0xa2, 0x01, 0x02, 0x03, 0x04]) + , ("{\"a\": 1, \"b\": [2, 3]}", [0xa2, 0x61, 0x61, 0x01, 0x61, 0x62, 0x82, 0x02, 0x03]) + , ("[\"a\", {\"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xa1, 0x61, 0x62, 0x61, 0x63]) + , ("{\"a\": \"A\", \"b\": \"B\", \"c\": \"C\", \"d\": \"D\", \"e\": \"E\"}", + [0xa5, 0x61, 0x61, 0x61, 0x41, 0x61, 0x62, 0x61, 0x42, 0x61, 0x63, 0x61, + 0x43, 0x61, 0x64, 0x61, 0x44, 0x61, 0x65, 0x61, 0x45]) + + , ("(_ h'0102', h'030405')", [0x5f, 0x42, 0x01, 0x02, 0x43, 0x03, 0x04, 0x05, 0xff]) + , ("(_ \"strea\", \"ming\")", [0x7f, 0x65, 0x73, 0x74, 0x72, 0x65, 0x61, 0x64, 0x6d, 0x69, 0x6e, 0x67, 0xff]) + + , ("[_ ]", [0x9f, 0xff]) + , ("[_ 1, [2, 3], [_ 4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff, 0xff]) + , ("[_ 1, [2, 3], [4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05, 0xff]) + , ("[1, [2, 3], [_ 4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff]) + , ("[1, [_ 2, 3], [4, 5]]", [0x83, 0x01, 0x9f, 0x02, 0x03, 0xff, 0x82, 0x04, 0x05]) + , ("[_ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]", + [0x9f, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, + 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, + 0x18, 0x18, 0x18, 0x19, 0xff]) + , ("{_ \"a\": 1, \"b\": [_ 2, 3]}", [0xbf, 0x61, 0x61, 0x01, 0x61, 0x62, 0x9f, 0x02, 0x03, 0xff, 0xff]) + + , ("[\"a\", {_ \"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xbf, 0x61, 0x62, 0x61, 0x63, 0xff]) + , ("{_ \"Fun\": true, \"Amt\": -2}", [0xbf, 0x63, 0x46, 0x75, 0x6e, 0xf5, 0x63, 0x41, 0x6d, 0x74, 0x21, 0xff]) + ] + +-- TODO FIXME: test redundant encodings e.g. +-- bigint with zero-length bytestring +-- bigint with leading zeros +-- bigint using indefinate bytestring encoding +-- larger than necessary ints, lengths, tags, simple etc + diff --git a/tests/Tests/Regress/FlatTerm.hs b/tests/Tests/Regress/FlatTerm.hs --- a/tests/Tests/Regress/FlatTerm.hs +++ b/tests/Tests/Regress/FlatTerm.hs @@ -19,7 +19,7 @@ -- Tests and properties -- | Test an edge case in the FlatTerm implementation: when encoding a word --- larger than @'maxBound' :: 'Int'@, we store it as an @'Integer'@, and +-- larger than @'maxBound' :: 'Int'@, we store it as an 'Integer', and -- need to remember to handle this case when we decode. largeWordTest :: Either String Word largeWordTest = fromFlatTerm decodeWord $ toFlatTerm (encodeWord largeWord) @@ -29,7 +29,7 @@ -- | Test an edge case in the FlatTerm implementation: when encoding an -- Int64 that is less than @'minBound' :: 'Int'@, make sure we use an --- @'Integer'@ to store the result, because sticking it into an @'Int'@ +-- 'Integer' to store the result, because sticking it into an 'Int' -- will result in overflow otherwise. smallInt64Test :: Either String Int64 smallInt64Test = fromFlatTerm decodeInt64 $ toFlatTerm (encodeInt64 smallInt64) diff --git a/tests/Tests/Regress/Issue160.hs b/tests/Tests/Regress/Issue160.hs --- a/tests/Tests/Regress/Issue160.hs +++ b/tests/Tests/Regress/Issue160.hs @@ -1,11 +1,18 @@ +{-# LANGUAGE CPP #-} module Tests.Regress.Issue160 ( testTree ) where import Codec.CBOR.Decoding import Codec.CBOR.Read + import Control.DeepSeq +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Monoid (Monoid(..)) +#endif import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Text (Text) + import Test.Tasty import Test.Tasty.HUnit diff --git a/tests/Tests/Regress/Issue162.hs b/tests/Tests/Regress/Issue162.hs --- a/tests/Tests/Regress/Issue162.hs +++ b/tests/Tests/Regress/Issue162.hs @@ -1,6 +1,7 @@ module Tests.Regress.Issue162 ( testTree ) where import Control.Monad (void) +import Control.Applicative ((<$), (<*)) import Data.Word import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LBS diff --git a/tests/Tests/Term.hs b/tests/Tests/Term.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Term.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Tests.Term ( + Term + , serialise + , deserialise + , toRefTerm + , fromRefTerm + , eqTerm + , canonicaliseTerm + , prop_fromToRefTerm + , prop_toFromRefTerm + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Word +import qualified Numeric.Half as Half + +import Codec.CBOR.Term +import Codec.CBOR.Read +import Codec.CBOR.Write + +import Test.QuickCheck + +import qualified Tests.Reference.Implementation as Ref +import Tests.Reference.Generators + ( floatToWord, doubleToWord, canonicalNaN + , HalfSpecials(..), FloatSpecials(..), DoubleSpecials(..) ) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Exception (throw) + + +------------------------------------------------------------------------------ + +serialise :: Term -> LBS.ByteString +serialise = toLazyByteString . encodeTerm + +deserialise :: LBS.ByteString -> Term +deserialise b = + case deserialiseFromBytes decodeTerm b of + Left failure -> throw failure + Right (trailing, _) | not (LBS.null trailing) + -> error "Test.deserialise: trailing data" + Right (_, t) -> t + + +------------------------------------------------------------------------------ + +toRefTerm :: Term -> Ref.Term +toRefTerm (TInt n) + | n >= 0 = Ref.TUInt (Ref.toUInt (fromIntegral n)) + | otherwise = Ref.TNInt (Ref.toUInt (fromIntegral (-1 - n))) +toRefTerm (TInteger n) -- = Ref.TBigInt n + | n >= 0 && n <= fromIntegral (maxBound :: Word64) + = Ref.TUInt (Ref.toUInt (fromIntegral n)) + | n < 0 && n >= -1 - fromIntegral (maxBound :: Word64) + = Ref.TNInt (Ref.toUInt (fromIntegral (-1 - n))) + | otherwise = Ref.TBigInt n +toRefTerm (TBytes bs) = Ref.TBytes (BS.unpack bs) +toRefTerm (TBytesI bs) = Ref.TBytess (map BS.unpack (LBS.toChunks bs)) +toRefTerm (TString st) = Ref.TString (T.unpack st) +toRefTerm (TStringI st) = Ref.TStrings (map T.unpack (LT.toChunks st)) +toRefTerm (TList ts) = Ref.TArray (map toRefTerm ts) +toRefTerm (TListI ts) = Ref.TArrayI (map toRefTerm ts) +toRefTerm (TMap ts) = Ref.TMap [ (toRefTerm x, toRefTerm y) + | (x,y) <- ts ] +toRefTerm (TMapI ts) = Ref.TMapI [ (toRefTerm x, toRefTerm y) + | (x,y) <- ts ] +toRefTerm (TTagged w t) = Ref.TTagged (Ref.toUInt (fromIntegral w)) + (toRefTerm t) +toRefTerm (TBool False) = Ref.TFalse +toRefTerm (TBool True) = Ref.TTrue +toRefTerm TNull = Ref.TNull +toRefTerm (TSimple 23) = Ref.TUndef +toRefTerm (TSimple w) = Ref.TSimple (Ref.toSimple w) +toRefTerm (THalf f) = if isNaN f + then Ref.TFloat16 canonicalNaN + else Ref.TFloat16 (HalfSpecials (Half.toHalf f)) +toRefTerm (TFloat f) = if isNaN f + then Ref.TFloat16 canonicalNaN + else Ref.TFloat32 (FloatSpecials f) +toRefTerm (TDouble f) = if isNaN f + then Ref.TFloat16 canonicalNaN + else Ref.TFloat64 (DoubleSpecials f) + + +fromRefTerm :: Ref.Term -> Term +fromRefTerm (Ref.TUInt u) + | n <= fromIntegral (maxBound :: Int) = TInt (fromIntegral n) + | otherwise = TInteger (fromIntegral n) + where n = Ref.fromUInt u + +fromRefTerm (Ref.TNInt u) + | n <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral n) + | otherwise = TInteger (-1 - fromIntegral n) + where n = Ref.fromUInt u + +fromRefTerm (Ref.TBigInt n) = TInteger n +fromRefTerm (Ref.TBytes bs) = TBytes (BS.pack bs) +fromRefTerm (Ref.TBytess bs) = TBytesI (LBS.fromChunks (map BS.pack bs)) +fromRefTerm (Ref.TString st) = TString (T.pack st) +fromRefTerm (Ref.TStrings st) = TStringI (LT.fromChunks (map T.pack st)) + +fromRefTerm (Ref.TArray ts) = TList (map fromRefTerm ts) +fromRefTerm (Ref.TArrayI ts) = TListI (map fromRefTerm ts) +fromRefTerm (Ref.TMap ts) = TMap [ (fromRefTerm x, fromRefTerm y) + | (x,y) <- ts ] +fromRefTerm (Ref.TMapI ts) = TMapI [ (fromRefTerm x, fromRefTerm y) + | (x,y) <- ts ] +fromRefTerm (Ref.TTagged w t) = TTagged (Ref.fromUInt w) + (fromRefTerm t) +fromRefTerm (Ref.TFalse) = TBool False +fromRefTerm (Ref.TTrue) = TBool True +fromRefTerm Ref.TNull = TNull +fromRefTerm Ref.TUndef = TSimple 23 +fromRefTerm (Ref.TSimple w) = TSimple (Ref.fromSimple w) +fromRefTerm (Ref.TFloat16 f) = THalf (Half.fromHalf (getHalfSpecials f)) +fromRefTerm (Ref.TFloat32 f) = TFloat (getFloatSpecials f) +fromRefTerm (Ref.TFloat64 f) = TDouble (getDoubleSpecials f) + +-- | Compare terms for equality. +-- +-- It does exact bit for bit equality of floats. This means we can compare +-- NaNs, and different NaNs do not compare equal. If you need equality +-- modulo different NaNs then use 'canonicaliseTerm'. +-- +-- If you need equality modulo different representations of 'TInt' vs 'TInteger' +-- then use 'canonicaliseTerm'. +-- +eqTerm :: Term -> Term -> Bool +eqTerm (TList ts) (TList ts') = and (zipWith eqTerm ts ts') +eqTerm (TListI ts) (TListI ts') = and (zipWith eqTerm ts ts') +eqTerm (TMap ts) (TMap ts') = and (zipWith eqTermPair ts ts') +eqTerm (TMapI ts) (TMapI ts') = and (zipWith eqTermPair ts ts') +eqTerm (TTagged w t) (TTagged w' t') = w == w' && eqTerm t t' +eqTerm (THalf f) (THalf f') = floatToWord f == floatToWord f' +eqTerm (TFloat f) (TFloat f') = floatToWord f == floatToWord f' +eqTerm (TDouble f) (TDouble f') = doubleToWord f == doubleToWord f' +eqTerm a b = a == b + +eqTermPair :: (Term, Term) -> (Term, Term) -> Bool +eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b' + +-- | Both 'toRefTerm' and the encoding \/ decoding round trip canonicalises +-- NaNs. So tests involving these often need this in combination with +-- comparing for exact equality using 'eqTerm'. +-- +canonicaliseTerm :: Term -> Term +canonicaliseTerm (THalf f) | isNaN f = canonicalTermNaN +canonicaliseTerm (TFloat f) | isNaN f = canonicalTermNaN +canonicaliseTerm (TDouble f) | isNaN f = canonicalTermNaN +canonicaliseTerm (TInteger n) | n <= fromIntegral (maxBound :: Int) + , n >= fromIntegral (minBound :: Int) + = TInt (fromIntegral n) +canonicaliseTerm (TList ts) = TList (map canonicaliseTerm ts) +canonicaliseTerm (TListI ts) = TListI (map canonicaliseTerm ts) +canonicaliseTerm (TMap ts) = TMap (map canonicaliseTermPair ts) +canonicaliseTerm (TMapI ts) = TMapI (map canonicaliseTermPair ts) +canonicaliseTerm (TTagged tag t) = TTagged tag (canonicaliseTerm t) +canonicaliseTerm t = t + +canonicalTermNaN :: Term +canonicalTermNaN = THalf canonicalNaN + +canonicaliseTermPair :: (Term, Term) -> (Term, Term) +canonicaliseTermPair (a,b) = + (canonicaliseTerm a, canonicaliseTerm b) + + +prop_fromToRefTerm :: Ref.Term -> Bool +prop_fromToRefTerm term = toRefTerm (fromRefTerm term) + == Ref.canonicaliseTerm term + +prop_toFromRefTerm :: Term -> Bool +prop_toFromRefTerm term = fromRefTerm (toRefTerm term) + `eqTerm` canonicaliseTerm term + +instance Arbitrary Term where + arbitrary = fromRefTerm <$> arbitrary + + shrink (TInt n) = [ TInt n' | n' <- shrink n ] + shrink (TInteger n) = [ TInteger n' | n' <- shrink n ] + + shrink (TBytes ws) = [ TBytes (BS.pack ws') | ws' <- shrink (BS.unpack ws) ] + shrink (TBytesI wss) = [ TBytesI (LBS.fromChunks (map BS.pack wss')) + | wss' <- shrink (map BS.unpack (LBS.toChunks wss)) ] + shrink (TString cs) = [ TString (T.pack cs') | cs' <- shrink (T.unpack cs) ] + shrink (TStringI css) = [ TStringI (LT.fromChunks (map T.pack css')) + | css' <- shrink (map T.unpack (LT.toChunks css)) ] + + shrink (TList xs@[x]) = x : [ TList xs' | xs' <- shrink xs ] + shrink (TList xs) = [ TList xs' | xs' <- shrink xs ] + shrink (TListI xs@[x]) = x : [ TListI xs' | xs' <- shrink xs ] + shrink (TListI xs) = [ TListI xs' | xs' <- shrink xs ] + + shrink (TMap xys@[(x,y)]) = x : y : [ TMap xys' | xys' <- shrink xys ] + shrink (TMap xys) = [ TMap xys' | xys' <- shrink xys ] + shrink (TMapI xys@[(x,y)]) = x : y : [ TMapI xys' | xys' <- shrink xys ] + shrink (TMapI xys) = [ TMapI xys' | xys' <- shrink xys ] + + shrink (TTagged w t) = t : [ TTagged w' t' | (w', t') <- shrink (w, t) + , not (Ref.reservedTag (fromIntegral w')) ] + + shrink (TBool _) = [] + shrink TNull = [] + + shrink (TSimple w) = [ TSimple w' | w' <- shrink w + , Ref.unassignedSimple w || w == 23 ] + shrink (THalf _f) = [] + shrink (TFloat f) = [ TFloat f' | f' <- shrink f ] + shrink (TDouble f) = [ TDouble f' | f' <- shrink f ] + diff --git a/tests/Tests/UnitTests.hs b/tests/Tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/UnitTests.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Tests.UnitTests (testTree) where + +import qualified Data.ByteString.Lazy as LBS + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase, assertEqual, (@=?)) + +import qualified Tests.Reference.Implementation as Ref +import Tests.Reference.TestVectors +import Tests.Reference (termToJson, equalJson) +import Tests.Term as Term (toRefTerm, serialise, deserialise) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + + +------------------------------------------------------------------------------- +-- Unit tests for test vector from CBOR spec RFC7049 Appendix A +-- + +unit_externalTestVector :: [ExternalTestCase] -> Assertion +unit_externalTestVector = mapM_ unit_externalTestCase + +unit_externalTestCase :: ExternalTestCase -> Assertion +unit_externalTestCase ExternalTestCase { + encoded, + decoded = Left expectedJson + } = do + let term = Term.deserialise encoded + actualJson = termToJson (toRefTerm term) + reencoded = Term.serialise term + + expectedJson `equalJson` actualJson + encoded @=? reencoded + +unit_externalTestCase ExternalTestCase { + encoded, + decoded = Right expectedDiagnostic + } = do + let term = Term.deserialise encoded + actualDiagnostic = Ref.diagnosticNotation (toRefTerm term) + reencoded = Term.serialise term + + expectedDiagnostic @=? actualDiagnostic + encoded @=? reencoded + + +------------------------------------------------------------------------------- +-- Unit tests for test vector from CBOR spec RFC7049 Appendix A +-- + +unit_expectedDiagnosticNotation :: RFC7049TestCase -> Assertion +unit_expectedDiagnosticNotation RFC7049TestCase { + expectedDiagnostic, + encodedBytes + } = do + let term = Term.deserialise (LBS.pack encodedBytes) + actualDiagnostic = Ref.diagnosticNotation (toRefTerm term) + + expectedDiagnostic @=? actualDiagnostic + +-- | The reference implementation satisfies the roundtrip property for most +-- examples (all the ones from Appendix A). It does not satisfy the roundtrip +-- property in general however, non-canonical over-long int encodings for +-- example. +-- +unit_encodedRoundtrip :: RFC7049TestCase -> Assertion +unit_encodedRoundtrip RFC7049TestCase { + expectedDiagnostic, + encodedBytes + } = do + let term = Term.deserialise (LBS.pack encodedBytes) + reencodedBytes = LBS.unpack (Term.serialise term) + + assertEqual ("for CBOR: " ++ expectedDiagnostic) encodedBytes reencodedBytes + + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = + testGroup "unit tests" + [ testCase "RFC7049 test vector: decode" $ + mapM_ unit_expectedDiagnosticNotation rfc7049TestVector + + , testCase "RFC7049 test vector: roundtrip" $ + mapM_ unit_encodedRoundtrip rfc7049TestVector + + , withExternalTestVector $ \getTestVector -> + testCase "external test vector" $ + getTestVector >>= unit_externalTestVector + ]