cborg 0.2.1.0 → 0.2.2.0

raw patch · 26 files changed

+3577/−998 lines, 26 filesdep +base-orphansdep +randomdep ~QuickCheckdep ~basedep ~primitivenew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base-orphans, random

Dependency ranges changed: QuickCheck, base, primitive, semigroups, tasty

API changes (from Hackage documentation)

Files

• ChangeLog.md +37/−0
• cborg.cabal +32/−18
• src/Codec/CBOR/ByteArray/Sliced.hs +6/−0
• src/Codec/CBOR/Decoding.hs +147/−98
• src/Codec/CBOR/Encoding.hs +45/−26
• src/Codec/CBOR/FlatTerm.hs +153/−24
• src/Codec/CBOR/Magic.hs +64/−53
• src/Codec/CBOR/Pretty.hs +8/−1
• src/Codec/CBOR/Read.hs +60/−28
• src/Codec/CBOR/Term.hs +10/−10
• src/Codec/CBOR/Write.hs +88/−68
• tests/Main.hs +23/−15
• tests/Tests/ByteOffset.hs +458/−0
• tests/Tests/CBOR.hs +0/−284
• tests/Tests/Canonical.hs +191/−0
• tests/Tests/PreEncoded.hs +95/−0
• tests/Tests/Properties.hs +1192/−0
• tests/Tests/Reference.hs +63/−192
• tests/Tests/Reference/Generators.hs +261/−0
• tests/Tests/Reference/Implementation.hs +118/−179
• tests/Tests/Reference/TestVectors.hs +199/−0
• tests/Tests/Regress/FlatTerm.hs +2/−2
• tests/Tests/Regress/Issue160.hs +7/−0
• tests/Tests/Regress/Issue162.hs +1/−0
• tests/Tests/Term.hs +220/−0
• tests/Tests/UnitTests.hs +97/−0

@@ -1,5 +1,42 @@ # Revision history for cborg +## 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

@@ -1,34 +1,39 @@ name:                cborg-version:             0.2.1.0-synopsis:            Concise Binary Object Representation+version:             0.2.2.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 == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC==8.8.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,13 +83,13 @@    build-depends:     array                   >= 0.4     && < 0.6,-    base                    >= 4.6     && < 5.0,+    base                    >= 4.7     && < 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,     half                    >= 0.2.2.3 && < 0.4,-    primitive               >= 0.5     && < 0.7,+    primitive               >= 0.5     && < 0.8,     text                    >= 1.1     && < 1.3    if flag(optimize-gmp)@@ -96,7 +101,7 @@     ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances   else     -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8-    build-depends: fail == 4.9.*, semigroups == 0.18.*+    build-depends: fail == 4.9.*, semigroups >=0.18 && <0.20  test-suite tests   type:              exitcode-stdio-1.0@@ -109,20 +114,28 @@     -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,+    base                    >= 4.7     && < 5.0,+    base-orphans,     bytestring              >= 0.10.4  && < 0.11,     text                    >= 1.1     && < 1.3,     cborg,@@ -132,9 +145,10 @@     deepseq                 >= 1.0     && < 1.5,     fail                    >= 4.9.0.0 && < 4.10,     half                    >= 0.2.2.3 && < 0.4,-    QuickCheck              >= 2.9     && < 2.13,+    QuickCheck              >= 2.9     && < 2.14,+    random,     scientific              >= 0.3     && < 0.4,-    tasty                   >= 0.11    && < 1.2,+    tasty                   >= 0.11    && < 1.3,     tasty-hunit             >= 0.9     && < 0.11,     tasty-quickcheck        >= 0.8     && < 0.11,     vector                  >= 0.10    && < 0.13

@@ -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

@@ -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,8 +129,8 @@  -- | 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@@ -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,7 +304,7 @@ 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)@@ -307,10 +316,10 @@ -- <https://tools.ietf.org/html/rfc7049#section-3.9> -- -- 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 +333,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,35 +347,35 @@ -- 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#)))) {-# 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#)))) {-# 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#)))) {-# INLINE decodeWord32 #-} --- | Decode a @'Word64'@.+-- | Decode a 'Word64'. -- -- @since 0.2.0.0 decodeWord64 :: Decoder s Word64@@ -378,14 +387,14 @@   Decoder (\k -> return (ConsumeWord64 (\w64# -> k (W64# 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@@ -397,35 +406,35 @@   Decoder (\k -> return (ConsumeNegWord64 (\w64# -> k (W64# 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#)))) {-# 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#)))) {-# 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#)))) {-# INLINE decodeInt32 #-} --- | Decode an @'Int64'@.+-- | Decode an 'Int64'. -- -- @since 0.2.0.0 decodeInt64 :: Decoder s Int64@@ -437,35 +446,35 @@   Decoder (\k -> return (ConsumeInt64 (\n64# -> k (I64# 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#)))) {-# 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#)))) {-# 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#)))) {-# INLINE decodeWord32Canonical #-} --- | Decode canonical representation of a @'Word64'@.+-- | Decode canonical representation of a 'Word64'. -- -- @since 0.2.0.0 decodeWord64Canonical :: Decoder s Word64@@ -477,14 +486,14 @@   Decoder (\k -> return (ConsumeWord64Canonical (\w64# -> k (W64# 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@@ -496,35 +505,35 @@   Decoder (\k -> return (ConsumeNegWord64Canonical (\w64# -> k (W64# 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#)))) {-# 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#)))) {-# 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#)))) {-# INLINE decodeInt32Canonical #-} --- | Decode canonical representation of an @'Int64'@.+-- | Decode canonical representation of an 'Int64'. -- -- @since 0.2.0.0 decodeInt64Canonical :: Decoder s Int64@@ -536,35 +545,35 @@   Decoder (\k -> return (ConsumeInt64Canonical (\n64# -> k (I64# 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 +610,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,14 +700,14 @@ 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@@ -711,7 +720,7 @@ #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,7 +728,7 @@ {-# 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@@ -745,7 +754,7 @@ 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@@ -753,28 +762,28 @@ decodeSimple = Decoder (\k -> return (ConsumeSimple (\w# -> k (W8# 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,7 +791,7 @@ {-# 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@@ -793,7 +802,7 @@ -- 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 +811,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 +819,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 +829,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 +837,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 +855,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 +869,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 +883,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 +895,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 +910,47 @@ 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# off#))))+{-# 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 +998,3 @@     go !acc 0 = return $! g acc     go !acc n = do !x <- get; go (f acc x) (n-1) {-# INLINE decodeSequenceLenN #-}-

@@ -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

@@ -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 @@ -60,19 +63,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 +105,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 +148,131 @@ 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.+              Read.Partial k <- Read.deserialiseIncremental decodeTermToken+              k (Just bs)+          collectOutput next++    collectOutput :: Read.IDecode s TermToken -> ST.Lazy.ST s FlatTerm+    collectOutput (Read.Fail _ _ err) = fail $ "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 <- decodeTag+                             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 +449,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,7 +544,7 @@     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@@ -440,12 +569,12 @@  -------------------------------------------------------------------------------- --- | 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 +583,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 +597,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 +691,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

@@ -26,7 +26,7 @@   , grabWord32        -- :: Ptr () -> Word   , grabWord64        -- :: Ptr () -> Word64 -    -- * @'ByteString'@ utilities+    -- * 'ByteString' utilities   , eatTailWord8      -- :: ByteString -> Word   , eatTailWord16     -- :: ByteString -> Word   , eatTailWord32     -- :: ByteString -> Word@@ -65,7 +65,7 @@   , word32ToWord64    -- :: Word32 -> Word64 #endif -    -- * @'Integer'@ utilities+    -- * 'Integer' utilities   , nintegerFromBytes -- :: ByteString -> Integer   , uintegerFromBytes -- :: ByteString -> Integer @@ -87,6 +87,9 @@ 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)@@ -104,7 +107,7 @@  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 +120,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 #-} @@ -226,43 +229,43 @@ -------------------------------------------------------------------------------- -- 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 +276,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 +284,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 +299,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 +326,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 +350,7 @@             case readDoubleArray# mba# 0# s'' of               (# _, f# #) -> f# {-# NOINLINE wordToFloat64# #-}+#endif  -------------------------------------------------------------------------------- -- Casting words and ints@@ -449,11 +460,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)@@ -483,11 +494,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 +508,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 +516,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 +524,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 +541,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 +553,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 +569,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 +584,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

@@ -42,7 +42,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 +103,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@@ -178,6 +180,7 @@     TkFloat16  f  TkEnd -> ppTkFloat16 f     TkFloat32  f  TkEnd -> ppTkFloat32 f     TkFloat64  f  TkEnd -> ppTkFloat64 f+    TkEncoded  _  TkEnd -> ppTkEncoded     TkEnd               -> str "# End of input"     _ -> fail $ unwords ["pprint: Unexpected token:", show term] @@ -202,6 +205,9 @@ 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"@@ -297,6 +303,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 ()

@@ -99,8 +99,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 +109,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 +128,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 +157,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 +170,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 +242,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 @@ -596,9 +598,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 +652,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 +702,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 +722,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 @@ -1095,9 +1100,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 +1161,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 +1264,11 @@       where         !offset' = offset + intToInt64 (BS.length bs - BS.length bs') +    SlowPeekByteOffset bs' k ->+      lift (k off#) >>= \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 +1366,12 @@         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 (k off#) >>= \daz -> go_slow daz bs' offset'+        where+          !(I64# off#) = offset'+       SlowFail bs_unconsumed msg ->         decodeFail (bs_unconsumed <> bs') offset'' msg         where@@ -1482,22 +1498,32 @@                  | 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 #-}@@ -1535,6 +1561,12 @@   where     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

@@ -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

@@ -14,8 +14,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@@ -60,102 +59,123 @@  -------------------------------------------------------------------------------- --- | 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 (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) (buildStep 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) (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

@@ -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     ]

@@ -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'+

@@ -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-        ]-    ]

@@ -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+    ]+  ]+

@@ -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+  ]+

@@ -0,0 +1,1192 @@+{-# 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.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           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           System.Random (Random)++import qualified Tests.Reference.Implementation as Ref+import           Tests.Reference.Implementation (UInt(..))+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+++-- | 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 :: *++  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+++--------------------------------------------------------------------------------+-- 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))+    ]++  , 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))+    ]++  , 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))+    ]++  , 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))+    ]++  , 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))+    ]++  , 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))+    ]++  , 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))+    ]++  , 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))+    ]++  , 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))+    ]+  ]

@@ -1,70 +1,42 @@ {-# 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 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 +44,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@@ -114,16 +89,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 +116,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 +152,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     ]

@@ -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+--+-- <https://en.wikipedia.org/wiki/Single-precision_floating-point_format>+-- <https://en.wikipedia.org/wiki/Half-precision_floating-point_format>+-- <https://en.wikipedia.org/wiki/Double-precision_floating-point_format>+--+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+

@@ -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,22 @@     deserialise,      Term(..),-    reservedTag,-    reservedSimple,-    eqTerm,+    Token(..),     canonicaliseTerm,+    isCanonicalTerm,      UInt(..),     fromUInt,     toUInt,     canonicaliseUInt, +    Simple(..),+    fromSimple,+    toSimple,+    reservedSimple,+    unassignedSimple,+    reservedTag,+     Decoder,     runDecoder,     testDecode,@@ -37,11 +42,11 @@     decodeTerm,     decodeTokens,     decodeToken,--    canonicalNaN,+    decodeTagged,      diagnosticNotation, +    Encoder,     encodeTerm,     encodeToken, @@ -58,16 +63,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 +78,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 +88,9 @@ import           Control.Applicative #endif +import           Tests.Reference.Generators + serialise :: Term -> LBS.ByteString serialise = LBS.pack . encodeTerm @@ -117,7 +118,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 +214,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 +317,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 +359,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 +384,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,11 +481,11 @@     --   | 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" @@ -464,12 +509,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, [])  @@ -497,9 +546,6 @@ 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 +553,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 +571,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 +596,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 +637,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 +667,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 +822,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 +838,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 +852,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 +868,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 +902,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 +1002,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 +1010,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 

@@ -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+-- <https://github.com/cbor/test-vectors/>+--+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 "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 $! 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+

@@ -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)

@@ -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 

@@ -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

@@ -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 ]+

@@ -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+    ]