cborg 0.1.1.0 → 0.2.0.0

raw patch · 12 files changed

+1513/−239 lines, 12 filesdep ~basedep ~ghc-primdep ~halfPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghc-prim, half

API changes (from Hackage documentation)

Files

• cborg.cabal +13/−4
• src/Codec/CBOR.hs +100/−1
• src/Codec/CBOR/ByteArray.hs +89/−0
• src/Codec/CBOR/ByteArray/Internal.hs +85/−0
• src/Codec/CBOR/ByteArray/Sliced.hs +153/−0
• src/Codec/CBOR/Decoding.hs +290/−14
• src/Codec/CBOR/Encoding.hs +23/−4
• src/Codec/CBOR/FlatTerm.hs +118/−11
• src/Codec/CBOR/Magic.hs +0/−5
• src/Codec/CBOR/Pretty.hs +2/−0
• src/Codec/CBOR/Read.hs +616/−196
• src/Codec/CBOR/Write.hs +24/−4

@@ -1,5 +1,5 @@ name:                cborg-version:             0.1.1.0+version:             0.2.0.0 synopsis:            Concise Binary Object Representation license:             BSD3 license-file:        LICENSE.txt@@ -17,11 +17,15 @@ description:   This package (formerly @binary-serialise-cbor@) provides an efficient   implementation of the Concise Binary Object Representation (CBOR), as-  specified by RFC 7049.+  specified by [RFC 7049](https://tools.ietf.org/html/rfc7049).   .   If you are looking for a library for serialisation of Haskell values,-  have a look at the @serialise@ package, which is built upon this library.-+  have a look at the [serialise](/package/serialise) package, which is+  built upon this library.+  .+  An implementation of the standard bijection between CBOR and JSON is provided+  by the [cborg-json](/package/cborg-json) package. Also see [cbor-tool](/package/cbor-tool)+  for a convenient command-line utility for working with CBOR data. extra-source-files:   src/cbits/cbor.h @@ -56,6 +60,11 @@     Codec.CBOR.Read     Codec.CBOR.Write     Codec.CBOR.Term+    Codec.CBOR.ByteArray+    Codec.CBOR.ByteArray.Sliced++  other-modules:+    Codec.CBOR.ByteArray.Internal    other-extensions:     CPP, ForeignFunctionInterface, MagicHash,

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+ -- | -- Module      : Codec.CBOR -- Copyright   : (c) Duncan Coutts 2015-2017@@ -10,5 +12,102 @@ -- A library for working with CBOR. -- module Codec.CBOR- (+ ( -- $intro+   -- * Library Structure+   -- $structure  ) where++-- used by Haddocks+import Codec.CBOR.Decoding (Decoder)+import Codec.CBOR.Encoding (Encoding)+import Codec.CBOR.FlatTerm (FlatTerm)+import Codec.CBOR.Term     (Term, encodeTerm, decodeTerm)++{- $intro++The @cborg@ library is a low-level parsing and encoding library for the+Compact Binary Object Representation (CBOR) defined in RFC 7049. CBOR is a+language-agnostic, extensible, and size- and computation-efficient encoding+for arbitrary data, with a well-defined bijection to the ubiquitous JSON format+and a precisely specified canonical form.++Note, however, that @cborg@ does not itself aim to be a serialisation+library; it merely serves as the substrate on which such a library might be+built. See the [serialise](/package/serialise) library if you are looking for+convenient serialisation of Haskell values.++Instead, @cborg@ targets cases where precise control over the CBOR object+structure is needed such as when working with externally-specified CBOR formats.++-}++{- $structure++The library is split into a number of modules,++* Decoding++    * "Codec.CBOR.Decoding" defines the machinery for decoding primitive CBOR terms+      into Haskell values. In particular, the 'Decoder' type and associated decoders,++      @+      data 'Decoder' s a++      -- for, e.g., safe in-place mutation during decoding+      liftST      :: ST s a -> 'Decoder' s a++      -- primitive decoders+      decodeWord  :: 'Decoder' s Word+      decodeBytes :: 'Decoder' s ByteString+      -- et cetera+      @+    * "Codec.CBOR.Read" defines the low-level wire-format decoder, e.g.++      @+      'Codec.CBOR.Read.deserialiseFromBytes' :: 'Decoder' a+                           -> ByteString+                           -> Either String (ByteString, a)+      @++* Encoding++      * "Codec.CBOR.Encoding" defines the 'Encoding' type, which is in essence+        difference-list of CBOR tokens and is used to construct CBOR encodings.++        @+        data 'Encoding'+        instance Monoid 'Encoding'++        encodeWord  :: Word       -> Encoding+        encodeBytes :: ByteString -> Encoding+        -- et cetera+        @++      * "Codec.CBOR.Write" defines the low-level wire-format encoder, e.g.++        @+        'Codec.CBOR.Write.toBuilder' :: 'Encoding' a -> Data.ByteString.Builder.Builder+        @++* Capturing arbitrary terms++      * "Codec.CBOR.Term" provides the 'Term' type, which provides a type for+        capturing arbitrary CBOR terms. 'Term's can be encoded and decoded with,++        @+        data 'Term'+          = TInt   Int+          | TBytes ByteString+          -- et cetera++        'encodeTerm' :: 'Term' -> 'Encoding'+        'decodeTerm' :: 'Decoder' 'Term'+        @++* Debugging++    * "Codec.CBOR.FlatTerm" contains the 'FlatTerm' type, which provides a+      concrete AST for capturing primitive CBOR wire encodings. This can be+      useful when testing decoders and encoders.++-}

@@ -0,0 +1,89 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Codec.CBOR.ByteArray+-- Copyright   : (c) Ben Gamari 2017-2018+-- License     : BSD3-style (see LICENSE.txt)+--+-- Maintainer  : duncan@community.haskell.org+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- A ByteArray with more instances than 'Data.Primitive.ByteArray.ByteArray'.+-- Some day when these instances are reliably available from @primitive@ we can+-- likely replace this with 'Data.Primitive.ByteArray.ByteArray'.+--+module Codec.CBOR.ByteArray+  ( -- * Simple byte arrays+    ByteArray(..)+  , sizeofByteArray+    -- * Conversions+  , fromShortByteString+  , toShortByteString+  , fromByteString+  , toBuilder+  , toSliced+  ) where++import Data.Char (ord)+import Data.Word+import GHC.Exts (IsList(..), IsString(..))++import qualified Data.Primitive.ByteArray as Prim+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as BSS+import qualified Data.ByteString.Short.Internal as BSS+import qualified Data.ByteString.Builder as BSB++import qualified Codec.CBOR.ByteArray.Sliced as Sliced+import           Codec.CBOR.ByteArray.Internal++newtype ByteArray = BA {unBA :: Prim.ByteArray}++sizeofByteArray :: ByteArray -> Int+{-# INLINE sizeofByteArray #-}+sizeofByteArray (BA ba) = Prim.sizeofByteArray ba++fromShortByteString :: BSS.ShortByteString -> ByteArray+fromShortByteString (BSS.SBS ba) = BA (Prim.ByteArray ba)++toShortByteString :: ByteArray -> BSS.ShortByteString+toShortByteString (BA (Prim.ByteArray ba)) = BSS.SBS ba++fromByteString :: BS.ByteString -> ByteArray+fromByteString = fromShortByteString . BSS.toShort++toBuilder :: ByteArray -> BSB.Builder+toBuilder = Sliced.toBuilder . toSliced++toSliced :: ByteArray -> Sliced.SlicedByteArray+toSliced ba@(BA arr) = Sliced.SBA arr 0 (sizeofByteArray ba)++instance Show ByteArray where+  showsPrec _ = shows . toSliced++instance Eq ByteArray where+  ba1 == ba2 = toSliced ba1 == toSliced ba2++instance Ord ByteArray where+  ba1 `compare` ba2 = toSliced ba1 `compare` toSliced ba2++instance IsString ByteArray where+  fromString = fromList . map checkedOrd+    where+      checkedOrd c+        | c > '\xff' = error "IsString(Codec.CBOR.ByteArray): Non-ASCII character"+        | otherwise  = fromIntegral $ ord c++instance IsList ByteArray where+  type Item ByteArray = Word8+  fromList xs = fromListN (Prelude.length xs) xs+  fromListN n xs =+      let arr = mkByteArray n xs+      in BA arr+  toList ba@(BA arr) =+      foldrByteArray (:) [] 0 (sizeofByteArray ba) arr

@@ -0,0 +1,85 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE UnboxedTuples       #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Codec.CBOR.ByteArray.Internal+-- Copyright   : (c) Ben Gamari 2017-2018+-- License     : BSD3-style (see LICENSE.txt)+--+-- Maintainer  : duncan@community.haskell.org+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Various bytearray utilities+--+module Codec.CBOR.ByteArray.Internal+  ( foldrByteArray+  , copyToAddr+  , isTrue#+  , sameByteArray+  , mkByteArray+  , isByteArrayPinned+  , touch+  ) where++import Control.Monad.ST+import Control.Monad+import GHC.IO (IO(..))+import GHC.Exts+import GHC.Word++import qualified Data.Primitive.ByteArray as Prim++foldrByteArray :: (Word8 -> a -> a) -> a+               -> Int             -- ^ offset+               -> Int             -- ^ length+               -> Prim.ByteArray  -- ^ array+               -> a+foldrByteArray f z off0 len ba = go off0+  where+    go !off+      | off == len = z+      | otherwise  =+        let x = Prim.indexByteArray ba off+        in f x (go (off+1))++copyToAddr :: Prim.ByteArray -> Int -> Ptr a -> Int -> IO ()+copyToAddr (Prim.ByteArray ba) (I# off) (Ptr addr) (I# len) =+    IO (\s -> case copyByteArrayToAddr# ba off addr len s of+                s' -> (# s', () #))++#if __GLASGOW_HASKELL__ < 706+isTrue# :: Bool -> Bool+isTrue# = id+#endif++sameByteArray :: Prim.ByteArray -> Prim.ByteArray -> Bool+sameByteArray (Prim.ByteArray ba1#) (Prim.ByteArray ba2#) =+    case reallyUnsafePtrEquality# (unsafeCoerce# ba1# :: ()) (unsafeCoerce# ba2# :: ()) of+      r -> isTrue# r++-- | @mkByteArray n xs@ forms a 'Prim.ByteArray' with contents @xs@. Note that+-- @n@ must be the precise length of @xs@.+mkByteArray :: Int -> [Word8] -> Prim.ByteArray+mkByteArray n xs = runST $ do+    arr <- Prim.newByteArray n+    zipWithM_ (Prim.writeByteArray arr) [0..n-1] (take n $ xs ++ repeat 0)+    Prim.unsafeFreezeByteArray arr++-- | A conservative estimate of pinned-ness.+isByteArrayPinned :: Prim.ByteArray -> Bool+isByteArrayPinned (Prim.ByteArray ba) =+#if __GLASGOW_HASKELL__ > 800+    case isByteArrayPinned# ba of+      0# -> False+      _  -> True+#else+    False+#endif++touch :: a -> IO ()+touch x = IO $ \s -> case touch# x s of s' -> (# s', () #)

@@ -0,0 +1,153 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE TypeFamilies        #-}++-- |+-- Module      : Codec.CBOR.ByteArray.Sliced+-- Copyright   : (c) Ben Gamari 2017-2018+-- License     : BSD3-style (see LICENSE.txt)+--+-- Maintainer  : duncan@community.haskell.org+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- A ByteArray with more instances than 'Data.Primitive.ByteArray.ByteArray'.+-- Some day when these instances are reliably available from @primitive@ we can+-- likely replace this with 'Data.Primitive.ByteArray.ByteArray'.+--+module Codec.CBOR.ByteArray.Sliced+  ( SlicedByteArray(..)+    -- * Conversions+  , sizeofSlicedByteArray+  , fromShortByteString+  , fromByteString+  , fromByteArray+  , toByteString+  , toBuilder+  ) where++import GHC.Exts+import Data.Char (chr, ord)+import Data.Word+import Foreign.Ptr+import Control.Monad.ST+import System.IO.Unsafe++import qualified Data.Primitive.ByteArray as Prim+import           Data.Primitive.Types (Addr(..))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Short as BSS+import qualified Data.ByteString.Short.Internal as BSS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Builder.Internal as BSB++import Codec.CBOR.ByteArray.Internal++data SlicedByteArray = SBA {unSBA :: !Prim.ByteArray, offset :: !Int, length :: !Int}++fromShortByteString :: BSS.ShortByteString -> SlicedByteArray+fromShortByteString (BSS.SBS ba) = fromByteArray (Prim.ByteArray ba)++fromByteString :: BS.ByteString -> SlicedByteArray+fromByteString = fromShortByteString . BSS.toShort++fromByteArray :: Prim.ByteArray -> SlicedByteArray+fromByteArray ba = SBA ba 0 (Prim.sizeofByteArray ba)++sizeofSlicedByteArray :: SlicedByteArray -> Int+sizeofSlicedByteArray (SBA _ _ len) = len++-- | Note that this may require a copy.+toByteString :: SlicedByteArray -> BS.ByteString+toByteString sba =+    unsafePerformIO+    $ BS.unsafePackCStringFinalizer ptr (sizeofSlicedByteArray sba) (touch pinned)+  where+    pinned = toPinned sba+    !(Addr addr#) = Prim.byteArrayContents pinned+    ptr = Ptr addr#++toPinned :: SlicedByteArray -> Prim.ByteArray+toPinned (SBA ba off len)+  | isByteArrayPinned ba = ba+  | otherwise = runST $ do+        ba' <- Prim.newPinnedByteArray len+        Prim.copyByteArray ba' 0 ba off len+        Prim.unsafeFreezeByteArray ba'++toBuilder :: SlicedByteArray -> BSB.Builder+toBuilder = \(SBA ba off len) -> BSB.builder (go ba off len)+  where+    go ba !ip !ipe !k (BSB.BufferRange op ope)+      | inpRemaining <= outRemaining = do+          copyToAddr ba ip op inpRemaining+          let !br' = BSB.BufferRange (op `plusPtr` inpRemaining) ope+          k br'+      | otherwise = do+          copyToAddr ba ip op outRemaining+          let !ip' = ip + outRemaining+          return $ BSB.bufferFull 1 ope (go ba ip' ipe k)+      where+        outRemaining = ope `minusPtr` op+        inpRemaining = ipe - ip++instance IsString SlicedByteArray where+  fromString = fromList . map checkedOrd+    where+      checkedOrd c+        | c > '\xff' = error "IsString(Codec.CBOR.ByteArray.Sliced): Non-ASCII character"+        | otherwise  = fromIntegral $ ord c++instance IsList SlicedByteArray where+  type Item SlicedByteArray = Word8+  fromList xs = fromListN (Prelude.length xs) xs+  -- Note that we make no attempt to behave sensibly if @n /= length xs@.+  -- The class definition allows this.+  fromListN n xs =+      let arr = mkByteArray n xs+      in SBA arr 0 n+  toList (SBA arr off len) =+      foldrByteArray (:) [] off len arr++instance Show SlicedByteArray where+  showsPrec _ = shows . map (chr . fromIntegral) . toList++instance Eq SlicedByteArray where+  SBA arr1 off1 len1 == SBA arr2 off2 len2+    | len1 /= len2+    = False++    | sameByteArray arr1 arr2+    , off1 == off2+    , len1 == len2+    = True++    | otherwise+    = let (!) :: Prim.ByteArray -> Int -> Word8+          (!) = Prim.indexByteArray+          go i1 i2+            | i1 == len1 && i2 == len2   = True+            | i1 == len1 || i2 == len2   = False+            | (arr1 ! i1) == (arr2 ! i2) = go (i1+1) (i2+1)+            | otherwise                  = False+      in go off1 off2++instance Ord SlicedByteArray where+  SBA arr1 off1 len1 `compare` SBA arr2 off2 len2+    | sameByteArray arr1 arr2+    , off1 == off2+    , len1 == len2+    = EQ++    | otherwise+    = let (!) :: Prim.ByteArray -> Int -> Word8+          (!) = Prim.indexByteArray+          go i1 i2+            | i1 == len1 && i2 == len2 = EQ+            | i1 == len1 || i2 == len2 = len1 `compare` len2+            | EQ <- o                  = go (i1+1) (i2+1)+            | otherwise                = o+            where o = (arr1 ! i1) `compare` (arr2 ! i2)+      in go off1 off2

@@ -36,26 +36,51 @@   , decodeInt16         -- :: Decoder s Int16   , decodeInt32         -- :: Decoder s Int32   , decodeInt64         -- :: Decoder s Int64+  , decodeWordCanonical      -- :: Decoder s Word+  , decodeWord8Canonical     -- :: Decoder s Word8+  , decodeWord16Canonical    -- :: Decoder s Word16+  , decodeWord32Canonical    -- :: Decoder s Word32+  , decodeWord64Canonical    -- :: Decoder s Word64+  , decodeNegWordCanonical   -- :: Decoder s Word+  , decodeNegWord64Canonical -- :: Decoder s Word64+  , decodeIntCanonical       -- :: Decoder s Int+  , decodeInt8Canonical      -- :: Decoder s Int8+  , decodeInt16Canonical     -- :: Decoder s Int16+  , decodeInt32Canonical     -- :: Decoder s Int32+  , decodeInt64Canonical     -- :: Decoder s Int64   , decodeInteger       -- :: Decoder s Integer   , decodeFloat         -- :: Decoder s Float   , 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+  , decodeListLenCanonical -- :: Decoder s Int   , decodeListLenIndef  -- :: Decoder s ()   , decodeMapLen        -- :: Decoder s Int+  , decodeMapLenCanonical -- :: Decoder s Int   , decodeMapLenIndef   -- :: Decoder s ()   , decodeTag           -- :: Decoder s Word   , decodeTag64         -- :: Decoder s Word64+  , decodeTagCanonical   -- :: Decoder s Word+  , decodeTag64Canonical -- :: Decoder s Word64   , decodeBool          -- :: Decoder s Bool   , decodeNull          -- :: Decoder s ()   , decodeSimple        -- :: Decoder s Word8+  , decodeIntegerCanonical -- :: Decoder s Integer+  , decodeFloat16Canonical -- :: Decoder s Float+  , decodeFloatCanonical   -- :: Decoder s Float+  , decodeDoubleCanonical  -- :: Decoder s Double+  , decodeSimpleCanonical  -- :: Decoder s Word8    -- ** Specialised Read input token operations   , decodeWordOf        -- :: Word -> Decoder s ()   , decodeListLenOf     -- :: Int  -> Decoder s ()+  , decodeWordCanonicalOf    -- :: Word -> Decoder s ()+  , decodeListLenCanonicalOf -- :: Int  -> Decoder s ()    -- ** Branching operations --, decodeBytesOrIndef@@ -89,6 +114,8 @@ import           Control.Monad.ST import qualified Control.Monad.Fail as Fail +import           Codec.CBOR.ByteArray (ByteArray)+ import           Prelude hiding (decodeFloat)  @@ -121,6 +148,19 @@     | ConsumeMapLen  (Int#  -> ST s (DecodeAction s a))     | ConsumeTag     (Word# -> ST s (DecodeAction s a)) +    | ConsumeWordCanonical    (Word# -> ST s (DecodeAction s a))+    | ConsumeWord8Canonical   (Word# -> ST s (DecodeAction s a))+    | ConsumeWord16Canonical  (Word# -> ST s (DecodeAction s a))+    | ConsumeWord32Canonical  (Word# -> ST s (DecodeAction s a))+    | ConsumeNegWordCanonical (Word# -> ST s (DecodeAction s a))+    | ConsumeIntCanonical     (Int#  -> ST s (DecodeAction s a))+    | ConsumeInt8Canonical    (Int#  -> ST s (DecodeAction s a))+    | ConsumeInt16Canonical   (Int#  -> ST s (DecodeAction s a))+    | ConsumeInt32Canonical   (Int#  -> ST s (DecodeAction s a))+    | ConsumeListLenCanonical (Int#  -> ST s (DecodeAction s a))+    | ConsumeMapLenCanonical  (Int#  -> ST s (DecodeAction s a))+    | ConsumeTagCanonical     (Word# -> ST s (DecodeAction s a))+ -- 64bit variants for 32bit machines #if defined(ARCH_32bit)     | ConsumeWord64    (Word64# -> ST s (DecodeAction s a))@@ -129,16 +169,31 @@     | ConsumeListLen64 (Int64#  -> ST s (DecodeAction s a))     | ConsumeMapLen64  (Int64#  -> ST s (DecodeAction s a))     | ConsumeTag64     (Word64# -> ST s (DecodeAction s a))++    | ConsumeWord64Canonical    (Word64# -> ST s (DecodeAction s a))+    | ConsumeNegWord64Canonical (Word64# -> ST s (DecodeAction s a))+    | ConsumeInt64Canonical     (Int64#  -> ST s (DecodeAction s a))+    | ConsumeListLen64Canonical (Int64#  -> ST s (DecodeAction s a))+    | ConsumeMapLen64Canonical  (Int64#  -> ST s (DecodeAction s a))+    | ConsumeTag64Canonical     (Word64# -> ST s (DecodeAction s a)) #endif -    | ConsumeInteger (Integer    -> ST s (DecodeAction s a))-    | ConsumeFloat   (Float#     -> ST s (DecodeAction s a))-    | ConsumeDouble  (Double#    -> ST s (DecodeAction s a))-    | ConsumeBytes   (ByteString -> ST s (DecodeAction s a))-    | ConsumeString  (Text       -> ST s (DecodeAction s a))-    | ConsumeBool    (Bool       -> ST s (DecodeAction s a))-    | ConsumeSimple  (Word#      -> ST s (DecodeAction s a))+    | ConsumeInteger       (Integer   -> ST s (DecodeAction s a))+    | ConsumeFloat         (Float#    -> ST s (DecodeAction s a))+    | ConsumeDouble        (Double#   -> ST s (DecodeAction s a))+    | ConsumeBytes         (ByteString-> ST s (DecodeAction s a))+    | ConsumeByteArray     (ByteArray -> ST s (DecodeAction s a))+    | ConsumeString        (Text      -> ST s (DecodeAction s a))+    | ConsumeUtf8ByteArray (ByteArray -> ST s (DecodeAction s a))+    | ConsumeBool          (Bool      -> ST s (DecodeAction s a))+    | ConsumeSimple        (Word#     -> ST s (DecodeAction s a)) +    | ConsumeIntegerCanonical (Integer -> ST s (DecodeAction s a))+    | ConsumeFloat16Canonical (Float#  -> ST s (DecodeAction s a))+    | ConsumeFloatCanonical   (Float#  -> ST s (DecodeAction s a))+    | ConsumeDoubleCanonical  (Double# -> ST s (DecodeAction s a))+    | ConsumeSimpleCanonical  (Word#   -> ST s (DecodeAction s a))+     | ConsumeBytesIndef   (ST s (DecodeAction s a))     | ConsumeStringIndef  (ST s (DecodeAction s a))     | ConsumeListLenIndef (ST s (DecodeAction s a))@@ -220,6 +275,10 @@ instance Fail.MonadFail (Decoder s) where     fail msg = Decoder $ \_ -> return (Fail msg) +-- | Lift an @ST@ action into a @Decoder@. Useful for, e.g., leveraging+-- in-place mutation to efficiently build a deserialised value.+--+-- @since 0.2.0.0 liftST :: ST s a -> Decoder s a liftST m = Decoder $ \k -> m >>= k @@ -333,6 +392,105 @@   Decoder (\k -> return (ConsumeInt64 (\n64# -> k (I64# n64#)))) #endif +-- | Decode canonical representation of a @'Word'@.+--+-- @since 0.2.0.0+decodeWordCanonical :: Decoder s Word+decodeWordCanonical = Decoder (\k -> return (ConsumeWordCanonical (\w# -> k (W# w#))))+{-# INLINE decodeWordCanonical #-}++-- | Decode canonical representation of a @'Word8'@.+--+-- @since 0.2.0.0+decodeWord8Canonical :: Decoder s Word8+decodeWord8Canonical = Decoder (\k -> return (ConsumeWord8Canonical (\w# -> k (W8# w#))))+{-# INLINE decodeWord8Canonical #-}++-- | Decode canonical representation of a @'Word16'@.+--+-- @since 0.2.0.0+decodeWord16Canonical :: Decoder s Word16+decodeWord16Canonical = Decoder (\k -> return (ConsumeWord16Canonical (\w# -> k (W16# w#))))+{-# INLINE decodeWord16Canonical #-}++-- | Decode canonical representation of a @'Word32'@.+--+-- @since 0.2.0.0+decodeWord32Canonical :: Decoder s Word32+decodeWord32Canonical = Decoder (\k -> return (ConsumeWord32Canonical (\w# -> k (W32# w#))))+{-# INLINE decodeWord32Canonical #-}++-- | Decode canonical representation of a @'Word64'@.+--+-- @since 0.2.0.0+decodeWord64Canonical :: Decoder s Word64+{-# INLINE decodeWord64Canonical #-}+decodeWord64Canonical =+#if defined(ARCH_64bit)+  Decoder (\k -> return (ConsumeWordCanonical (\w# -> k (W64# w#))))+#else+  Decoder (\k -> return (ConsumeWord64Canonical (\w64# -> k (W64# w64#))))+#endif++-- | Decode canonical representation of a negative @'Word'@.+--+-- @since 0.2.0.0+decodeNegWordCanonical :: Decoder s Word+decodeNegWordCanonical = Decoder (\k -> return (ConsumeNegWordCanonical (\w# -> k (W# w#))))+{-# INLINE decodeNegWordCanonical #-}++-- | Decode canonical representation of a negative @'Word64'@.+--+-- @since 0.2.0.0+decodeNegWord64Canonical :: Decoder s Word64+{-# INLINE decodeNegWord64Canonical #-}+decodeNegWord64Canonical =+#if defined(ARCH_64bit)+  Decoder (\k -> return (ConsumeNegWordCanonical (\w# -> k (W64# w#))))+#else+  Decoder (\k -> return (ConsumeNegWord64Canonical (\w64# -> k (W64# w64#))))+#endif++-- | Decode canonical representation of an @'Int'@.+--+-- @since 0.2.0.0+decodeIntCanonical :: Decoder s Int+decodeIntCanonical = Decoder (\k -> return (ConsumeIntCanonical (\n# -> k (I# n#))))+{-# INLINE decodeIntCanonical #-}++-- | Decode canonical representation of an @'Int8'@.+--+-- @since 0.2.0.0+decodeInt8Canonical :: Decoder s Int8+decodeInt8Canonical = Decoder (\k -> return (ConsumeInt8Canonical (\w# -> k (I8# w#))))+{-# INLINE decodeInt8Canonical #-}++-- | Decode canonical representation of an @'Int16'@.+--+-- @since 0.2.0.0+decodeInt16Canonical :: Decoder s Int16+decodeInt16Canonical = Decoder (\k -> return (ConsumeInt16Canonical (\w# -> k (I16# w#))))+{-# INLINE decodeInt16Canonical #-}++-- | Decode canonical representation of an @'Int32'@.+--+-- @since 0.2.0.0+decodeInt32Canonical :: Decoder s Int32+decodeInt32Canonical = Decoder (\k -> return (ConsumeInt32Canonical (\w# -> k (I32# w#))))+{-# INLINE decodeInt32Canonical #-}++-- | Decode canonical representation of an @'Int64'@.+--+-- @since 0.2.0.0+decodeInt64Canonical :: Decoder s Int64+{-# INLINE decodeInt64Canonical #-}+decodeInt64Canonical =+#if defined(ARCH_64bit)+  Decoder (\k -> return (ConsumeIntCanonical (\n# -> k (I64# n#))))+#else+  Decoder (\k -> return (ConsumeInt64Canonical (\n64# -> k (I64# n64#))))+#endif+ -- | Decode an @'Integer'@. -- -- @since 0.2.0.0@@ -369,6 +527,17 @@ decodeBytesIndef = Decoder (\k -> return (ConsumeBytesIndef (k ()))) {-# INLINE decodeBytesIndef #-} +-- | Decode a string of bytes as a 'ByteArray'.+--+-- Also note that this will eagerly copy the content out of the input+-- to ensure that the input does not leak in the event that the 'ByteArray' is+-- live but not forced.+--+-- @since 0.2.0.0+decodeByteArray :: Decoder s ByteArray+decodeByteArray = Decoder (\k -> return (ConsumeByteArray k))+{-# INLINE decodeByteArray #-}+ -- | Decode a textual string as a piece of @'Text'@. -- -- @since 0.2.0.0@@ -384,6 +553,18 @@ decodeStringIndef = Decoder (\k -> return (ConsumeStringIndef (k ()))) {-# INLINE decodeStringIndef #-} +-- | Decode a textual string as UTF-8 encoded 'ByteArray'. Note that+-- the result is not validated to be well-formed UTF-8.+--+-- Also note that this will eagerly copy the content out of the input+-- to ensure that the input does not leak in the event that the 'ByteArray' is+-- live but not forced.+--+-- @since 0.2.0.0+decodeUtf8ByteArray :: Decoder s ByteArray+decodeUtf8ByteArray = Decoder (\k -> return (ConsumeUtf8ByteArray k))+{-# INLINE decodeUtf8ByteArray #-}+ -- | Decode the length of a list. -- -- @since 0.2.0.0@@ -391,6 +572,13 @@ decodeListLen = Decoder (\k -> return (ConsumeListLen (\n# -> k (I# n#)))) {-# INLINE decodeListLen #-} +-- | Decode canonical representation of the length of a list.+--+-- @since 0.2.0.0+decodeListLenCanonical :: Decoder s Int+decodeListLenCanonical = Decoder (\k -> return (ConsumeListLenCanonical (\n# -> k (I# n#))))+{-# INLINE decodeListLenCanonical #-}+ -- | Decode a token marking the beginning of a list of indefinite -- length. --@@ -406,6 +594,13 @@ decodeMapLen = Decoder (\k -> return (ConsumeMapLen (\n# -> k (I# n#)))) {-# INLINE decodeMapLen #-} +-- | Decode canonical representation of the length of a map.+--+-- @since 0.2.0.0+decodeMapLenCanonical :: Decoder s Int+decodeMapLenCanonical = Decoder (\k -> return (ConsumeMapLenCanonical (\n# -> k (I# n#))))+{-# INLINE decodeMapLenCanonical #-}+ -- | Decode a token marking the beginning of a map of indefinite -- length. --@@ -433,6 +628,27 @@   Decoder (\k -> return (ConsumeTag64 (\w64# -> k (W64# w64#)))) #endif +-- | Decode canonical representation of an arbitrary tag and return it as a+-- @'Word'@.+--+-- @since 0.2.0.0+decodeTagCanonical :: Decoder s Word+decodeTagCanonical = Decoder (\k -> return (ConsumeTagCanonical (\w# -> k (W# w#))))+{-# INLINE decodeTagCanonical #-}++-- | Decode canonical representation of an arbitrary 64-bit tag and return it as+-- a @'Word64'@.+--+-- @since 0.2.0.0+decodeTag64Canonical :: Decoder s Word64+{-# INLINE decodeTag64Canonical #-}+decodeTag64Canonical =+#if defined(ARCH_64bit)+  Decoder (\k -> return (ConsumeTagCanonical (\w# -> k (W64# w#))))+#else+  Decoder (\k -> return (ConsumeTag64Canonical (\w64# -> k (W64# w64#))))+#endif+ -- | Decode a bool. -- -- @since 0.2.0.0@@ -455,7 +671,42 @@ decodeSimple = Decoder (\k -> return (ConsumeSimple (\w# -> k (W8# w#)))) {-# INLINE decodeSimple #-} +-- | Decode canonical representation of an @'Integer'@.+--+-- @since 0.2.0.0+decodeIntegerCanonical :: Decoder s Integer+decodeIntegerCanonical = Decoder (\k -> return (ConsumeIntegerCanonical (\n -> k n)))+{-# INLINE decodeIntegerCanonical #-} +-- | Decode canonical representation of a half-precision @'Float'@.+--+-- @since 0.2.0.0+decodeFloat16Canonical :: Decoder s Float+decodeFloat16Canonical = Decoder (\k -> return (ConsumeFloat16Canonical (\f# -> k (F# f#))))+{-# INLINE decodeFloat16Canonical #-}++-- | Decode canonical representation of a @'Float'@.+--+-- @since 0.2.0.0+decodeFloatCanonical :: Decoder s Float+decodeFloatCanonical = Decoder (\k -> return (ConsumeFloatCanonical (\f# -> k (F# f#))))+{-# INLINE decodeFloatCanonical #-}++-- | Decode canonical representation of a @'Double'@.+--+-- @since 0.2.0.0+decodeDoubleCanonical :: Decoder s Double+decodeDoubleCanonical = Decoder (\k -> return (ConsumeDoubleCanonical (\f# -> k (D# f#))))+{-# INLINE decodeDoubleCanonical #-}++-- | Decode canonical representation of a 'simple' CBOR value and give back a+-- @'Word8'@. You probably don't ever need to use this.+--+-- @since 0.2.0.0+decodeSimpleCanonical :: Decoder s Word8+decodeSimpleCanonical = Decoder (\k -> return (ConsumeSimpleCanonical (\w# -> k (W8# w#))))+{-# INLINE decodeSimpleCanonical #-}+ -------------------------------------------------------------- -- Specialised read operations: expect a token with a specific value --@@ -466,10 +717,7 @@ -- @since 0.2.0.0 decodeWordOf :: Word -- ^ Expected value of the decoded word              -> Decoder s ()-decodeWordOf n = do-  n' <- decodeWord-  if n == n' then return ()-             else fail $ "expected word " ++ show n+decodeWordOf = decodeWordOfHelper decodeWord {-# INLINE decodeWordOf #-}  -- | Attempt to decode a list length using @'decodeListLen'@, and@@ -477,12 +725,40 @@ -- -- @since 0.2.0.0 decodeListLenOf :: Int -> Decoder s ()-decodeListLenOf len = do-  len' <- decodeListLen+decodeListLenOf = decodeListLenOfHelper decodeListLen+{-# INLINE decodeListLenOf #-}++-- | Attempt to decode canonical representation of a word with @'decodeWordCanonical'@,+-- and ensure the word is exactly as expected, or fail.+--+-- @since 0.2.0.0+decodeWordCanonicalOf :: Word -- ^ Expected value of the decoded word+                      -> Decoder s ()+decodeWordCanonicalOf = decodeWordOfHelper decodeWordCanonical+{-# INLINE decodeWordCanonicalOf #-}++-- | Attempt to decode canonical representation of a list length using+-- @'decodeListLenCanonical'@, and ensure it is exactly the specified length, or+-- fail.+--+-- @since 0.2.0.0+decodeListLenCanonicalOf :: Int -> Decoder s ()+decodeListLenCanonicalOf = decodeListLenOfHelper decodeListLenCanonical+{-# INLINE decodeListLenCanonicalOf #-}++decodeListLenOfHelper :: (Show a, Eq a, Monad m) => m a -> a -> m ()+decodeListLenOfHelper decodeFun = \len -> do+  len' <- decodeFun   if len == len' then return ()                  else fail $ "expected list of length " ++ show len-{-# INLINE decodeListLenOf #-}+{-# INLINE decodeListLenOfHelper #-} +decodeWordOfHelper :: (Show a, Eq a, Monad m) => m a -> a -> m ()+decodeWordOfHelper decodeFun = \n -> do+  n' <- decodeFun+  if n == n' then return ()+             else fail $ "expected word " ++ show n+{-# INLINE decodeWordOfHelper #-}  -------------------------------------------------------------- -- Branching operations

@@ -31,8 +31,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@@ -58,6 +60,8 @@ import qualified Data.ByteString as B import qualified Data.Text       as T +import           Codec.CBOR.ByteArray.Sliced (SlicedByteArray)+ import           Prelude         hiding (encodeFloat)  import {-# SOURCE #-} qualified Codec.CBOR.FlatTerm as FlatTerm@@ -95,10 +99,12 @@     | TkInt64    {-# UNPACK #-} !Int64        Tokens      -- Bytes and string (type 2,3)-    | TkBytes    {-# UNPACK #-} !B.ByteString Tokens-    | TkBytesBegin                            Tokens-    | TkString   {-# UNPACK #-} !T.Text       Tokens-    | TkStringBegin                           Tokens+    | TkBytes         {-# UNPACK #-} !B.ByteString    Tokens+    | TkBytesBegin                                    Tokens+    | TkByteArray     {-# UNPACK #-} !SlicedByteArray Tokens+    | TkString        {-# UNPACK #-} !T.Text          Tokens+    | TkUtf8ByteArray {-# UNPACK #-} !SlicedByteArray Tokens+    | TkStringBegin                                   Tokens      -- Structures (type 4,5)     | TkListLen  {-# UNPACK #-} !Word         Tokens@@ -214,6 +220,12 @@ encodeBytes :: B.ByteString -> Encoding encodeBytes = Encoding . TkBytes +-- | Encode a bytestring in a flattened format.+--+-- @since 0.2.0.0+encodeByteArray :: SlicedByteArray -> Encoding+encodeByteArray = Encoding . TkByteArray+ -- | Encode a token specifying the beginning of a string of bytes of -- indefinite length. In reality, this specifies a stream of many -- occurrences of `encodeBytes`, each specifying a single chunk of the@@ -235,6 +247,13 @@ -- @since 0.2.0.0 encodeStringIndef :: Encoding encodeStringIndef = Encoding TkStringBegin++-- | Encode a UTF-8 string in a flattened format. Note that the contents+-- is not validated to be well-formed UTF-8.+--+-- @since 0.2.0.0+encodeUtf8ByteArray :: SlicedByteArray -> Encoding+encodeUtf8ByteArray = Encoding . TkUtf8ByteArray  -- | Encode the length of a list, used to indicate that the following -- tokens represent the list values.

@@ -43,6 +43,8 @@ import           Codec.CBOR.Encoding (Encoding(..)) import qualified Codec.CBOR.Encoding as Enc import           Codec.CBOR.Decoding as Dec+import qualified Codec.CBOR.ByteArray        as BA+import qualified Codec.CBOR.ByteArray.Sliced as BAS  import           Data.Int #if defined(ARCH_32bit)@@ -56,6 +58,7 @@  import           Data.Word import           Data.Text (Text)+import qualified Data.Text.Encoding as TE import           Data.ByteString (ByteString) import           Control.Monad.ST @@ -118,8 +121,12 @@   | otherwise                       = TkInteger   n : convFlatTerm ts convFlatTerm (Enc.TkBytes    bs ts) = TkBytes    bs : convFlatTerm ts convFlatTerm (Enc.TkBytesBegin  ts) = TkBytesBegin  : convFlatTerm ts+convFlatTerm (Enc.TkByteArray a ts)+  = TkBytes (BAS.toByteString a) : convFlatTerm ts convFlatTerm (Enc.TkString   st ts) = TkString   st : convFlatTerm ts convFlatTerm (Enc.TkStringBegin ts) = TkStringBegin : convFlatTerm ts+convFlatTerm (Enc.TkUtf8ByteArray a ts)+  = TkString (TE.decodeUtf8 $ BAS.toByteString a) : convFlatTerm ts convFlatTerm (Enc.TkListLen  n  ts) = TkListLen   n : convFlatTerm ts convFlatTerm (Enc.TkListBegin   ts) = TkListBegin   : convFlatTerm ts convFlatTerm (Enc.TkMapLen   n  ts) = TkMapLen    n : convFlatTerm ts@@ -196,6 +203,52 @@     go (TkTag     n : ts) (ConsumeTag     k)         | n <= maxWord                       = k (unW# (fromIntegral n)) >>= go ts +    go (TkInt     n : ts) (ConsumeWordCanonical k)+        | n >= 0                             = k (unW# (fromIntegral n)) >>= go ts+    go (TkInteger n : ts) (ConsumeWordCanonical k)+        | n >= 0                             = k (unW# (fromIntegral n)) >>= go ts+    go (TkInt     n : ts) (ConsumeWord8Canonical k)+        | n >= 0 && n <= maxWord8            = k (unW# (fromIntegral n)) >>= go ts+    go (TkInteger n : ts) (ConsumeWord8Canonical k)+        | n >= 0 && n <= maxWord8            = k (unW# (fromIntegral n)) >>= go ts+    go (TkInt     n : ts) (ConsumeWord16Canonical k)+        | n >= 0 && n <= maxWord16           = k (unW# (fromIntegral n)) >>= go ts+    go (TkInteger n : ts) (ConsumeWord16Canonical k)+        | n >= 0 && n <= maxWord16           = k (unW# (fromIntegral n)) >>= go ts+    go (TkInt     n : ts) (ConsumeWord32Canonical k)+        -- NOTE: we have to be very careful about this branch+        -- on 32 bit machines, because maxBound :: Int < maxBound :: Word32+        | intIsValidWord32 n                 = k (unW# (fromIntegral n)) >>= go ts+    go (TkInteger n : ts) (ConsumeWord32Canonical k)+        | n >= 0 && n <= maxWord32           = k (unW# (fromIntegral n)) >>= go ts+    go (TkInt     n : ts) (ConsumeNegWordCanonical k)+        | n <  0                             = k (unW# (fromIntegral (-1-n))) >>= go ts+    go (TkInteger n : ts) (ConsumeNegWordCanonical k)+        | n <  0                             = k (unW# (fromIntegral (-1-n))) >>= go ts+    go (TkInt     n : ts) (ConsumeIntCanonical k)     = k (unI# n) >>= go ts+    go (TkInteger n : ts) (ConsumeInt k)+        | n <= maxInt                        = k (unI# (fromIntegral n)) >>= go ts+    go (TkInt     n : ts) (ConsumeInt8Canonical k)+        | n >= minInt8 && n <= maxInt8       = k (unI# n) >>= go ts+    go (TkInteger n : ts) (ConsumeInt8Canonical k)+        | n >= minInt8 && n <= maxInt8       = k (unI# (fromIntegral n)) >>= go ts+    go (TkInt     n : ts) (ConsumeInt16Canonical k)+        | n >= minInt16 && n <= maxInt16     = k (unI# n) >>= go ts+    go (TkInteger n : ts) (ConsumeInt16Canonical k)+        | n >= minInt16 && n <= maxInt16     = k (unI# (fromIntegral n)) >>= go ts+    go (TkInt     n : ts) (ConsumeInt32Canonical k)+        | n >= minInt32 && n <= maxInt32     = k (unI# n) >>= go ts+    go (TkInteger n : ts) (ConsumeInt32Canonical k)+        | n >= minInt32 && n <= maxInt32     = k (unI# (fromIntegral n)) >>= go ts+    go (TkInt     n : ts) (ConsumeIntegerCanonical k) = k (fromIntegral n) >>= go ts+    go (TkInteger n : ts) (ConsumeIntegerCanonical k) = k n >>= go ts+    go (TkListLen n : ts) (ConsumeListLenCanonical k)+        | n <= maxInt                        = k (unI# (fromIntegral n)) >>= go ts+    go (TkMapLen  n : ts) (ConsumeMapLenCanonical  k)+        | n <= maxInt                        = k (unI# (fromIntegral n)) >>= go ts+    go (TkTag     n : ts) (ConsumeTagCanonical     k)+        | n <= maxWord                       = k (unW# (fromIntegral n)) >>= go ts+ #if defined(ARCH_32bit)     -- 64bit variants for 32bit machines     go (TkInt       n : ts) (ConsumeWord64    k)@@ -212,22 +265,47 @@      go (TkTag       n : ts) (ConsumeTag64     k) = k (unW64# n) >>= go ts +    go (TkInt       n : ts) (ConsumeWord64Canonical    k)+      | n >= 0                                   = k (unW64# (fromIntegral n)) >>= go ts+    go (TkInteger   n : ts) (ConsumeWord64Canonical    k)+      | n >= 0                                   = k (unW64# (fromIntegral n)) >>= go ts+    go (TkInt       n : ts) (ConsumeNegWord64Canonical k)+      | n < 0                                    = k (unW64# (fromIntegral (-1-n))) >>= go ts+    go (TkInteger   n : ts) (ConsumeNegWord64Canonical k)+      | n < 0                                    = k (unW64# (fromIntegral (-1-n))) >>= go ts++    go (TkInt       n : ts) (ConsumeInt64Canonical     k) = k (unI64# (fromIntegral n)) >>= go ts+    go (TkInteger   n : ts) (ConsumeInt64Canonical     k) = k (unI64# (fromIntegral n)) >>= go ts++    go (TkTag       n : ts) (ConsumeTag64Canonical     k) = k (unW64# n) >>= go ts++     -- TODO FIXME (aseipp/dcoutts): are these going to be utilized?     -- see fallthrough case below if/when fixed.-    go ts (ConsumeListLen64 _)                   = unexpected "decodeListLen64" ts-    go ts (ConsumeMapLen64  _)                   = unexpected "decodeMapLen64"  ts+    go ts (ConsumeListLen64 _)          = unexpected "decodeListLen64" ts+    go ts (ConsumeMapLen64  _)          = unexpected "decodeMapLen64"  ts+    go ts (ConsumeListLen64Canonical _) = unexpected "decodeListLen64Canonical" ts+    go ts (ConsumeMapLen64Canonical  _) = unexpected "decodeMapLen64Canonical"  ts #endif -    go (TkFloat16 f : ts) (ConsumeFloat  k) = k (unF# f) >>= go ts-    go (TkFloat32 f : ts) (ConsumeFloat  k) = k (unF# f) >>= go ts-    go (TkFloat16 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts-    go (TkFloat32 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts-    go (TkFloat64 f : ts) (ConsumeDouble k) = k (unD# f) >>= go ts-    go (TkBytes  bs : ts) (ConsumeBytes  k) = k bs >>= go ts-    go (TkString st : ts) (ConsumeString k) = k st >>= go ts-    go (TkBool    b : ts) (ConsumeBool   k) = k b >>= go ts-    go (TkSimple  n : ts) (ConsumeSimple k) = k (unW8# n) >>= go ts+    go (TkFloat16 f : ts) (ConsumeFloat  k)        = k (unF# f) >>= go ts+    go (TkFloat32 f : ts) (ConsumeFloat  k)        = k (unF# f) >>= go ts+    go (TkFloat16 f : ts) (ConsumeDouble k)        = k (unD# (float2Double f)) >>= go ts+    go (TkFloat32 f : ts) (ConsumeDouble k)        = k (unD# (float2Double f)) >>= go ts+    go (TkFloat64 f : ts) (ConsumeDouble k)        = k (unD# f) >>= go ts+    go (TkBytes  bs : ts) (ConsumeBytes  k)        = k bs >>= go ts+    go (TkBytes  bs : ts) (ConsumeByteArray k)     = k (BA.fromByteString bs) >>= go ts+    go (TkString st : ts) (ConsumeString k)        = k st >>= go ts+    go (TkString st : ts) (ConsumeUtf8ByteArray k) = k (BA.fromByteString $ TE.encodeUtf8 st)+                                                     >>= go ts+    go (TkBool    b : ts) (ConsumeBool   k)        = k b >>= go ts+    go (TkSimple  n : ts) (ConsumeSimple k)        = k (unW8# n) >>= go ts +    go (TkFloat16 f : ts) (ConsumeFloat16Canonical k) = k (unF# f) >>= go ts+    go (TkFloat32 f : ts) (ConsumeFloatCanonical   k) = k (unF# f) >>= go ts+    go (TkFloat64 f : ts) (ConsumeDoubleCanonical  k) = k (unD# f) >>= go ts+    go (TkSimple  n : ts) (ConsumeSimpleCanonical  k) = k (unW8# n) >>= go ts+     go (TkBytesBegin  : ts) (ConsumeBytesIndef   da) = da >>= go ts     go (TkStringBegin : ts) (ConsumeStringIndef  da) = da >>= go ts     go (TkListBegin   : ts) (ConsumeListLenIndef da) = da >>= go ts@@ -269,13 +347,35 @@     go ts (ConsumeMapLen  _) = unexpected "decodeMapLen"  ts     go ts (ConsumeTag     _) = unexpected "decodeTag"     ts +    go ts (ConsumeWordCanonical    _) = unexpected "decodeWordCanonical"    ts+    go ts (ConsumeWord8Canonical   _) = unexpected "decodeWord8Canonical"   ts+    go ts (ConsumeWord16Canonical  _) = unexpected "decodeWord16Canonical"  ts+    go ts (ConsumeWord32Canonical  _) = unexpected "decodeWord32Canonical"  ts+    go ts (ConsumeNegWordCanonical _) = unexpected "decodeNegWordCanonical" ts+    go ts (ConsumeIntCanonical     _) = unexpected "decodeIntCanonical"     ts+    go ts (ConsumeInt8Canonical    _) = unexpected "decodeInt8Canonical"    ts+    go ts (ConsumeInt16Canonical   _) = unexpected "decodeInt16Canonical"   ts+    go ts (ConsumeInt32Canonical   _) = unexpected "decodeInt32Canonical"   ts+    go ts (ConsumeIntegerCanonical _) = unexpected "decodeIntegerCanonical" ts++    go ts (ConsumeListLenCanonical _) = unexpected "decodeListLenCanonical" ts+    go ts (ConsumeMapLenCanonical  _) = unexpected "decodeMapLenCanonical"  ts+    go ts (ConsumeTagCanonical     _) = unexpected "decodeTagCanonical"     ts+     go ts (ConsumeFloat  _) = unexpected "decodeFloat"  ts     go ts (ConsumeDouble _) = unexpected "decodeDouble" ts     go ts (ConsumeBytes  _) = unexpected "decodeBytes"  ts+    go ts (ConsumeByteArray     _) = unexpected "decodeByteArray"     ts     go ts (ConsumeString _) = unexpected "decodeString" ts+    go ts (ConsumeUtf8ByteArray _) = unexpected "decodeUtf8ByteArray" ts     go ts (ConsumeBool   _) = unexpected "decodeBool"   ts     go ts (ConsumeSimple _) = unexpected "decodeSimple" ts +    go ts (ConsumeFloat16Canonical _) = unexpected "decodeFloat16Canonical" ts+    go ts (ConsumeFloatCanonical   _) = unexpected "decodeFloatCanonical"   ts+    go ts (ConsumeDoubleCanonical  _) = unexpected "decodeDoubleCanonical"  ts+    go ts (ConsumeSimpleCanonical  _) = unexpected "decodeSimpleCanonical"  ts+ #if defined(ARCH_32bit)     -- 64bit variants for 32bit machines     go ts (ConsumeWord64    _) = unexpected "decodeWord64"    ts@@ -284,6 +384,13 @@     go ts (ConsumeTag64     _) = unexpected "decodeTag64"     ts   --go ts (ConsumeListLen64 _) = unexpected "decodeListLen64" ts   --go ts (ConsumeMapLen64  _) = unexpected "decodeMapLen64"  ts++    go ts (ConsumeWord64Canonical    _) = unexpected "decodeWord64Canonical"    ts+    go ts (ConsumeNegWord64Canonical _) = unexpected "decodeNegWord64Canonical" ts+    go ts (ConsumeInt64Canonical     _) = unexpected "decodeInt64Canonical"     ts+    go ts (ConsumeTag64Canonical     _) = unexpected "decodeTag64Canonical"     ts+  --go ts (ConsumeListLen64Canonical _) = unexpected "decodeListLen64Canonical" ts+  --go ts (ConsumeMapLen64Canonical  _) = unexpected "decodeMapLen64Canonical"  ts #endif      go ts (ConsumeBytesIndef   _) = unexpected "decodeBytesIndef"   ts

@@ -236,13 +236,8 @@ -- with it. withBsPtr :: (Ptr b -> a) -> ByteString -> a withBsPtr f (BS.PS x off _) =-#if MIN_VERSION_bytestring(0,10,6)-    BS.accursedUnutterablePerformIO $ withForeignPtr x $-        \(Ptr addr#) -> return $! (f (Ptr addr# `plusPtr` off))-#else     unsafeDupablePerformIO $ withForeignPtr x $         \(Ptr addr#) -> return $! (f (Ptr addr# `plusPtr` off))-#endif {-# INLINE withBsPtr #-}  --------------------------------------------------------------------------------

@@ -279,8 +279,10 @@ unconsToken (TkInt64 i     tks) = Just (TkInt64 i     TkEnd,tks) unconsToken (TkBytes bs    tks) = Just (TkBytes bs    TkEnd,tks) unconsToken (TkBytesBegin  tks) = Just (TkBytesBegin  TkEnd,tks)+unconsToken (TkByteArray a tks) = Just (TkByteArray a TkEnd,tks) unconsToken (TkString t    tks) = Just (TkString t    TkEnd,tks) unconsToken (TkStringBegin tks) = Just (TkStringBegin TkEnd,tks)+unconsToken (TkUtf8ByteArray a tks) = Just (TkUtf8ByteArray a TkEnd,tks) unconsToken (TkListLen len tks) = Just (TkListLen len TkEnd,tks) unconsToken (TkListBegin   tks) = Just (TkListBegin   TkEnd,tks) unconsToken (TkMapLen len  tks) = Just (TkMapLen len  TkEnd,tks)

@@ -2,11 +2,14 @@ {-# LANGUAGE MagicHash          #-} {-# LANGUAGE BangPatterns       #-} {-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE DeriveDataTypeable #-} +#if __GLASGOW_HASKELL__ > 706 -- Bump up from the default 1.5, otherwise our decoder fast path is no good. -- We went over the threshold when we switched to using ST. {-# OPTIONS_GHC -funfolding-keeness-factor=2.0 #-}+#endif  -- | -- Module      : Codec.CBOR.Read@@ -21,8 +24,9 @@ -- back into ordinary values. -- module Codec.CBOR.Read-  ( deserialiseFromBytes   -- :: Decoder a -> ByteString -> Either String (ByteString, a)-  , deserialiseIncremental -- :: Decoder a -> ST s (IDecode s a)+  ( deserialiseFromBytes         -- :: Decoder a -> ByteString -> Either String (ByteString, a)+  , deserialiseFromBytesWithSize -- :: Decoder a -> ByteString -> Either String (ByteString, ByteOffset, a)+  , deserialiseIncremental       -- :: Decoder a -> ST s (IDecode s a)   , DeserialiseFailure(..)   , IDecode(..)   , ByteOffset@@ -51,11 +55,15 @@ import qualified Data.Text.Encoding as T import           Data.Word import           GHC.Word+#if defined(ARCH_32bit)+import           GHC.IntWord64+#endif import           GHC.Exts import           GHC.Float (float2Double) import           Data.Typeable import           Control.Exception +import qualified Codec.CBOR.ByteArray as BA import           Codec.CBOR.Decoding hiding (DecodeAction(Done, Fail)) import           Codec.CBOR.Decoding (DecodeAction) import qualified Codec.CBOR.Decoding as D@@ -108,22 +116,37 @@                      -> LBS.ByteString                      -> Either DeserialiseFailure (LBS.ByteString, a) deserialiseFromBytes d lbs =-    runIDecode (deserialiseIncremental d) lbs+    fmap f $ runIDecode (deserialiseIncremental d) lbs+  where f (rest, _, x) = (rest, x) +-- | Given a @'Decoder'@ and some @'LBS.ByteString'@ representing+-- an encoded CBOR value, return @'Either'@ the decoded CBOR value+-- or an error. In addition to the decoded value return any remaining input+-- content and the number of bytes consumed.+--+-- @since 0.2.0.0+deserialiseFromBytesWithSize :: (forall s. Decoder s a)+                             -> LBS.ByteString+                             -> Either DeserialiseFailure (LBS.ByteString, ByteOffset, a)+deserialiseFromBytesWithSize d lbs =+    runIDecode (deserialiseIncremental d) lbs  runIDecode :: (forall s. ST s (IDecode s a))            -> LBS.ByteString-           -> Either DeserialiseFailure (LBS.ByteString, a)+           -> Either DeserialiseFailure (LBS.ByteString, ByteOffset, a) runIDecode d lbs =     runST (go lbs =<< d)   where     go :: LBS.ByteString        -> IDecode s a-       -> ST s (Either DeserialiseFailure (LBS.ByteString, a))-    go  _                  (Fail _ _ err) = return (Left err)-    go  lbs'               (Done bs _ x)  = return (Right (LBS.Chunk bs lbs', x))-    go  LBS.Empty          (Partial  k)   = k Nothing   >>= go LBS.Empty-    go (LBS.Chunk bs lbs') (Partial  k)   = k (Just bs) >>= go lbs'+       -> ST s (Either DeserialiseFailure (LBS.ByteString, ByteOffset, a))+    go  _                  (Fail _ _ err)  = return (Left err)+    go  lbs'               (Done bs off x) = let rest+                                                   | BS.null bs = lbs'+                                                   | otherwise  = LBS.Chunk bs lbs'+                                             in return (Right (rest, off, x))+    go  LBS.Empty          (Partial  k)    = k Nothing   >>= go LBS.Empty+    go (LBS.Chunk bs lbs') (Partial  k)    = k (Just bs) >>= go lbs'  -- | Run a @'Decoder'@ incrementally, returning a continuation -- representing the result of the incremental decode.@@ -208,11 +231,13 @@ -- of tokens spanning a chunk boundary. -- data SlowPath s a-   = FastDone               {-# UNPACK #-} !ByteString a-   | SlowConsumeTokenString {-# UNPACK #-} !ByteString (T.Text     -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int-   | SlowConsumeTokenBytes  {-# UNPACK #-} !ByteString (ByteString -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int-   | SlowDecodeAction       {-# UNPACK #-} !ByteString (DecodeAction s a)-   | SlowFail               {-# UNPACK #-} !ByteString String+   = FastDone                      {-# UNPACK #-} !ByteString a+   | SlowConsumeTokenBytes         {-# UNPACK #-} !ByteString (ByteString   -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int+   | SlowConsumeTokenByteArray     {-# UNPACK #-} !ByteString (BA.ByteArray -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int+   | SlowConsumeTokenString        {-# UNPACK #-} !ByteString (T.Text       -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int+   | SlowConsumeTokenUtf8ByteArray {-# UNPACK #-} !ByteString (BA.ByteArray -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int+   | SlowDecodeAction              {-# UNPACK #-} !ByteString (DecodeAction s a)+   | SlowFail                      {-# UNPACK #-} !ByteString String   -- The main fast path. The fast path itself is actually split into two parts@@ -313,7 +338,113 @@       DecodeFailure           -> go_fast_end bs da       DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs) +go_fast !bs da@(ConsumeWordCanonical k) =+    case tryConsumeWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (W# w#)+        | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise             -> go_fast_end bs da++go_fast !bs da@(ConsumeWord8Canonical k) =+    case tryConsumeWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (W# w#) ->+        case gtWord# w# 0xff## of+          0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+          _                          -> go_fast_end bs da++go_fast !bs da@(ConsumeWord16Canonical k) =+    case tryConsumeWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (W# w#) ->+        case gtWord# w# 0xffff## of+          0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+          _                          -> go_fast_end bs da++go_fast !bs da@(ConsumeWord32Canonical k) =+    case tryConsumeWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (W# w#) ->+        case w_out_of_range w# of+          0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+          _                          -> go_fast_end bs da+  where+    w_out_of_range _w# = #if defined(ARCH_32bit)+      0#+#else+      gtWord# _w# 0xffffffff##+#endif++go_fast !bs da@(ConsumeNegWordCanonical k) =+    case tryConsumeNegWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (W# w#)+        | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise             -> go_fast_end bs da++go_fast !bs da@(ConsumeIntCanonical k) =+    case tryConsumeInt (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (I# n#)+        | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise            -> go_fast_end bs da++go_fast !bs da@(ConsumeInt8Canonical k) =+    case tryConsumeInt (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (I# n#) ->+        case (n# ># 0x7f#) `orI#` (n# <# -0x80#) of+          0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs)+          _                         -> go_fast_end bs da++go_fast !bs da@(ConsumeInt16Canonical k) =+    case tryConsumeInt (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (I# n#) ->+        case (n# ># 0x7fff#) `orI#` (n# <# -0x8000#) of+          0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs)+          _                         -> go_fast_end bs da++go_fast !bs da@(ConsumeInt32Canonical k) =+    case tryConsumeInt (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (I# n#) ->+        case n_out_of_range n# of+          0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs)+          _                         -> go_fast_end bs da+  where+    n_out_of_range _n# =+#if defined(ARCH_32bit)+      0#+#else+      (_n# ># 0x7fffffff#) `orI#` (_n# <# -0x80000000#)+#endif++go_fast !bs da@(ConsumeListLenCanonical k) =+    case tryConsumeListLen (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (I# n#)+          -- List length can't be negative, cast it to Word#.+        | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise                         -> go_fast_end bs da++go_fast !bs da@(ConsumeMapLenCanonical k) =+    case tryConsumeMapLen (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (I# n#)+          -- Map length can't be negative, cast it to Word#.+        | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise                         -> go_fast_end bs da++go_fast !bs da@(ConsumeTagCanonical k) =+    case tryConsumeTag (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (W# w#)+        | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise             -> go_fast_end bs da++#if defined(ARCH_32bit) go_fast !bs da@(ConsumeWord64 k) =   case tryConsumeWord64 (BS.unsafeHead bs) bs of     DecodeFailure             -> go_fast_end bs da@@ -343,12 +474,56 @@   case tryConsumeTag64 (BS.unsafeHead bs) bs of     DecodeFailure             -> go_fast_end bs da     DecodedToken sz (W64# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeWord64Canonical k) =+  case tryConsumeWord64 (BS.unsafeHead bs) bs of+    DecodeFailure             -> go_fast_end bs da+    DecodedToken sz (W64# w#)+      | isWord64Canonical -> k w# >>= go_fast (BS.unsafeDrop sz bs)+      | otherwise         -> go_fast_end bs da++go_fast !bs da@(ConsumeNegWord64Canonical k) =+  case tryConsumeNegWord64 (BS.unsafeHead bs) bs of+    DecodeFailure             -> go_fast_end bs da+    DecodedToken sz (W64# w#)+      | isWord64Canonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+      | otherwise               -> go_fast_end bs da++go_fast !bs da@(ConsumeInt64Canonical k) =+  case tryConsumeInt64 (BS.unsafeHead bs) bs of+    DecodeFailure             -> go_fast_end bs da+    DecodedToken sz (I64# i#)+      | isInt64Canonical sz i# -> k i# >>= go_fast (BS.unsafeDrop sz bs)+      | otherwise              -> go_fast_end bs da++go_fast !bs da@(ConsumeListLen64Canonical k) =+  case tryConsumeListLen64 (BS.unsafeHead bs) bs of+    DecodeFailure             -> go_fast_end bs da+    DecodedToken sz (I64# i#)+        -- List length can't be negative, cast it to Word64#.+      | isWord64Canonical sz (int64ToWord64 i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs)+      | otherwise                               -> go_fast_end bs da++go_fast !bs da@(ConsumeMapLen64Canonical k) =+  case tryConsumeMapLen64 (BS.unsafeHead bs) bs of+    DecodeFailure             -> go_fast_end bs da+    DecodedToken sz (I64# i#)+        -- Map length can't be negative, cast it to Word64#.+      | isWord64Canonical sz (int64ToWord64 i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs)+      | otherwise                               -> go_fast_end bs da++go_fast !bs da@(ConsumeTag64Canonical k) =+  case tryConsumeTag64 (BS.unsafeHead bs) bs of+    DecodeFailure             -> go_fast_end bs da+    DecodedToken sz (W64# w#)+      | isWord64Canonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+      | otherwise               -> go_fast_end bs da #endif  go_fast !bs da@(ConsumeInteger k) =     case tryConsumeInteger (BS.unsafeHead bs) bs of-      DecodedToken sz (BigIntToken n) -> k n >>= go_fast (BS.unsafeDrop sz bs)-      _                               -> go_fast_end bs da+      DecodedToken sz (BigIntToken _ n) -> k n >>= go_fast (BS.unsafeDrop sz bs)+      _                                 -> go_fast_end bs da  go_fast !bs da@(ConsumeFloat k) =     case tryConsumeFloat (BS.unsafeHead bs) bs of@@ -366,12 +541,26 @@       DecodedToken sz (Fits bstr)   -> k bstr >>= go_fast (BS.unsafeDrop sz bs)       DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len +go_fast !bs da@(ConsumeByteArray k) =+    case tryConsumeBytes (BS.unsafeHead bs) bs of+      DecodeFailure                 -> go_fast_end bs da+      DecodedToken sz (Fits str)    -> k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs)+      DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len+ go_fast !bs da@(ConsumeString k) =     case tryConsumeString (BS.unsafeHead bs) bs of       DecodeFailure                 -> go_fast_end bs da-      DecodedToken sz (Fits str)    -> k str >>= go_fast (BS.unsafeDrop sz bs)+      DecodedToken sz (Fits str)    -> case T.decodeUtf8' str of+                                         Right t -> k t >>= go_fast (BS.unsafeDrop sz bs)+                                         Left e  -> return $! SlowFail bs (show e)       DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len +go_fast !bs da@(ConsumeUtf8ByteArray k) =+    case tryConsumeString (BS.unsafeHead bs) bs of+      DecodeFailure                 -> go_fast_end bs da+      DecodedToken sz (Fits str)    -> k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs)+      DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len+ go_fast !bs da@(ConsumeBool k) =     case tryConsumeBool (BS.unsafeHead bs) of       DecodeFailure     -> go_fast_end bs da@@ -382,6 +571,40 @@       DecodeFailure           -> go_fast_end bs da       DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs) +go_fast !bs da@(ConsumeIntegerCanonical k) =+    case tryConsumeInteger (BS.unsafeHead bs) bs of+      DecodedToken sz (BigIntToken True n) -> k n >>= go_fast (BS.unsafeDrop sz bs)+      _                                    -> go_fast_end bs da+++go_fast !bs da@(ConsumeFloat16Canonical k) =+    case tryConsumeFloat (BS.unsafeHead bs) bs of+      DecodeFailure     -> go_fast_end bs da+      DecodedToken sz (F# f#)+        | isFloat16Canonical sz -> k f# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise             -> go_fast_end bs da++go_fast !bs da@(ConsumeFloatCanonical k) =+    case tryConsumeFloat (BS.unsafeHead bs) bs of+      DecodeFailure     -> go_fast_end bs da+      DecodedToken sz f@(F# f#)+        | isFloatCanonical sz bs f -> k f# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise                -> go_fast_end bs da++go_fast !bs da@(ConsumeDoubleCanonical k) =+    case tryConsumeDouble (BS.unsafeHead bs) bs of+      DecodeFailure     -> go_fast_end bs da+      DecodedToken sz f@(D# f#)+        | isDoubleCanonical sz bs f -> k f# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise                 -> go_fast_end bs da++go_fast !bs da@(ConsumeSimpleCanonical k) =+    case tryConsumeSimple (BS.unsafeHead bs) bs of+      DecodeFailure           -> go_fast_end bs da+      DecodedToken sz (W# w#)+        | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+        | otherwise             -> go_fast_end bs da+ go_fast !bs da@(ConsumeBytesIndef k) =     case tryConsumeBytesIndef (BS.unsafeHead bs) of       DecodeFailure     -> go_fast_end bs da@@ -554,7 +777,116 @@       DecodeFailure           -> return $! SlowFail bs "expected tag"       DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) +go_fast_end !bs (ConsumeWordCanonical k) =+    case tryConsumeWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected word"+      DecodedToken sz (W# w#)+        | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise             -> return $! SlowFail bs "non-canonical word"++go_fast_end !bs (ConsumeWord8Canonical k) =+    case tryConsumeWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected word8"+      DecodedToken sz (W# w#) -> case gtWord# w# 0xff## of+          0# | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+             | otherwise             -> return $! SlowFail bs "non-canonical word8"+          _                          -> return $! SlowFail bs "expected word8"++go_fast_end !bs (ConsumeWord16Canonical k) =+    case tryConsumeWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected word16"+      DecodedToken sz (W# w#) -> case gtWord# w# 0xffff## of+        0# | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+           | otherwise             -> return $! SlowFail bs "non-canonical word16"+        _                          -> return $! SlowFail bs "expected word16"++go_fast_end !bs (ConsumeWord32Canonical k) =+    case tryConsumeWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected word32"+      DecodedToken sz (W# w#) -> case w_out_of_range w# of+        0# | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+           | otherwise             -> return $! SlowFail bs "non-canonical word32"+        _                          -> return $! SlowFail bs "expected word32"+  where+    w_out_of_range _w# = #if defined(ARCH_32bit)+      0#+#else+      gtWord# _w# 0xffffffff##+#endif++go_fast_end !bs (ConsumeNegWordCanonical k) =+    case tryConsumeNegWord (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected negative int"+      DecodedToken sz (W# w#)+        | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise             -> return $! SlowFail bs "non-canonical negative int"++go_fast_end !bs (ConsumeIntCanonical k) =+    case tryConsumeInt (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected int"+      DecodedToken sz (I# n#)+        | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise            -> return $! SlowFail bs "non-canonical int"++go_fast_end !bs (ConsumeInt8Canonical k) =+    case tryConsumeInt (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected int8"+      DecodedToken sz (I# n#) ->+        case (n# ># 0x7f#) `orI#` (n# <# -0x80#) of+          0# | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+             | otherwise            -> return $! SlowFail bs "non-canonical int8"+          _                         -> return $! SlowFail bs "expected int8"++go_fast_end !bs (ConsumeInt16Canonical k) =+    case tryConsumeInt (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected int16"+      DecodedToken sz (I# n#) ->+        case (n# ># 0x7fff#) `orI#` (n# <# -0x8000#) of+          0# | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+             | otherwise            -> return $! SlowFail bs "non-canonical int16"+          _                         -> return $! SlowFail bs "expected int16"++go_fast_end !bs (ConsumeInt32Canonical k) =+    case tryConsumeInt (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected int32"+      DecodedToken sz (I# n#) ->+        case n_out_of_range n# of+          0# | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+             | otherwise            -> return $! SlowFail bs "non-canonical int32"+          _                         -> return $! SlowFail bs "expected int32"+  where+    n_out_of_range _n# =+#if defined(ARCH_32bit)+      0#+#else+      (_n# ># 0x7fffffff#) `orI#` (_n# <# -0x80000000#)+#endif++go_fast_end !bs (ConsumeListLenCanonical k) =+    case tryConsumeListLen (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected list len"+      DecodedToken sz (I# n#)+          -- List length can't be negative, cast it to Word#.+        | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise                         -> return $! SlowFail bs "non-canonical list len"++go_fast_end !bs (ConsumeMapLenCanonical k) =+    case tryConsumeMapLen (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected map len"+      DecodedToken sz (I# n#)+          -- Map length can't be negative, cast it to Word#.+        | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise                         -> return $! SlowFail bs "non-canonical map len"++go_fast_end !bs (ConsumeTagCanonical k) =+    case tryConsumeTag (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected tag"+      DecodedToken sz (W# w#)+        | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise             -> return $! SlowFail bs "non-canonical tag"++#if defined(ARCH_32bit) go_fast_end !bs (ConsumeWord64 k) =   case tryConsumeWord64 (BS.unsafeHead bs) bs of     DecodeFailure             -> return $! SlowFail bs "expected word64"@@ -589,7 +921,7 @@ go_fast_end !bs (ConsumeInteger k) =     case tryConsumeInteger (BS.unsafeHead bs) bs of       DecodeFailure                         -> return $! SlowFail bs "expected integer"-      DecodedToken sz (BigIntToken n)       -> k n >>= go_fast_end (BS.unsafeDrop sz bs)+      DecodedToken sz (BigIntToken _ n)     -> k n >>= go_fast_end (BS.unsafeDrop sz bs)       DecodedToken sz (BigUIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigUIntNeedBody k) len       DecodedToken sz (BigNIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigNIntNeedBody k) len       DecodedToken sz  BigUIntNeedHeader    -> return $! SlowDecodeAction      (BS.unsafeDrop sz bs) (adjustContBigUIntNeedHeader k)@@ -611,12 +943,26 @@       DecodedToken sz (Fits bstr)   -> k bstr >>= go_fast_end (BS.unsafeDrop sz bs)       DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len +go_fast_end !bs (ConsumeByteArray k) =+    case tryConsumeBytes (BS.unsafeHead bs) bs of+      DecodeFailure                 -> return $! SlowFail bs "expected string"+      DecodedToken sz (Fits str)    -> (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs)+      DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len+ go_fast_end !bs (ConsumeString k) =     case tryConsumeString (BS.unsafeHead bs) bs of       DecodeFailure                 -> return $! SlowFail bs "expected string"-      DecodedToken sz (Fits str)    -> k str >>= go_fast_end (BS.unsafeDrop sz bs)+      DecodedToken sz (Fits str)    -> case T.decodeUtf8' str of+                                         Right t -> k t >>= go_fast_end (BS.unsafeDrop sz bs)+                                         Left e  -> return $! SlowFail bs (show e)       DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len +go_fast_end !bs (ConsumeUtf8ByteArray k) =+    case tryConsumeString (BS.unsafeHead bs) bs of+      DecodeFailure                 -> return $! SlowFail bs "expected string"+      DecodedToken sz (Fits str)    -> (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs)+      DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len+ go_fast_end !bs (ConsumeBool k) =     case tryConsumeBool (BS.unsafeHead bs) of       DecodeFailure     -> return $! SlowFail bs "expected bool"@@ -627,6 +973,45 @@       DecodeFailure           -> return $! SlowFail bs "expected simple"       DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) +go_fast_end !bs (ConsumeIntegerCanonical k) =+    case tryConsumeInteger (BS.unsafeHead bs) bs of+      DecodeFailure                         -> return $! SlowFail bs "expected integer"+      DecodedToken sz (BigIntToken canonical n)+        | canonical -> k n >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise -> return $! SlowFail bs "non-canonical integer"+      DecodedToken sz (BigUIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigUIntNeedBody k) len+      DecodedToken sz (BigNIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigNIntNeedBody k) len+      DecodedToken sz  BigUIntNeedHeader    -> return $! SlowDecodeAction      (BS.unsafeDrop sz bs) (adjustContBigUIntNeedHeader k)+      DecodedToken sz  BigNIntNeedHeader    -> return $! SlowDecodeAction      (BS.unsafeDrop sz bs) (adjustContBigNIntNeedHeader k)++go_fast_end !bs (ConsumeFloat16Canonical k) =+    case tryConsumeFloat (BS.unsafeHead bs) bs of+      DecodeFailure     -> return $! SlowFail bs "expected float"+      DecodedToken sz (F# f#)+        | isFloat16Canonical sz -> k f# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise             -> return $! SlowFail bs "non-canonical float16"++go_fast_end !bs (ConsumeFloatCanonical k) =+    case tryConsumeFloat (BS.unsafeHead bs) bs of+      DecodeFailure     -> return $! SlowFail bs "expected float"+      DecodedToken sz f@(F# f#)+        | isFloatCanonical sz bs f -> k f# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise                -> return $! SlowFail bs "non-canonical float"++go_fast_end !bs (ConsumeDoubleCanonical k) =+    case tryConsumeDouble (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected double"+      DecodedToken sz f@(D# f#)+        | isDoubleCanonical sz bs f -> k f# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise                 -> return $! SlowFail bs "non-canonical double"++go_fast_end !bs (ConsumeSimpleCanonical k) =+    case tryConsumeSimple (BS.unsafeHead bs) bs of+      DecodeFailure           -> return $! SlowFail bs "expected simple"+      DecodedToken sz (W# w#)+        | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+        | otherwise             -> return $! SlowFail bs "non-canonical simple"+ go_fast_end !bs (ConsumeBytesIndef k) =     case tryConsumeBytesIndef (BS.unsafeHead bs) of       DecodeFailure     -> return $! SlowFail bs "expected bytes start"@@ -685,6 +1070,13 @@       where         !offset' = offset + fromIntegral (BS.length bs - BS.length bs') +    SlowConsumeTokenByteArray bs' k len -> do+      (bstr, bs'') <- getTokenVarLen len bs' offset'+      let !str = BA.fromByteString bstr+      lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len)+      where+        !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+     SlowConsumeTokenString bs' k len -> do       (bstr, bs'') <- getTokenVarLen len bs' offset'       let !str = T.decodeUtf8 bstr  -- TODO FIXME: utf8 validation@@ -692,6 +1084,13 @@       where         !offset' = offset + fromIntegral (BS.length bs - BS.length bs') +    SlowConsumeTokenUtf8ByteArray bs' k len -> do+      (bstr, bs'') <- getTokenVarLen len bs' offset'+      let !str = BA.fromByteString bstr+      lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len)+      where+        !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+     -- we didn't have enough input in the buffer     SlowDecodeAction bs' da' | BS.null bs' -> do       -- in this case we're exactly out of input@@ -783,32 +1182,39 @@         assert (BS.null bs_empty) $         return (bs', offset', x) -      SlowConsumeTokenBytes bs_empty k len ->-        assert (BS.null bs_empty) $ do-        (bstr, bs'') <- if BS.length bs' < len-                          then getTokenVarLen len bs' offset'-                          else let !bstr = BS.take len bs'-                                   !bs'' = BS.drop len bs'-                                in return (bstr, bs'')-        lift (k bstr) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len)+      SlowConsumeTokenBytes bs_empty k len         -> consume id                bs' offset' bs_empty k len -      SlowConsumeTokenString bs_empty k len ->+      SlowConsumeTokenByteArray bs_empty k len     -> consume BA.fromByteString bs' offset' bs_empty k len++      SlowConsumeTokenString bs_empty k len        -> consume T.decodeUtf8      bs' offset' bs_empty k len+        -- TODO FIXME: utf8 validation++      SlowConsumeTokenUtf8ByteArray bs_empty k len -> consume BA.fromByteString bs' offset' bs_empty k len++      SlowFail bs_unconsumed msg ->+        decodeFail (bs_unconsumed <> bs') offset'' msg+        where+          !offset'' = offset + fromIntegral (sz - BS.length bs_unconsumed)+  where+    {-# INLINE consume #-}+    consume :: (BS.ByteString -> a)+            -> BS.ByteString                   -- bs'+            -> Int64                           -- offset'+            -> BS.ByteString                   -- bs_empty+            -> (a -> ST s (DecodeAction s r))  -- continuation+            -> Int                             -- length+            -> IncrementalDecoder s (ByteString, ByteOffset, r)+    consume pack bs' offset' bs_empty k len =         assert (BS.null bs_empty) $ do         (bstr, bs'') <- if BS.length bs' < len                           then getTokenVarLen len bs' offset'                           else let !bstr = BS.take len bs'                                    !bs'' = BS.drop len bs'                                 in return (bstr, bs'')-        let !str = T.decodeUtf8 bstr  -- TODO FIXME: utf8 validation+        let !str = pack bstr         lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len) -      SlowFail bs_unconsumed msg ->-        decodeFail (bs_unconsumed <> bs') offset'' msg-        where-          !offset'' = offset + fromIntegral (sz - BS.length bs_unconsumed) -- -- TODO FIXME: we can do slightly better here. If we're returning a -- lazy string (String, lazy Text, lazy ByteString) then we don't have -- to strictify here and if we're returning a strict string perhaps we@@ -907,14 +1313,66 @@ encodeHeader :: Word -> Word -> Word8 encodeHeader mt ai = fromIntegral (mt `shiftL` 5 .|. ai) - data DecodedToken a = DecodedToken !Int !a | DecodeFailure   deriving Show  data LongToken a = Fits !a | TooLong !Int   deriving Show +{-# INLINE isFloat16Canonical #-}+isFloat16Canonical :: Int -> Bool+isFloat16Canonical sz+  | sz == 3   = True+  | otherwise = False +{-# INLINE isFloatCanonical #-}+isFloatCanonical :: Int -> BS.ByteString -> Float -> Bool+isFloatCanonical sz bs f+  | isNaN f   = sz == 3 && "\xf9\x7e\x00" `BS.isPrefixOf` bs+  | otherwise = sz == 5++{-# INLINE isDoubleCanonical #-}+isDoubleCanonical :: Int -> BS.ByteString -> Double -> Bool+isDoubleCanonical sz bs f+  | isNaN f   = sz == 3 && "\xf9\x7e\x00" `BS.isPrefixOf` bs+  | otherwise = sz == 9++{-# INLINE isWordCanonical #-}+isWordCanonical :: Int -> Word# -> Bool+isWordCanonical sz w#+  | sz == 2 && isTrue# (w# `leWord#` 0x17##)       = False+  | sz == 3 && isTrue# (w# `leWord#` 0xff##)       = False+  | sz == 5 && isTrue# (w# `leWord#` 0xffff##)     = False+  | sz == 9 && isTrue# (w# `leWord#` 0xffffffff##) = False+  | otherwise                                      = True++{-# INLINE isIntCanonical #-}+isIntCanonical :: Int -> Int# -> Bool+isIntCanonical sz i#+  | isTrue# (i# <# 0#) = isWordCanonical sz (not# w#)+  | otherwise          = isWordCanonical sz       w#+  where+    w# = int2Word# i#++#if defined(ARCH_32bit)+{-# INLINE isWord64Canonical #-}+isWord64Canonical :: Int -> Word64# -> Bool+isWord64Canonical sz w#+  | sz == 2 && isTrue# (w# `leWord64#` 0x17##)       = False+  | sz == 3 && isTrue# (w# `leWord64#` 0xff##)       = False+  | sz == 5 && isTrue# (w# `leWord64#` 0xffff##)     = False+  | sz == 9 && isTrue# (w# `leWord64#` 0xffffffff##) = False+  | otherwise                                        = True++{-# INLINE isInt64Canonical #-}+isInt64Canonical :: Int -> Int64# -> Bool+isInt64Canonical sz i#+  | isTrue# (i# <# 0#) = isWord64Canonical sz (not64# w#)+  | otherwise          = isWord64Canonical sz         w#+  where+    w# = int64ToWord64# i#+#endif+ -- TODO FIXME: check with 7.10 and file ticket: -- a case analysis against 0x00 .. 0xff :: Word8 turns into a huge chain -- of >= tests. It could use a jump table, or at least it could use a binary@@ -1060,64 +1518,89 @@ tryConsumeInteger hdr !bs = case fromIntegral hdr :: Word of    -- Positive integers (type 0)-  0x00 -> DecodedToken 1 (BigIntToken 0)-  0x01 -> DecodedToken 1 (BigIntToken 1)-  0x02 -> DecodedToken 1 (BigIntToken 2)-  0x03 -> DecodedToken 1 (BigIntToken 3)-  0x04 -> DecodedToken 1 (BigIntToken 4)-  0x05 -> DecodedToken 1 (BigIntToken 5)-  0x06 -> DecodedToken 1 (BigIntToken 6)-  0x07 -> DecodedToken 1 (BigIntToken 7)-  0x08 -> DecodedToken 1 (BigIntToken 8)-  0x09 -> DecodedToken 1 (BigIntToken 9)-  0x0a -> DecodedToken 1 (BigIntToken 10)-  0x0b -> DecodedToken 1 (BigIntToken 11)-  0x0c -> DecodedToken 1 (BigIntToken 12)-  0x0d -> DecodedToken 1 (BigIntToken 13)-  0x0e -> DecodedToken 1 (BigIntToken 14)-  0x0f -> DecodedToken 1 (BigIntToken 15)-  0x10 -> DecodedToken 1 (BigIntToken 16)-  0x11 -> DecodedToken 1 (BigIntToken 17)-  0x12 -> DecodedToken 1 (BigIntToken 18)-  0x13 -> DecodedToken 1 (BigIntToken 19)-  0x14 -> DecodedToken 1 (BigIntToken 20)-  0x15 -> DecodedToken 1 (BigIntToken 21)-  0x16 -> DecodedToken 1 (BigIntToken 22)-  0x17 -> DecodedToken 1 (BigIntToken 23)-  0x18 -> DecodedToken 2 (BigIntToken (fromIntegral (eatTailWord8 bs)))-  0x19 -> DecodedToken 3 (BigIntToken (fromIntegral (eatTailWord16 bs)))-  0x1a -> DecodedToken 5 (BigIntToken (fromIntegral (eatTailWord32 bs)))-  0x1b -> DecodedToken 9 (BigIntToken (fromIntegral (eatTailWord64 bs)))+  0x00 -> DecodedToken 1 (BigIntToken True 0)+  0x01 -> DecodedToken 1 (BigIntToken True 1)+  0x02 -> DecodedToken 1 (BigIntToken True 2)+  0x03 -> DecodedToken 1 (BigIntToken True 3)+  0x04 -> DecodedToken 1 (BigIntToken True 4)+  0x05 -> DecodedToken 1 (BigIntToken True 5)+  0x06 -> DecodedToken 1 (BigIntToken True 6)+  0x07 -> DecodedToken 1 (BigIntToken True 7)+  0x08 -> DecodedToken 1 (BigIntToken True 8)+  0x09 -> DecodedToken 1 (BigIntToken True 9)+  0x0a -> DecodedToken 1 (BigIntToken True 10)+  0x0b -> DecodedToken 1 (BigIntToken True 11)+  0x0c -> DecodedToken 1 (BigIntToken True 12)+  0x0d -> DecodedToken 1 (BigIntToken True 13)+  0x0e -> DecodedToken 1 (BigIntToken True 14)+  0x0f -> DecodedToken 1 (BigIntToken True 15)+  0x10 -> DecodedToken 1 (BigIntToken True 16)+  0x11 -> DecodedToken 1 (BigIntToken True 17)+  0x12 -> DecodedToken 1 (BigIntToken True 18)+  0x13 -> DecodedToken 1 (BigIntToken True 19)+  0x14 -> DecodedToken 1 (BigIntToken True 20)+  0x15 -> DecodedToken 1 (BigIntToken True 21)+  0x16 -> DecodedToken 1 (BigIntToken True 22)+  0x17 -> DecodedToken 1 (BigIntToken True 23) +  0x18 -> let !w@(W# w#) = eatTailWord8 bs+              sz = 2+          in DecodedToken sz (BigIntToken (isWordCanonical sz w#)   (fromIntegral w))+  0x19 -> let !w@(W# w#) = eatTailWord16 bs+              sz = 3+          in DecodedToken sz (BigIntToken (isWordCanonical sz w#)   (fromIntegral w))+  0x1a -> let !w@(W# w#) = eatTailWord32 bs+              sz = 5+          in DecodedToken sz (BigIntToken (isWordCanonical sz w#)   (fromIntegral w))+  0x1b -> let !w@(W64# w#) = eatTailWord64 bs+              sz = 9+#if defined(ARCH_32bit)+          in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (fromIntegral w))+#else+          in DecodedToken sz (BigIntToken (isWordCanonical sz w#)   (fromIntegral w))+#endif+   -- Negative integers (type 1)-  0x20 -> DecodedToken 1 (BigIntToken (-1))-  0x21 -> DecodedToken 1 (BigIntToken (-2))-  0x22 -> DecodedToken 1 (BigIntToken (-3))-  0x23 -> DecodedToken 1 (BigIntToken (-4))-  0x24 -> DecodedToken 1 (BigIntToken (-5))-  0x25 -> DecodedToken 1 (BigIntToken (-6))-  0x26 -> DecodedToken 1 (BigIntToken (-7))-  0x27 -> DecodedToken 1 (BigIntToken (-8))-  0x28 -> DecodedToken 1 (BigIntToken (-9))-  0x29 -> DecodedToken 1 (BigIntToken (-10))-  0x2a -> DecodedToken 1 (BigIntToken (-11))-  0x2b -> DecodedToken 1 (BigIntToken (-12))-  0x2c -> DecodedToken 1 (BigIntToken (-13))-  0x2d -> DecodedToken 1 (BigIntToken (-14))-  0x2e -> DecodedToken 1 (BigIntToken (-15))-  0x2f -> DecodedToken 1 (BigIntToken (-16))-  0x30 -> DecodedToken 1 (BigIntToken (-17))-  0x31 -> DecodedToken 1 (BigIntToken (-18))-  0x32 -> DecodedToken 1 (BigIntToken (-19))-  0x33 -> DecodedToken 1 (BigIntToken (-20))-  0x34 -> DecodedToken 1 (BigIntToken (-21))-  0x35 -> DecodedToken 1 (BigIntToken (-22))-  0x36 -> DecodedToken 1 (BigIntToken (-23))-  0x37 -> DecodedToken 1 (BigIntToken (-24))-  0x38 -> DecodedToken 2 (BigIntToken (-1 - fromIntegral (eatTailWord8 bs)))-  0x39 -> DecodedToken 3 (BigIntToken (-1 - fromIntegral (eatTailWord16 bs)))-  0x3a -> DecodedToken 5 (BigIntToken (-1 - fromIntegral (eatTailWord32 bs)))-  0x3b -> DecodedToken 9 (BigIntToken (-1 - fromIntegral (eatTailWord64 bs)))+  0x20 -> DecodedToken 1 (BigIntToken True (-1))+  0x21 -> DecodedToken 1 (BigIntToken True (-2))+  0x22 -> DecodedToken 1 (BigIntToken True (-3))+  0x23 -> DecodedToken 1 (BigIntToken True (-4))+  0x24 -> DecodedToken 1 (BigIntToken True (-5))+  0x25 -> DecodedToken 1 (BigIntToken True (-6))+  0x26 -> DecodedToken 1 (BigIntToken True (-7))+  0x27 -> DecodedToken 1 (BigIntToken True (-8))+  0x28 -> DecodedToken 1 (BigIntToken True (-9))+  0x29 -> DecodedToken 1 (BigIntToken True (-10))+  0x2a -> DecodedToken 1 (BigIntToken True (-11))+  0x2b -> DecodedToken 1 (BigIntToken True (-12))+  0x2c -> DecodedToken 1 (BigIntToken True (-13))+  0x2d -> DecodedToken 1 (BigIntToken True (-14))+  0x2e -> DecodedToken 1 (BigIntToken True (-15))+  0x2f -> DecodedToken 1 (BigIntToken True (-16))+  0x30 -> DecodedToken 1 (BigIntToken True (-17))+  0x31 -> DecodedToken 1 (BigIntToken True (-18))+  0x32 -> DecodedToken 1 (BigIntToken True (-19))+  0x33 -> DecodedToken 1 (BigIntToken True (-20))+  0x34 -> DecodedToken 1 (BigIntToken True (-21))+  0x35 -> DecodedToken 1 (BigIntToken True (-22))+  0x36 -> DecodedToken 1 (BigIntToken True (-23))+  0x37 -> DecodedToken 1 (BigIntToken True (-24))+  0x38 -> let !w@(W# w#) = eatTailWord8 bs+              sz = 2+          in DecodedToken sz (BigIntToken (isWordCanonical sz w#)   (-1 - fromIntegral w))+  0x39 -> let !w@(W# w#) = eatTailWord16 bs+              sz = 3+          in DecodedToken sz (BigIntToken (isWordCanonical sz w#)   (-1 - fromIntegral w))+  0x3a -> let !w@(W# w#) = eatTailWord32 bs+              sz = 5+          in DecodedToken sz (BigIntToken (isWordCanonical sz w#)   (-1 - fromIntegral w))+  0x3b -> let !w@(W64# w#) = eatTailWord64 bs+              sz = 9+#if defined(ARCH_32bit)+          in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (-1 - fromIntegral w))+#else+          in DecodedToken sz (BigIntToken (isWordCanonical sz w#)   (-1 - fromIntegral w))+#endif    0xc2 -> readBigUInt bs   0xc3 -> readBigNInt bs@@ -1162,38 +1645,38 @@   {-# INLINE tryConsumeString #-}-tryConsumeString :: Word8 -> ByteString -> DecodedToken (LongToken T.Text)+tryConsumeString :: Word8 -> ByteString -> DecodedToken (LongToken BS.ByteString) tryConsumeString hdr !bs = case fromIntegral hdr :: Word of    -- Strings (type 3)-  0x60 -> readStringSmall 0 bs-  0x61 -> readStringSmall 1 bs-  0x62 -> readStringSmall 2 bs-  0x63 -> readStringSmall 3 bs-  0x64 -> readStringSmall 4 bs-  0x65 -> readStringSmall 5 bs-  0x66 -> readStringSmall 6 bs-  0x67 -> readStringSmall 7 bs-  0x68 -> readStringSmall 8 bs-  0x69 -> readStringSmall 9 bs-  0x6a -> readStringSmall 10 bs-  0x6b -> readStringSmall 11 bs-  0x6c -> readStringSmall 12 bs-  0x6d -> readStringSmall 13 bs-  0x6e -> readStringSmall 14 bs-  0x6f -> readStringSmall 15 bs-  0x70 -> readStringSmall 16 bs-  0x71 -> readStringSmall 17 bs-  0x72 -> readStringSmall 18 bs-  0x73 -> readStringSmall 19 bs-  0x74 -> readStringSmall 20 bs-  0x75 -> readStringSmall 21 bs-  0x76 -> readStringSmall 22 bs-  0x77 -> readStringSmall 23 bs-  0x78 -> readString8  bs-  0x79 -> readString16 bs-  0x7a -> readString32 bs-  0x7b -> readString64 bs+  0x60 -> readBytesSmall 0 bs+  0x61 -> readBytesSmall 1 bs+  0x62 -> readBytesSmall 2 bs+  0x63 -> readBytesSmall 3 bs+  0x64 -> readBytesSmall 4 bs+  0x65 -> readBytesSmall 5 bs+  0x66 -> readBytesSmall 6 bs+  0x67 -> readBytesSmall 7 bs+  0x68 -> readBytesSmall 8 bs+  0x69 -> readBytesSmall 9 bs+  0x6a -> readBytesSmall 10 bs+  0x6b -> readBytesSmall 11 bs+  0x6c -> readBytesSmall 12 bs+  0x6d -> readBytesSmall 13 bs+  0x6e -> readBytesSmall 14 bs+  0x6f -> readBytesSmall 15 bs+  0x70 -> readBytesSmall 16 bs+  0x71 -> readBytesSmall 17 bs+  0x72 -> readBytesSmall 18 bs+  0x73 -> readBytesSmall 19 bs+  0x74 -> readBytesSmall 20 bs+  0x75 -> readBytesSmall 21 bs+  0x76 -> readBytesSmall 22 bs+  0x77 -> readBytesSmall 23 bs+  0x78 -> readBytes8  bs+  0x79 -> readBytes16 bs+  0x7a -> readBytes32 bs+  0x7b -> readBytes64 bs   _    -> DecodeFailure  @@ -1782,78 +2265,6 @@     -- TODO FIXME: int overflow     n = fromIntegral (eatTailWord64 bs) --readStringSmall :: Int -> ByteString -> DecodedToken (LongToken T.Text)-readStringSmall n bs-  -- if n <= bound then ok return it all-  | n + hdrsz <= BS.length bs-  = DecodedToken (n+hdrsz) $ Fits $-      T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs))-      -- TODO FIXME: utf8 validation--  -- if n > bound then slow path, multi-chunk-  | otherwise-  = DecodedToken hdrsz $ TooLong n-  where-    hdrsz = 1--readString8, readString16,- readString32, readString64 :: ByteString -> DecodedToken (LongToken T.Text)-readString8 bs-  | n <= BS.length bs - hdrsz-  = DecodedToken (n+hdrsz) $ Fits $-      T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs))-      -- TODO FIXME: utf8 validation--  -- if n > bound then slow path, multi-chunk-  | otherwise-  = DecodedToken hdrsz $ TooLong n-  where-    hdrsz = 2-    n = fromIntegral (eatTailWord8 bs)--readString16 bs-  | n <= BS.length bs - hdrsz-  = DecodedToken (n+hdrsz) $ Fits $-      T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs))-      -- TODO FIXME: utf8 validation--  -- if n > bound then slow path, multi-chunk-  | otherwise-  = DecodedToken hdrsz $ TooLong n-  where-    hdrsz = 3-    n = fromIntegral (eatTailWord16 bs)--readString32 bs-  | n <= BS.length bs - hdrsz-  = DecodedToken (n+hdrsz) $ Fits $-      T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs))-      -- TODO FIXME: utf8 validation--  -- if n > bound then slow path, multi-chunk-  | otherwise-  = DecodedToken hdrsz $ TooLong n-  where-    hdrsz = 5-    -- TODO FIXME: int overflow-    n = fromIntegral (eatTailWord32 bs)--readString64 bs-  | n <= BS.length bs - hdrsz-  = DecodedToken (n+hdrsz) $ Fits $-      T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs))-      -- TODO FIXME: utf8 validation--  -- if n > bound then slow path, multi-chunk-  | otherwise-  = DecodedToken hdrsz $ TooLong n-  where-    hdrsz = 5-    -- TODO FIXME: int overflow-    n = fromIntegral (eatTailWord64 bs)-- ------------------------------------------------------------------------------ -- Reading big integers --@@ -1883,7 +2294,7 @@ -- decoding a big int across an input buffer boundary ought to be rare, and -- allocating a new continuation closure isn't that expensive. -data BigIntToken a = BigIntToken Integer+data BigIntToken a = BigIntToken Bool {- canonical? -} Integer                    | BigUIntNeedBody Int                    | BigNIntNeedBody Int                    | BigUIntNeedHeader@@ -1930,7 +2341,8 @@     , BS.length bs' >= tokenSize hdr     = case tryConsumeBytes hdr bs' of         DecodeFailure                 -> DecodeFailure-        DecodedToken sz (Fits bstr)   -> DecodedToken (1+sz) (BigIntToken (uintegerFromBytes bstr))+        DecodedToken sz (Fits bstr)   -> DecodedToken (1+sz)+          (BigIntToken (isBigIntRepCanonical bstr) (uintegerFromBytes bstr))         DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigUIntNeedBody len)      | otherwise@@ -1945,8 +2357,16 @@     , BS.length bs' >= tokenSize hdr     = case tryConsumeBytes hdr bs' of         DecodeFailure                 -> DecodeFailure-        DecodedToken sz (Fits bstr)   -> DecodedToken (1+sz) (BigIntToken (nintegerFromBytes bstr))+        DecodedToken sz (Fits bstr)   -> DecodedToken (1+sz)+          (BigIntToken (isBigIntRepCanonical bstr) (nintegerFromBytes bstr))         DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigNIntNeedBody len)      | otherwise     = DecodedToken 1 BigNIntNeedHeader++-- Binary representation of a big integer is canonical if it's at least 9 bytes+-- long (as for smaller values the canonical representation is the same one as+-- for Int) and the leading byte is not zero (meaning that it's the smallest+-- representation for the number in question).+isBigIntRepCanonical :: ByteString -> Bool+isBigIntRepCanonical bstr = BS.length bstr > 8 && BS.unsafeHead bstr /= 0x00

@@ -50,6 +50,7 @@ #endif #endif +import qualified Codec.CBOR.ByteArray.Sliced           as BAS import           Codec.CBOR.Encoding import           Codec.CBOR.Magic @@ -93,7 +94,9 @@                TkBytes    x vs' -> BI.runBuilderWith (bytesMP  x) (step vs' k) (BI.BufferRange op ope0)               TkBytesBegin vs' -> PI.runB bytesBeginMP  () op >>= go vs'+              TkByteArray x vs' -> BI.runBuilderWith (byteArrayMP x) (step vs' k) (BI.BufferRange op ope0) +              TkUtf8ByteArray x vs' -> BI.runBuilderWith (utf8ByteArrayMP x) (step vs' k) (BI.BufferRange op ope0)               TkString   x vs' -> BI.runBuilderWith (stringMP x) (step vs' k) (BI.BufferRange op ope0)               TkStringBegin vs'-> PI.runB stringBeginMP () op >>= go vs' @@ -351,6 +354,10 @@     condB (<= 0xffff)     (fromIntegral >$< withConstHeader 0x59 P.word16BE) $     condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0x5a P.word32BE) $                           (fromIntegral >$< withConstHeader 0x5b P.word64BE)+byteArrayMP :: BAS.SlicedByteArray -> B.Builder+byteArrayMP ba =+    P.primBounded bytesLenMP n <> BAS.toBuilder ba+  where n = fromIntegral $ BAS.sizeofSlicedByteArray ba  bytesBeginMP :: P.BoundedPrim () bytesBeginMP = constHeader 0x5f@@ -388,6 +395,12 @@ stringBeginMP :: P.BoundedPrim () stringBeginMP = constHeader 0x7f +utf8ByteArrayMP :: BAS.SlicedByteArray -> B.Builder+utf8ByteArrayMP t =+    P.primBounded stringLenMP n <> BAS.toBuilder t+  where+    n = fromIntegral $ BAS.sizeofSlicedByteArray t+ {-    Major type 4:  an array of data items.  Arrays are also called lists,       sequences, or tuples.  The array's length follows the rules for@@ -518,15 +531,22 @@ undefMP :: P.BoundedPrim () undefMP = constHeader 0xf7 +-- Canonical encoding of a NaN as per RFC 7049, section 3.9.+canonicalNaN :: PI.BoundedPrim a+canonicalNaN = P.liftFixedToBounded $ const (0xf9, (0x7e, 0x00))+                                   >$< P.word8 >*< P.word8 >*< P.word8+ halfMP :: P.BoundedPrim Float-halfMP = floatToWord16 >$<-         withConstHeader 0xf9 P.word16BE+halfMP = condB isNaN canonicalNaN+                     (floatToWord16 >$< withConstHeader 0xf9 P.word16BE)  floatMP :: P.BoundedPrim Float-floatMP = withConstHeader 0xfa P.floatBE+floatMP = condB isNaN canonicalNaN+                      (withConstHeader 0xfa P.floatBE)  doubleMP :: P.BoundedPrim Double-doubleMP = withConstHeader 0xfb P.doubleBE+doubleMP = condB isNaN canonicalNaN+                       (withConstHeader 0xfb P.doubleBE)  breakMP :: P.BoundedPrim () breakMP = constHeader 0xff