serialise 0.2.0.0 → 0.2.1.0

raw patch · 20 files changed

+180/−2434 lines, 20 filesdep +semigroupsdep −base16-bytestringdep −base64-bytestringdep −scientificdep ~QuickCheckdep ~aesondep ~binaryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: semigroups

Dependencies removed: base16-bytestring, base64-bytestring, scientific

Dependency ranges changed: QuickCheck, aeson, binary, containers, criterion, primitive, store, tasty, tasty-hunit, tasty-quickcheck, time

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−1
• bench/instances/Instances/Float.hs +25/−0
• bench/instances/Main.hs +3/−1
• bench/micro/Micro/CBOR.hs +4/−1
• bench/versus/Macro/CBOR.hs +4/−1
• bench/versus/Macro/DeepSeq.hs +4/−0
• bench/versus/Macro/Load.hs +62/−10
• serialise.cabal +33/−46
• src/Codec/Serialise/Tutorial.hs +5/−5
• tests/Main.hs +3/−6
• tests/Tests/CBOR.hs +0/−297
• tests/Tests/Negative.hs +5/−0
• tests/Tests/Orphanage.hs +3/−1
• tests/Tests/Reference.hs +0/−293
• tests/Tests/Reference/Implementation.hs +0/−1070
• tests/Tests/Regress.hs +1/−3
• tests/Tests/Regress/FlatTerm.hs +0/−47
• tests/Tests/Serialise.hs +14/−1
• tests/test-vectors/README.md +0/−27
• tests/test-vectors/appendix_a.json +0/−624

@@ -1,5 +1,18 @@ # Revision history for serialise -## 0.1.0.0  -- YYYY-mm-dd+## 0.2.1.0  -- 2018-10-11++* Bounds bumps and GHC 8.6 compatibility++## 0.2.0.0  -- 2017-11-30++* Improved robustness in presence of invalid UTF-8 strings++* Add encoders and decoders for `ByteArray`++* Export `GSerialiseProd(..) and GSerialiseSum(..)`+++## 0.1.0.0  -- 2017-06-28  * First version. Released on an unsuspecting world.

@@ -0,0 +1,25 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Instances.Float+  ( benchmarks -- :: [Benchmark]+  ) where++import           Criterion.Main+import           Codec.Serialise+import           Control.DeepSeq (force)+import qualified Data.ByteString.Lazy as BSL++benchmarks :: [Benchmark]+benchmarks =+  [ bench "serialise Float" (whnf (BSL.length . serialise) fakesF)+  , bench "deserialise Float" (nf (deserialise :: BSL.ByteString -> [Float]) serialF)+  , bench "serialise Double" (whnf (BSL.length . serialise) fakesD)+  , bench "deserialise Double" (nf (deserialise :: BSL.ByteString -> [Double]) serialD)+  ]+  where+    fakesF = force (replicate 100 (3.14159 :: Float))+    fakesD = force (replicate 100 (3.14159 :: Double))++    serialF = force (serialise fakesF)+    serialD = force (serialise fakesD)+

@@ -4,6 +4,7 @@  import           Criterion.Main (bgroup, defaultMain) +import qualified Instances.Float   as Float import qualified Instances.Integer as Integer import qualified Instances.Time    as Time import qualified Instances.Vector  as Vector@@ -12,7 +13,8 @@  main :: IO () main = defaultMain-  [ bgroup "integer" Integer.benchmarks+  [ bgroup "float"   Float.benchmarks+  , bgroup "integer" Integer.benchmarks   , bgroup "time"    Time.benchmarks   , bgroup "vector"  Vector.benchmarks   ]

@@ -8,7 +8,10 @@ import Codec.Serialise.Encoding import Codec.Serialise.Decoding hiding (DecodeAction(Done, Fail)) import qualified Codec.Serialise as Serialise-import Data.Monoid++#if ! MIN_VERSION_base(4,11,0)+import           Data.Monoid+#endif  import qualified Data.ByteString.Lazy as BS 

@@ -13,7 +13,10 @@ import Codec.Serialise.Decoding hiding (DecodeAction(Done, Fail)) import Codec.CBOR.Read import Codec.CBOR.Write-import Data.Monoid++#if ! MIN_VERSION_base(4,11,0)+import           Data.Monoid+#endif  import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as BS

@@ -1,9 +1,13 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Macro.DeepSeq where  import Macro.Types  import Control.DeepSeq+#if MIN_VERSION_deepseq(1,4,3)+     hiding (rnf1, rnf2)+#endif  rnf0 :: () rnf1 :: NFData a => a -> ()

@@ -9,7 +9,7 @@ import qualified Text.ParserCombinators.ReadP as Parse import qualified Text.PrettyPrint          as Disp import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace)-import Text.PrettyPrint hiding (braces)+import Text.PrettyPrint hiding (braces, (<>))  import Data.List import Data.Function (on)@@ -25,11 +25,21 @@ import qualified Codec.Archive.Tar       as Tar import qualified Codec.Archive.Tar.Entry as Tar +#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif+import Data.Semigroup hiding (option)+ #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..)) import Data.Monoid hiding ((<>)) #endif +#if !MIN_VERSION_base(4,9,0)+instance Semigroup Doc where+  a <> b = mappend a b+#endif+ readPkgIndex :: BS.ByteString -> Either String [GenericPackageDescription] readPkgIndex = fmap extractCabalFiles . readTarIndex   where@@ -2378,7 +2388,13 @@     libExposed     = True,     libBuildInfo   = mempty   }-  mappend a b = Library {+  mappend = mappendLibrary++instance Semigroup Library where+  a <> b = mappendLibrary a b++mappendLibrary :: Library -> Library -> Library+mappendLibrary a b = Library {     exposedModules = combine exposedModules,     libExposed     = libExposed a && libExposed b, -- so False propagates     libBuildInfo   = combine libBuildInfo@@ -2394,7 +2410,13 @@     modulePath = mempty,     buildInfo  = mempty   }-  mappend a b = Executable{+  mappend = mappendExecutable++instance Semigroup Executable where+  a <> b = mappendExecutable a b++mappendExecutable :: Executable -> Executable -> Executable+mappendExecutable a b = Executable {     exeName    = combine' exeName,     modulePath = combine modulePath,     buildInfo  = combine buildInfo@@ -2417,8 +2439,13 @@         testBuildInfo = mempty,         testEnabled   = False     }+    mappend = mappendTestSuite -    mappend a b = TestSuite {+instance Semigroup TestSuite where+    a <> b = mappendTestSuite a b++mappendTestSuite :: TestSuite -> TestSuite -> TestSuite+mappendTestSuite a b = TestSuite {         testName      = combine' testName,         testInterface = combine  testInterface,         testBuildInfo = combine  testBuildInfo,@@ -2433,9 +2460,15 @@  instance Monoid TestSuiteInterface where     mempty  =  TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))-    mappend a (TestSuiteUnsupported _) = a-    mappend _ b                        = b+    mappend = mappendTestSuiteInterface +instance Semigroup TestSuiteInterface where+    a <> b = mappendTestSuiteInterface a b++mappendTestSuiteInterface :: TestSuiteInterface -> TestSuiteInterface -> TestSuiteInterface+mappendTestSuiteInterface a (TestSuiteUnsupported _) = a+mappendTestSuiteInterface _ b                        = b+ emptyTestSuite :: TestSuite emptyTestSuite = mempty @@ -2446,8 +2479,10 @@         benchmarkBuildInfo = mempty,         benchmarkEnabled   = False     }+    mappend = mappendBenchmark -    mappend a b = Benchmark {+mappendBenchmark :: Benchmark -> Benchmark -> Benchmark+mappendBenchmark a b = Benchmark {         benchmarkName      = combine' benchmarkName,         benchmarkInterface = combine  benchmarkInterface,         benchmarkBuildInfo = combine  benchmarkBuildInfo,@@ -2462,9 +2497,14 @@  instance Monoid BenchmarkInterface where     mempty  =  BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] []))-    mappend a (BenchmarkUnsupported _) = a-    mappend _ b                        = b+    mappend = mappendBenchmarkInterface +mappendBenchmarkInterface :: BenchmarkInterface -> BenchmarkInterface -> BenchmarkInterface+mappendBenchmarkInterface a (BenchmarkUnsupported _) = a+mappendBenchmarkInterface _ b                        = b+++ emptyBenchmark :: Benchmark emptyBenchmark = mempty @@ -2496,7 +2536,10 @@     customFieldsBI    = [],     targetBuildDepends = []   }-  mappend a b = BuildInfo {+  mappend = mappendBuildInfo++mappendBuildInfo :: BuildInfo -> BuildInfo -> BuildInfo+mappendBuildInfo a b = BuildInfo {     buildable         = buildable a && buildable b,     buildTools        = combine    buildTools,     cppOptions        = combine    cppOptions,@@ -2528,6 +2571,15 @@       combineNub field = nub (combine field)       combineMby field = field b `mplus` field a ++instance Semigroup Benchmark where+  a <> b = mappendBenchmark a b++instance Semigroup BenchmarkInterface where+  a <> b = mappendBenchmarkInterface a b++instance Semigroup BuildInfo where+  a <> b = mappendBuildInfo a b  -- | Parse a list of fields, given a list of field descriptions, --   a structure to accumulate the parsed fields, and a function

@@ -1,5 +1,5 @@ name:                serialise-version:             0.2.0.0+version:             0.2.1.0 synopsis:            A binary serialisation library for Haskell values. description:   This package (formerly @binary-serialise-cbor@) provides pure, efficient@@ -11,7 +11,7 @@   Representation', or CBOR, specified in RFC 7049. As a result,   serialised Haskell values have implicit structure outside of the   Haskell program itself, meaning they can be inspected or analyzed-  with custom tools.+  without custom tools.   .   An implementation of the standard bijection between CBOR and JSON is provided   by the [cborg-json](/package/cborg-json) package. Also see@@ -31,8 +31,6 @@ build-type:          Simple  extra-source-files:-  tests/test-vectors/appendix_a.json-  tests/test-vectors/README.md   ChangeLog.md  source-repository head@@ -67,9 +65,9 @@     base                    >= 4.6     && < 5.0,     bytestring              >= 0.10.4  && < 0.11,     cborg                   == 0.2.*,-    containers              >= 0.5     && < 0.6,-    ghc-prim                >= 0.3     && < 0.6,-    half                    >= 0.2.2.3 && < 0.3,+    containers              >= 0.5     && < 0.7,+    ghc-prim                >= 0.3.1.0 && < 0.6,+    half                    >= 0.2.2.3 && < 0.4,     hashable                >= 1.2     && < 2.0,     primitive               >= 0.5     && < 0.7,     text                    >= 1.1     && < 1.3,@@ -78,7 +76,7 @@    if flag(newtime15)     build-depends:-      time                  >= 1.5     && < 1.9+      time                  >= 1.5     && < 1.10   else     build-depends:       time                  >= 1.4     && < 1.5,@@ -97,10 +95,10 @@    default-language:  Haskell2010   ghc-options:-    -Wall -fno-warn-orphans -threaded -rtsopts "-with-rtsopts=-N"+    -Wall -fno-warn-orphans+    -threaded -rtsopts "-with-rtsopts=-N2"    other-modules:-    Tests.CBOR     Tests.IO     Tests.Negative     Tests.Orphanage@@ -112,39 +110,25 @@     Tests.Regress.Issue80     Tests.Regress.Issue106     Tests.Regress.Issue135-    Tests.Regress.FlatTerm-    Tests.Reference-    Tests.Reference.Implementation     Tests.Deriving     Tests.GeneralisedUTF8    build-depends:-    array                   >= 0.4     && < 0.6,     base                    >= 4.6     && < 5.0,-    binary                  >= 0.7     && < 0.10,     bytestring              >= 0.10.4  && < 0.11,     directory               >= 1.0     && < 1.4,     filepath                >= 1.0     && < 1.5,-    ghc-prim                >= 0.3     && < 0.6,     text                    >= 1.1     && < 1.3,-    time                    >= 1.4     && < 1.9,-    containers              >= 0.5     && < 0.6,+    time                    >= 1.4     && < 1.10,+    containers              >= 0.5     && < 0.7,     unordered-containers    >= 0.2     && < 0.3,-    hashable                >= 1.2     && < 2.0,     primitive               >= 0.5     && < 0.7,     cborg,     serialise,--    aeson                   >= 0.7     && < 1.3,-    base64-bytestring       >= 1.0     && < 1.1,-    base16-bytestring       >= 0.1     && < 0.2,-    deepseq                 >= 1.0     && < 1.5,-    half                    >= 0.2.2.3 && < 0.3,-    QuickCheck              >= 2.9     && < 2.11,-    scientific              >= 0.3     && < 0.4,-    tasty                   >= 0.11    && < 0.13,-    tasty-hunit             >= 0.9     && < 0.10,-    tasty-quickcheck        >= 0.8     && < 0.10,+    QuickCheck              >= 2.9     && < 2.13,+    tasty                   >= 0.11    && < 1.2,+    tasty-hunit             >= 0.9     && < 0.11,+    tasty-quickcheck        >= 0.8     && < 0.11,     quickcheck-instances    >= 0.3.12  && < 0.4,     vector                  >= 0.10    && < 0.13 @@ -161,24 +145,25 @@     -Wall -rtsopts -fno-cse -fno-ignore-asserts -fno-warn-orphans    other-modules:+    Instances.Float     Instances.Integer     Instances.Vector     Instances.Time    build-depends:     base                    >= 4.6     && < 5.0,-    binary                  >= 0.7     && < 0.10,+    binary                  >= 0.7     && < 0.11,     bytestring              >= 0.10.4  && < 0.11,     vector                  >= 0.10    && < 0.13,     cborg,     serialise,      deepseq                 >= 1.0     && < 1.5,-    criterion               >= 1.0     && < 1.3+    criterion               >= 1.0     && < 1.6    if flag(newtime15)     build-depends:-      time                  >= 1.5     && < 1.9+      time                  >= 1.5     && < 1.10   else     build-depends:       time                  >= 1.4     && < 1.5,@@ -211,19 +196,20 @@    build-depends:     base                    >= 4.6     && < 5.0,-    binary                  >= 0.7     && < 0.10,+    binary                  >= 0.7     && < 0.11,     bytestring              >= 0.10.4  && < 0.11,-    ghc-prim                >= 0.3     && < 0.6,+    ghc-prim                >= 0.3.1.0 && < 0.6,     vector                  >= 0.10    && < 0.13,     cborg,     serialise, -    aeson                   >= 0.7     && < 1.3,+    aeson                   >= 0.7     && < 1.5,     deepseq                 >= 1.0     && < 1.5,-    criterion               >= 1.0     && < 1.3,+    criterion               >= 1.0     && < 1.6,     cereal                  >= 0.5.2.0 && < 0.6,     cereal-vector           >= 0.2     && < 0.3,-    store                   >= 0.4     && < 0.5+    store                   >= 0.4     && < 0.6,+    semigroups              == 0.18.*  benchmark versus   type:              exitcode-stdio-1.0@@ -257,30 +243,31 @@   build-depends:     array                   >= 0.4     && < 0.6,     base                    >= 4.6     && < 5.0,-    binary                  >= 0.7     && < 0.10,+    binary                  >= 0.7     && < 0.11,     bytestring              >= 0.10.4  && < 0.11,     directory               >= 1.0     && < 1.4,-    ghc-prim                >= 0.3     && < 0.6,+    ghc-prim                >= 0.3.1.0 && < 0.6,     text                    >= 1.1     && < 1.3,     vector                  >= 0.10    && < 0.13,     cborg,     serialise,      filepath                >= 1.0     && < 1.5,-    containers              >= 0.5     && < 0.6,+    containers              >= 0.5     && < 0.7,     deepseq                 >= 1.0     && < 1.5,-    aeson                   >= 0.7     && < 1.3,+    aeson                   >= 0.7     && < 1.5,     cereal                  >= 0.5.2.0 && < 0.6,-    half                    >= 0.2.2.3 && < 0.3,+    half                    >= 0.2.2.3 && < 0.4,     tar                     >= 0.4     && < 0.6,     zlib                    >= 0.5     && < 0.7,     pretty                  >= 1.0     && < 1.2,-    criterion               >= 1.0     && < 1.3,-    store                   >= 0.4     && < 0.5+    criterion               >= 1.0     && < 1.6,+    store                   >= 0.4     && < 0.6,+    semigroups              == 0.18.*    if flag(newtime15)     build-depends:-      time                  >= 1.5     && < 1.9+      time                  >= 1.5     && < 1.10   else     build-depends:       time                  >= 1.4     && < 1.5,

@@ -270,24 +270,24 @@ > -- HoppingAnimal, SwimmingAnimal cases are unchanged... > encodeAnimal (HoppingAnimal name height) = >     encodeListLen 3 <> encodeWord 0 <> encode name <> encode height-> encodeAnimal (WalkingAnimal name speed) =->     encodeListLen 3 <> encodeWord 1 <> encode name <> encode speed+> encodeAnimal (SwimmingAnimal numberOfFins) =+>     encodeListLen 2 <> encodeWord 2 <> encode numberOfFins > -- This is new... > encodeAnimal (WalkingAnimal animalName walkingSpeed numberOfFeet) =->     encodeListLen 4 <> encodeWord 3 <> encode animalName <> encode walkingSpeed <> encode numberOfFins+>     encodeListLen 4 <> encodeWord 3 <> encode animalName <> encode walkingSpeed <> encode numberOfFeet > > decodeAnimal :: Decoder s Animal > decodeAnimal = do >     len <- decodeListLen >     tag <- decodeWord >     case (len, tag) of->       -- this cases are unchanged...+>       -- these cases are unchanged... >       (3, 0) -> HoppingAnimal <$> decode <*> decode >       (2, 2) -> SwimmingAnimal <$> decode >       -- this is new... >       (3, 1) -> WalkingAnimal <$> decode <*> decode <*> pure 4 >                                                      -- ^ note the default for backwards compat->       (4, 3) -> WalkingAnimal <$> decode <*> decode+>       (4, 3) -> WalkingAnimal <$> decode <*> decode <*> decode >       _      -> fail "invalid Animal encoding"  We can use this same approach to handle field removal and type changes.

@@ -4,20 +4,17 @@ import           Test.Tasty (defaultMain, testGroup)  import qualified Tests.IO        as IO-import qualified Tests.CBOR      as CBOR import qualified Tests.Regress   as Regress-import qualified Tests.Reference as Reference import qualified Tests.Serialise as Serialise import qualified Tests.Negative  as Negative import qualified Tests.Deriving  as Deriving import qualified Tests.GeneralisedUTF8  as GeneralisedUTF8  main :: IO ()-main = Reference.loadTestCases >>= \tcs -> defaultMain $+main =+  defaultMain $   testGroup "CBOR tests"-    [ CBOR.testTree tcs-    , Reference.testTree tcs-    , Serialise.testTree+    [ Serialise.testTree     , Serialise.testGenerics     , Negative.testTree     , IO.testTree

@@ -1,297 +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(..))--#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----------------------------------------------------------------------------------splits2 :: LBS.ByteString -> [LBS.ByteString]-splits2 bs = zipWith (\a b -> LBS.fromChunks [a,b]) (BS.inits sbs) (BS.tails sbs)-  where-    sbs = LBS.toStrict bs--splits3 :: LBS.ByteString -> [LBS.ByteString]-splits3 bs =-    [ LBS.fromChunks [a,b,c]-    | (a,x) <- zip (BS.inits sbs) (BS.tails sbs)-    , (b,c) <- zip (BS.inits x)   (BS.tails x) ]-  where-    sbs = LBS.toStrict bs---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-        ]-    ]

@@ -1,7 +1,12 @@+{-# LANGUAGE CPP #-} module Tests.Negative   ( testTree -- :: TestTree   ) where++#if ! MIN_VERSION_base(4,11,0) import           Data.Monoid+#endif+ import           Data.Version  import           Test.Tasty

@@ -26,7 +26,7 @@ import           Test.QuickCheck.Arbitrary  import qualified Data.Vector.Primitive      as Vector.Primitive-import qualified Data.ByteString.Short      as BSS+-- import qualified Data.ByteString.Short      as BSS  -------------------------------------------------------------------------------- -- QuickCheck Orphans@@ -195,8 +195,10 @@ deriving instance Eq a   => Eq   (Const a b) #endif +#if !MIN_VERSION_quickcheck_instances(0,3,17) instance Arbitrary BSS.ShortByteString where   arbitrary = BSS.pack <$> arbitrary+#endif  instance (Vector.Primitive.Prim a, Arbitrary a          ) => Arbitrary (Vector.Primitive.Vector a) where

@@ -1,293 +0,0 @@-{-# LANGUAGE NamedFieldPuns     #-}-{-# LANGUAGE OverloadedStrings  #-}-module Tests.Reference-  ( TestCase(..)   -- :: *-  , termToJson     -- ::-  , equalJson      -- ::-  , loadTestCases  -- ::-  , specTestVector -- ::-  , testTree       -- :: TestTree-  ) where--import           Test.Tasty-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---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-      }--loadTestCases :: IO [TestCase]-loadTestCases = do-    content <- LBS.readFile "tests/test-vectors/appendix_a.json"-    either fail return (Aeson.eitherDecode' content)--externalTestCase :: TestCase -> Assertion-externalTestCase TestCase { encoded, decoded = Left expectedJson } = do-  let term       = deserialise encoded-      actualJson = termToJson term-      reencoded  = serialise term--  expectedJson `equalJson` actualJson-  encoded @=? reencoded--externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do-  let term             = deserialise encoded-      actualDiagnostic = diagnosticNotation term-      reencoded        = serialise term--  expectedDiagnostic @=? actualDiagnostic-  encoded @=? reencoded--equalJson :: Aeson.Value -> Aeson.Value -> Assertion-equalJson (Aeson.Number expected) (Aeson.Number actual)-  | toRealFloat expected == promoteDouble (toRealFloat actual)-                          = return ()-  where-    -- This is because the expected JSON output is always using double precision-    -- where as Aeson's Scientific type preserves the precision of the input.-    -- So for tests using Float, we're more precise than the reference values.-    promoteDouble :: Float -> Double-    promoteDouble = realToFrac--equalJson expected actual = expected @=? actual---termToJson :: CBOR.Term -> Aeson.Value-termToJson (TUInt    n)   = Aeson.Number (fromIntegral (fromUInt n))-termToJson (TNInt    n)   = Aeson.Number (-1 - fromIntegral (fromUInt n))-termToJson (TBigInt  n)   = Aeson.Number (fromIntegral n)-termToJson (TBytes   ws)  = Aeson.String (bytesToBase64Text ws)-termToJson (TBytess  wss) = Aeson.String (bytesToBase64Text (concat wss))-termToJson (TString  cs)  = Aeson.String (T.pack cs)-termToJson (TStrings css) = Aeson.String (T.pack (concat css))-termToJson (TArray   ts)  = Aeson.Array  (V.fromList (map termToJson ts))-termToJson (TArrayI  ts)  = Aeson.Array  (V.fromList (map termToJson ts))-termToJson (TMap     kvs) = Aeson.object [ (T.pack k, termToJson v)-                                         | (TString k,v) <- kvs ]-termToJson (TMapI    kvs) = Aeson.object [ (T.pack k, termToJson v)-                                         | (TString k,v) <- kvs ]-termToJson (TTagged _ t)  = termToJson t-termToJson  TTrue         = Aeson.Bool True-termToJson  TFalse        = Aeson.Bool False-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)--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-      actualDiagnostic = diagnosticNotation 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 Just (term, [])  = runDecoder decodeTerm encoded-      reencoded        = encodeTerm term--  assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded---- | 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 =-  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 "properties"-        [ testProperty "encoding/decoding initial byte"    prop_InitialByte-        , testProperty "encoding/decoding additional info" prop_AdditionalInfo-        , testProperty "encoding/decoding token header"    prop_TokenHeader-        , testProperty "encoding/decoding token header 2"  prop_TokenHeader2-        , testProperty "encoding/decoding tokens"          prop_Token-        , --localOption (QuickCheckTests  1000) $-          localOption (QuickCheckMaxSize 150) $-          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-        ]-    ]

@@ -1,1070 +0,0 @@-{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples, RankNTypes, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module      : Codec.CBOR--- Copyright   : 2013 Simon Meier <iridcode@gmail.com>,---               2013-2014 Duncan Coutts,--- License     : BSD3-style (see LICENSE.txt)------ Maintainer  : Duncan Coutts--- Stability   :--- Portability : portable------ CBOR format support.-----------------------------------------------------------------------------------module Tests.Reference.Implementation (-    serialise,-    deserialise,--    Term(..),-    reservedTag,-    reservedSimple,-    eqTerm,-    canonicaliseTerm,--    UInt(..),-    fromUInt,-    toUInt,-    canonicaliseUInt,--    Decoder,-    runDecoder,-    testDecode,--    decodeTerm,-    decodeTokens,-    decodeToken,--    canonicalNaN,--    diagnosticNotation,--    encodeTerm,-    encodeToken,--    prop_InitialByte,-    prop_AdditionalInfo,-    prop_TokenHeader,-    prop_TokenHeader2,-    prop_Token,-    prop_Term,--    -- properties of internal helpers-    prop_integerToFromBytes,-    prop_word16ToFromNet,-    prop_word32ToFromNet,-    prop_word64ToFromNet,-    prop_halfToFromFloat,--    arbitraryFullRangeIntegral,-    ) where---import           Data.Bits-import           Data.Word-import           Data.Int-import           Numeric.Half (Half(..))-import qualified Numeric.Half as Half-import           Data.List-import           Numeric-import           GHC.Float (float2Double)-import qualified Data.ByteString      as BS-import qualified Data.ByteString.Lazy as LBS-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-import           Test.QuickCheck.Gen--#if !MIN_VERSION_base(4,8,0)-import           Data.Monoid (Monoid(..))-import           Control.Applicative-#endif---serialise :: Term -> LBS.ByteString-serialise = LBS.pack . encodeTerm--deserialise :: LBS.ByteString -> Term-deserialise bytes =-    case runDecoder decodeTerm (LBS.unpack bytes) of-      Just (term, []) -> term-      Just _          -> error "ReferenceImpl.deserialise: trailing data"-      Nothing         -> error "ReferenceImpl.deserialise: decoding failed"-----------------------------------------------------------------------------newtype Decoder a = Decoder { runDecoder :: [Word8] -> Maybe (a, [Word8]) }--instance Functor Decoder where-  fmap f a = a >>= return . f--instance Applicative Decoder where-  pure  = return-  (<*>) = ap--instance Monad Decoder where-  return x = Decoder (\ws -> Just (x, ws))-  d >>= f  = Decoder (\ws -> case runDecoder d ws of-                               Nothing       -> Nothing-                               Just (x, ws') -> runDecoder (f x) ws')-  fail _   = Decoder (\_ -> Nothing)--getByte :: Decoder Word8-getByte =-  Decoder $ \ws ->-    case ws of-      w:ws' -> Just (w, ws')-      _     -> Nothing--getBytes :: Integral n => n -> Decoder [Word8]-getBytes n =-  Decoder $ \ws ->-    case genericSplitAt n ws of-      (ws', [])   | genericLength ws' == n -> Just (ws', [])-                  | otherwise              -> Nothing-      (ws', ws'')                          -> Just (ws', ws'')--eof :: Decoder Bool-eof = Decoder $ \ws -> Just (null ws, ws)--type Encoder a = a -> [Word8]---- The initial byte of each data item contains both information about--- the major type (the high-order 3 bits, described in Section 2.1) and--- additional information (the low-order 5 bits).--data MajorType = MajorType0 | MajorType1 | MajorType2 | MajorType3-               | MajorType4 | MajorType5 | MajorType6 | MajorType7-  deriving (Show, Eq, Ord, Enum)--instance Arbitrary MajorType where-  arbitrary = elements [MajorType0 .. MajorType7]--encodeInitialByte :: MajorType -> Word -> Word8-encodeInitialByte mt ai-  | ai < 2^(5 :: Int)-  = fromIntegral (fromIntegral (fromEnum mt) `shiftL` 5 .|. ai)--  | otherwise-  = error "encodeInitialByte: invalid additional info value"--decodeInitialByte :: Word8 -> (MajorType, Word)-decodeInitialByte ib = ( toEnum $ fromIntegral $ ib `shiftR` 5-                       , fromIntegral $ ib .&. 0x1f)--prop_InitialByte :: Bool-prop_InitialByte =-    and [ (uncurry encodeInitialByte . decodeInitialByte) w8 == w8-        | w8 <- [minBound..maxBound] ]---- When the value of the--- additional information is less than 24, it is directly used as a--- small unsigned integer.  When it is 24 to 27, the additional bytes--- for a variable-length integer immediately follow; the values 24 to 27--- of the additional information specify that its length is a 1-, 2-,--- 4-, or 8-byte unsigned integer, respectively.  Additional information--- value 31 is used for indefinite-length items, described in--- Section 2.2.  Additional information values 28 to 30 are reserved for--- future expansion.------ In all additional information values, the resulting integer is--- interpreted depending on the major type.  It may represent the actual--- data: for example, in integer types, the resulting integer is used--- for the value itself.  It may instead supply length information: for--- example, in byte strings it gives the length of the byte string data--- that follows.--data UInt =-       UIntSmall Word-     | UInt8     Word8-     | UInt16    Word16-     | UInt32    Word32-     | UInt64    Word64-  deriving (Eq, Show)--data AdditionalInformation =-       AiValue    UInt-     | AiIndefLen-     | AiReserved Word-  deriving (Eq, Show)--instance Arbitrary UInt where-  arbitrary =-    sized $ \n ->-      oneof $ take (1 + n `div` 2)-        [ UIntSmall <$> choose (0, 23)-        , UInt8     <$> arbitraryBoundedIntegral-        , UInt16    <$> arbitraryBoundedIntegral-        , UInt32    <$> arbitraryBoundedIntegral-        , UInt64    <$> arbitraryBoundedIntegral-        ]--instance Arbitrary AdditionalInformation where-  arbitrary =-    frequency-      [ (7, AiValue <$> arbitrary)-      , (2, pure AiIndefLen)-      , (1, AiReserved <$> choose (28, 30))-      ]--decodeAdditionalInfo :: Word -> Decoder AdditionalInformation-decodeAdditionalInfo = dec-  where-    dec n-      | n < 24 = return (AiValue (UIntSmall n))-    dec 24     = do w <- getByte-                    return (AiValue (UInt8 w))-    dec 25     = do [w1,w0] <- getBytes (2 :: Int)-                    let w = word16FromNet w1 w0-                    return (AiValue (UInt16 w))-    dec 26     = do [w3,w2,w1,w0] <- getBytes (4 :: Int)-                    let w = word32FromNet w3 w2 w1 w0-                    return (AiValue (UInt32 w))-    dec 27     = do [w7,w6,w5,w4,w3,w2,w1,w0] <- getBytes (8 :: Int)-                    let w = word64FromNet w7 w6 w5 w4 w3 w2 w1 w0-                    return (AiValue (UInt64 w))-    dec 31     = return AiIndefLen-    dec n-      | n < 31 = return (AiReserved n)-    dec _      = fail ""--encodeAdditionalInfo :: AdditionalInformation -> (Word, [Word8])-encodeAdditionalInfo = enc-  where-    enc (AiValue (UIntSmall n))-      | n < 24               = (n, [])-      | otherwise            = error "invalid UIntSmall value"-    enc (AiValue (UInt8  w)) = (24, [w])-    enc (AiValue (UInt16 w)) = (25, [w1, w0])-                               where (w1, w0) = word16ToNet w-    enc (AiValue (UInt32 w)) = (26, [w3, w2, w1, w0])-                               where (w3, w2, w1, w0) = word32ToNet w-    enc (AiValue (UInt64 w)) = (27, [w7, w6, w5, w4,-                                     w3, w2, w1, w0])-                               where (w7, w6, w5, w4,-                                      w3, w2, w1, w0) = word64ToNet w-    enc  AiIndefLen          = (31, [])-    enc (AiReserved n)-      | n >= 28 && n < 31    = (n,  [])-      | otherwise            = error "invalid AiReserved value"--prop_AdditionalInfo :: AdditionalInformation -> Bool-prop_AdditionalInfo ai =-    let (w, ws) = encodeAdditionalInfo ai-        Just (ai', _) = runDecoder (decodeAdditionalInfo w) ws-     in ai == ai'---data TokenHeader = TokenHeader MajorType AdditionalInformation-  deriving (Show, Eq)--instance Arbitrary TokenHeader where-  arbitrary = TokenHeader <$> arbitrary <*> arbitrary--decodeTokenHeader :: Decoder TokenHeader-decodeTokenHeader = do-    b <- getByte-    let (mt, ai) = decodeInitialByte b-    ai' <- decodeAdditionalInfo ai-    return (TokenHeader mt ai')--encodeTokenHeader :: Encoder TokenHeader-encodeTokenHeader (TokenHeader mt ai) =-    let (w, ws) = encodeAdditionalInfo ai-     in encodeInitialByte mt w : ws--prop_TokenHeader :: TokenHeader -> Bool-prop_TokenHeader header =-    let ws                = encodeTokenHeader header-        Just (header', _) = runDecoder decodeTokenHeader ws-     in header == header'--prop_TokenHeader2 :: Bool-prop_TokenHeader2 =-    and [ w8 : extraused == encoded-        | w8 <- [minBound..maxBound]-        , let extra = [1..8]-              Just (header, unused) = runDecoder decodeTokenHeader (w8 : extra)-              encoded   = encodeTokenHeader header-              extraused = take (8 - length unused) extra-        ]--data Token =-     MT0_UnsignedInt UInt-   | MT1_NegativeInt UInt-   | MT2_ByteString  UInt [Word8]-   | MT2_ByteStringIndef-   | MT3_String      UInt [Word8]-   | MT3_StringIndef-   | MT4_ArrayLen    UInt-   | MT4_ArrayLenIndef-   | MT5_MapLen      UInt-   | MT5_MapLenIndef-   | MT6_Tag     UInt-   | MT7_Simple  Word8-   | MT7_Float16 Half-   | MT7_Float32 Float-   | MT7_Float64 Double-   | MT7_Break-  deriving (Show, Eq)--instance Arbitrary Token where-  arbitrary =-    oneof-      [ MT0_UnsignedInt <$> arbitrary-      , MT1_NegativeInt <$> arbitrary-      , do ws <- arbitrary-           MT2_ByteString <$> arbitraryLengthUInt ws <*> pure ws-      , pure MT2_ByteStringIndef-      , do cs <- arbitrary-           let ws = encodeUTF8 cs-           MT3_String <$> arbitraryLengthUInt ws <*> pure ws-      , pure MT3_StringIndef-      , MT4_ArrayLen <$> arbitrary-      , pure MT4_ArrayLenIndef-      , MT5_MapLen <$> arbitrary-      , pure MT5_MapLenIndef-      , MT6_Tag     <$> arbitrary-      , MT7_Simple  <$> arbitrary-      , MT7_Float16 . getFloatSpecials <$> arbitrary-      , MT7_Float32 . getFloatSpecials <$> arbitrary-      , MT7_Float64 . getFloatSpecials <$> arbitrary-      , pure MT7_Break-      ]-    where-      arbitraryLengthUInt xs =-        let n = length xs in-        elements $-             [ UIntSmall (fromIntegral n) | n < 24  ]-          ++ [ UInt8     (fromIntegral n) | n < 255 ]-          ++ [ UInt16    (fromIntegral n) | n < 65536 ]-          ++ [ UInt32    (fromIntegral n)-             , UInt64    (fromIntegral n) ]--testDecode :: [Word8] -> Term-testDecode ws =-    case runDecoder decodeTerm ws of-      Just (x, []) -> x-      _            -> error "testDecode: parse error"--decodeTokens :: Decoder [Token]-decodeTokens = do-    done <- eof-    if done-      then return []-      else do tok  <- decodeToken-              toks <- decodeTokens-              return (tok:toks)--decodeToken :: Decoder Token-decodeToken = do-    header <- decodeTokenHeader-    extra  <- getBytes (tokenExtraLen header)-    either fail return (packToken header extra)--tokenExtraLen :: TokenHeader -> Word64-tokenExtraLen (TokenHeader MajorType2 (AiValue n)) = fromUInt n  -- bytestrings-tokenExtraLen (TokenHeader MajorType3 (AiValue n)) = fromUInt n  -- unicode strings-tokenExtraLen _                                    = 0--packToken :: TokenHeader -> [Word8] -> Either String Token-packToken (TokenHeader mt ai) extra = case (mt, ai) of-    -- Major type 0:  an unsigned integer.  The 5-bit additional information-    -- is either the integer itself (for additional information values 0-    -- through 23) or the length of additional data.-    (MajorType0, AiValue n)  -> return (MT0_UnsignedInt n)--    -- Major type 1:  a negative integer.  The encoding follows the rules-    -- for unsigned integers (major type 0), except that the value is-    -- then -1 minus the encoded unsigned integer.-    (MajorType1, AiValue n)  -> return (MT1_NegativeInt n)--    -- Major type 2:  a byte string.  The string's length in bytes is-    -- represented following the rules for positive integers (major type 0).-    (MajorType2, AiValue n)  -> return (MT2_ByteString n extra)-    (MajorType2, AiIndefLen) -> return MT2_ByteStringIndef--    -- Major type 3:  a text string, specifically a string of Unicode-    -- characters that is encoded as UTF-8 [RFC3629].  The format of this-    -- type is identical to that of byte strings (major type 2), that is,-    -- as with major type 2, the length gives the number of bytes.-    (MajorType3, AiValue n)  -> return (MT3_String n extra)-    (MajorType3, AiIndefLen) -> return MT3_StringIndef--    -- Major type 4:  an array of data items. The array's length follows the-    -- rules for byte strings (major type 2), except that the length-    -- denotes the number of data items, not the length in bytes that the-    -- array takes up.-    (MajorType4, AiValue n)  -> return (MT4_ArrayLen n)-    (MajorType4, AiIndefLen) -> return  MT4_ArrayLenIndef--    -- Major type 5:  a map of pairs of data items. A map is comprised of-    -- pairs of data items, each pair consisting of a key that is-    -- immediately followed by a value. The map's length follows the-    -- rules for byte strings (major type 2), except that the length-    -- denotes the number of pairs, not the length in bytes that the map-    -- takes up.-    (MajorType5, AiValue n)  -> return (MT5_MapLen n)-    (MajorType5, AiIndefLen) -> return  MT5_MapLenIndef--    -- Major type 6:  optional semantic tagging of other major types.-    -- The initial bytes of the tag follow the rules for positive integers-    -- (major type 0).-    (MajorType6, AiValue n)  -> return (MT6_Tag n)--    -- Major type 7 is for two types of data: floating-point numbers and-    -- "simple values" that do not need any content.  Each value of the-    -- 5-bit additional information in the initial byte has its own separate-    -- meaning, as defined in Table 1.-    --   | 0..23       | Simple value (value 0..23)                       |-    --   | 24          | Simple value (value 32..255 in following byte)   |-    --   | 25          | IEEE 754 Half-Precision Float (16 bits follow)   |-    --   | 26          | IEEE 754 Single-Precision Float (32 bits follow) |-    --   | 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, AiIndefLen)            -> return (MT7_Break)-    _                                   -> fail "invalid token header"---encodeToken :: Encoder Token-encodeToken tok =-    let (header, extra) = unpackToken tok-     in encodeTokenHeader header ++ extra---unpackToken :: Token -> (TokenHeader, [Word8])-unpackToken tok = (\(mt, ai, ws) -> (TokenHeader mt ai, ws)) $ case tok of-    (MT0_UnsignedInt n)    -> (MajorType0, AiValue n,  [])-    (MT1_NegativeInt n)    -> (MajorType1, AiValue n,  [])-    (MT2_ByteString  n ws) -> (MajorType2, AiValue n,  ws)-    MT2_ByteStringIndef    -> (MajorType2, AiIndefLen, [])-    (MT3_String      n ws) -> (MajorType3, AiValue n,  ws)-    MT3_StringIndef        -> (MajorType3, AiIndefLen, [])-    (MT4_ArrayLen    n)    -> (MajorType4, AiValue n,  [])-    MT4_ArrayLenIndef      -> (MajorType4, AiIndefLen, [])-    (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_Break              -> (MajorType7, AiIndefLen, [])---fromUInt :: UInt -> Word64-fromUInt (UIntSmall w) = fromIntegral w-fromUInt (UInt8     w) = fromIntegral w-fromUInt (UInt16    w) = fromIntegral w-fromUInt (UInt32    w) = fromIntegral w-fromUInt (UInt64    w) = fromIntegral w--toUInt :: Word64 -> UInt-toUInt n-  | n < 24                                 = UIntSmall (fromIntegral n)-  | n <= fromIntegral (maxBound :: Word8)  = UInt8     (fromIntegral n)-  | n <= fromIntegral (maxBound :: Word16) = UInt16    (fromIntegral n)-  | n <= fromIntegral (maxBound :: Word32) = UInt32    (fromIntegral n)-  | otherwise                              = UInt64    n--lengthUInt :: [a] -> UInt-lengthUInt = toUInt . fromIntegral . length--decodeUTF8 :: [Word8] -> Either String [Char]-decodeUTF8 = either (fail . show) (return . T.unpack) . T.decodeUtf8' . BS.pack--encodeUTF8 :: [Char] -> [Word8]-encodeUTF8 = BS.unpack . T.encodeUtf8 . T.pack--reservedSimple :: Word8 -> Bool-reservedSimple w = w >= 20 && w <= 31--reservedTag :: Word64 -> Bool-reservedTag w = w <= 5--prop_Token :: Token -> Bool-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--data Term = TUInt   UInt-          | TNInt   UInt-          | TBigInt Integer-          | TBytes    [Word8]-          | TBytess  [[Word8]]-          | TString   [Char]-          | TStrings [[Char]]-          | TArray  [Term]-          | TArrayI [Term]-          | TMap    [(Term, Term)]-          | TMapI   [(Term, Term)]-          | TTagged UInt Term-          | TTrue-          | TFalse-          | TNull-          | TUndef-          | TSimple  Word8-          | TFloat16 Half-          | TFloat32 Float-          | TFloat64 Double-  deriving (Show, Eq)--instance Arbitrary Term where-  arbitrary =-      frequency-        [ (1, TUInt    <$> arbitrary)-        , (1, TNInt    <$> arbitrary)-        , (1, TBigInt . getLargeInteger <$> arbitrary)-        , (1, TBytes   <$> arbitrary)-        , (1, TBytess  <$> arbitrary)-        , (1, TString  <$> arbitrary)-        , (1, TStrings <$> arbitrary)-        , (2, TArray   <$> listOfSmaller arbitrary)-        , (2, TArrayI  <$> listOfSmaller arbitrary)-        , (2, TMap     <$> listOfSmaller ((,) <$> arbitrary <*> arbitrary))-        , (2, TMapI    <$> listOfSmaller ((,) <$> arbitrary <*> arbitrary))-        , (1, TTagged  <$> arbitraryTag <*> sized (\sz -> resize (max 0 (sz-1)) arbitrary))-        , (1, pure TFalse)-        , (1, pure TTrue)-        , (1, pure TNull)-        , (1, pure TUndef)-        , (1, TSimple  <$> arbitrary `suchThat` (not . reservedSimple))-        , (1, TFloat16 <$> arbitrary)-        , (1, TFloat32 <$> arbitrary)-        , (1, TFloat64 <$> arbitrary)-        ]-    where-      listOfSmaller :: Gen a -> Gen [a]-      listOfSmaller gen =-        sized $ \n -> do-          k <- choose (0,n)-          vectorOf k (resize (n `div` (k+1)) gen)--      arbitraryTag = arbitrary `suchThat` (not . reservedTag . fromUInt)--  shrink (TUInt   n)    = [ TUInt    n'   | n' <- shrink n ]-  shrink (TNInt   n)    = [ TNInt    n'   | n' <- shrink n ]-  shrink (TBigInt n)    = [ TBigInt  n'   | n' <- shrink n ]--  shrink (TBytes  ws)   = [ TBytes   ws'  | ws'  <- shrink ws  ]-  shrink (TBytess wss)  = [ TBytess  wss' | wss' <- shrink wss ]-  shrink (TString  ws)  = [ TString  ws'  | ws'  <- shrink ws  ]-  shrink (TStrings wss) = [ TStrings wss' | wss' <- shrink wss ]--  shrink (TArray  xs@[x]) = x : [ TArray  xs' | xs' <- shrink xs ]-  shrink (TArray  xs)     =     [ TArray  xs' | xs' <- shrink xs ]-  shrink (TArrayI xs@[x]) = x : [ TArrayI xs' | xs' <- shrink xs ]-  shrink (TArrayI xs)     =     [ TArrayI 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 (reservedTag (fromUInt w')) ]--  shrink TFalse = []-  shrink TTrue  = []-  shrink TNull  = []-  shrink TUndef = []--  shrink (TSimple  w) = [ TSimple  w' | w' <- shrink w, not (reservedSimple w) ]-  shrink (TFloat16 f) = [ TFloat16 f' | f' <- shrink f ]-  shrink (TFloat32 f) = [ TFloat32 f' | f' <- shrink f ]-  shrink (TFloat64 f) = [ TFloat64 f' | f' <- shrink f ]---decodeTerm :: Decoder Term-decodeTerm = decodeToken >>= decodeTermFrom--decodeTermFrom :: Token -> Decoder Term-decodeTermFrom tk =-    case tk of-      MT0_UnsignedInt n  -> return (TUInt n)-      MT1_NegativeInt n  -> return (TNInt n)--      MT2_ByteString _ bs -> return (TBytes bs)-      MT2_ByteStringIndef -> decodeBytess []--      MT3_String _ ws    -> either fail (return . TString) (decodeUTF8 ws)-      MT3_StringIndef    -> decodeStrings []--      MT4_ArrayLen len   -> decodeArrayN (fromUInt len) []-      MT4_ArrayLenIndef  -> decodeArray []--      MT5_MapLen  len    -> decodeMapN (fromUInt len) []-      MT5_MapLenIndef    -> decodeMap  []--      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_Float16 f      -> return (TFloat16 f)-      MT7_Float32 f      -> return (TFloat32 f)-      MT7_Float64 f      -> return (TFloat64 f)-      MT7_Break          -> fail "unexpected"---decodeBytess :: [[Word8]] -> Decoder Term-decodeBytess acc = do-    tk <- decodeToken-    case tk of-      MT7_Break            -> return $! TBytess (reverse acc)-      MT2_ByteString _ bs  -> decodeBytess (bs : acc)-      _                    -> fail "unexpected"--decodeStrings :: [String] -> Decoder Term-decodeStrings acc = do-    tk <- decodeToken-    case tk of-      MT7_Break        -> return $! TStrings (reverse acc)-      MT3_String _ ws  -> do cs <- either fail return (decodeUTF8 ws)-                             decodeStrings (cs : acc)-      _                -> fail "unexpected"--decodeArrayN :: Word64 -> [Term] -> Decoder Term-decodeArrayN n acc =-    case n of-      0 -> return $! TArray (reverse acc)-      _ -> do t <- decodeTerm-              decodeArrayN (n-1) (t : acc)--decodeArray :: [Term] -> Decoder Term-decodeArray acc = do-    tk <- decodeToken-    case tk of-      MT7_Break -> return $! TArrayI (reverse acc)-      _         -> do-        tm <- decodeTermFrom tk-        decodeArray (tm : acc)--decodeMapN :: Word64 -> [(Term, Term)] -> Decoder Term-decodeMapN n acc =-    case n of-      0 -> return $! TMap (reverse acc)-      _ -> do-        tm   <- decodeTerm-        tm'  <- decodeTerm-        decodeMapN (n-1) ((tm, tm') : acc)--decodeMap :: [(Term, Term)] -> Decoder Term-decodeMap acc = do-    tk <- decodeToken-    case tk of-      MT7_Break -> return $! TMapI (reverse acc)-      _         -> do-        tm  <- decodeTermFrom tk-        tm' <- decodeTerm-        decodeMap ((tm, tm') : acc)--decodeTagged :: UInt -> Decoder Term-decodeTagged tag | fromUInt tag == 2 = do-    MT2_ByteString _ bs <- decodeToken-    let !n = integerFromBytes bs-    return (TBigInt n)-decodeTagged tag | fromUInt tag == 3 = do-    MT2_ByteString _ bs <- decodeToken-    let !n = integerFromBytes bs-    return (TBigInt (-1 - n))-decodeTagged tag = do-    tm <- decodeTerm-    return (TTagged tag tm)--integerFromBytes :: [Word8] -> Integer-integerFromBytes []       = 0-integerFromBytes (w0:ws0) = go (fromIntegral w0) ws0-  where-    go !acc []     = acc-    go !acc (w:ws) = go (acc `shiftL` 8 + fromIntegral w) ws--integerToBytes :: Integer -> [Word8]-integerToBytes n0-  | n0 == 0   = [0]-  | n0 < 0    = reverse (go (-n0))-  | otherwise = reverse (go n0)-  where-    go n | n == 0    = []-         | otherwise = narrow n : go (n `shiftR` 8)--    narrow :: Integer -> Word8-    narrow = fromIntegral--prop_integerToFromBytes :: LargeInteger -> Bool-prop_integerToFromBytes (LargeInteger n)-  | n >= 0 =-    let ws = integerToBytes n-        n' = integerFromBytes ws-     in n == n'-  | otherwise =-    let ws = integerToBytes n-        n' = integerFromBytes ws-     in n == -n'-----------------------------------------------------------------------------------encodeTerm :: Encoder Term-encodeTerm (TUInt n)       = encodeToken (MT0_UnsignedInt n)-encodeTerm (TNInt n)       = encodeToken (MT1_NegativeInt n)-encodeTerm (TBigInt n)-               | n >= 0    = encodeToken (MT6_Tag (UIntSmall 2))-                          <> let ws  = integerToBytes n-                                 len = lengthUInt ws in-                             encodeToken (MT2_ByteString len ws)-               | otherwise = encodeToken (MT6_Tag (UIntSmall 3))-                          <> let ws  = integerToBytes (-1 - n)-                                 len = lengthUInt ws in-                             encodeToken (MT2_ByteString len ws)-encodeTerm (TBytes ws)     = let len = lengthUInt ws in-                             encodeToken (MT2_ByteString len ws)-encodeTerm (TBytess wss)   = encodeToken MT2_ByteStringIndef-                          <> mconcat [ encodeToken (MT2_ByteString len ws)-                                     | ws <- wss-                                     , let len = lengthUInt ws ]-                          <> encodeToken MT7_Break-encodeTerm (TString  cs)   = let ws  = encodeUTF8 cs-                                 len = lengthUInt ws in-                             encodeToken (MT3_String len ws)-encodeTerm (TStrings css)  = encodeToken MT3_StringIndef-                          <> mconcat [ encodeToken (MT3_String len ws)-                                     | cs <- css-                                     , let ws  = encodeUTF8 cs-                                           len = lengthUInt ws ]-                          <> encodeToken MT7_Break-encodeTerm (TArray  ts)    = let len = lengthUInt ts in-                             encodeToken (MT4_ArrayLen len)-                          <> mconcat (map encodeTerm ts)-encodeTerm (TArrayI ts)    = encodeToken MT4_ArrayLenIndef-                          <> mconcat (map encodeTerm ts)-                          <> encodeToken MT7_Break-encodeTerm (TMap    kvs)   = let len = lengthUInt kvs in-                             encodeToken (MT5_MapLen len)-                          <> mconcat [ encodeTerm k <> encodeTerm v-                                     | (k,v) <- kvs ]-encodeTerm (TMapI   kvs)   = encodeToken MT5_MapLenIndef-                          <> mconcat [ encodeTerm k <> encodeTerm v-                                     | (k,v) <- kvs ]-                          <> 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 (TSimple  w)    = encodeToken (MT7_Simple w)-encodeTerm (TFloat16 f)    = encodeToken (MT7_Float16 f)-encodeTerm (TFloat32 f)    = encodeToken (MT7_Float32 f)-encodeTerm (TFloat64 f)    = encodeToken (MT7_Float64 f)------------------------------------------------------------------------------------prop_Term :: Term -> Bool-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--eqTermPair :: (Term, Term) -> (Term, Term) -> Bool-eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b'--canonicaliseTerm :: Term -> Term-canonicaliseTerm (TUInt n) = TUInt (canonicaliseUInt n)-canonicaliseTerm (TNInt n) = TNInt (canonicaliseUInt n)-canonicaliseTerm (TBigInt n)-  | n >= 0 && n <= fromIntegral (maxBound :: Word64)-                           = TUInt (toUInt (fromIntegral n))-  | 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 (TBytess  wss) = TBytess  (filter (not . null) wss)-canonicaliseTerm (TStrings css) = TStrings (filter (not . null) css)-canonicaliseTerm (TArray  ts) = TArray  (map canonicaliseTerm ts)-canonicaliseTerm (TArrayI ts) = TArrayI (map canonicaliseTerm ts)-canonicaliseTerm (TMap    ts) = TMap    (map canonicaliseTermPair ts)-canonicaliseTerm (TMapI   ts) = TMapI   (map canonicaliseTermPair ts)-canonicaliseTerm (TTagged tag t) = TTagged (canonicaliseUInt tag) (canonicaliseTerm t)-canonicaliseTerm t = t--canonicaliseUInt :: UInt -> UInt-canonicaliseUInt = toUInt . fromUInt--canonicaliseHalf :: Half -> Half-canonicaliseHalf f-  | isNaN f   = canonicalNaN-  | otherwise = f--canonicaliseTermPair :: (Term, Term) -> (Term, Term)-canonicaliseTermPair (x,y) = (canonicaliseTerm x, canonicaliseTerm y)--canonicalNaN :: Half-canonicalNaN = Half 0x7e00-----------------------------------------------------------------------------------diagnosticNotation :: Term -> String-diagnosticNotation = \t -> showsTerm t ""-  where-    showsTerm tm = case tm of-      TUInt    n     -> shows (fromUInt n)-      TNInt    n     -> shows (-1 - fromIntegral (fromUInt n) :: Integer)-      TBigInt  n     -> shows n-      TBytes   bs    -> showsBytes bs-      TBytess  bss   -> surround '(' ')' (underscoreSpace . commaSep showsBytes bss)-      TString  cs    -> shows cs-      TStrings css   -> surround '(' ')' (underscoreSpace . commaSep shows css)-      TArray   ts    -> surround '[' ']' (commaSep showsTerm ts)-      TArrayI  ts    -> surround '[' ']' (underscoreSpace . commaSep showsTerm ts)-      TMap     ts    -> surround '{' '}' (commaSep showsMapElem ts)-      TMapI    ts    -> surround '{' '}' (underscoreSpace . commaSep showsMapElem ts)-      TTagged  tag t -> shows (fromUInt tag) . surround '(' ')' (showsTerm t)-      TTrue          -> showString "true"-      TFalse         -> showString "false"-      TNull          -> showString "null"-      TUndef         -> showString "undefined"-      TSimple  n     -> showString "simple" . surround '(' ')' (shows 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--    surround a b x = showChar a . x . showChar b--    commaSpace = showChar ',' . showChar ' '-    underscoreSpace = showChar '_' . showChar ' '--    showsMapElem (k,v) = showsTerm k . showChar ':' . showChar ' ' . showsTerm v--    catShows :: (a -> ShowS) -> [a] -> ShowS-    catShows f xs = \s -> foldr (\x r -> f x . r) id xs s--    sepShows :: ShowS -> (a -> ShowS) -> [a] -> ShowS-    sepShows sep f xs = foldr (.) id (intersperse sep (map f xs))--    commaSep = sepShows commaSpace--    showsBytes :: [Word8] -> ShowS-    showsBytes bs = showChar 'h' . showChar '\''-                                 . catShows showFHex bs-                                 . showChar '\''--    showFHex n | n < 16    = showChar '0' . showHex n-               | otherwise = showHex n--    showFloatCompat n-      | exponent' >= -5 && exponent' <= 15 = showFFloat Nothing n-      | otherwise                          = showEFloat Nothing n-      where exponent' = snd (floatToDigits 10 n)---word16FromNet :: Word8 -> Word8 -> Word16-word16FromNet w1 w0 =-      fromIntegral w1 `shiftL` (8*1)-  .|. fromIntegral w0 `shiftL` (8*0)--word16ToNet :: Word16 -> (Word8, Word8)-word16ToNet w =-    ( fromIntegral ((w `shiftR` (8*1)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*0)) .&. 0xff)-    )--word32FromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Word32-word32FromNet w3 w2 w1 w0 =-      fromIntegral w3 `shiftL` (8*3)-  .|. fromIntegral w2 `shiftL` (8*2)-  .|. fromIntegral w1 `shiftL` (8*1)-  .|. fromIntegral w0 `shiftL` (8*0)--word32ToNet :: Word32 -> (Word8, Word8, Word8, Word8)-word32ToNet w =-    ( fromIntegral ((w `shiftR` (8*3)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*2)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*1)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*0)) .&. 0xff)-    )--word64FromNet :: Word8 -> Word8 -> Word8 -> Word8 ->-                 Word8 -> Word8 -> Word8 -> Word8 -> Word64-word64FromNet w7 w6 w5 w4 w3 w2 w1 w0 =-      fromIntegral w7 `shiftL` (8*7)-  .|. fromIntegral w6 `shiftL` (8*6)-  .|. fromIntegral w5 `shiftL` (8*5)-  .|. fromIntegral w4 `shiftL` (8*4)-  .|. fromIntegral w3 `shiftL` (8*3)-  .|. fromIntegral w2 `shiftL` (8*2)-  .|. fromIntegral w1 `shiftL` (8*1)-  .|. fromIntegral w0 `shiftL` (8*0)--word64ToNet :: Word64 -> (Word8, Word8, Word8, Word8,-                          Word8, Word8, Word8, Word8)-word64ToNet w =-    ( fromIntegral ((w `shiftR` (8*7)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*6)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*5)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*4)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*3)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*2)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*1)) .&. 0xff)-    , fromIntegral ((w `shiftR` (8*0)) .&. 0xff)-    )--prop_word16ToFromNet :: Word8 -> Word8 -> Bool-prop_word16ToFromNet w1 w0 =-    word16ToNet (word16FromNet w1 w0) == (w1, w0)--prop_word32ToFromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Bool-prop_word32ToFromNet w3 w2 w1 w0 =-    word32ToNet (word32FromNet w3 w2 w1 w0) == (w3, w2, w1, w0)--prop_word64ToFromNet :: Word8 -> Word8 -> Word8 -> Word8 ->-                        Word8 -> Word8 -> Word8 -> Word8 -> Bool-prop_word64ToFromNet w7 w6 w5 w4 w3 w2 w1 w0 =-    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-prop_halfToFromFloat =-    all (\w -> roundTrip w || isNaN (Half.Half w)) [minBound..maxBound]-  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-

@@ -9,15 +9,13 @@ import qualified Tests.Regress.Issue80  as Issue80 import qualified Tests.Regress.Issue106 as Issue106 import qualified Tests.Regress.Issue135 as Issue135-import qualified Tests.Regress.FlatTerm as FlatTerm  -------------------------------------------------------------------------------- -- Tests and properties  testTree :: TestTree testTree = testGroup "Regression tests"-  [ FlatTerm.testTree-  , Issue13.testTree+  [ Issue13.testTree   , Issue67.testTree   , Issue80.testTree   , Issue106.testTree

@@ -1,47 +0,0 @@-{-# LANGUAGE CPP                  #-}-module Tests.Regress.FlatTerm-  ( testTree -- :: TestTree-  ) where--import           Data.Int-#if !MIN_VERSION_base(4,8,0)-import           Data.Word-#endif--import           Test.Tasty-import           Test.Tasty.HUnit--import           Codec.CBOR.Encoding-import           Codec.CBOR.Decoding-import           Codec.CBOR.FlatTerm------------------------------------------------------------------------------------- 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--- need to remember to handle this case when we decode.-largeWordTest :: Either String Word-largeWordTest = fromFlatTerm decodeWord $ toFlatTerm (encodeWord largeWord)--largeWord :: Word-largeWord = fromIntegral (maxBound :: Int) + 1---- | 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'@--- will result in overflow otherwise.-smallInt64Test :: Either String Int64-smallInt64Test = fromFlatTerm decodeInt64 $ toFlatTerm (encodeInt64 smallInt64)--smallInt64 :: Int64-smallInt64 = fromIntegral (minBound :: Int) - 1------------------------------------------------------------------------------------- TestTree API--testTree :: TestTree-testTree = testGroup "FlatTerm regressions"-  [ testCase "Decoding of large-ish words" (Right largeWord  @=? largeWordTest)-  , testCase "Encoding of Int64s on 32bit" (Right smallInt64 @=? smallInt64Test)-  ]

@@ -218,7 +218,7 @@       , mkTest (T :: T CUIntMax)       , mkTest (T :: T CClock)       , mkTest (T :: T CTime)-      , mkTest (T :: T CUSeconds)+      , mkTest (T :: T CUSeconds_)       , mkTest (T :: T CSUSeconds)       , mkTest (T :: T CFloat)       , mkTest (T :: T CDouble)@@ -334,6 +334,19 @@   , testProperty "flat term is valid"  (prop_validFlatTerm t)   ] +--------------------------------------------------------------------------------+-- Various data types++-- Wrapper for CUSeconds with Arbitrary instance that works on x86_32.+newtype CUSeconds_ = CUSeconds_ CUSeconds+  deriving (Eq, Show, Typeable)++instance Arbitrary CUSeconds_ where+  arbitrary = CUSeconds_ . CUSeconds <$> arbitraryBoundedIntegral++instance Serialise CUSeconds_ where+  encode (CUSeconds_ s) = encode s+  decode = CUSeconds_ <$> decode  -------------------------------------------------------------------------------- -- Generic data types

@@ -1,27 +0,0 @@-test-vectors-============--This repo collects some simple test vectors in machine-processable form.--appendix_a.json------------------All examples in Appendix A of RFC 7049, encoded as a JSON array.--Each element of the test vector is a map (JSON object) with the keys:--- cbor: a base-64 encoded CBOR data item-- hex: the same CBOR data item in hex encoding-- roundtrip: a boolean that indicates whether a generic CBOR encoder-  would _typically_ produce identical CBOR on re-encoding the decoded-  data item (your mileage may vary)-- decoded: the decoded data item if it can be represented in JSON-- diagnostic: the representation of the data item in CBOR diagnostic notation, otherwise--To make use of the cases that need diagnostic notation, a diagnostic-notation printer is usually all that is needed: decode the CBOR, print-the decoded data item in diagnostic notation, and compare.--(Note that the diagnostic notation uses full decoration for the-indefinite length byte string, while the decoded indefinite length-text string represented in JSON necessarily doesn't.)

@@ -1,624 +0,0 @@-[-  {-    "cbor": "AA==",-    "hex": "00",-    "roundtrip": true,-    "decoded": 0-  },-  {-    "cbor": "AQ==",-    "hex": "01",-    "roundtrip": true,-    "decoded": 1-  },-  {-    "cbor": "Cg==",-    "hex": "0a",-    "roundtrip": true,-    "decoded": 10-  },-  {-    "cbor": "Fw==",-    "hex": "17",-    "roundtrip": true,-    "decoded": 23-  },-  {-    "cbor": "GBg=",-    "hex": "1818",-    "roundtrip": true,-    "decoded": 24-  },-  {-    "cbor": "GBk=",-    "hex": "1819",-    "roundtrip": true,-    "decoded": 25-  },-  {-    "cbor": "GGQ=",-    "hex": "1864",-    "roundtrip": true,-    "decoded": 100-  },-  {-    "cbor": "GQPo",-    "hex": "1903e8",-    "roundtrip": true,-    "decoded": 1000-  },-  {-    "cbor": "GgAPQkA=",-    "hex": "1a000f4240",-    "roundtrip": true,-    "decoded": 1000000-  },-  {-    "cbor": "GwAAAOjUpRAA",-    "hex": "1b000000e8d4a51000",-    "roundtrip": true,-    "decoded": 1000000000000-  },-  {-    "cbor": "G///////////",-    "hex": "1bffffffffffffffff",-    "roundtrip": true,-    "decoded": 18446744073709551615-  },-  {-    "cbor": "wkkBAAAAAAAAAAA=",-    "hex": "c249010000000000000000",-    "roundtrip": true,-    "decoded": 18446744073709551616-  },-  {-    "cbor": "O///////////",-    "hex": "3bffffffffffffffff",-    "roundtrip": true,-    "decoded": -18446744073709551616-  },-  {-    "cbor": "w0kBAAAAAAAAAAA=",-    "hex": "c349010000000000000000",-    "roundtrip": true,-    "decoded": -18446744073709551617-  },-  {-    "cbor": "IA==",-    "hex": "20",-    "roundtrip": true,-    "decoded": -1-  },-  {-    "cbor": "KQ==",-    "hex": "29",-    "roundtrip": true,-    "decoded": -10-  },-  {-    "cbor": "OGM=",-    "hex": "3863",-    "roundtrip": true,-    "decoded": -100-  },-  {-    "cbor": "OQPn",-    "hex": "3903e7",-    "roundtrip": true,-    "decoded": -1000-  },-  {-    "cbor": "+QAA",-    "hex": "f90000",-    "roundtrip": true,-    "decoded": 0.0-  },-  {-    "cbor": "+YAA",-    "hex": "f98000",-    "roundtrip": true,-    "decoded": -0.0-  },-  {-    "cbor": "+TwA",-    "hex": "f93c00",-    "roundtrip": true,-    "decoded": 1.0-  },-  {-    "cbor": "+z/xmZmZmZma",-    "hex": "fb3ff199999999999a",-    "roundtrip": true,-    "decoded": 1.1-  },-  {-    "cbor": "+T4A",-    "hex": "f93e00",-    "roundtrip": true,-    "decoded": 1.5-  },-  {-    "cbor": "+Xv/",-    "hex": "f97bff",-    "roundtrip": true,-    "decoded": 65504.0-  },-  {-    "cbor": "+kfDUAA=",-    "hex": "fa47c35000",-    "roundtrip": true,-    "decoded": 100000.0-  },-  {-    "cbor": "+n9///8=",-    "hex": "fa7f7fffff",-    "roundtrip": true,-    "decoded": 3.4028234663852886e+38-  },-  {-    "cbor": "+3435DyIAHWc",-    "hex": "fb7e37e43c8800759c",-    "roundtrip": true,-    "decoded": 1.0e+300-  },-  {-    "cbor": "+QAB",-    "hex": "f90001",-    "roundtrip": true,-    "decoded": 5.960464477539063e-08-  },-  {-    "cbor": "+QQA",-    "hex": "f90400",-    "roundtrip": true,-    "decoded": 6.103515625e-05-  },-  {-    "cbor": "+cQA",-    "hex": "f9c400",-    "roundtrip": true,-    "decoded": -4.0-  },-  {-    "cbor": "+8AQZmZmZmZm",-    "hex": "fbc010666666666666",-    "roundtrip": true,-    "decoded": -4.1-  },-  {-    "cbor": "+XwA",-    "hex": "f97c00",-    "roundtrip": true,-    "diagnostic": "Infinity"-  },-  {-    "cbor": "+X4A",-    "hex": "f97e00",-    "roundtrip": true,-    "diagnostic": "NaN"-  },-  {-    "cbor": "+fwA",-    "hex": "f9fc00",-    "roundtrip": true,-    "diagnostic": "-Infinity"-  },-  {-    "cbor": "+n+AAAA=",-    "hex": "fa7f800000",-    "roundtrip": false,-    "diagnostic": "Infinity"-  },-  {-    "cbor": "+v+AAAA=",-    "hex": "faff800000",-    "roundtrip": false,-    "diagnostic": "-Infinity"-  },-  {-    "cbor": "+3/wAAAAAAAA",-    "hex": "fb7ff0000000000000",-    "roundtrip": false,-    "diagnostic": "Infinity"-  },-  {-    "cbor": "+//wAAAAAAAA",-    "hex": "fbfff0000000000000",-    "roundtrip": false,-    "diagnostic": "-Infinity"-  },-  {-    "cbor": "9A==",-    "hex": "f4",-    "roundtrip": true,-    "decoded": false-  },-  {-    "cbor": "9Q==",-    "hex": "f5",-    "roundtrip": true,-    "decoded": true-  },-  {-    "cbor": "9g==",-    "hex": "f6",-    "roundtrip": true,-    "decoded": null-  },-  {-    "cbor": "9w==",-    "hex": "f7",-    "roundtrip": true,-    "diagnostic": "undefined"-  },-  {-    "cbor": "8A==",-    "hex": "f0",-    "roundtrip": true,-    "diagnostic": "simple(16)"-  },-  {-    "cbor": "+Bg=",-    "hex": "f818",-    "roundtrip": true,-    "diagnostic": "simple(24)"-  },-  {-    "cbor": "+P8=",-    "hex": "f8ff",-    "roundtrip": true,-    "diagnostic": "simple(255)"-  },-  {-    "cbor": "wHQyMDEzLTAzLTIxVDIwOjA0OjAwWg==",-    "hex": "c074323031332d30332d32315432303a30343a30305a",-    "roundtrip": true,-    "diagnostic": "0(\"2013-03-21T20:04:00Z\")"-  },-  {-    "cbor": "wRpRS2ew",-    "hex": "c11a514b67b0",-    "roundtrip": true,-    "diagnostic": "1(1363896240)"-  },-  {-    "cbor": "wftB1FLZ7CAAAA==",-    "hex": "c1fb41d452d9ec200000",-    "roundtrip": true,-    "diagnostic": "1(1363896240.5)"-  },-  {-    "cbor": "10QBAgME",-    "hex": "d74401020304",-    "roundtrip": true,-    "diagnostic": "23(h'01020304')"-  },-  {-    "cbor": "2BhFZElFVEY=",-    "hex": "d818456449455446",-    "roundtrip": true,-    "diagnostic": "24(h'6449455446')"-  },-  {-    "cbor": "2CB2aHR0cDovL3d3dy5leGFtcGxlLmNvbQ==",-    "hex": "d82076687474703a2f2f7777772e6578616d706c652e636f6d",-    "roundtrip": true,-    "diagnostic": "32(\"http://www.example.com\")"-  },-  {-    "cbor": "QA==",-    "hex": "40",-    "roundtrip": true,-    "diagnostic": "h''"-  },-  {-    "cbor": "RAECAwQ=",-    "hex": "4401020304",-    "roundtrip": true,-    "diagnostic": "h'01020304'"-  },-  {-    "cbor": "YA==",-    "hex": "60",-    "roundtrip": true,-    "decoded": ""-  },-  {-    "cbor": "YWE=",-    "hex": "6161",-    "roundtrip": true,-    "decoded": "a"-  },-  {-    "cbor": "ZElFVEY=",-    "hex": "6449455446",-    "roundtrip": true,-    "decoded": "IETF"-  },-  {-    "cbor": "YiJc",-    "hex": "62225c",-    "roundtrip": true,-    "decoded": "\"\\"-  },-  {-    "cbor": "YsO8",-    "hex": "62c3bc",-    "roundtrip": true,-    "decoded": "ü"-  },-  {-    "cbor": "Y+awtA==",-    "hex": "63e6b0b4",-    "roundtrip": true,-    "decoded": "水"-  },-  {-    "cbor": "ZPCQhZE=",-    "hex": "64f0908591",-    "roundtrip": true,-    "decoded": "𐅑"-  },-  {-    "cbor": "gA==",-    "hex": "80",-    "roundtrip": true,-    "decoded": [--    ]-  },-  {-    "cbor": "gwECAw==",-    "hex": "83010203",-    "roundtrip": true,-    "decoded": [-      1,-      2,-      3-    ]-  },-  {-    "cbor": "gwGCAgOCBAU=",-    "hex": "8301820203820405",-    "roundtrip": true,-    "decoded": [-      1,-      [-        2,-        3-      ],-      [-        4,-        5-      ]-    ]-  },-  {-    "cbor": "mBkBAgMEBQYHCAkKCwwNDg8QERITFBUWFxgYGBk=",-    "hex": "98190102030405060708090a0b0c0d0e0f101112131415161718181819",-    "roundtrip": true,-    "decoded": [-      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-    ]-  },-  {-    "cbor": "oA==",-    "hex": "a0",-    "roundtrip": true,-    "decoded": {-    }-  },-  {-    "cbor": "ogECAwQ=",-    "hex": "a201020304",-    "roundtrip": true,-    "diagnostic": "{1: 2, 3: 4}"-  },-  {-    "cbor": "omFhAWFiggID",-    "hex": "a26161016162820203",-    "roundtrip": true,-    "decoded": {-      "a": 1,-      "b": [-        2,-        3-      ]-    }-  },-  {-    "cbor": "gmFhoWFiYWM=",-    "hex": "826161a161626163",-    "roundtrip": true,-    "decoded": [-      "a",-      {-        "b": "c"-      }-    ]-  },-  {-    "cbor": "pWFhYUFhYmFCYWNhQ2FkYURhZWFF",-    "hex": "a56161614161626142616361436164614461656145",-    "roundtrip": true,-    "decoded": {-      "a": "A",-      "b": "B",-      "c": "C",-      "d": "D",-      "e": "E"-    }-  },-  {-    "cbor": "X0IBAkMDBAX/",-    "hex": "5f42010243030405ff",-    "roundtrip": false,-    "diagnostic": "(_ h'0102', h'030405')"-  },-  {-    "cbor": "f2VzdHJlYWRtaW5n/w==",-    "hex": "7f657374726561646d696e67ff",-    "roundtrip": false,-    "decoded": "streaming"-  },-  {-    "cbor": "n/8=",-    "hex": "9fff",-    "roundtrip": false,-    "decoded": [--    ]-  },-  {-    "cbor": "nwGCAgOfBAX//w==",-    "hex": "9f018202039f0405ffff",-    "roundtrip": false,-    "decoded": [-      1,-      [-        2,-        3-      ],-      [-        4,-        5-      ]-    ]-  },-  {-    "cbor": "nwGCAgOCBAX/",-    "hex": "9f01820203820405ff",-    "roundtrip": false,-    "decoded": [-      1,-      [-        2,-        3-      ],-      [-        4,-        5-      ]-    ]-  },-  {-    "cbor": "gwGCAgOfBAX/",-    "hex": "83018202039f0405ff",-    "roundtrip": false,-    "decoded": [-      1,-      [-        2,-        3-      ],-      [-        4,-        5-      ]-    ]-  },-  {-    "cbor": "gwGfAgP/ggQF",-    "hex": "83019f0203ff820405",-    "roundtrip": false,-    "decoded": [-      1,-      [-        2,-        3-      ],-      [-        4,-        5-      ]-    ]-  },-  {-    "cbor": "nwECAwQFBgcICQoLDA0ODxAREhMUFRYXGBgYGf8=",-    "hex": "9f0102030405060708090a0b0c0d0e0f101112131415161718181819ff",-    "roundtrip": false,-    "decoded": [-      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-    ]-  },-  {-    "cbor": "v2FhAWFinwID//8=",-    "hex": "bf61610161629f0203ffff",-    "roundtrip": false,-    "decoded": {-      "a": 1,-      "b": [-        2,-        3-      ]-    }-  },-  {-    "cbor": "gmFhv2FiYWP/",-    "hex": "826161bf61626163ff",-    "roundtrip": false,-    "decoded": [-      "a",-      {-        "b": "c"-      }-    ]-  },-  {-    "cbor": "v2NGdW71Y0FtdCH/",-    "hex": "bf6346756ef563416d7421ff",-    "roundtrip": false,-    "decoded": {-      "Fun": true,-      "Amt": -2-    }-  }-]