serialise 0.1.0.0 → 0.2.0.0

raw patch · 18 files changed

+537/−85 lines, 18 filesdep ~QuickCheckdep ~aesondep ~binaryPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, aeson, binary, cborg, criterion, ghc-prim, half, tasty, tasty-quickcheck

API changes (from Hackage documentation)

Files

• serialise.cabal +26/−16
• src/Codec/Serialise.hs +1/−1
• src/Codec/Serialise/Class.hs +46/−9
• src/Codec/Serialise/Decoding.hs +2/−0
• src/Codec/Serialise/Encoding.hs +2/−0
• src/Codec/Serialise/Internal/GeneralisedUTF8.hs +161/−0
• src/Codec/Serialise/Tutorial.hs +23/−20
• tests/Main.hs +2/−0
• tests/Tests/CBOR.hs +15/−5
• tests/Tests/GeneralisedUTF8.hs +37/−0
• tests/Tests/Orphanage.hs +17/−7
• tests/Tests/Reference.hs +0/−2
• tests/Tests/Reference/Implementation.hs +15/−3
• tests/Tests/Regress.hs +3/−1
• tests/Tests/Regress/Issue135.hs +34/−0
• tests/Tests/Serialise.hs +57/−9
• tests/Tests/Serialise/Canonical.hs +96/−0
• tests/test-vectors/appendix_a.json +0/−12

@@ -1,5 +1,5 @@ name:                serialise-version:             0.1.0.0+version:             0.2.0.0 synopsis:            A binary serialisation library for Haskell values. description:   This package (formerly @binary-serialise-cbor@) provides pure, efficient@@ -12,6 +12,11 @@   serialised Haskell values have implicit structure outside of the   Haskell program itself, meaning they can be inspected or analyzed   with custom tools.+  .+  An implementation of the standard bijection between CBOR and JSON is provided+  by the [cborg-json](/package/cborg-json) package. Also see+  [cbor-tool](/package/cbor-tool) for a convenient command-line utility for+  working with CBOR data. homepage:            https://github.com/well-typed/cborg license:             BSD3 license-file:        LICENSE.txt@@ -38,7 +43,7 @@ -- Flags  flag newtime15-  default: False+  default: True   manual: False   description: Use the new time 1.5 library @@ -55,12 +60,13 @@     Codec.Serialise.IO     Codec.Serialise.Properties     Codec.Serialise.Tutorial+    Codec.Serialise.Internal.GeneralisedUTF8    build-depends:     array                   >= 0.4     && < 0.6,     base                    >= 4.6     && < 5.0,     bytestring              >= 0.10.4  && < 0.11,-    cborg                   == 0.1.*,+    cborg                   == 0.2.*,     containers              >= 0.5     && < 0.6,     ghc-prim                >= 0.3     && < 0.6,     half                    >= 0.2.2.3 && < 0.3,@@ -99,20 +105,23 @@     Tests.Negative     Tests.Orphanage     Tests.Serialise+    Tests.Serialise.Canonical     Tests.Regress     Tests.Regress.Issue13     Tests.Regress.Issue67     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.9,+    binary                  >= 0.7     && < 0.10,     bytestring              >= 0.10.4  && < 0.11,     directory               >= 1.0     && < 1.4,     filepath                >= 1.0     && < 1.5,@@ -122,19 +131,20 @@     containers              >= 0.5     && < 0.6,     unordered-containers    >= 0.2     && < 0.3,     hashable                >= 1.2     && < 2.0,+    primitive               >= 0.5     && < 0.7,     cborg,     serialise, -    aeson                   >= 0.7     && < 1.2,+    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.10,+    QuickCheck              >= 2.9     && < 2.11,     scientific              >= 0.3     && < 0.4,-    tasty                   >= 0.11    && < 0.12,+    tasty                   >= 0.11    && < 0.13,     tasty-hunit             >= 0.9     && < 0.10,-    tasty-quickcheck        >= 0.8     && < 0.9,+    tasty-quickcheck        >= 0.8     && < 0.10,     quickcheck-instances    >= 0.3.12  && < 0.4,     vector                  >= 0.10    && < 0.13 @@ -157,14 +167,14 @@    build-depends:     base                    >= 4.6     && < 5.0,-    binary                  >= 0.7     && < 0.9,+    binary                  >= 0.7     && < 0.10,     bytestring              >= 0.10.4  && < 0.11,     vector                  >= 0.10    && < 0.13,     cborg,     serialise,      deepseq                 >= 1.0     && < 1.5,-    criterion               >= 1.0     && < 1.2+    criterion               >= 1.0     && < 1.3    if flag(newtime15)     build-depends:@@ -201,16 +211,16 @@    build-depends:     base                    >= 4.6     && < 5.0,-    binary                  >= 0.7     && < 0.9,+    binary                  >= 0.7     && < 0.10,     bytestring              >= 0.10.4  && < 0.11,     ghc-prim                >= 0.3     && < 0.6,     vector                  >= 0.10    && < 0.13,     cborg,     serialise, -    aeson                   >= 0.7     && < 1.2,+    aeson                   >= 0.7     && < 1.3,     deepseq                 >= 1.0     && < 1.5,-    criterion               >= 1.0     && < 1.2,+    criterion               >= 1.0     && < 1.3,     cereal                  >= 0.5.2.0 && < 0.6,     cereal-vector           >= 0.2     && < 0.3,     store                   >= 0.4     && < 0.5@@ -247,7 +257,7 @@   build-depends:     array                   >= 0.4     && < 0.6,     base                    >= 4.6     && < 5.0,-    binary                  >= 0.7     && < 0.9,+    binary                  >= 0.7     && < 0.10,     bytestring              >= 0.10.4  && < 0.11,     directory               >= 1.0     && < 1.4,     ghc-prim                >= 0.3     && < 0.6,@@ -259,13 +269,13 @@     filepath                >= 1.0     && < 1.5,     containers              >= 0.5     && < 0.6,     deepseq                 >= 1.0     && < 1.5,-    aeson                   >= 0.7     && < 1.2,+    aeson                   >= 0.7     && < 1.3,     cereal                  >= 0.5.2.0 && < 0.6,     half                    >= 0.2.2.3 && < 0.3,     tar                     >= 0.4     && < 0.6,     zlib                    >= 0.5     && < 0.7,     pretty                  >= 1.0     && < 1.2,-    criterion               >= 1.0     && < 1.2,+    criterion               >= 1.0     && < 1.3,     store                   >= 0.4     && < 0.5    if flag(newtime15)

@@ -16,7 +16,7 @@ -- and utilities to help you make your types serialisable. -- -- For a full tutorial on using this module, see--- "Codec.CBOR.Tutorial".+-- "Codec.Serialise.Tutorial". -- module Codec.Serialise   ( -- * High level, one-shot API

@@ -24,6 +24,8 @@    Serialise(..)  , GSerialiseEncode(..)  , GSerialiseDecode(..)+ , GSerialiseProd(..)+ , GSerialiseSum(..)  , encodeVector  , decodeVector  ) where@@ -31,6 +33,7 @@ import           Control.Applicative  import           Control.Monad+import           Data.Char import           Data.Hashable import           Data.Int import           Data.Monoid@@ -54,6 +57,7 @@  import qualified Data.Foldable                       as Foldable import qualified Data.ByteString                     as BS+import qualified Data.ByteString.Short.Internal      as BSS import qualified Data.Text                           as Text  -- TODO FIXME: more instances@@ -68,6 +72,7 @@ import qualified Data.HashSet                        as HashSet import qualified Data.HashMap.Strict                 as HashMap import qualified Data.Tree                           as Tree+import qualified Data.Primitive.ByteArray            as Prim import qualified Data.Vector                         as Vector import qualified Data.Vector.Unboxed                 as Vector.Unboxed import qualified Data.Vector.Storable                as Vector.Storable@@ -105,6 +110,9 @@ import           Codec.CBOR.Decoding import           Codec.CBOR.Encoding import           Codec.CBOR.Term+import           Codec.Serialise.Internal.GeneralisedUTF8+import qualified Codec.CBOR.ByteArray                as BA+import qualified Codec.CBOR.ByteArray.Sliced         as BAS   --------------------------------------------------------------------------------@@ -304,16 +312,37 @@  -- | @since 0.2.0.0 instance Serialise Char where-    encode c = encodeString (Text.singleton c)-    decode = do t <- decodeString-                if Text.length t == 1-                  then return $! Text.head t-                  else fail "expected a single char, found a string"+    -- Here we've taken great pains to ensure that surrogate characters, which+    -- are not representable in UTF-8 yet still admitted by Char,+    -- round-trip properly. We scan the encoded characters during encoding+    -- looking for surrogates; if we find any we encode the string as a+    -- a list of code-points encoded as words. This is slow, but should be rare.+    encode c+      | isSurrogate c = encodeWord (fromIntegral $ ord c)+      | otherwise     = encodeString (Text.singleton c)+    decode = do ty <- peekTokenType+                case ty of+                  TypeUInt -> chr . fromIntegral <$> decodeWord+                  TypeString -> do+                    t <- decodeString+                    if Text.length t == 1+                      then return $! Text.head t+                      else fail "expected a single char, found a string"+                  _ -> fail "expected a word or string"      -- For [Char]/String we have a special encoding-    encodeList cs = encodeString (Text.pack cs)-    decodeList    = do txt <- decodeString-                       return (Text.unpack txt) -- unpack lazily+    encodeList cs =+        case encodeGenUTF8 cs of+          (ba, ConformantUTF8)  -> encodeUtf8ByteArray ba+          (ba, GeneralisedUTF8) -> encodeByteArray ba+    decodeList    = do+        ty <- peekTokenType+        case ty of+          TypeBytes  -> decodeGenUTF8 . BA.unBA <$> decodeByteArray+          TypeString -> do+              txt <- decodeString+              return (Text.unpack txt) -- unpack lazily+          _          -> fail "expected a list or string"  -- | @since 0.2.0.0 instance Serialise Text.Text where@@ -325,6 +354,14 @@     encode = encodeBytes     decode = decodeBytes +-- | @since 0.2.0.0+instance Serialise BSS.ShortByteString where+    encode sbs@(BSS.SBS ba) =+        encodeByteArray $ BAS.SBA (Prim.ByteArray ba) 0 (BSS.length sbs)+    decode = do+        BA.BA (Prim.ByteArray ba) <- decodeByteArray+        return $ BSS.SBS ba+ encodeChunked :: Serialise c               => Encoding               -> ((c -> Encoding -> Encoding) -> Encoding -> a -> Encoding)@@ -1242,7 +1279,7 @@         Just HRefl -> pure rep         Nothing    -> fail $ unlines                       [ "Codec.CBOR.Class.decode(TypeRep): Type mismatch"-                      , "    Deserialized type: " ++ show rep+                      , "    Deserialised type: " ++ show rep                       , "    Expected type:     " ++ show expected                       ]     where expected = typeRep :: TypeRep a

@@ -35,8 +35,10 @@   , decodeDouble        -- :: Decoder s Double   , decodeBytes         -- :: Decoder s ByteString   , decodeBytesIndef    -- :: Decoder s ()+  , decodeByteArray     -- :: Decoder s ByteArray   , decodeString        -- :: Decoder s Text   , decodeStringIndef   -- :: Decoder s ()+  , decodeUtf8ByteArray -- :: Decoder s ByteArray   , decodeListLen       -- :: Decoder s Int   , decodeListLenIndef  -- :: Decoder s ()   , decodeMapLen        -- :: Decoder s Int

@@ -29,8 +29,10 @@   , encodeInteger            -- :: Integer -> Encoding   , encodeBytes              -- :: B.ByteString -> Encoding   , encodeBytesIndef         -- :: Encoding+  , encodeByteArray          -- :: ByteArray -> Encoding   , encodeString             -- :: T.Text -> Encoding   , encodeStringIndef        -- :: Encoding+  , encodeUtf8ByteArray      -- :: ByteArray -> Encoding   , encodeListLen            -- :: Word -> Encoding   , encodeListLenIndef       -- :: Encoding   , encodeMapLen             -- :: Word -> Encoding

@@ -0,0 +1,161 @@+{-# LANGUAGE BangPatterns #-}++module Codec.Serialise.Internal.GeneralisedUTF8+    ( encodeGenUTF8+    , UTF8Encoding(..)+    , decodeGenUTF8+      -- * Utilities+    , isSurrogate+    , isValid+    ) where++import Control.Monad.ST+import Data.Bits+import Data.Char+import Data.Word+import qualified Codec.CBOR.ByteArray.Sliced as BAS+import Data.Primitive.ByteArray++data UTF8Encoding = ConformantUTF8 | GeneralisedUTF8+                  deriving (Show, Eq)++-- | Is a 'Char' a UTF-16 surrogate?+isSurrogate :: Char -> Bool+isSurrogate c = c >= '\xd800' && c <= '\xdfff'++-- | Encode a string as (generalized) UTF-8. In addition to the encoding, we+-- return a flag indicating whether the encoded string contained any surrogate+-- characters, in which case the output is generalized UTF-8.+encodeGenUTF8 :: String -> (BAS.SlicedByteArray, UTF8Encoding)+encodeGenUTF8 st = runST $ do+    -- We slightly over-allocate such that we won't need to copy in the+    -- ASCII-only case.+    ba <- newByteArray (length st + 4)+    go ba ConformantUTF8 0 st+  where+    go :: MutableByteArray s -> UTF8Encoding+       -> Int -> [Char]+       -> ST s (BAS.SlicedByteArray, UTF8Encoding)+    go ba !enc !off  [] = do+        ba' <- unsafeFreezeByteArray ba+        return (BAS.SBA ba' 0 off, enc)+    go ba enc off  (c:cs)+      | off + 4 >= cap = do+        -- We ran out of room; reallocate and copy+        ba' <- newByteArray (cap + cap `div` 2 + 1)+        copyMutableByteArray ba' 0 ba 0 off+        go ba' enc off (c:cs)++      | c >= '\x10000' = do+        writeByteArray ba (off+0) (0xf0 .|. (0x07 .&. shiftedByte 18))+        writeByteArray ba (off+1) (0x80 .|. (0x3f .&. shiftedByte 12))+        writeByteArray ba (off+2) (0x80 .|. (0x3f .&. shiftedByte  6))+        writeByteArray ba (off+3) (0x80 .|. (0x3f .&. shiftedByte  0))+        go ba enc (off+4) cs++      | c >= '\x0800'  = do+        writeByteArray ba (off+0) (0xe0 .|. (0x0f .&. shiftedByte 12))+        writeByteArray ba (off+1) (0x80 .|. (0x3f .&. shiftedByte  6))+        writeByteArray ba (off+2) (0x80 .|. (0x3f .&. shiftedByte  0))++        -- Is this a surrogate character?+        let enc'+              | isSurrogate c = GeneralisedUTF8+              | otherwise     = enc+        go ba enc' (off+3) cs++      | c >= '\x0080'  = do+        writeByteArray ba (off+0) (0xc0 .|. (0x1f .&. shiftedByte  6))+        writeByteArray ba (off+1) (0x80 .|. (0x3f .&. shiftedByte  0))+        go ba enc (off+2) cs++      | c <= '\x007f'  = do+        writeByteArray ba off (fromIntegral n :: Word8)+        go ba enc (off+1) cs++      | otherwise      = error "encodeGenUTF8: Impossible"+      where+        cap = sizeofMutableByteArray ba+        n = ord c+        shiftedByte :: Int -> Word8+        shiftedByte shft = fromIntegral $ n `shiftR` shft++decodeGenUTF8 :: ByteArray -> String+decodeGenUTF8 ba = go 0+  where+    !len = sizeofByteArray ba++    index :: Int -> Int+    index i = fromIntegral (ba `indexByteArray` i :: Word8)++    go !off+      | off == len = []++      | n0 .&. 0xf8 == 0xf0 =+        let n1 = index (off + 1)+            n2 = index (off + 2)+            n3 = index (off + 3)+            c  = chr $  (n0 .&. 0x07) `shiftL` 18+                    .|. (n1 .&. 0x3f) `shiftL` 12+                    .|. (n2 .&. 0x3f) `shiftL`  6+                    .|. (n3 .&. 0x3f)+        in c : go (off + 4)++      | n0 .&. 0xf0 == 0xe0 =+        let n1 = index (off + 1)+            n2 = index (off + 2)+            c  = chr $  (n0 .&. 0x0f) `shiftL` 12+                    .|. (n1 .&. 0x3f) `shiftL`  6+                    .|. (n2 .&. 0x3f)+        in c : go (off + 3)++      | n0 .&. 0xe0 == 0xc0 =+        let n1 = index (off + 1)+            c  = chr $  (n0 .&. 0x1f) `shiftL`  6+                    .|. (n1 .&. 0x3f)+        in c : go (off + 2)++      | otherwise =+        let c =  chr $  (n0 .&. 0x7f)+        in c : go (off + 1)+      where !n0 = index off++-- | Is the given byte sequence valid under the given encoding?+isValid :: UTF8Encoding -> [Word8] -> Bool+isValid encoding = go+  where+    go [] = True+    go (b0:bs)+      | inRange 0x00 0x7f b0 = go bs+    go (b0:b1:bs)+      | inRange 0xc2 0xdf b0+      , inRange 0x80 0xbf b1 = go bs+    go (0xe0:b1:b2:bs)+      | inRange 0xa0 0xbf b1+      , inRange 0x80 0xbf b2 = go bs+    go (0xed:b1:_)+      -- surrogate range+      | encoding == ConformantUTF8+      , inRange 0xa0 0xbf b1+      = False+    go (b0:b1:b2:bs)+      | inRange 0xe1 0xef b0+      , inRange 0x80 0xbf b1+      , inRange 0x80 0xbf b2 = go bs+    go (0xf0:b1:b2:b3:bs)+      | inRange 0x90 0xbf b1+      , inRange 0x80 0xbf b2+      , inRange 0x80 0xbf b3 = go bs+    go (b0:b1:b2:b3:bs)+      | inRange 0xf1 0xf3 b0+      , inRange 0x80 0xbf b1+      , inRange 0x80 0xbf b2+      , inRange 0x80 0xbf b3 = go bs+    go (0xf4:b1:b2:b3:bs)+      | inRange 0x80 0x8f b1+      , inRange 0x80 0xbf b2+      , inRange 0x80 0xbf b3 = go bs+    go _ = False++inRange :: Ord a => a -> a -> a -> Bool+inRange lower upper x = lower <= x && x <= upper

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-}  -- |--- Module      : Codec.CBOR.Tutorial+-- Module      : Codec.Serialise.Tutorial -- Copyright   : (c) Duncan Coutts 2015-2017 -- License     : BSD3-style (see LICENSE.txt) --@@ -53,7 +53,7 @@ As in modern serialisation libraries, @cborg@ offers instance derivation via GHC's 'GHC.Generic' mechanism, -> import Serialise.Cborg+> import Codec.Serialise > import qualified Data.ByteString.Lazy as BSL > > data Animal = HoppingAnimal { animalName :: String, hoppingHeight :: Int }@@ -162,16 +162,16 @@ {- $encoding  For the purposes of encoding, abstract CBOR representations are embodied by the-'Serialise.Cborg.Encoding.Tokens' type. Such a representation can be efficiently-built using the 'Serialise.Cborg.Encoding.Encoding' 'Monoid'.+'Codec.CBOR.Encoding.Tokens' type. Such a representation can be efficiently+built using the 'Codec.CBOR.Encoding.Encoding' 'Monoid'.  For instance, to implement an encoder for the @Animal@ type above we might write,  > encodeAnimal :: Animal -> Encoding > encodeAnimal (HoppingAnimal name height) =->     encodeListLen 3 <> encodeTag 0 <> encode name <> encode height+>     encodeListLen 3 <> encodeWord 0 <> encode name <> encode height > encodeAnimal (WalkingAnimal name speed) =->     encodeListLen 3 <> encodeTag 1 <> encode name <> encode 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@@ -182,6 +182,9 @@ the length and tag, to ensure that you have the option to migrate your types later on. +Also note that the recommended encoding represents Haskell constructor indexes+as CBOR words, not CBOR tags.+ -}  {- $decoding@@ -193,7 +196,7 @@ > decodeAnimal :: Decoder s Animal > decodeAnimal = do >     len <- decodeListLen->     tag <- decodeTag+>     tag <- decodeWord >     case (len, tag) of >       (3, 0) -> HoppingAnimal <$> decode <*> decode >       (3, 1) -> WalkingAnimal <$> decode <*> decode@@ -232,17 +235,17 @@ > encodeAnimal :: Animal -> Encoding > -- HoppingAnimal, SwimmingAnimal cases are unchanged... > encodeAnimal (HoppingAnimal name height) =->     encodeListLen 3 <> encodeTag 0 <> encode name <> encode height+>     encodeListLen 3 <> encodeWord 0 <> encode name <> encode height > encodeAnimal (WalkingAnimal name speed) =->     encodeListLen 3 <> encodeTag 1 <> encode name <> encode speed+>     encodeListLen 3 <> encodeWord 1 <> encode name <> encode speed > -- Here is out new case... > encodeAnimal (SwimmingAnimal numberOfFins) =->     encodeListLen 2 <> encodeTag 2 <> encode numberOfFins+>     encodeListLen 2 <> encodeWord 2 <> encode numberOfFins > > decodeAnimal :: Decoder s Animal > decodeAnimal = do >     len <- decodeListLen->     tag <- decodeTag+>     tag <- decodeWord >     case (len, tag) of >       -- these cases are unchanged... >       (3, 0) -> HoppingAnimal <$> decode <*> decode@@ -266,17 +269,17 @@ > encodeAnimal :: Animal -> Encoding > -- HoppingAnimal, SwimmingAnimal cases are unchanged... > encodeAnimal (HoppingAnimal name height) =->     encodeListLen 3 <> encodeTag 0 <> encode name <> encode height+>     encodeListLen 3 <> encodeWord 0 <> encode name <> encode height > encodeAnimal (WalkingAnimal name speed) =->     encodeListLen 3 <> encodeTag 1 <> encode name <> encode speed+>     encodeListLen 3 <> encodeWord 1 <> encode name <> encode speed > -- This is new... > encodeAnimal (WalkingAnimal animalName walkingSpeed numberOfFeet) =->     encodeListLen 4 <> encodeTag 3 <> encode animalName <> encode walkingSpeed <> encode numberOfFins+>     encodeListLen 4 <> encodeWord 3 <> encode animalName <> encode walkingSpeed <> encode numberOfFins > > decodeAnimal :: Decoder s Animal > decodeAnimal = do >     len <- decodeListLen->     tag <- decodeTag+>     tag <- decodeWord >     case (len, tag) of >       -- this cases are unchanged... >       (3, 0) -> HoppingAnimal <$> decode <*> decode@@ -295,7 +298,7 @@  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 'Serialise.Cborg.Term.Term' type provides such a+some later result). The 'Codec.CBOR.Term.Term' type provides such a representation, losslessly capturing a CBOR AST. It can be serialised and deserialised with its 'Serialise' instance. @@ -305,9 +308,9 @@  We can also look In addition to serialisation and deserialisation, @cborg@ provides a variety of tools for representing arbitrary CBOR encodings in the-"Serialise.Cborg.FlatTerm" and "Serialise.Cborg.Pretty" modules.+"Codec.CBOR.FlatTerm" and "Codec.CBOR.Pretty" modules. -The 'Serialise.Cborg.FlatTerm.FlatTerm' type represents a single CBOR /term/, as+The 'Codec.CBOR.FlatTerm.FlatTerm' type represents a single CBOR /term/, as would be found in the ultimate CBOR representation. For instance, we can easily look at the structure of our @Animal@ encoding above, @@ -319,10 +322,10 @@ This can be useful both for understanding external CBOR formats, as well as understanding and testing your own hand-rolled encodings. -The package also includes a pretty-printer in "Serialise.Cborg.Pretty", for+The package also includes a pretty-printer in "Codec.CBOR.Pretty", for visualising the CBOR wire protocol alongside its semantic structure. For instance, ->>> putStrLn $ Serialise.Cborg.Pretty.prettyHexEnc $ encode $ HoppingAnimal "Fred" 42+>>> putStrLn $ Codec.CBOR.Pretty.prettyHexEnc $ encode $ HoppingAnimal "Fred" 42 83  # list(3)    00  # word(0)    64 46 72 65 64  # text("Fred")

@@ -10,6 +10,7 @@ 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 $@@ -22,4 +23,5 @@     , IO.testTree     , Regress.testTree     , Deriving.testTree+    , GeneralisedUTF8.testTree     ]

@@ -155,9 +155,15 @@ toRefTerm  TNull        = RefImpl.TNull toRefTerm (TSimple  23) = RefImpl.TUndef toRefTerm (TSimple   w) = RefImpl.TSimple (fromIntegral w)-toRefTerm (THalf     f) = RefImpl.TFloat16 (Half.toHalf f)-toRefTerm (TFloat    f) = RefImpl.TFloat32 f-toRefTerm (TDouble   f) = RefImpl.TFloat64 f+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@@ -191,8 +197,12 @@ fromRefTerm  RefImpl.TUndef      = TSimple 23 fromRefTerm (RefImpl.TSimple  w) = TSimple w fromRefTerm (RefImpl.TFloat16 f) = THalf (Half.fromHalf f)-fromRefTerm (RefImpl.TFloat32 f) = TFloat f-fromRefTerm (RefImpl.TFloat64 f) = TDouble 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

@@ -0,0 +1,37 @@+module Tests.GeneralisedUTF8 where++import GHC.Exts+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString as BS++import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Codec.CBOR.ByteArray as BA+import Codec.Serialise.Internal.GeneralisedUTF8++testEncoder :: String -> Property+testEncoder s =+    case encodeGenUTF8 s of+      (ba, enc) ->+          toList ba === BS.unpack (T.encodeUtf8 $ T.pack s)+          .&&.+          enc === correctEnc+  where+    correctEnc+      | any isSurrogate s = GeneralisedUTF8+      | otherwise         = ConformantUTF8++testDecoder :: String -> Property+testDecoder s =+    decodeGenUTF8 ba === s+  where+    BA.BA ba = BA.fromByteString $ T.encodeUtf8 $ T.pack s++testTree :: TestTree+testTree =+    testGroup "Generalised UTF-8 codec"+        [ testProperty "encoder" testEncoder+        , testProperty "decoder" testDecoder+        ]

@@ -4,26 +4,29 @@ {-# LANGUAGE DeriveDataTypeable #-} module Tests.Orphanage where -#if !MIN_VERSION_base(4,8,0)+#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,10,0) import           Control.Applicative import           Data.Monoid as Monoid #endif -#if MIN_VERSION_base(4,9,0)+#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_QuickCheck(2,10,0) import qualified Data.Semigroup as Semigroup #endif -import           Data.Typeable-+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(..))-import           GHC.Fingerprint.Type  import           Test.QuickCheck.Gen+#endif+ import           Test.QuickCheck.Arbitrary  import qualified Data.Vector.Primitive      as Vector.Primitive+import qualified Data.ByteString.Short      as BSS  -------------------------------------------------------------------------------- -- QuickCheck Orphans@@ -35,6 +38,7 @@  -- Foreign C types +#if !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary CChar where   arbitrary = CChar <$> arbitrary   shrink (CChar x) = CChar <$> shrink x@@ -134,10 +138,11 @@ instance Arbitrary CDouble where   arbitrary = CDouble <$> arbitrary   shrink (CDouble x) = CDouble <$> shrink x+#endif  -- Miscellaneous types from base -#if MIN_VERSION_base(4,9,0)+#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary a => Arbitrary (Semigroup.Min a) where   arbitrary = fmap Semigroup.Min arbitrary   shrink = map Semigroup.Min . shrink . Semigroup.getMin@@ -167,11 +172,13 @@   arbitrary = fmap Down arbitrary   shrink = map Down . shrink . (\(Down a) -> a) +#if !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary ExitCode where   arbitrary = frequency [(1, return ExitSuccess), (3, fmap ExitFailure arbitrary)]    shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ]   shrink _        = []+#endif  #if !MIN_VERSION_base(4,8,0) deriving instance Typeable Const@@ -188,11 +195,14 @@ deriving instance Eq a   => Eq   (Const a b) #endif +instance Arbitrary BSS.ShortByteString where+  arbitrary = BSS.pack <$> arbitrary+ instance (Vector.Primitive.Prim a, Arbitrary a          ) => Arbitrary (Vector.Primitive.Vector a) where     arbitrary = Vector.Primitive.fromList <$> arbitrary -#if MIN_VERSION_base(4,7,0)+#if MIN_VERSION_base(4,7,0) && !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary (Proxy a) where   arbitrary = return Proxy #endif

@@ -185,10 +185,8 @@   , ("NaN",       [0xf9, 0x7e, 0x00])   , ("-Infinity", [0xf9, 0xfc, 0x00])   , ("Infinity",  [0xfa, 0x7f, 0x80, 0x00, 0x00])-  , ("NaN",       [0xfa, 0x7f, 0xc0, 0x00, 0x00])   , ("-Infinity", [0xfa, 0xff, 0x80, 0x00, 0x00])   , ("Infinity",  [0xfb, 0x7f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])-  , ("NaN",       [0xfb, 0x7f, 0xf8, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])   , ("-Infinity", [0xfb, 0xff, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])    , ("false",       [0xf4])

@@ -38,6 +38,8 @@     decodeTokens,     decodeToken, +    canonicalNaN,+     diagnosticNotation,      encodeTerm,@@ -64,7 +66,7 @@ import           Data.Bits import           Data.Word import           Data.Int-import           Numeric.Half (Half)+import           Numeric.Half (Half(..)) import qualified Numeric.Half as Half import           Data.List import           Numeric@@ -816,6 +818,12 @@                            = 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)@@ -828,12 +836,16 @@ canonicaliseUInt :: UInt -> UInt canonicaliseUInt = toUInt . fromUInt --- some NaNs do not roundtrip https://github.com/ekmett/half/issues/3 canonicaliseHalf :: Half -> Half-canonicaliseHalf = Half.toHalf . Half.fromHalf+canonicaliseHalf f+  | isNaN f   = canonicalNaN+  | otherwise = f  canonicaliseTermPair :: (Term, Term) -> (Term, Term) canonicaliseTermPair (x,y) = (canonicaliseTerm x, canonicaliseTerm y)++canonicalNaN :: Half+canonicalNaN = Half 0x7e00  ------------------------------------------------------------------------------- 

@@ -7,7 +7,8 @@ import qualified Tests.Regress.Issue13  as Issue13 import qualified Tests.Regress.Issue67  as Issue67 import qualified Tests.Regress.Issue80  as Issue80-import qualified Tests.Regress.Issue106  as Issue106+import qualified Tests.Regress.Issue106 as Issue106+import qualified Tests.Regress.Issue135 as Issue135 import qualified Tests.Regress.FlatTerm as FlatTerm  --------------------------------------------------------------------------------@@ -20,4 +21,5 @@   , Issue67.testTree   , Issue80.testTree   , Issue106.testTree+  , Issue135.testTree   ]

@@ -0,0 +1,34 @@+-- Issue #135: Ensure that surrogate characters round-trip+--+module Tests.Regress.Issue135+  ( testTree -- :: TestTree+  ) where++import           Codec.Serialise++import           Test.Tasty+import           Test.Tasty.QuickCheck+import           Test.Tasty.HUnit++newtype StringWithSurrogates = StringWithSurrogates String+                             deriving (Show)++instance Arbitrary StringWithSurrogates where+  arbitrary =+      fmap StringWithSurrogates $ listOf1+      $ oneof [choose ('\xd800', '\xdfff'), arbitrary]++prop_surrogateRoundtrip :: StringWithSurrogates -> Property+prop_surrogateRoundtrip (StringWithSurrogates s) =+    s === deserialise (serialise s)++roundTrips :: (Eq a, Serialise a) => a -> Bool+roundTrips x = x == deserialise (serialise x)++testTree :: TestTree+testTree =+  testGroup "Issue 135 - surrogate characters round-trip"+    [ testCase "simple reproduction case"   (True @=? all (\c -> c == deserialise (serialise c)) ['\xdc80'..'\xdcff'])+    , testCase "all Chars round-trip" ([] @=? filter (not . roundTrips) ['\x0000'..'\x10ffff'])+    , testProperty "surrogates round-trip" prop_surrogateRoundtrip+    ]

@@ -19,6 +19,7 @@ import qualified Data.Semigroup as Semigroup #endif +import           Data.Char (ord) import           Data.Complex import           Data.Int import           Data.Fixed@@ -27,6 +28,7 @@ import           Data.Ratio import           Data.Time import           Data.Word+import           GHC.Exts (IsList(..)) import           GHC.Float (float2Double) import           Data.Version @@ -40,17 +42,21 @@ import           Test.QuickCheck.Instances () import           Test.Tasty.HUnit import           GHC.Generics  (Generic)-import qualified Data.Text            as Text-import qualified Data.Text.Lazy       as Text.Lazy-import qualified Data.ByteString      as BS-import qualified Data.ByteString.Lazy as BS.Lazy+import qualified Data.Text                      as Text+import qualified Data.Text.Encoding             as Text+import qualified Data.Text.Lazy                 as Text.Lazy+import qualified Data.ByteString                as BS+import qualified Data.ByteString.Lazy           as BS.Lazy+import qualified Data.ByteString.Short          as BSS+import qualified Data.ByteString.Short.Internal as BSS import           System.Exit (ExitCode(..)) +import qualified Codec.CBOR.ByteArray           as CBOR.BA import           Codec.CBOR.FlatTerm (toFlatTerm, fromFlatTerm) import           Codec.Serialise import           Codec.Serialise.Encoding import           Codec.Serialise.Decoding-import qualified Codec.Serialise.Properties as Props+import qualified Codec.Serialise.Properties     as Props  import qualified Data.HashMap.Strict        as HashMap import qualified Data.HashSet               as HashSet@@ -65,8 +71,10 @@ import qualified Data.Vector.Storable       as Vector.Storable import qualified Data.Vector.Primitive      as Vector.Primitive import           GHC.Fingerprint.Type (Fingerprint(..))+import           Data.Primitive.ByteArray   as Prim  import           Tests.Orphanage()+import           Tests.Serialise.Canonical  -------------------------------------------------------------------------------- -- Tests and properties@@ -152,9 +160,22 @@       , mkTest (T :: T Word16)       , mkTest (T :: T Word32)       , mkTest (T :: T Word64)+      , mkTest (T :: T (Canonical Int))+      , mkTest (T :: T (Canonical Int8))+      , mkTest (T :: T (Canonical Int16))+      , mkTest (T :: T (Canonical Int32))+      , mkTest (T :: T (Canonical Int64))+      , mkTest (T :: T (Canonical Word))+      , mkTest (T :: T (Canonical Word8))+      , mkTest (T :: T (Canonical Word16))+      , mkTest (T :: T (Canonical Word32))+      , mkTest (T :: T (Canonical Word64))       , mkTest (T :: T Integer)       , mkTest (T :: T Float)       , mkTest (T :: T Double)+      , mkTest (T :: T (Canonical Integer))+      , mkTest (T :: T (Canonical Float))+      , mkTest (T :: T (Canonical Double))       , mkTest (T :: T [()]) #if MIN_VERSION_base(4,9,0)       , mkTest (T :: T (NonEmpty ()))@@ -214,6 +235,9 @@       , mkTest (T :: T Text.Lazy.Text)       , mkTest (T :: T BS.ByteString)       , mkTest (T :: T BS.Lazy.ByteString)+      , mkTest (T :: T BSS.ShortByteString)+      , mkTest (T :: T BytesByteArray)+      , mkTest (T :: T Utf8ByteArray)       , mkTest (T :: T [Int])       , mkTest (T :: T UTCTime)       , mkTest (T :: T Version)@@ -274,7 +298,7 @@       (TkListLen 3 $ TkWord 0 $ TkInt 12 $ TkFloat32 0.5 $ TkEnd)   , format       (P3 12 0.5 "asdf")-      (TkListLen 4 $ TkWord 0 $ TkInt 12 $ TkFloat32 0.5 $ TkString "asdf" $ TkEnd)+      (TkListLen 4 $ TkWord 0 $ TkInt 12 $ TkFloat32 0.5 $ tkStr "asdf" $ TkEnd)   , format       (C1 12)       (TkListLen 2 $ TkWord 0 $ TkInt 12 $ TkEnd)@@ -283,18 +307,20 @@       (TkListLen 3 $ TkWord 1 $ TkInt 12 $ TkFloat32 0.5 $ TkEnd)   , format       (C3 12 0.5 "asdf")-      (TkListLen 4 $ TkWord 2 $ TkInt 12 $ TkFloat32 0.5 $ TkString "asdf" $ TkEnd)+      (TkListLen 4 $ TkWord 2 $ TkInt 12 $ TkFloat32 0.5 $ tkStr "asdf" $ TkEnd)   , format        C4       (TkListLen 1 $ TkWord 3 $ TkEnd)   , format       (Cons "foo" (Cons "bar" Nil) :: List String)-      (TkListLen 3 $ TkWord 0 $ TkString "foo" $-       TkListLen 3 $ TkWord 0 $ TkString "bar" $+      (TkListLen 3 $ TkWord 0 $ tkStr "foo" $+       TkListLen 3 $ TkWord 0 $ tkStr "bar" $        TkListLen 1 $ TkWord 1 $        TkEnd)   ] +  where tkStr = TkUtf8ByteArray . fromList . map (fromIntegral . ord)+ -------------------------------------------------------------------------------- -- Extra machinery @@ -366,3 +392,25 @@       where         cnv :: [a] -> List a         cnv = foldr Cons Nil++newtype BytesByteArray = BytesBA CBOR.BA.ByteArray+                       deriving (Eq, Ord, Show)++instance Serialise BytesByteArray where+    encode (BytesBA ba) = encodeByteArray $ CBOR.BA.toSliced ba+    decode = BytesBA <$> decodeByteArray++instance Arbitrary BytesByteArray where+    arbitrary = BytesBA . fromList <$> arbitrary++newtype Utf8ByteArray = Utf8BA CBOR.BA.ByteArray+                      deriving (Eq, Ord, Show)++instance Serialise Utf8ByteArray where+    encode (Utf8BA ba) = encodeUtf8ByteArray $ CBOR.BA.toSliced ba+    decode = Utf8BA <$> decodeUtf8ByteArray++instance Arbitrary Utf8ByteArray where+    arbitrary = do+        BSS.SBS ba <- BSS.toShort . Text.encodeUtf8 <$> arbitrary+        return $ Utf8BA $ CBOR.BA.BA $ Prim.ByteArray ba

@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+module Tests.Serialise.Canonical where++import Data.Bits+import Data.Int+import Data.Typeable+import Data.Word+import Test.QuickCheck++import Codec.CBOR.Decoding+import Codec.CBOR.Encoding as E+import Codec.Serialise.Class++newtype Canonical a = Canonical { fromCanonical :: a }+  deriving (Typeable, Eq, Show)++-- | Generate "proper" big integers (as standard Arbitrary Integer instance+-- doesn't really do that) to test canonicity.+instance Arbitrary (Canonical Integer) where+  arbitrary = do+    c <- choose (1, 5)+    neg <- arbitrary+    Canonical . (if neg then negate else id) . foldr combine 0+      <$> vectorOf c arbitrary+    where+      combine :: Word64 -> Integer -> Integer+      combine v acc = (acc `shiftL` finiteBitSize v) + toInteger v++deriving instance Arbitrary (Canonical Word)+deriving instance Arbitrary (Canonical Word8)+deriving instance Arbitrary (Canonical Word16)+deriving instance Arbitrary (Canonical Word32)+deriving instance Arbitrary (Canonical Word64)+deriving instance Arbitrary (Canonical Int)+deriving instance Arbitrary (Canonical Int8)+deriving instance Arbitrary (Canonical Int16)+deriving instance Arbitrary (Canonical Int32)+deriving instance Arbitrary (Canonical Int64)+deriving instance Arbitrary (Canonical Float)+deriving instance Arbitrary (Canonical Double)++----------------------------------------++instance Serialise (Canonical Word) where+  encode = encodeWord . fromCanonical+  decode = Canonical <$> decodeWordCanonical++instance Serialise (Canonical Word8) where+  encode = encodeWord8 . fromCanonical+  decode = Canonical <$> decodeWord8Canonical++instance Serialise (Canonical Word16) where+  encode = encodeWord16 . fromCanonical+  decode = Canonical <$> decodeWord16Canonical++instance Serialise (Canonical Word32) where+  encode = encodeWord32 . fromCanonical+  decode = Canonical <$> decodeWord32Canonical++instance Serialise (Canonical Word64) where+  encode = encodeWord64 . fromCanonical+  decode = Canonical <$> decodeWord64Canonical++instance Serialise (Canonical Int) where+  encode = encodeInt . fromCanonical+  decode = Canonical <$> decodeIntCanonical++instance Serialise (Canonical Int8) where+  encode = encodeInt8 . fromCanonical+  decode = Canonical <$> decodeInt8Canonical++instance Serialise (Canonical Int16) where+  encode = encodeInt16 . fromCanonical+  decode = Canonical <$> decodeInt16Canonical++instance Serialise (Canonical Int32) where+  encode = encodeInt32 . fromCanonical+  decode = Canonical <$> decodeInt32Canonical++instance Serialise (Canonical Int64) where+  encode = encodeInt64 . fromCanonical+  decode = Canonical <$> decodeInt64Canonical++instance Serialise (Canonical Integer) where+  encode = encodeInteger . fromCanonical+  decode = Canonical <$> decodeIntegerCanonical++instance Serialise (Canonical Float) where+    encode = E.encodeFloat . fromCanonical+    decode = Canonical <$> decodeFloatCanonical++instance Serialise (Canonical Double) where+    encode = encodeDouble . fromCanonical+    decode = Canonical <$> decodeDoubleCanonical

@@ -210,12 +210,6 @@     "diagnostic": "Infinity"   },   {-    "cbor": "+n/AAAA=",-    "hex": "fa7fc00000",-    "roundtrip": false,-    "diagnostic": "NaN"-  },-  {     "cbor": "+v+AAAA=",     "hex": "faff800000",     "roundtrip": false,@@ -226,12 +220,6 @@     "hex": "fb7ff0000000000000",     "roundtrip": false,     "diagnostic": "Infinity"-  },-  {-    "cbor": "+3/4AAAAAAAA",-    "hex": "fb7ff8000000000000",-    "roundtrip": false,-    "diagnostic": "NaN"   },   {     "cbor": "+//wAAAAAAAA",