serialise 0.2.0.0 → 0.2.6.1
raw patch · 24 files changed
Files
- ChangeLog.md +41/−1
- bench/instances/Instances/Float.hs +25/−0
- bench/instances/Main.hs +3/−1
- bench/micro/Micro/CBOR.hs +4/−1
- bench/micro/Micro/PkgAesonTH.hs +2/−3
- bench/versus/Macro/CBOR.hs +4/−1
- bench/versus/Macro/DeepSeq.hs +4/−0
- bench/versus/Macro/Load.hs +71/−14
- bench/versus/Macro/PkgAesonTH.hs +18/−18
- serialise.cabal +68/−70
- src/Codec/Serialise/Class.hs +113/−10
- src/Codec/Serialise/Tutorial.hs +118/−92
- tests/Main.hs +3/−6
- tests/Tests/CBOR.hs +0/−297
- tests/Tests/Negative.hs +5/−0
- tests/Tests/Orphanage.hs +22/−18
- 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 +28/−5
- tests/Tests/Serialise/Canonical.hs +6/−0
- tests/test-vectors/README.md +0/−27
- tests/test-vectors/appendix_a.json +0/−624
ChangeLog.md view
@@ -1,5 +1,45 @@ # Revision history for serialise -## 0.1.0.0 -- YYYY-mm-dd+## 0.2.6.1 -- 2023-11-13++* Support GHC 9.8++## 0.2.6.0 -- 2022-09-24++* Support GHC 9.4++* Drop GHC 8.0 and 8.2 support++## 0.2.4.0 -- UNRELEASED++* Add instances for Data.Void, strict and these.++## 0.2.3.0 -- 2020-05-10++* Bounds bumps and GHC 8.10 compatibility++## 0.2.2.0 -- 2019-12-29++* Export `encodeContainerSkel`, `encodeMapSkel` and `decodeMapSkel` from+ `Codec.Serialise.Class`++* Fix `Serialise` instances for `TypeRep` and `SomeTypeRep` (#216)++* Bounds bumps and GHC 8.8 compatibility++## 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.
+ bench/instances/Instances/Float.hs view
@@ -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)+
bench/instances/Main.hs view
@@ -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 ]
bench/micro/Micro/CBOR.hs view
@@ -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
bench/micro/Micro/PkgAesonTH.hs view
@@ -8,11 +8,10 @@ import Data.ByteString.Lazy as BS import Data.Maybe +deriveJSON defaultOptions ''Tree+ serialise :: Tree -> BS.ByteString serialise = Aeson.encode deserialise :: BS.ByteString -> Tree deserialise = fromJust . Aeson.decode'--deriveJSON defaultOptions ''Tree-
bench/versus/Macro/CBOR.hs view
@@ -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
bench/versus/Macro/DeepSeq.hs view
@@ -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 -> ()
bench/versus/Macro/Load.hs view
@@ -8,8 +8,7 @@ import Text.ParserCombinators.ReadP as ReadP hiding (get) 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)@@ -19,17 +18,28 @@ import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) import Data.Bits import Control.Monad+import qualified Control.Monad.Fail as Fail import Control.Exception import qualified Data.ByteString.Lazy.Char8 as BS import System.FilePath (normalise, splitDirectories, takeExtension) 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@@ -141,6 +151,8 @@ ParseOk ws x >>= f = case f x of ParseFailed err -> ParseFailed err ParseOk ws' x' -> ParseOk (ws'++ws) x'++instance Fail.MonadFail ParseResult where fail s = ParseFailed (FromString s Nothing) catchParseError :: ParseResult a -> (PError -> ParseResult a)@@ -1190,7 +1202,7 @@ Just ke -> return ke Nothing ->- fail ("Can't parse " ++ show extension ++ " as KnownExtension")+ Fail.fail ("Can't parse " ++ show extension ++ " as KnownExtension") classifyExtension :: String -> Extension classifyExtension string@@ -1834,6 +1846,9 @@ (a,s') <- f s runStT (g a) s' +instance Fail.MonadFail m => Fail.MonadFail (StT s m) where+ fail s = StT (\_ -> Fail.fail s)+ get :: Monad m => StT s m s get = StT $ \s -> return (s, s) @@ -1976,7 +1991,7 @@ `catchParseError` \parseError -> case parseError of TabsError _ -> parseFail parseError _ | versionOk -> parseFail parseError- | otherwise -> fail message+ | otherwise -> Fail.fail message where versionOk = cabalVersionNeeded <= cabalVersion message = "This package requires at least Cabal version " ++ display cabalVersionNeeded@@ -2286,7 +2301,7 @@ checkCondTreeFlags definedFlags ct = do let fv = nub $ freeVars ct unless (all (`elem` definedFlags) fv) $- fail $ "These flags are used without having been defined: "+ Fail.fail $ "These flags are used without having been defined: " ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] findIndentTabs :: String -> [(Int,Int)]@@ -2378,7 +2393,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 +2415,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 +2444,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 +2465,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 +2484,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 +2502,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 +2541,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 +2576,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
bench/versus/Macro/PkgAesonTH.hs view
@@ -8,12 +8,6 @@ import Data.ByteString.Lazy as BS import Data.Maybe -serialise :: [GenericPackageDescription] -> BS.ByteString-serialise pkgs = Aeson.encode pkgs--deserialise :: BS.ByteString -> [GenericPackageDescription]-deserialise = fromJust . Aeson.decode'- deriveJSON defaultOptions ''Version deriveJSON defaultOptions ''PackageName deriveJSON defaultOptions ''PackageId@@ -21,29 +15,35 @@ deriveJSON defaultOptions ''Dependency deriveJSON defaultOptions ''CompilerFlavor deriveJSON defaultOptions ''License-deriveJSON defaultOptions ''SourceRepo deriveJSON defaultOptions ''RepoKind deriveJSON defaultOptions ''RepoType+deriveJSON defaultOptions ''SourceRepo deriveJSON defaultOptions ''BuildType+deriveJSON defaultOptions ''ModuleName+deriveJSON defaultOptions ''Language+deriveJSON defaultOptions ''KnownExtension+deriveJSON defaultOptions ''Extension+deriveJSON defaultOptions ''BuildInfo deriveJSON defaultOptions ''Library deriveJSON defaultOptions ''Executable-deriveJSON defaultOptions ''TestSuite-deriveJSON defaultOptions ''TestSuiteInterface deriveJSON defaultOptions ''TestType-deriveJSON defaultOptions ''Benchmark-deriveJSON defaultOptions ''BenchmarkInterface+deriveJSON defaultOptions ''TestSuiteInterface+deriveJSON defaultOptions ''TestSuite deriveJSON defaultOptions ''BenchmarkType-deriveJSON defaultOptions ''BuildInfo-deriveJSON defaultOptions ''ModuleName-deriveJSON defaultOptions ''Language-deriveJSON defaultOptions ''Extension-deriveJSON defaultOptions ''KnownExtension+deriveJSON defaultOptions ''BenchmarkInterface+deriveJSON defaultOptions ''Benchmark deriveJSON defaultOptions ''PackageDescription deriveJSON defaultOptions ''OS deriveJSON defaultOptions ''Arch-deriveJSON defaultOptions ''Flag deriveJSON defaultOptions ''FlagName+deriveJSON defaultOptions ''Flag+deriveJSON defaultOptions ''Condition deriveJSON defaultOptions ''CondTree deriveJSON defaultOptions ''ConfVar-deriveJSON defaultOptions ''Condition deriveJSON defaultOptions ''GenericPackageDescription++serialise :: [GenericPackageDescription] -> BS.ByteString+serialise pkgs = Aeson.encode pkgs++deserialise :: BS.ByteString -> [GenericPackageDescription]+deserialise = fromJust . Aeson.decode'
serialise.cabal view
@@ -1,5 +1,5 @@ name: serialise-version: 0.2.0.0+version: 0.2.6.1 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@@ -29,10 +29,16 @@ cabal-version: >=1.10 category: Codec build-type: Simple+tested-with:+ GHC == 8.4.4,+ GHC == 8.6.5,+ GHC == 8.8.3,+ GHC == 8.10.7,+ GHC == 9.0.1,+ GHC == 9.2.2,+ GHC == 9.4.2 extra-source-files:- tests/test-vectors/appendix_a.json- tests/test-vectors/README.md ChangeLog.md source-repository head@@ -63,29 +69,31 @@ Codec.Serialise.Internal.GeneralisedUTF8 build-depends:+ base >= 4.11 && < 4.20, array >= 0.4 && < 0.6,- base >= 4.6 && < 5.0,- bytestring >= 0.10.4 && < 0.11,+ bytestring >= 0.10.4 && < 0.13, 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.8,+ ghc-prim >= 0.3.1.0 && < 0.12,+ half >= 0.2.2.3 && < 0.4, hashable >= 1.2 && < 2.0,- primitive >= 0.5 && < 0.7,- text >= 1.1 && < 1.3,+ primitive >= 0.5 && < 0.10,+ strict >= 0.4 && < 0.6,+ text >= 1.1 && < 2.2,+ these >= 1.1 && < 2.2, unordered-containers >= 0.2 && < 0.3,- vector >= 0.10 && < 0.13+ vector >= 0.10 && < 0.14 if flag(newtime15) build-depends:- time >= 1.5 && < 1.9+ time >= 1.5 && < 1.14 else build-depends: time >= 1.4 && < 1.5, old-locale if impl(ghc >= 8.0)- ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+ ghc-options: -Wcompat -Wnoncanonical-monad-instances -------------------------------------------------------------------------------- -- Tests@@ -97,10 +105,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,41 +120,27 @@ 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,+ base >= 4.11 && < 4.20,+ bytestring >= 0.10.4 && < 0.13, 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,+ text >= 1.1 && < 2.2,+ time >= 1.4 && < 1.14,+ containers >= 0.5 && < 0.8, unordered-containers >= 0.2 && < 0.3,- hashable >= 1.2 && < 2.0,- primitive >= 0.5 && < 0.7,+ primitive >= 0.5 && < 0.10, 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.15,+ tasty >= 0.11 && < 1.6,+ tasty-hunit >= 0.9 && < 0.11,+ tasty-quickcheck >= 0.8 && < 0.11, quickcheck-instances >= 0.3.12 && < 0.4,- vector >= 0.10 && < 0.13+ vector >= 0.10 && < 0.14 -------------------------------------------------------------------------------- -- Benchmarks@@ -161,24 +155,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,- bytestring >= 0.10.4 && < 0.11,- vector >= 0.10 && < 0.13,+ base >= 4.11 && < 4.20,+ binary >= 0.7 && < 0.11,+ bytestring >= 0.10.4 && < 0.13,+ vector >= 0.10 && < 0.14, cborg, serialise, - deepseq >= 1.0 && < 1.5,- criterion >= 1.0 && < 1.3+ deepseq >= 1.0 && < 1.6,+ criterion >= 1.0 && < 1.7 if flag(newtime15) build-depends:- time >= 1.5 && < 1.9+ time >= 1.5 && < 1.14 else build-depends: time >= 1.4 && < 1.5,@@ -210,20 +205,21 @@ SimpleVersus build-depends:- base >= 4.6 && < 5.0,- binary >= 0.7 && < 0.10,- bytestring >= 0.10.4 && < 0.11,- ghc-prim >= 0.3 && < 0.6,- vector >= 0.10 && < 0.13,+ base >= 4.11 && < 4.20,+ binary >= 0.7 && < 0.11,+ bytestring >= 0.10.4 && < 0.13,+ ghc-prim >= 0.3.1.0 && < 0.12,+ vector >= 0.10 && < 0.14, cborg, serialise, - aeson >= 0.7 && < 1.3,- deepseq >= 1.0 && < 1.5,- criterion >= 1.0 && < 1.3,+ aeson >= 0.7 && < 2.3,+ deepseq >= 1.0 && < 1.6,+ criterion >= 1.0 && < 1.7, cereal >= 0.5.2.0 && < 0.6, cereal-vector >= 0.2 && < 0.3,- store >= 0.4 && < 0.5+ semigroups >= 0.18 && < 0.21,+ store >= 0.7.1 && < 0.8 benchmark versus type: exitcode-stdio-1.0@@ -255,32 +251,34 @@ Macro.CBOR build-depends:+ base >= 4.11 && < 4.20, array >= 0.4 && < 0.6,- base >= 4.6 && < 5.0,- binary >= 0.7 && < 0.10,- bytestring >= 0.10.4 && < 0.11,+ binary >= 0.7 && < 0.11,+ bytestring >= 0.10.4 && < 0.13, directory >= 1.0 && < 1.4,- ghc-prim >= 0.3 && < 0.6,- text >= 1.1 && < 1.3,- vector >= 0.10 && < 0.13,+ ghc-prim >= 0.3.1.0 && < 0.12,+ fail >= 4.9.0.0 && < 4.10,+ text >= 1.1 && < 2.2,+ vector >= 0.10 && < 0.14, cborg, serialise, filepath >= 1.0 && < 1.5,- containers >= 0.5 && < 0.6,- deepseq >= 1.0 && < 1.5,- aeson >= 0.7 && < 1.3,+ containers >= 0.5 && < 0.8,+ deepseq >= 1.0 && < 1.6,+ aeson >= 0.7 && < 2.3, 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.7,+ store >= 0.7.1 && < 0.8,+ semigroups if flag(newtime15) build-depends:- time >= 1.5 && < 1.9+ time >= 1.5 && < 1.14 else build-depends: time >= 1.4 && < 1.5,
src/Codec/Serialise/Class.hs view
@@ -28,6 +28,9 @@ , GSerialiseSum(..) , encodeVector , decodeVector+ , encodeContainerSkel+ , encodeMapSkel+ , decodeMapSkel ) where import Control.Applicative@@ -48,6 +51,7 @@ #if MIN_VERSION_base(4,8,0) import Numeric.Natural import Data.Functor.Identity+import Data.Void (Void, absurd) #endif #if MIN_VERSION_base(4,9,0)@@ -67,10 +71,12 @@ import qualified Data.Map as Map import qualified Data.Sequence as Sequence import qualified Data.Set as Set+import qualified Data.Strict as Strict import qualified Data.IntSet as IntSet import qualified Data.IntMap as IntMap import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap+import qualified Data.These as These import qualified Data.Tree as Tree import qualified Data.Primitive.ByteArray as Prim import qualified Data.Vector as Vector@@ -96,6 +102,9 @@ import Prelude hiding (decodeFloat, encodeFloat, foldr) import qualified Prelude+#if MIN_VERSION_base(4,16,0)+import GHC.Exts (Levity(..))+#endif #if MIN_VERSION_base(4,10,0) import Type.Reflection import Type.Reflection.Unsafe@@ -201,6 +210,13 @@ -------------------------------------------------------------------------------- -- Primitive and integral instances +#if MIN_VERSION_base(4,8,0)+-- | @since 0.2.4.0+instance Serialise Void where+ encode = absurd+ decode = fail "tried to decode void"+#endif+ -- | @since 0.2.0.0 instance Serialise () where encode = const encodeNull@@ -527,10 +543,12 @@ encode = encode . Semigroup.getLast decode = fmap Semigroup.Last decode +#if !MIN_VERSION_base(4,16,0) -- | @since 0.2.0.0 instance Serialise a => Serialise (Semigroup.Option a) where encode = encode . Semigroup.getOption decode = fmap Semigroup.Option decode+#endif instance Serialise a => Serialise (Semigroup.WrappedMonoid a) where encode = encode . Semigroup.unwrapMonoid@@ -847,7 +865,45 @@ return (Right x) _ -> fail "unknown tag" +-- | @since 0.2.4.0+instance (Serialise a, Serialise b) => Serialise (These.These a b) where+ encode (These.This x) = encodeListLen 2 <> encodeWord 0 <> encode x+ encode (These.That x) = encodeListLen 2 <> encodeWord 1 <> encode x+ encode (These.These x y) = encodeListLen 3 <> encodeWord 2 <> encode x <> encode y + decode = do n <- decodeListLen+ t <- decodeWord+ case (t, n) of+ (0, 2) -> do !x <- decode+ return (These.This x)+ (1, 2) -> do !x <- decode+ return (These.That x)+ (2, 3) -> do !x <- decode+ !y <- decode+ return (These.These x y)+ _ -> fail "unknown tag"++-- | @since 0.2.4.0+instance (Serialise a, Serialise b) => Serialise (Strict.Pair a b) where+ encode = encode . Strict.toLazy+ decode = Strict.toStrict <$> decode++-- | @since 0.2.4.0+instance Serialise a => Serialise (Strict.Maybe a) where+ encode = encode . Strict.toLazy+ decode = Strict.toStrict <$> decode++-- | @since 0.2.4.0+instance (Serialise a, Serialise b) => Serialise (Strict.Either a b) where+ encode = encode . Strict.toLazy+ decode = Strict.toStrict <$> decode++-- | @since 0.2.4.0+instance (Serialise a, Serialise b) => Serialise (Strict.These a b) where+ encode = encode . Strict.toLazy+ decode = Strict.toStrict <$> decode++ -------------------------------------------------------------------------------- -- Container instances @@ -856,9 +912,10 @@ encode (Tree.Node r sub) = encodeListLen 2 <> encode r <> encode sub decode = decodeListLenOf 2 *> (Tree.Node <$> decode <*> decode) -encodeContainerSkel :: (Word -> Encoding)- -> (container -> Int)- -> (accumFunc -> Encoding -> container -> Encoding)+-- | Patch functions together to obtain an 'Encoding' for a container.+encodeContainerSkel :: (Word -> Encoding) -- ^ encoder of the length+ -> (container -> Int) -- ^ length+ -> (accumFunc -> Encoding -> container -> Encoding) -- ^ foldr -> accumFunc -> container -> Encoding@@ -996,8 +1053,9 @@ encode = encodeSetSkel HashSet.size HashSet.foldr decode = decodeSetSkel HashSet.fromList +-- | A helper function for encoding maps. encodeMapSkel :: (Serialise k, Serialise v)- => (m -> Int)+ => (m -> Int) -- ^ obtain the length -> ((k -> v -> Encoding -> Encoding) -> Encoding -> m -> Encoding) -> m -> Encoding@@ -1009,8 +1067,9 @@ (\k v b -> encode k <> encode v <> b) {-# INLINE encodeMapSkel #-} +-- | A utility function to construct a 'Decoder' for maps. decodeMapSkel :: (Serialise k, Serialise v)- => ([(k,v)] -> m)+ => ([(k,v)] -> m) -- ^ fromList -> Decoder s m decodeMapSkel fromList = do n <- decodeMapLen@@ -1130,6 +1189,15 @@ decodeListLenOf 1 toEnum . fromIntegral <$> decodeWord +#if MIN_VERSION_base(4,16,0)+-- | @since 0.2.6.0+instance Serialise Levity where+ encode lev = encodeListLen 1 <> encodeWord (fromIntegral $ fromEnum lev)+ decode = do+ decodeListLenOf 1+ toEnum . fromIntegral <$> decodeWord+#endif+ -- | @since 0.2.0.0 instance Serialise RuntimeRep where encode rr =@@ -1137,8 +1205,12 @@ VecRep a b -> encodeListLen 3 <> encodeWord 0 <> encode a <> encode b TupleRep reps -> encodeListLen 2 <> encodeWord 1 <> encode reps SumRep reps -> encodeListLen 2 <> encodeWord 2 <> encode reps+#if MIN_VERSION_base(4,16,0)+ BoxedRep lev -> encodeListLen 2 <> encodeWord 3 <> encode lev+#else LiftedRep -> encodeListLen 1 <> encodeWord 3 UnliftedRep -> encodeListLen 1 <> encodeWord 4+#endif IntRep -> encodeListLen 1 <> encodeWord 5 WordRep -> encodeListLen 1 <> encodeWord 6 Int64Rep -> encodeListLen 1 <> encodeWord 7@@ -1146,6 +1218,16 @@ AddrRep -> encodeListLen 1 <> encodeWord 9 FloatRep -> encodeListLen 1 <> encodeWord 10 DoubleRep -> encodeListLen 1 <> encodeWord 11+#if MIN_VERSION_base(4,13,0)+ Int8Rep -> encodeListLen 1 <> encodeWord 12+ Int16Rep -> encodeListLen 1 <> encodeWord 13+ Word8Rep -> encodeListLen 1 <> encodeWord 14+ Word16Rep -> encodeListLen 1 <> encodeWord 15+#endif+#if MIN_VERSION_base(4,14,0)+ Int32Rep -> encodeListLen 1 <> encodeWord 16+ Word32Rep -> encodeListLen 1 <> encodeWord 17+#endif decode = do len <- decodeListLen@@ -1154,8 +1236,12 @@ 0 | len == 3 -> VecRep <$> decode <*> decode 1 | len == 2 -> TupleRep <$> decode 2 | len == 2 -> SumRep <$> decode+#if MIN_VERSION_base(4,16,0)+ 3 | len == 2 -> BoxedRep <$> decode+#else 3 | len == 1 -> pure LiftedRep 4 | len == 1 -> pure UnliftedRep+#endif 5 | len == 1 -> pure IntRep 6 | len == 1 -> pure WordRep 7 | len == 1 -> pure Int64Rep@@ -1163,6 +1249,16 @@ 9 | len == 1 -> pure AddrRep 10 | len == 1 -> pure FloatRep 11 | len == 1 -> pure DoubleRep+#if MIN_VERSION_base(4,13,0)+ 12 | len == 1 -> pure Int8Rep+ 13 | len == 1 -> pure Int16Rep+ 14 | len == 1 -> pure Word8Rep+ 15 | len == 1 -> pure Word16Rep+#endif+#if MIN_VERSION_base(4,14,0)+ 16 | len == 1 -> pure Int32Rep+ 17 | len == 1 -> pure Word32Rep+#endif _ -> fail "Data.Serialise.Binary.CBOR.getRuntimeRep: invalid tag" -- | @since 0.2.0.0@@ -1195,12 +1291,18 @@ <> case n of TypeLitSymbol -> encodeWord 0 TypeLitNat -> encodeWord 1+#if MIN_VERSION_base(4,16,0)+ TypeLitChar -> encodeWord 2+#endif decode = do decodeListLenOf 1 tag <- decodeWord case tag of 0 -> pure TypeLitSymbol 1 -> pure TypeLitNat+#if MIN_VERSION_base(4,16,0)+ 2 -> pure TypeLitChar+#endif _ -> fail "Data.Serialise.Binary.CBOR.putTypeLitSort: invalid tag" decodeSomeTypeRep :: Decoder s SomeTypeRep@@ -1210,11 +1312,11 @@ case tag of 0 | len == 1 -> return $! SomeTypeRep (typeRep :: TypeRep Type)- 1 | len == 2 -> do+ 1 | len == 3 -> do !con <- decode !ks <- decode return $! SomeTypeRep $ mkTrCon con ks- 2 | len == 2 -> do+ 2 | len == 3 -> do SomeTypeRep f <- decodeSomeTypeRep SomeTypeRep x <- decodeSomeTypeRep case typeRepKind f of@@ -1233,7 +1335,7 @@ [ "Applied type: " ++ show f , "To argument: " ++ show x ]- 3 | len == 2 -> do+ 3 | len == 3 -> do SomeTypeRep arg <- decodeSomeTypeRep SomeTypeRep res <- decodeSomeTypeRep case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of@@ -1242,7 +1344,9 @@ Just HRefl -> return $! SomeTypeRep $ Fun arg res Nothing -> failure "Kind mismatch" [] Nothing -> failure "Kind mismatch" []- _ -> failure "unexpected tag" []+ _ -> failure "unexpected tag"+ [ "Tag: " ++ show tag+ , "Len: " ++ show len ] where failure description info = fail $ unlines $ [ "Codec.CBOR.Class.decodeSomeTypeRep: "++description ]@@ -1268,7 +1372,6 @@ <> encodeWord 3 <> encodeTypeRep arg <> encodeTypeRep res-encodeTypeRep _ = error "Codec.CBOR.Class.encodeTypeRep: Impossible" -- | @since 0.2.0.0 instance Typeable a => Serialise (TypeRep (a :: k)) where
src/Codec/Serialise/Tutorial.hs view
@@ -9,33 +9,32 @@ -- Stability : experimental -- Portability : non-portable (GHC extensions) ----- @cborg@ is a library for the serialisation of Haskell values.+-- @serialise@ library is built on @cborg@, they implement CBOR (Concise Binary Object Representation, specified by [IETF RFC 7049](https://tools.ietf.org/html/rfc7049)) and serialisers/deserializers for it. -- module Codec.Serialise.Tutorial- ( -- * Introduction+ ( -- * Basic use example -- $introduction - -- ** The CBOR format+ -- * The CBOR format -- $cbor_format + -- ** Interoperability with other CBOR implementations+ -- $interoperability+ -- * The 'Serialise' class -- $serialise - -- ** Encoding terms+ -- ** How to write encoding terms -- $encoding - -- ** Decoding terms+ -- ** How to write decoding terms -- $decoding -- * Migrations -- $migrations -- * Working with foreign encodings- -- | While @cborg@ is primarily designed to be a Haskell serialisation- -- library, the fact that it uses the standard CBOR encoding means that it can also- -- find uses in interacting with foreign non-@cborg@ producers and- -- consumers. In this section we will describe a few features of the library- -- which may be useful in such applications.+ -- $foreign_encodings -- ** Working with arbitrary terms -- $arbitrary_terms@@ -45,19 +44,25 @@ ) where -- These are necessary for haddock to properly hyperlink+import Codec.Serialise import Codec.Serialise.Decoding import Codec.Serialise.Class+import Codec.CBOR.Term+import Codec.CBOR.FlatTerm+import Codec.CBOR.Pretty {- $introduction -As in modern serialisation libraries, @cborg@ offers-instance derivation via GHC's 'GHC.Generic' mechanism,+@serialise@ offers ability to derive instances via 'GHC.Generic' mechanism: > import Codec.Serialise > import qualified Data.ByteString.Lazy as BSL >+> fileName :: FilePath+> fileName = "out.cbor"+> > data Animal = HoppingAnimal { animalName :: String, hoppingHeight :: Int }-> | WalkingAnimal { animalName :: String, walkingSpeed :: Int }+> | WalkingAnimal { animalName :: String, walkingSpeed :: Int } > deriving (Generic) > > instance Serialise Animal@@ -65,41 +70,55 @@ > fredTheFrog :: Animal > fredTheFrog = HoppingAnimal "Fred" 4 >-> main = BSL.writeFile "hi" (serialise fredTheFrog)--We can then later read Fred,--> main = do-> fred <- deserialise <$> BSL.readFile "hi"-> print fred+> -- | To output value into a file+> write :: Serialise a => FilePath -> a -> IO ()+> write file val = BSL.writeFile file (serialise val)+>+> -- | Outputs @Fred@ value into file+> writeIO :: IO ()+> writeIO = write fileName fredTheFrog+>+> -- | Reads the value from file+> readIO :: IO Animal+> readIO = deserialise <$> BSL.readFile fileName+>+> printIO :: IO ()+> printIO = do+> val <- readIO+> print val -} {- $cbor_format -@cborg@ uses the Concise Binary Object Representation, CBOR-(IETF RFC 7049, <https://tools.ietf.org/html/rfc7049>), as its serialised-representation. This encoding is efficient in both encoding\/decoding complexity-as well as space, and is generally machine-independent.+CBOR encoding is efficient in encoding\/decoding complexity and space, and is generally machine-independent. -The CBOR data model resembles that of JSON, having arrays, key\/value maps,-integers, floating point numbers, binary strings, and text. In addition,-CBOR allows items to be /tagged/ with a number which describes the type of data-that follows. This can be used both to identify which data constructor of a type-an encoding represents, as well as representing different versions of the same+CBOR data model has:+ * integers+ * floating point numbers+ * binary strings+ * text+ * arrays+ * key\/value maps+and resembles JSON.++CBOR allows items to be /tagged/ with a number which identifies the type of data.+This can be used both to identify which data constructor of a type+is represented, as well as representing different versions of the same constructor. -=== A note on interoperability+-} -@cborg@ is intended primarily as a /serialisation/ library for-Haskell values. That is, a means of stably storing Haskell values for later-reading by @cborg@. While it uses the CBOR encoding format, the-library is /not/ primarily aimed to facilitate serialisation and+{- $interoperability++Library provides means of stably storing Haskell values for later+reading by the library.++The library is /not/ aimed to facilitate serialisation and deserialisation across different CBOR implementations.+But that is possible to setup practically. -If you want to use @cborg@ to serialise\/deserialise values-for\/from another CBOR implementation (either in Haskell or another language),-you should keep a few things in mind,+A few things on compatibility with other CBOR implementations: 1. The 'Serialise' instances for some "basic" Haskell types (e.g. 'Maybe', 'Data.ByteString.ByteString', tuples) don't carry a tag, in contrast to common@@ -111,12 +130,12 @@ non-backwards-compatible ways across super-major versions. For example the library may start producing a new representation for some type. The new version of the library will be able to decode the old and new representation,- but your different CBOR decoder would not be expecting the new representation+ but different CBOR decoder would not be expecting the new representation and would have to be updated to match. 3. While the library tries to use standard encodings in its instances wherever possible, these instances aren't guaranteed to implement all valid variants of the- encodings in the specification. For instance, the 'UTCTime' instance only+ RFCs/standards mentioned in the specification. For instance, the 'UTCTime' instance only implements a small subset of the encodings described by the Extended Date RFC. @@ -124,48 +143,47 @@ {- $serialise -@cborg@ provides a 'Serialise' class for convenient access to serialisers and-deserialisers. Writing a serialiser can be as simple as deriving 'Generic' and+'Serialise' class provides convenient access to serialisers and+deserialisers.++Creating & using a serialiser can be as simple as deriving 'Generic' and 'Serialise', +> -- all GHCs+> data MyType = ...+> deriving (Generic)+> instance Serialise MyType+> > -- with DerivingStrategies (GHC 8.2 and newer) > data Animal = ... > deriving stock (Generic) > deriving anyclass (Serialise)->-> -- older GHCs-> data MyType = ...-> deriving (Generic)-> instance Serialise MyType -Of course, you can also write the equivalent serialisers manually.-A hand-rolled 'Serialise' instance may be desireable for a variety-of reasons,+Of course, equivalent implementations can be handwritten.+A custom 'Serialise' instance may be desireable for a variety+of reasons: - * Deviating from the type-guided encoding that the 'Generic' instance will- provide+ * deviating from the type-guided encoding that the 'Generic' instance provides - * Interfacing with other CBOR implementations+ * interfacing with other CBOR implementations - * Enabling migrations for future changes to the type or its encoding+ * managing migration changes to the type and its encoding -A minimal hand-rolled instance will define the 'encode' and 'decode' methods,+'encode' and 'decode' methods form a minimal `Serialise` instance definition: > instance Serialise Animal where > encode = encodeAnimal > decode = decodeAnimal -Below we will describe how to write these pieces.- -} {- $encoding For the purposes of encoding, abstract CBOR representations are embodied by the 'Codec.CBOR.Encoding.Tokens' type. Such a representation can be efficiently-built using the 'Codec.CBOR.Encoding.Encoding' 'Monoid'.+built using the 'Monoid' 'Codec.CBOR.Encoding.Encoding'. -For instance, to implement an encoder for the @Animal@ type above we might write,+For instance, to implement an encoder for the @Animal@ type above: > encodeAnimal :: Animal -> Encoding > encodeAnimal (HoppingAnimal name height) =@@ -173,16 +191,16 @@ > encodeAnimal (WalkingAnimal name speed) = > encodeListLen 3 <> encodeWord 1 <> encode name <> encode speed -Here we see that each encoding begins with a /length/, describing how many-values belonging to our @Animal@ will follow. We then encode a /tag/, which-identifies which constructor. We then encode the fields using their respective-'Serialise' instance.+Each encoding begins with a /length/, declaring how many+values belonging to @Animal@ constructor going to follow. Then a /tag/ which+identifies constructor. Fields are encoded using their respective+'Serialise' instances. -It is recommended that you not deviate from this encoding scheme, including both-the length and tag, to ensure that you have the option to migrate your types+It is recommended to not deviate from this encoding scheme - including both+the length and tag - to ensure to have the option to migrate types later on. -Also note that the recommended encoding represents Haskell constructor indexes+Note: the recommended encoding represents Haskell constructor indexes as CBOR words, not CBOR tags. -}@@ -190,8 +208,7 @@ {- $decoding Decoding CBOR representations to Haskell values is done in the 'Decoder'-'Monad'. We can write a 'Decoder' for the @Animal@ type defined above as-follows,+'Monad'. A 'decode' for the @Animal@ type would be: > decodeAnimal :: Decoder s Animal > decodeAnimal = do@@ -206,31 +223,30 @@ {- $migrations -One eventuality that data serialisation schemes need to account for is the need-for changes in the data's structure. There are two types of compatibility-which we might want to strive for in our serialisers,+One eventuality that data serialisation schemes need to account for+- is the future changes in the data's structure. - * Backward compatibility, such that newer versions of the serialiser can read+There are two types of compatibility to strive for in serialisers:++ * backward compatibility: newer versions of the serialiser can read older versions of an encoding - * Forward compatibility, such that older versions of the serialiser can read+ * forward compatibility: older versions of the serialiser can read (or at least tolerate) newer versions of an encoding -Below we will look at a few of the types of changes which we may need to make-and describe how these can be handled in a backwards-compatible manner with-@cborg@.+Below are a few examples of how to provide backward-compatible serialisation. === Adding a constructor -Say we want to add a new constructor to our @Animal@ type, @SwimmingAnimal@,+Example: adding a new constructor to @Animal@ type, @SwimmingAnimal@, > data Animal = HoppingAnimal { animalName :: String, hoppingHeight :: Int } > | WalkingAnimal { animalName :: String, walkingSpeed :: Int } > | SwimmingAnimal { numberOfFins :: Int } > deriving (Generic) -We can account for this in our hand-rolled serialiser by simply adding a new tag-to our encoder and decoder,+To account for this in handwritten serialiser - add a new tag+to encoder and decoder, > encodeAnimal :: Animal -> Encoding > -- HoppingAnimal, SwimmingAnimal cases are unchanged...@@ -256,49 +272,59 @@ === Adding\/removing\/modifying fields -Say then we want to add a new field to our @WalkingAnimal@ constructor,+Example: adding a new field to @WalkingAnimal@ constructor, > data Animal = HoppingAnimal { animalName :: String, hoppingHeight :: Int }-> | WalkingAnimal { animalName :: String, walkingSpeed :: Int, numberOfFeet :: Int }+> | WalkingAnimal { animalName :: String, walkingSpeed :: Int, numberOfFeet :: Int } > | SwimmingAnimal { numberOfFins :: Int } > deriving (Generic) -We can account for this by representing @WalkingAnimal@ with a new encoding with-a new tag,+To account for this - represent @WalkingAnimal@ with a new encoding with+a new tag, while also providing default value for backward compatibility: > encodeAnimal :: Animal -> Encoding > -- 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.+The same approach can be used to handle field removal and type changes. -} +{- $foreign_encodings++While @serialise@ & @cborg@ are primarily designed to be a Haskell-only values serialisation+library, the fact that it implements the standard CBOR encoding means that it also can+find uses in interacting with foreign CBOR producers &+consumers. In this section we will describe a few features of the library+which may be useful in such applications.++-}+ {- $arbitrary_terms When working with foreign encodings, it can sometimes be useful to capture a-serialised CBOR term verbatim (for instance, so you can later re-serialise it in-some later result). The 'Codec.CBOR.Term.Term' type provides such a+serialised CBOR term verbatim (for instance, to later re-serialise it in+some later result). The 'Codec.CBOR.Term.Term' type provides such representation, losslessly capturing a CBOR AST. It can be serialised and deserialised with its 'Serialise' instance. @@ -306,7 +332,7 @@ {- $examining_encodings -We can also look In addition to serialisation and deserialisation, @cborg@+In addition to serialisation and deserialisation, @cborg@ provides a variety of tools for representing arbitrary CBOR encodings in the "Codec.CBOR.FlatTerm" and "Codec.CBOR.Pretty" modules. @@ -320,7 +346,7 @@ Right (HoppingAnimal {animalName = "Fred", hoppingHeight = 42}) This can be useful both for understanding external CBOR formats, as well as-understanding and testing your own hand-rolled encodings.+understanding and testing handwritten encodings. The package also includes a pretty-printer in "Codec.CBOR.Pretty", for visualising the CBOR wire protocol alongside its semantic structure. For instance,
tests/Main.hs view
@@ -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
− tests/Tests/CBOR.hs
@@ -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- ]- ]
tests/Tests/Negative.hs view
@@ -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
tests/Tests/Orphanage.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}+#if MIN_VERSION_base(4,10,0)+{-# LANGUAGE TypeApplications #-}+#endif module Tests.Orphanage where -#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,10,0)+#if !MIN_VERSION_base(4,8,0) import Control.Applicative import Data.Monoid as Monoid #endif@@ -13,10 +16,14 @@ import qualified Data.Semigroup as Semigroup #endif +#if MIN_VERSION_base(4,10,0)+import Data.Proxy+import qualified Type.Reflection as Refl+#endif+ import GHC.Fingerprint.Type import Data.Ord #if !MIN_VERSION_QuickCheck(2,10,0)-import Data.Typeable import Foreign.C.Types import System.Exit (ExitCode(..)) @@ -26,8 +33,11 @@ import Test.QuickCheck.Arbitrary import qualified Data.Vector.Primitive as Vector.Primitive+#if !MIN_VERSION_quickcheck_instances(0,3,17) import qualified Data.ByteString.Short as BSS+#endif + -------------------------------------------------------------------------------- -- QuickCheck Orphans @@ -180,23 +190,10 @@ shrink _ = [] #endif -#if !MIN_VERSION_base(4,8,0)-deriving instance Typeable Const-deriving instance Typeable ZipList-deriving instance Typeable Down-deriving instance Typeable Monoid.Sum-deriving instance Typeable Monoid.All-deriving instance Typeable Monoid.Any-deriving instance Typeable Monoid.Product-deriving instance Typeable Monoid.Dual-deriving instance Typeable Fingerprint--deriving instance Show a => Show (Const a b)-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@@ -209,3 +206,10 @@ instance Arbitrary Fingerprint where arbitrary = Fingerprint <$> arbitrary <*> arbitrary++#if MIN_VERSION_base(4,10,0)+data Kind a = Type a++instance Arbitrary Refl.SomeTypeRep where+ arbitrary = return (Refl.someTypeRep $ Proxy @([Either (Maybe Int) (Proxy ('Type String))]))+#endif
− tests/Tests/Reference.hs
@@ -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- ]- ]
− tests/Tests/Reference/Implementation.hs
@@ -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-
tests/Tests/Regress.hs view
@@ -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
− tests/Tests/Regress/FlatTerm.hs
@@ -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)- ]
tests/Tests/Serialise.hs view
@@ -19,6 +19,10 @@ import qualified Data.Semigroup as Semigroup #endif +#if MIN_VERSION_base(4,10,0)+import qualified Type.Reflection as Refl+#endif+ import Data.Char (ord) import Data.Complex import Data.Int@@ -177,13 +181,18 @@ , mkTest (T :: T (Canonical Float)) , mkTest (T :: T (Canonical Double)) , mkTest (T :: T [()])+#if MIN_VERSION_base(4,10,0)+ , mkTest (T :: T (Refl.SomeTypeRep))+#endif #if MIN_VERSION_base(4,9,0) , mkTest (T :: T (NonEmpty ())) , mkTest (T :: T (Semigroup.Min ())) , mkTest (T :: T (Semigroup.Max ())) , mkTest (T :: T (Semigroup.First ())) , mkTest (T :: T (Semigroup.Last ()))+#if !MIN_VERSION_base(4,16,0) , mkTest (T :: T (Semigroup.Option ()))+#endif , mkTest (T :: T (Semigroup.WrappedMonoid ())) #endif #if MIN_VERSION_base(4,7,0)@@ -218,7 +227,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,7 +343,20 @@ , 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 @@ -394,7 +416,7 @@ cnv = foldr Cons Nil newtype BytesByteArray = BytesBA CBOR.BA.ByteArray- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, Typeable) instance Serialise BytesByteArray where encode (BytesBA ba) = encodeByteArray $ CBOR.BA.toSliced ba@@ -404,7 +426,7 @@ arbitrary = BytesBA . fromList <$> arbitrary newtype Utf8ByteArray = Utf8BA CBOR.BA.ByteArray- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, Typeable) instance Serialise Utf8ByteArray where encode (Utf8BA ba) = encodeUtf8ByteArray $ CBOR.BA.toSliced ba@@ -412,5 +434,6 @@ instance Arbitrary Utf8ByteArray where arbitrary = do- BSS.SBS ba <- BSS.toShort . Text.encodeUtf8 <$> arbitrary- return $ Utf8BA $ CBOR.BA.BA $ Prim.ByteArray ba+ bss <- BSS.toShort . Text.encodeUtf8 <$> arbitrary+ case bss of+ BSS.SBS ba -> return $ Utf8BA $ CBOR.BA.BA $ Prim.ByteArray ba
tests/Tests/Serialise/Canonical.hs view
@@ -1,7 +1,13 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-} module Tests.Serialise.Canonical where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif import Data.Bits import Data.Int
− tests/test-vectors/README.md
@@ -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.)
− tests/test-vectors/appendix_a.json
@@ -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- }- }-]