cborg (empty) → 0.1.1.0
raw patch · 15 files changed
+5159/−0 lines, 15 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, containers, fail, ghc-prim, half, integer-gmp, primitive, semigroups, text
Files
- LICENSE.txt +33/−0
- Setup.hs +2/−0
- cborg.cabal +84/−0
- src/Codec/CBOR.hs +14/−0
- src/Codec/CBOR/Decoding.hs +593/−0
- src/Codec/CBOR/Encoding.hs +331/−0
- src/Codec/CBOR/Encoding.hs-boot +5/−0
- src/Codec/CBOR/FlatTerm.hs +486/−0
- src/Codec/CBOR/FlatTerm.hs-boot +10/−0
- src/Codec/CBOR/Magic.hs +453/−0
- src/Codec/CBOR/Pretty.hs +307/−0
- src/Codec/CBOR/Read.hs +1952/−0
- src/Codec/CBOR/Term.hs +251/−0
- src/Codec/CBOR/Write.hs +590/−0
- src/cbits/cbor.h +48/−0
+ LICENSE.txt view
@@ -0,0 +1,33 @@+Copyright (c) 2015-2017 Duncan Coutts,+ 2015-2017 Well-Typed LLP,+ 2015 IRIS Connect Ltd.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Duncan Coutts nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cborg.cabal view
@@ -0,0 +1,84 @@+name: cborg+version: 0.1.1.0+synopsis: Concise Binary Object Representation+license: BSD3+license-file: LICENSE.txt+author: Duncan Coutts+maintainer: duncan@community.haskell.org, ben@smart-cactus.org+bug-reports: https://github.com/well-typed/cborg/issues+copyright: 2015-2017 Duncan Coutts,+ 2015-2017 Well-Typed LLP,+ 2015 IRIS Connect Ltd+category: Codec+build-type: Simple+cabal-version: >= 1.10+tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1++description:+ This package (formerly @binary-serialise-cbor@) provides an efficient+ implementation of the Concise Binary Object Representation (CBOR), as+ specified by RFC 7049.+ .+ 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.++extra-source-files:+ src/cbits/cbor.h++source-repository head+ type: git+ location: https://github.com/well-typed/cborg.git++--------------------------------------------------------------------------------+-- Flags++flag optimize-gmp+ default: True+ manual: False+ description: Use optimized code paths for integer-gmp++--------------------------------------------------------------------------------+-- Library++library+ default-language: Haskell2010+ ghc-options: -Wall+ include-dirs: src/cbits+ hs-source-dirs: src++ exposed-modules:+ Codec.CBOR+ Codec.CBOR.Decoding+ Codec.CBOR.Encoding+ Codec.CBOR.FlatTerm+ Codec.CBOR.Magic+ Codec.CBOR.Pretty+ Codec.CBOR.Read+ Codec.CBOR.Write+ Codec.CBOR.Term++ other-extensions:+ CPP, ForeignFunctionInterface, MagicHash,+ UnboxedTuples, BangPatterns, DeriveDataTypeable,+ RankNTypes++ build-depends:+ array >= 0.4 && < 0.6,+ base >= 4.6 && < 5.0,+ bytestring >= 0.10.4 && < 0.11,+ containers >= 0.5 && < 0.6,+ ghc-prim >= 0.3 && < 0.6,+ half >= 0.2.2.3 && < 0.3,+ primitive >= 0.5 && < 0.7,+ text >= 1.1 && < 1.3++ if flag(optimize-gmp)+ cpp-options: -DFLAG_OPTIMIZE_GMP+ build-depends:+ integer-gmp++ if impl(ghc >= 8.0)+ ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+ else+ -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8+ build-depends: fail == 4.9.*, semigroups == 0.18.*
+ src/Codec/CBOR.hs view
@@ -0,0 +1,14 @@+-- |+-- Module : Codec.CBOR+-- Copyright : (c) Duncan Coutts 2015-2017+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : duncan@community.haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- A library for working with CBOR.+--+module Codec.CBOR+ (+ ) where
+ src/Codec/CBOR/Decoding.hs view
@@ -0,0 +1,593 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module : Codec.CBOR.Decoding+-- Copyright : (c) Duncan Coutts 2015-2017+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : duncan@community.haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- High level API for decoding values that were encoded with the+-- "Codec.CBOR.Encoding" module, using a @'Monad'@+-- based interface.+--+module Codec.CBOR.Decoding+ ( -- * Decode primitive operations+ Decoder+ , DecodeAction(..)+ , liftST+ , getDecodeAction++ -- ** Read input tokens+ , decodeWord -- :: Decoder s Word+ , decodeWord8 -- :: Decoder s Word8+ , decodeWord16 -- :: Decoder s Word16+ , decodeWord32 -- :: Decoder s Word32+ , decodeWord64 -- :: Decoder s Word64+ , decodeNegWord -- :: Decoder s Word+ , decodeNegWord64 -- :: Decoder s Word64+ , decodeInt -- :: Decoder s Int+ , decodeInt8 -- :: Decoder s Int8+ , decodeInt16 -- :: Decoder s Int16+ , decodeInt32 -- :: Decoder s Int32+ , decodeInt64 -- :: Decoder s Int64+ , decodeInteger -- :: Decoder s Integer+ , decodeFloat -- :: Decoder s Float+ , decodeDouble -- :: Decoder s Double+ , decodeBytes -- :: Decoder s ByteString+ , decodeBytesIndef -- :: Decoder s ()+ , decodeString -- :: Decoder s Text+ , decodeStringIndef -- :: Decoder s ()+ , decodeListLen -- :: Decoder s Int+ , decodeListLenIndef -- :: Decoder s ()+ , decodeMapLen -- :: Decoder s Int+ , decodeMapLenIndef -- :: Decoder s ()+ , decodeTag -- :: Decoder s Word+ , decodeTag64 -- :: Decoder s Word64+ , decodeBool -- :: Decoder s Bool+ , decodeNull -- :: Decoder s ()+ , decodeSimple -- :: Decoder s Word8++ -- ** Specialised Read input token operations+ , decodeWordOf -- :: Word -> Decoder s ()+ , decodeListLenOf -- :: Int -> Decoder s ()++ -- ** Branching operations+--, decodeBytesOrIndef+--, decodeStringOrIndef+ , decodeListLenOrIndef -- :: Decoder s (Maybe Int)+ , decodeMapLenOrIndef -- :: Decoder s (Maybe Int)+ , decodeBreakOr -- :: Decoder s Bool++ -- ** Inspecting the token type+ , peekTokenType -- :: Decoder s TokenType+ , peekAvailable -- :: Decoder s Int+ , TokenType(..)++ -- ** Special operations+--, ignoreTerms+--, decodeTrace++ -- * Sequence operations+ , decodeSequenceLenIndef -- :: ...+ , decodeSequenceLenN -- :: ...+ ) where++#include "cbor.h"++import GHC.Exts+import GHC.Word+import GHC.Int+import Data.Text (Text)+import Data.ByteString (ByteString)+import Control.Applicative+import Control.Monad.ST+import qualified Control.Monad.Fail as Fail++import Prelude hiding (decodeFloat)+++-- | A continuation-based decoder, used for decoding values that were+-- previously encoded using the "Codec.CBOR.Encoding"+-- module. As @'Decoder'@ has a @'Monad'@ instance, you can easily+-- write @'Decoder'@s monadically for building your deserialisation+-- logic.+--+-- @since 0.2.0.0+data Decoder s a = Decoder {+ runDecoder :: forall r. (a -> ST s (DecodeAction s r)) -> ST s (DecodeAction s r)+ }++-- | An action, representing a step for a decoder to taken and a+-- continuation to invoke with the expected value.+--+-- @since 0.2.0.0+data DecodeAction s a+ = ConsumeWord (Word# -> ST s (DecodeAction s a))+ | ConsumeWord8 (Word# -> ST s (DecodeAction s a))+ | ConsumeWord16 (Word# -> ST s (DecodeAction s a))+ | ConsumeWord32 (Word# -> ST s (DecodeAction s a))+ | ConsumeNegWord (Word# -> ST s (DecodeAction s a))+ | ConsumeInt (Int# -> ST s (DecodeAction s a))+ | ConsumeInt8 (Int# -> ST s (DecodeAction s a))+ | ConsumeInt16 (Int# -> ST s (DecodeAction s a))+ | ConsumeInt32 (Int# -> ST s (DecodeAction s a))+ | ConsumeListLen (Int# -> ST s (DecodeAction s a))+ | ConsumeMapLen (Int# -> ST s (DecodeAction s a))+ | ConsumeTag (Word# -> ST s (DecodeAction s a))++-- 64bit variants for 32bit machines+#if defined(ARCH_32bit)+ | ConsumeWord64 (Word64# -> ST s (DecodeAction s a))+ | ConsumeNegWord64 (Word64# -> ST s (DecodeAction s a))+ | ConsumeInt64 (Int64# -> ST s (DecodeAction s a))+ | ConsumeListLen64 (Int64# -> ST s (DecodeAction s a))+ | ConsumeMapLen64 (Int64# -> ST s (DecodeAction s a))+ | ConsumeTag64 (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))++ | ConsumeBytesIndef (ST s (DecodeAction s a))+ | ConsumeStringIndef (ST s (DecodeAction s a))+ | ConsumeListLenIndef (ST s (DecodeAction s a))+ | ConsumeMapLenIndef (ST s (DecodeAction s a))+ | ConsumeNull (ST s (DecodeAction s a))++ | ConsumeListLenOrIndef (Int# -> ST s (DecodeAction s a))+ | ConsumeMapLenOrIndef (Int# -> ST s (DecodeAction s a))+ | ConsumeBreakOr (Bool -> ST s (DecodeAction s a))++ | PeekTokenType (TokenType -> ST s (DecodeAction s a))+ | PeekAvailable (Int# -> ST s (DecodeAction s a))++ | Fail String+ | Done a++-- | The type of a token, which a decoder can ask for at+-- an arbitrary time.+--+-- @since 0.2.0.0+data TokenType+ = TypeUInt+ | TypeUInt64+ | TypeNInt+ | TypeNInt64+ | TypeInteger+ | TypeFloat16+ | TypeFloat32+ | TypeFloat64+ | TypeBytes+ | TypeBytesIndef+ | TypeString+ | TypeStringIndef+ | TypeListLen+ | TypeListLen64+ | TypeListLenIndef+ | TypeMapLen+ | TypeMapLen64+ | TypeMapLenIndef+ | TypeTag+ | TypeTag64+ | TypeBool+ | TypeNull+ | TypeSimple+ | TypeBreak+ | TypeInvalid+ deriving (Eq, Ord, Enum, Bounded, Show)++-- | @since 0.2.0.0+instance Functor (Decoder s) where+ {-# INLINE fmap #-}+ fmap f = \d -> Decoder $ \k -> runDecoder d (k . f)++-- | @since 0.2.0.0+instance Applicative (Decoder s) where+ {-# INLINE pure #-}+ pure = \x -> Decoder $ \k -> k x++ {-# INLINE (<*>) #-}+ (<*>) = \df dx -> Decoder $ \k ->+ runDecoder df (\f -> runDecoder dx (\x -> k (f x)))++ {-# INLINE (*>) #-}+ (*>) = \dm dn -> Decoder $ \k -> runDecoder dm (\_ -> runDecoder dn k)++-- | @since 0.2.0.0+instance Monad (Decoder s) where+ return = pure++ {-# INLINE (>>=) #-}+ (>>=) = \dm f -> Decoder $ \k -> runDecoder dm (\m -> runDecoder (f m) k)++ {-# INLINE (>>) #-}+ (>>) = (*>)++ fail = Fail.fail++-- | @since 0.2.0.0+instance Fail.MonadFail (Decoder s) where+ fail msg = Decoder $ \_ -> return (Fail msg)++liftST :: ST s a -> Decoder s a+liftST m = Decoder $ \k -> m >>= k++-- | Given a @'Decoder'@, give us the @'DecodeAction'@+--+-- @since 0.2.0.0+getDecodeAction :: Decoder s a -> ST s (DecodeAction s a)+getDecodeAction (Decoder k) = k (\x -> return (Done x))+++---------------------------------------+-- Read input tokens of various types+--++-- | Decode a @'Word'@.+--+-- @since 0.2.0.0+decodeWord :: Decoder s Word+decodeWord = Decoder (\k -> return (ConsumeWord (\w# -> k (W# w#))))+{-# INLINE decodeWord #-}++-- | Decode a @'Word8'@.+--+-- @since 0.2.0.0+decodeWord8 :: Decoder s Word8+decodeWord8 = Decoder (\k -> return (ConsumeWord8 (\w# -> k (W8# w#))))+{-# INLINE decodeWord8 #-}++-- | Decode a @'Word16'@.+--+-- @since 0.2.0.0+decodeWord16 :: Decoder s Word16+decodeWord16 = Decoder (\k -> return (ConsumeWord16 (\w# -> k (W16# w#))))+{-# INLINE decodeWord16 #-}++-- | Decode a @'Word32'@.+--+-- @since 0.2.0.0+decodeWord32 :: Decoder s Word32+decodeWord32 = Decoder (\k -> return (ConsumeWord32 (\w# -> k (W32# w#))))+{-# INLINE decodeWord32 #-}++-- | Decode a @'Word64'@.+--+-- @since 0.2.0.0+decodeWord64 :: Decoder s Word64+{-# INLINE decodeWord64 #-}+decodeWord64 =+#if defined(ARCH_64bit)+ Decoder (\k -> return (ConsumeWord (\w# -> k (W64# w#))))+#else+ Decoder (\k -> return (ConsumeWord64 (\w64# -> k (W64# w64#))))+#endif++-- | Decode a negative @'Word'@.+--+-- @since 0.2.0.0+decodeNegWord :: Decoder s Word+decodeNegWord = Decoder (\k -> return (ConsumeNegWord (\w# -> k (W# w#))))+{-# INLINE decodeNegWord #-}++-- | Decode a negative @'Word64'@.+--+-- @since 0.2.0.0+decodeNegWord64 :: Decoder s Word64+{-# INLINE decodeNegWord64 #-}+decodeNegWord64 =+#if defined(ARCH_64bit)+ Decoder (\k -> return (ConsumeNegWord (\w# -> k (W64# w#))))+#else+ Decoder (\k -> return (ConsumeNegWord64 (\w64# -> k (W64# w64#))))+#endif++-- | Decode an @'Int'@.+--+-- @since 0.2.0.0+decodeInt :: Decoder s Int+decodeInt = Decoder (\k -> return (ConsumeInt (\n# -> k (I# n#))))+{-# INLINE decodeInt #-}++-- | Decode an @'Int8'@.+--+-- @since 0.2.0.0+decodeInt8 :: Decoder s Int8+decodeInt8 = Decoder (\k -> return (ConsumeInt8 (\w# -> k (I8# w#))))+{-# INLINE decodeInt8 #-}++-- | Decode an @'Int16'@.+--+-- @since 0.2.0.0+decodeInt16 :: Decoder s Int16+decodeInt16 = Decoder (\k -> return (ConsumeInt16 (\w# -> k (I16# w#))))+{-# INLINE decodeInt16 #-}++-- | Decode an @'Int32'@.+--+-- @since 0.2.0.0+decodeInt32 :: Decoder s Int32+decodeInt32 = Decoder (\k -> return (ConsumeInt32 (\w# -> k (I32# w#))))+{-# INLINE decodeInt32 #-}++-- | Decode an @'Int64'@.+--+-- @since 0.2.0.0+decodeInt64 :: Decoder s Int64+{-# INLINE decodeInt64 #-}+decodeInt64 =+#if defined(ARCH_64bit)+ Decoder (\k -> return (ConsumeInt (\n# -> k (I64# n#))))+#else+ Decoder (\k -> return (ConsumeInt64 (\n64# -> k (I64# n64#))))+#endif++-- | Decode an @'Integer'@.+--+-- @since 0.2.0.0+decodeInteger :: Decoder s Integer+decodeInteger = Decoder (\k -> return (ConsumeInteger (\n -> k n)))+{-# INLINE decodeInteger #-}++-- | Decode a @'Float'@.+--+-- @since 0.2.0.0+decodeFloat :: Decoder s Float+decodeFloat = Decoder (\k -> return (ConsumeFloat (\f# -> k (F# f#))))+{-# INLINE decodeFloat #-}++-- | Decode a @'Double'@.+--+-- @since 0.2.0.0+decodeDouble :: Decoder s Double+decodeDouble = Decoder (\k -> return (ConsumeDouble (\f# -> k (D# f#))))+{-# INLINE decodeDouble #-}++-- | Decode a string of bytes as a @'ByteString'@.+--+-- @since 0.2.0.0+decodeBytes :: Decoder s ByteString+decodeBytes = Decoder (\k -> return (ConsumeBytes (\bs -> k bs)))+{-# INLINE decodeBytes #-}++-- | Decode a token marking the beginning of an indefinite length+-- set of bytes.+--+-- @since 0.2.0.0+decodeBytesIndef :: Decoder s ()+decodeBytesIndef = Decoder (\k -> return (ConsumeBytesIndef (k ())))+{-# INLINE decodeBytesIndef #-}++-- | Decode a textual string as a piece of @'Text'@.+--+-- @since 0.2.0.0+decodeString :: Decoder s Text+decodeString = Decoder (\k -> return (ConsumeString (\str -> k str)))+{-# INLINE decodeString #-}++-- | Decode a token marking the beginning of an indefinite length+-- string.+--+-- @since 0.2.0.0+decodeStringIndef :: Decoder s ()+decodeStringIndef = Decoder (\k -> return (ConsumeStringIndef (k ())))+{-# INLINE decodeStringIndef #-}++-- | Decode the length of a list.+--+-- @since 0.2.0.0+decodeListLen :: Decoder s Int+decodeListLen = Decoder (\k -> return (ConsumeListLen (\n# -> k (I# n#))))+{-# INLINE decodeListLen #-}++-- | Decode a token marking the beginning of a list of indefinite+-- length.+--+-- @since 0.2.0.0+decodeListLenIndef :: Decoder s ()+decodeListLenIndef = Decoder (\k -> return (ConsumeListLenIndef (k ())))+{-# INLINE decodeListLenIndef #-}++-- | Decode the length of a map.+--+-- @since 0.2.0.0+decodeMapLen :: Decoder s Int+decodeMapLen = Decoder (\k -> return (ConsumeMapLen (\n# -> k (I# n#))))+{-# INLINE decodeMapLen #-}++-- | Decode a token marking the beginning of a map of indefinite+-- length.+--+-- @since 0.2.0.0+decodeMapLenIndef :: Decoder s ()+decodeMapLenIndef = Decoder (\k -> return (ConsumeMapLenIndef (k ())))+{-# INLINE decodeMapLenIndef #-}++-- | Decode an arbitrary tag and return it as a @'Word'@.+--+-- @since 0.2.0.0+decodeTag :: Decoder s Word+decodeTag = Decoder (\k -> return (ConsumeTag (\w# -> k (W# w#))))+{-# INLINE decodeTag #-}++-- | Decode an arbitrary 64-bit tag and return it as a @'Word64'@.+--+-- @since 0.2.0.0+decodeTag64 :: Decoder s Word64+{-# INLINE decodeTag64 #-}+decodeTag64 =+#if defined(ARCH_64bit)+ Decoder (\k -> return (ConsumeTag (\w# -> k (W64# w#))))+#else+ Decoder (\k -> return (ConsumeTag64 (\w64# -> k (W64# w64#))))+#endif++-- | Decode a bool.+--+-- @since 0.2.0.0+decodeBool :: Decoder s Bool+decodeBool = Decoder (\k -> return (ConsumeBool (\b -> k b)))+{-# INLINE decodeBool #-}++-- | Decode a nullary value, and return a unit value.+--+-- @since 0.2.0.0+decodeNull :: Decoder s ()+decodeNull = Decoder (\k -> return (ConsumeNull (k ())))+{-# INLINE decodeNull #-}++-- | Decode a 'simple' CBOR value and give back a @'Word8'@. You+-- probably don't ever need to use this.+--+-- @since 0.2.0.0+decodeSimple :: Decoder s Word8+decodeSimple = Decoder (\k -> return (ConsumeSimple (\w# -> k (W8# w#))))+{-# INLINE decodeSimple #-}+++--------------------------------------------------------------+-- Specialised read operations: expect a token with a specific value+--++-- | Attempt to decode a word with @'decodeWord'@, and ensure the word+-- is exactly as expected, or fail.+--+-- @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+{-# INLINE decodeWordOf #-}++-- | Attempt to decode a list length using @'decodeListLen'@, and+-- ensure it is exactly the specified length, or fail.+--+-- @since 0.2.0.0+decodeListLenOf :: Int -> Decoder s ()+decodeListLenOf len = do+ len' <- decodeListLen+ if len == len' then return ()+ else fail $ "expected list of length " ++ show len+{-# INLINE decodeListLenOf #-}+++--------------------------------------------------------------+-- Branching operations++-- | Attempt to decode a token for the length of a finite, known list,+-- or an indefinite list. If @'Nothing'@ is returned, then an+-- indefinite length list occurs afterwords. If @'Just' x@ is+-- returned, then a list of length @x@ is encoded.+--+-- @since 0.2.0.0+decodeListLenOrIndef :: Decoder s (Maybe Int)+decodeListLenOrIndef =+ Decoder (\k -> return (ConsumeListLenOrIndef (\n# ->+ if I# n# >= 0+ then k (Just (I# n#))+ else k Nothing)))+{-# INLINE decodeListLenOrIndef #-}++-- | Attempt to decode a token for the length of a finite, known map,+-- or an indefinite map. If @'Nothing'@ is returned, then an+-- indefinite length map occurs afterwords. If @'Just' x@ is returned,+-- then a map of length @x@ is encoded.+--+-- @since 0.2.0.0+decodeMapLenOrIndef :: Decoder s (Maybe Int)+decodeMapLenOrIndef =+ Decoder (\k -> return (ConsumeMapLenOrIndef (\n# ->+ if I# n# >= 0+ then k (Just (I# n#))+ else k Nothing)))+{-# INLINE decodeMapLenOrIndef #-}++-- | Attempt to decode a @Break@ token, and if that was+-- successful, return @'True'@. If the token was of any+-- other type, return @'False'@.+--+-- @since 0.2.0.0+decodeBreakOr :: Decoder s Bool+decodeBreakOr = Decoder (\k -> return (ConsumeBreakOr (\b -> k b)))+{-# INLINE decodeBreakOr #-}++--------------------------------------------------------------+-- Special operations++-- | Peek at the current token we're about to decode, and return a+-- @'TokenType'@ specifying what it is.+--+-- @since 0.2.0.0+peekTokenType :: Decoder s TokenType+peekTokenType = Decoder (\k -> return (PeekTokenType (\tk -> k tk)))+{-# INLINE peekTokenType #-}++-- | Peek and return the length of the current buffer that we're+-- running our decoder on.+--+-- @since 0.2.0.0+peekAvailable :: Decoder s Int+peekAvailable = Decoder (\k -> return (PeekAvailable (\len# -> k (I# len#))))+{-# INLINE peekAvailable #-}++{-+expectExactly :: Word -> Decoder (Word :#: s) s+expectExactly n = expectExactly_ n done++expectAtLeast :: Word -> Decoder (Word :#: s) (Word :#: s)+expectAtLeast n = expectAtLeast_ n done++ignoreTrailingTerms :: Decoder (a :*: Word :#: s) (a :*: s)+ignoreTrailingTerms = IgnoreTerms done+-}++------------------------------------------------------------------------------+-- Special combinations for sequences+--++-- | Decode an indefinite sequence length.+--+-- @since 0.2.0.0+decodeSequenceLenIndef :: (r -> a -> r)+ -> r+ -> (r -> r')+ -> Decoder s a+ -> Decoder s r'+decodeSequenceLenIndef f z g get =+ go z+ where+ go !acc = do+ stop <- decodeBreakOr+ if stop then return $! g acc+ else do !x <- get; go (f acc x)+{-# INLINE decodeSequenceLenIndef #-}++-- | Decode a sequence length.+--+-- @since 0.2.0.0+decodeSequenceLenN :: (r -> a -> r)+ -> r+ -> (r -> r')+ -> Int+ -> Decoder s a+ -> Decoder s r'+decodeSequenceLenN f z g c get =+ go z c+ where+ go !acc 0 = return $! g acc+ go !acc n = do !x <- get; go (f acc x) (n-1)+{-# INLINE decodeSequenceLenN #-}+
+ src/Codec/CBOR/Encoding.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE CPP #-}++-- |+-- Module : Codec.CBOR.Encoding+-- Copyright : (c) Duncan Coutts 2015-2017+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : duncan@community.haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- High level API for encoding values, for later serialization into+-- CBOR binary format, using a @'Monoid'@ based interface.+--+module Codec.CBOR.Encoding+ ( -- * Encoding implementation+ Encoding(..) -- :: *+ , Tokens(..) -- :: *++ -- * @'Encoding'@ API for serialisation+ , encodeWord -- :: Word -> Encoding+ , encodeWord8 -- :: Word8 -> Encoding+ , encodeWord16 -- :: Word16 -> Encoding+ , encodeWord32 -- :: Word32 -> Encoding+ , encodeWord64 -- :: Word64 -> Encoding+ , encodeInt -- :: Int -> Encoding+ , encodeInt8 -- :: Int8 -> Encoding+ , encodeInt16 -- :: Int16 -> Encoding+ , encodeInt32 -- :: Int32 -> Encoding+ , encodeInt64 -- :: Int64 -> Encoding+ , encodeInteger -- :: Integer -> Encoding+ , encodeBytes -- :: B.ByteString -> Encoding+ , encodeBytesIndef -- :: Encoding+ , encodeString -- :: T.Text -> Encoding+ , encodeStringIndef -- :: Encoding+ , encodeListLen -- :: Word -> Encoding+ , encodeListLenIndef -- :: Encoding+ , encodeMapLen -- :: Word -> Encoding+ , encodeMapLenIndef -- :: Encoding+ , encodeBreak -- :: Encoding+ , encodeTag -- :: Word -> Encoding+ , encodeTag64 -- :: Word64 -> Encoding+ , encodeBool -- :: Bool -> Encoding+ , encodeUndef -- :: Encoding+ , encodeNull -- :: Encoding+ , encodeSimple -- :: Word8 -> Encoding+ , encodeFloat16 -- :: Float -> Encoding+ , encodeFloat -- :: Float -> Encoding+ , encodeDouble -- :: Double -> Encoding+ ) where++#include "cbor.h"++import Data.Int+import Data.Word+import Data.Semigroup++import qualified Data.ByteString as B+import qualified Data.Text as T++import Prelude hiding (encodeFloat)++import {-# SOURCE #-} qualified Codec.CBOR.FlatTerm as FlatTerm++-- | An intermediate form used during serialisation, specified as a+-- @'Monoid'@. It supports efficient concatenation, and is equivalent+-- to a specialised @'Data.Monoid.Endo' 'Tokens'@ type.+--+-- It is used for the stage in serialisation where we flatten out the+-- Haskell data structure but it is independent of any specific+-- external binary or text format.+--+-- Traditionally, to build any arbitrary @'Encoding'@ value, you specify+-- larger structures from smaller ones and append the small ones together+-- using @'Data.Monoid.mconcat'@.+--+-- @since 0.2.0.0+newtype Encoding = Encoding (Tokens -> Tokens)++instance Show Encoding where+ show = show . FlatTerm.toFlatTerm++-- | A flattened representation of a term, which is independent+-- of any underlying binary representation, but which we later+-- serialise into CBOR format.+--+-- @since 0.2.0.0+data Tokens =++ -- Positive and negative integers (type 0,1)+ TkWord {-# UNPACK #-} !Word Tokens+ | TkWord64 {-# UNPACK #-} !Word64 Tokens+ -- convenience for either positive or negative+ | TkInt {-# UNPACK #-} !Int Tokens+ | TkInt64 {-# UNPACK #-} !Int64 Tokens++ -- Bytes and string (type 2,3)+ | TkBytes {-# UNPACK #-} !B.ByteString Tokens+ | TkBytesBegin Tokens+ | TkString {-# UNPACK #-} !T.Text Tokens+ | TkStringBegin Tokens++ -- Structures (type 4,5)+ | TkListLen {-# UNPACK #-} !Word Tokens+ | TkListBegin Tokens+ | TkMapLen {-# UNPACK #-} !Word Tokens+ | TkMapBegin Tokens++ -- Tagged values (type 6)+ | TkTag {-# UNPACK #-} !Word Tokens+ | TkTag64 {-# UNPACK #-} !Word64 Tokens+ | TkInteger !Integer Tokens++ -- Simple and floats (type 7)+ | TkNull Tokens+ | TkUndef Tokens+ | TkBool !Bool Tokens+ | TkSimple {-# UNPACK #-} !Word8 Tokens+ | TkFloat16 {-# UNPACK #-} !Float Tokens+ | TkFloat32 {-# UNPACK #-} !Float Tokens+ | TkFloat64 {-# UNPACK #-} !Double Tokens+ | TkBreak Tokens++ | TkEnd+ deriving (Show,Eq)++-- | @since 0.2.0.0+instance Semigroup Encoding where+ Encoding b1 <> Encoding b2 = Encoding (\ts -> b1 (b2 ts))+ {-# INLINE (<>) #-}++-- | @since 0.2.0.0+instance Monoid Encoding where+ mempty = Encoding (\ts -> ts)+ {-# INLINE mempty #-}++ mappend = (<>)+ {-# INLINE mappend #-}++ mconcat = foldr (<>) mempty+ {-# INLINE mconcat #-}++-- | Encode a @'Word'@ in a flattened format.+--+-- @since 0.2.0.0+encodeWord :: Word -> Encoding+encodeWord = Encoding . TkWord++-- | Encode a @'Word8'@ in a flattened format.+--+-- @since 0.2.0.0+encodeWord8 :: Word8 -> Encoding+encodeWord8 = Encoding . TkWord . fromIntegral++-- | Encode a @'Word16'@ in a flattened format.+--+-- @since 0.2.0.0+encodeWord16 :: Word16 -> Encoding+encodeWord16 = Encoding . TkWord . fromIntegral++-- | Encode a @'Word32'@ in a flattened format.+--+-- @since 0.2.0.0+encodeWord32 :: Word32 -> Encoding+encodeWord32 = Encoding . TkWord . fromIntegral++-- | Encode a @'Word64'@ in a flattened format.+--+-- @since 0.2.0.0+encodeWord64 :: Word64 -> Encoding+encodeWord64 = Encoding . TkWord64++-- | Encode an @'Int'@ in a flattened format.+--+-- @since 0.2.0.0+encodeInt :: Int -> Encoding+encodeInt = Encoding . TkInt++-- | Encode an @'Int8'@ in a flattened format.+--+-- @since 0.2.0.0+encodeInt8 :: Int8 -> Encoding+encodeInt8 = Encoding . TkInt . fromIntegral++-- | Encode an @'Int16'@ in a flattened format.+--+-- @since 0.2.0.0+encodeInt16 :: Int16 -> Encoding+encodeInt16 = Encoding . TkInt . fromIntegral++-- | Encode an @'Int32'@ in a flattened format.+--+-- @since 0.2.0.0+encodeInt32 :: Int32 -> Encoding+encodeInt32 = Encoding . TkInt . fromIntegral++-- | Encode an @'Int64' in a flattened format.+--+-- @since 0.2.0.0+encodeInt64 :: Int64 -> Encoding+encodeInt64 = Encoding . TkInt64++-- | Encode an arbitrarily large @'Integer' in a+-- flattened format.+--+-- @since 0.2.0.0+encodeInteger :: Integer -> Encoding+encodeInteger n = Encoding (TkInteger n)++-- | Encode an arbitrary strict @'B.ByteString'@ in+-- a flattened format.+--+-- @since 0.2.0.0+encodeBytes :: B.ByteString -> Encoding+encodeBytes = Encoding . TkBytes++-- | 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+-- overall string. After all the bytes desired have been encoded, you+-- should follow it with a break token (see @'encodeBreak'@).+--+-- @since 0.2.0.0+encodeBytesIndef :: Encoding+encodeBytesIndef = Encoding TkBytesBegin++-- | Encode a @'T.Text'@ in a flattened format.+--+-- @since 0.2.0.0+encodeString :: T.Text -> Encoding+encodeString = Encoding . TkString++-- | Encode the beginning of an indefinite string.+--+-- @since 0.2.0.0+encodeStringIndef :: Encoding+encodeStringIndef = Encoding TkStringBegin++-- | Encode the length of a list, used to indicate that the following+-- tokens represent the list values.+--+-- @since 0.2.0.0+encodeListLen :: Word -> Encoding+encodeListLen = Encoding . TkListLen++-- | Encode a token specifying that this is the beginning of an+-- indefinite list of unknown size. Tokens representing the list are+-- expected afterwords, followed by a break token (see+-- @'encodeBreak'@) when the list has ended.+--+-- @since 0.2.0.0+encodeListLenIndef :: Encoding+encodeListLenIndef = Encoding TkListBegin++-- | Encode the length of a Map, used to indicate that+-- the following tokens represent the map values.+--+-- @since 0.2.0.0+encodeMapLen :: Word -> Encoding+encodeMapLen = Encoding . TkMapLen++-- | Encode a token specifying that this is the beginning of an+-- indefinite map of unknown size. Tokens representing the map are+-- expected afterwords, followed by a break token (see+-- @'encodeBreak'@) when the map has ended.+--+-- @since 0.2.0.0+encodeMapLenIndef :: Encoding+encodeMapLenIndef = Encoding TkMapBegin++-- | Encode a \'break\', used to specify the end of indefinite+-- length objects like maps or lists.+--+-- @since 0.2.0.0+encodeBreak :: Encoding+encodeBreak = Encoding TkBreak++-- | Encode an arbitrary @'Word'@ tag.+--+-- @since 0.2.0.0+encodeTag :: Word -> Encoding+encodeTag = Encoding . TkTag++-- | Encode an arbitrary 64-bit @'Word64'@ tag.+--+-- @since 0.2.0.0+encodeTag64 :: Word64 -> Encoding+encodeTag64 = Encoding . TkTag64++-- | Encode a @'Bool'@.+--+-- @since 0.2.0.0+encodeBool :: Bool -> Encoding+encodeBool b = Encoding (TkBool b)++-- | Encode an @Undef@ value.+--+-- @since 0.2.0.0+encodeUndef :: Encoding+encodeUndef = Encoding TkUndef++-- | Encode a @Null@ value.+--+-- @since 0.2.0.0+encodeNull :: Encoding+encodeNull = Encoding TkNull++-- | Encode a \'simple\' CBOR token that can be represented with an+-- 8-bit word. You probably don't ever need this.+--+-- @since 0.2.0.0+encodeSimple :: Word8 -> Encoding+encodeSimple = Encoding . TkSimple++-- | Encode a small 16-bit @'Float'@ in a flattened format.+--+-- @since 0.2.0.0+encodeFloat16 :: Float -> Encoding+encodeFloat16 = Encoding . TkFloat16++-- | Encode a full precision @'Float'@ in a flattened format.+--+-- @since 0.2.0.0+encodeFloat :: Float -> Encoding+encodeFloat = Encoding . TkFloat32++-- | Encode a @'Double'@ in a flattened format.+--+-- @since 0.2.0.0+encodeDouble :: Double -> Encoding+encodeDouble = Encoding . TkFloat64
+ src/Codec/CBOR/Encoding.hs-boot view
@@ -0,0 +1,5 @@+module Codec.CBOR.Encoding where++newtype Encoding = Encoding (Tokens -> Tokens)++data Tokens
+ src/Codec/CBOR/FlatTerm.hs view
@@ -0,0 +1,486 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module : Codec.CBOR.FlatTerm+-- Copyright : (c) Duncan Coutts 2015-2017+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : duncan@community.haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- A simpler form than CBOR for writing out @'Enc.Encoding'@ values that allows+-- easier verification and testing. While this library primarily focuses+-- on taking @'Enc.Encoding'@ values (independent of any underlying format)+-- and serializing them into CBOR format, this module offers an alternative+-- format called @'FlatTerm'@ for serializing @'Enc.Encoding'@ values.+--+-- The @'FlatTerm'@ form is very simple and internally mirrors the original+-- @'Encoding'@ type very carefully. The intention here is that once you+-- have @'Enc.Encoding'@ and @'Dec.Decoding'@ values for your types, you can+-- round-trip values through @'FlatTerm'@ to catch bugs more easily and with+-- a smaller amount of code to look through.+--+-- For that reason, this module is primarily useful for client libraries,+-- and even then, only for their test suites to offer a simpler form for+-- doing encoding tests and catching problems in an encoder and decoder.+--+module Codec.CBOR.FlatTerm+ ( -- * Types+ FlatTerm -- :: *+ , TermToken(..) -- :: *++ -- * Functions+ , toFlatTerm -- :: Encoding -> FlatTerm+ , fromFlatTerm -- :: Decoder s a -> FlatTerm -> Either String a+ , validFlatTerm -- :: FlatTerm -> Bool+ ) where++#include "cbor.h"++import Codec.CBOR.Encoding (Encoding(..))+import qualified Codec.CBOR.Encoding as Enc+import Codec.CBOR.Decoding as Dec++import Data.Int+#if defined(ARCH_32bit)+import GHC.Int (Int64(I64#))+import GHC.Word (Word64(W64#))+import GHC.Exts (Word64#, Int64#)+#endif+import GHC.Word (Word(W#), Word8(W8#))+import GHC.Exts (Int(I#), Int#, Word#, Float#, Double#)+import GHC.Float (Float(F#), Double(D#), float2Double)++import Data.Word+import Data.Text (Text)+import Data.ByteString (ByteString)+import Control.Monad.ST+++--------------------------------------------------------------------------------++-- | A "flat" representation of an @'Enc.Encoding'@ value,+-- useful for round-tripping and writing tests.+--+-- @since 0.2.0.0+type FlatTerm = [TermToken]++-- | A concrete encoding of @'Enc.Encoding'@ values, one+-- which mirrors the original @'Enc.Encoding'@ type closely.+--+-- @since 0.2.0.0+data TermToken+ = TkInt {-# UNPACK #-} !Int+ | TkInteger !Integer+ | TkBytes {-# UNPACK #-} !ByteString+ | TkBytesBegin+ | TkString {-# UNPACK #-} !Text+ | TkStringBegin+ | TkListLen {-# UNPACK #-} !Word+ | TkListBegin+ | TkMapLen {-# UNPACK #-} !Word+ | TkMapBegin+ | TkBreak+ | TkTag {-# UNPACK #-} !Word64+ | TkBool !Bool+ | TkNull+ | TkSimple {-# UNPACK #-} !Word8+ | TkFloat16 {-# UNPACK #-} !Float+ | TkFloat32 {-# UNPACK #-} !Float+ | TkFloat64 {-# UNPACK #-} !Double+ deriving (Eq, Ord, Show)++--------------------------------------------------------------------------------++-- | Convert an arbitrary @'Enc.Encoding'@ into a @'FlatTerm'@.+--+-- @since 0.2.0.0+toFlatTerm :: Encoding -- ^ The input @'Enc.Encoding'@.+ -> FlatTerm -- ^ The resulting @'FlatTerm'@.+toFlatTerm (Encoding tb) = convFlatTerm (tb Enc.TkEnd)++convFlatTerm :: Enc.Tokens -> FlatTerm+convFlatTerm (Enc.TkWord w ts)+ | w <= maxInt = TkInt (fromIntegral w) : convFlatTerm ts+ | otherwise = TkInteger (fromIntegral w) : convFlatTerm ts+convFlatTerm (Enc.TkWord64 w ts)+ | w <= maxInt = TkInt (fromIntegral w) : convFlatTerm ts+ | otherwise = TkInteger (fromIntegral w) : convFlatTerm ts+convFlatTerm (Enc.TkInt n ts) = TkInt n : convFlatTerm ts+convFlatTerm (Enc.TkInt64 n ts)+ | n <= maxInt && n >= minInt = TkInt (fromIntegral n) : convFlatTerm ts+ | otherwise = TkInteger (fromIntegral n) : convFlatTerm ts+convFlatTerm (Enc.TkInteger n ts)+ | n <= maxInt && n >= minInt = TkInt (fromIntegral n) : convFlatTerm ts+ | otherwise = TkInteger n : convFlatTerm ts+convFlatTerm (Enc.TkBytes bs ts) = TkBytes bs : convFlatTerm ts+convFlatTerm (Enc.TkBytesBegin ts) = TkBytesBegin : convFlatTerm ts+convFlatTerm (Enc.TkString st ts) = TkString st : convFlatTerm ts+convFlatTerm (Enc.TkStringBegin ts) = TkStringBegin : 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+convFlatTerm (Enc.TkMapBegin ts) = TkMapBegin : convFlatTerm ts+convFlatTerm (Enc.TkTag n ts) = TkTag (fromIntegral n) : convFlatTerm ts+convFlatTerm (Enc.TkTag64 n ts) = TkTag n : convFlatTerm ts+convFlatTerm (Enc.TkBool b ts) = TkBool b : convFlatTerm ts+convFlatTerm (Enc.TkNull ts) = TkNull : convFlatTerm ts+convFlatTerm (Enc.TkUndef ts) = TkSimple 23 : convFlatTerm ts+convFlatTerm (Enc.TkSimple n ts) = TkSimple n : convFlatTerm ts+convFlatTerm (Enc.TkFloat16 f ts) = TkFloat16 f : convFlatTerm ts+convFlatTerm (Enc.TkFloat32 f ts) = TkFloat32 f : convFlatTerm ts+convFlatTerm (Enc.TkFloat64 f ts) = TkFloat64 f : convFlatTerm ts+convFlatTerm (Enc.TkBreak ts) = TkBreak : convFlatTerm ts+convFlatTerm Enc.TkEnd = []++--------------------------------------------------------------------------------++-- | Given a @'Dec.Decoder'@, decode a @'FlatTerm'@ back into+-- an ordinary value, or return an error.+--+-- @since 0.2.0.0+fromFlatTerm :: (forall s. Decoder s a)+ -- ^ A @'Dec.Decoder'@ for a serialised value.+ -> FlatTerm -- ^ The serialised @'FlatTerm'@.+ -> Either String a -- ^ The deserialised value, or an error.+fromFlatTerm decoder ft =+ runST (getDecodeAction decoder >>= go ft)+ where+ go :: FlatTerm -> DecodeAction s a -> ST s (Either String a)+ go (TkInt n : ts) (ConsumeWord k)+ | n >= 0 = k (unW# (fromIntegral n)) >>= go ts+ go (TkInteger n : ts) (ConsumeWord k)+ | n >= 0 = k (unW# (fromIntegral n)) >>= go ts+ go (TkInt n : ts) (ConsumeWord8 k)+ | n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts+ go (TkInteger n : ts) (ConsumeWord8 k)+ | n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts+ go (TkInt n : ts) (ConsumeWord16 k)+ | n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts+ go (TkInteger n : ts) (ConsumeWord16 k)+ | n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts+ go (TkInt n : ts) (ConsumeWord32 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) (ConsumeWord32 k)+ | n >= 0 && n <= maxWord32 = k (unW# (fromIntegral n)) >>= go ts+ go (TkInt n : ts) (ConsumeNegWord k)+ | n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts+ go (TkInteger n : ts) (ConsumeNegWord k)+ | n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts+ go (TkInt n : ts) (ConsumeInt k) = k (unI# n) >>= go ts+ go (TkInteger n : ts) (ConsumeInt k)+ | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts+ go (TkInt n : ts) (ConsumeInt8 k)+ | n >= minInt8 && n <= maxInt8 = k (unI# n) >>= go ts+ go (TkInteger n : ts) (ConsumeInt8 k)+ | n >= minInt8 && n <= maxInt8 = k (unI# (fromIntegral n)) >>= go ts+ go (TkInt n : ts) (ConsumeInt16 k)+ | n >= minInt16 && n <= maxInt16 = k (unI# n) >>= go ts+ go (TkInteger n : ts) (ConsumeInt16 k)+ | n >= minInt16 && n <= maxInt16 = k (unI# (fromIntegral n)) >>= go ts+ go (TkInt n : ts) (ConsumeInt32 k)+ | n >= minInt32 && n <= maxInt32 = k (unI# n) >>= go ts+ go (TkInteger n : ts) (ConsumeInt32 k)+ | n >= minInt32 && n <= maxInt32 = k (unI# (fromIntegral n)) >>= go ts+ go (TkInt n : ts) (ConsumeInteger k) = k (fromIntegral n) >>= go ts+ go (TkInteger n : ts) (ConsumeInteger k) = k n >>= go ts+ go (TkListLen n : ts) (ConsumeListLen k)+ | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts+ go (TkMapLen n : ts) (ConsumeMapLen k)+ | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts+ go (TkTag n : ts) (ConsumeTag k)+ | n <= maxWord = k (unW# (fromIntegral n)) >>= go ts++#if defined(ARCH_32bit)+ -- 64bit variants for 32bit machines+ go (TkInt n : ts) (ConsumeWord64 k)+ | n >= 0 = k (unW64# (fromIntegral n)) >>= go ts+ go (TkInteger n : ts) (ConsumeWord64 k)+ | n >= 0 = k (unW64# (fromIntegral n)) >>= go ts+ go (TkInt n : ts) (ConsumeNegWord64 k)+ | n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts+ go (TkInteger n : ts) (ConsumeNegWord64 k)+ | n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts++ go (TkInt n : ts) (ConsumeInt64 k) = k (unI64# (fromIntegral n)) >>= go ts+ go (TkInteger n : ts) (ConsumeInt64 k) = k (unI64# (fromIntegral n)) >>= go ts++ go (TkTag n : ts) (ConsumeTag64 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+#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 (TkBytesBegin : ts) (ConsumeBytesIndef da) = da >>= go ts+ go (TkStringBegin : ts) (ConsumeStringIndef da) = da >>= go ts+ go (TkListBegin : ts) (ConsumeListLenIndef da) = da >>= go ts+ go (TkMapBegin : ts) (ConsumeMapLenIndef da) = da >>= go ts+ go (TkNull : ts) (ConsumeNull da) = da >>= go ts++ go (TkListLen n : ts) (ConsumeListLenOrIndef k)+ | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts+ go (TkListBegin : ts) (ConsumeListLenOrIndef k) = k (-1#) >>= go ts+ go (TkMapLen n : ts) (ConsumeMapLenOrIndef k)+ | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts+ go (TkMapBegin : ts) (ConsumeMapLenOrIndef k) = k (-1#) >>= go ts+ go (TkBreak : ts) (ConsumeBreakOr k) = k True >>= go ts+ go ts@(_ : _ ) (ConsumeBreakOr k) = k False >>= go ts++ go ts@(tk:_) (PeekTokenType k) = k (tokenTypeOf tk) >>= go ts+ go ts (PeekTokenType _) = unexpected "peekTokenType" ts+ go ts (PeekAvailable k) = k (unI# (length ts)) >>= go ts++ go _ (Fail msg) = return $ Left msg+ go [] (Done x) = return $ Right x+ go ts (Done _) = return $ Left ("trailing tokens: " ++ show (take 5 ts))++ ----------------------------------------------------------------------------+ -- Fallthrough cases: unhandled token/DecodeAction combinations++ go ts (ConsumeWord _) = unexpected "decodeWord" ts+ go ts (ConsumeWord8 _) = unexpected "decodeWord8" ts+ go ts (ConsumeWord16 _) = unexpected "decodeWord16" ts+ go ts (ConsumeWord32 _) = unexpected "decodeWord32" ts+ go ts (ConsumeNegWord _) = unexpected "decodeNegWord" ts+ go ts (ConsumeInt _) = unexpected "decodeInt" ts+ go ts (ConsumeInt8 _) = unexpected "decodeInt8" ts+ go ts (ConsumeInt16 _) = unexpected "decodeInt16" ts+ go ts (ConsumeInt32 _) = unexpected "decodeInt32" ts+ go ts (ConsumeInteger _) = unexpected "decodeInteger" ts++ go ts (ConsumeListLen _) = unexpected "decodeListLen" ts+ go ts (ConsumeMapLen _) = unexpected "decodeMapLen" ts+ go ts (ConsumeTag _) = unexpected "decodeTag" ts++ go ts (ConsumeFloat _) = unexpected "decodeFloat" ts+ go ts (ConsumeDouble _) = unexpected "decodeDouble" ts+ go ts (ConsumeBytes _) = unexpected "decodeBytes" ts+ go ts (ConsumeString _) = unexpected "decodeString" ts+ go ts (ConsumeBool _) = unexpected "decodeBool" ts+ go ts (ConsumeSimple _) = unexpected "decodeSimple" ts++#if defined(ARCH_32bit)+ -- 64bit variants for 32bit machines+ go ts (ConsumeWord64 _) = unexpected "decodeWord64" ts+ go ts (ConsumeNegWord64 _) = unexpected "decodeNegWord64" ts+ go ts (ConsumeInt64 _) = unexpected "decodeInt64" ts+ go ts (ConsumeTag64 _) = unexpected "decodeTag64" ts+ --go ts (ConsumeListLen64 _) = unexpected "decodeListLen64" ts+ --go ts (ConsumeMapLen64 _) = unexpected "decodeMapLen64" ts+#endif++ go ts (ConsumeBytesIndef _) = unexpected "decodeBytesIndef" ts+ go ts (ConsumeStringIndef _) = unexpected "decodeStringIndef" ts+ go ts (ConsumeListLenIndef _) = unexpected "decodeListLenIndef" ts+ go ts (ConsumeMapLenIndef _) = unexpected "decodeMapLenIndef" ts+ go ts (ConsumeNull _) = unexpected "decodeNull" ts++ go ts (ConsumeListLenOrIndef _) = unexpected "decodeListLenOrIndef" ts+ go ts (ConsumeMapLenOrIndef _) = unexpected "decodeMapLenOrIndef" ts+ go ts (ConsumeBreakOr _) = unexpected "decodeBreakOr" ts++ unexpected name [] = return $ Left $ name ++ ": unexpected end of input"+ unexpected name (tok:_) = return $ Left $ name ++ ": unexpected token " ++ show tok++-- | Map a @'TermToken'@ to the underlying CBOR @'TokenType'@+tokenTypeOf :: TermToken -> TokenType+tokenTypeOf (TkInt n)+ | n >= 0 = TypeUInt+ | otherwise = TypeNInt+tokenTypeOf TkInteger{} = TypeInteger+tokenTypeOf TkBytes{} = TypeBytes+tokenTypeOf TkBytesBegin{} = TypeBytesIndef+tokenTypeOf TkString{} = TypeString+tokenTypeOf TkStringBegin{} = TypeStringIndef+tokenTypeOf TkListLen{} = TypeListLen+tokenTypeOf TkListBegin{} = TypeListLenIndef+tokenTypeOf TkMapLen{} = TypeMapLen+tokenTypeOf TkMapBegin{} = TypeMapLenIndef+tokenTypeOf TkTag{} = TypeTag+tokenTypeOf TkBool{} = TypeBool+tokenTypeOf TkNull = TypeNull+tokenTypeOf TkBreak = TypeBreak+tokenTypeOf TkSimple{} = TypeSimple+tokenTypeOf TkFloat16{} = TypeFloat16+tokenTypeOf TkFloat32{} = TypeFloat32+tokenTypeOf TkFloat64{} = TypeFloat64++--------------------------------------------------------------------------------++-- | Ensure a @'FlatTerm'@ is internally consistent and was created in a valid+-- manner.+--+-- @since 0.2.0.0+validFlatTerm :: FlatTerm -- ^ The input @'FlatTerm'@+ -> Bool -- ^ @'True'@ if valid, @'False'@ otherwise.+validFlatTerm ts =+ either (const False) (const True) $ do+ ts' <- validateTerm TopLevelSingle ts+ case ts' of+ [] -> return ()+ _ -> Left "trailing data"++-- | A data type used for tracking the position we're at+-- as we traverse a @'FlatTerm'@ and make sure it's valid.+data Loc = TopLevelSingle+ | TopLevelSequence+ | InString Int Loc+ | InBytes Int Loc+ | InListN Int Int Loc+ | InList Int Loc+ | InMapNKey Int Int Loc+ | InMapNVal Int Int Loc+ | InMapKey Int Loc+ | InMapVal Int Loc+ | InTagged Word64 Loc+ deriving Show++-- | Validate an arbitrary @'FlatTerm'@ at an arbitrary location.+validateTerm :: Loc -> FlatTerm -> Either String FlatTerm+validateTerm _loc (TkInt _ : ts) = return ts+validateTerm _loc (TkInteger _ : ts) = return ts+validateTerm _loc (TkBytes _ : ts) = return ts+validateTerm loc (TkBytesBegin : ts) = validateBytes loc 0 ts+validateTerm _loc (TkString _ : ts) = return ts+validateTerm loc (TkStringBegin : ts) = validateString loc 0 ts+validateTerm loc (TkListLen len : ts)+ | len <= maxInt = validateListN loc 0 (fromIntegral len) ts+ | otherwise = Left "list len too long (> max int)"+validateTerm loc (TkListBegin : ts) = validateList loc 0 ts+validateTerm loc (TkMapLen len : ts)+ | len <= maxInt = validateMapN loc 0 (fromIntegral len) ts+ | otherwise = Left "map len too long (> max int)"+validateTerm loc (TkMapBegin : ts) = validateMap loc 0 ts+validateTerm loc (TkTag w : ts) = validateTerm (InTagged w loc) ts+validateTerm _loc (TkBool _ : ts) = return ts+validateTerm _loc (TkNull : ts) = return ts+validateTerm loc (TkBreak : _) = unexpectedToken TkBreak loc+validateTerm _loc (TkSimple _ : ts) = return ts+validateTerm _loc (TkFloat16 _ : ts) = return ts+validateTerm _loc (TkFloat32 _ : ts) = return ts+validateTerm _loc (TkFloat64 _ : ts) = return ts+validateTerm loc [] = unexpectedEof loc++unexpectedToken :: TermToken -> Loc -> Either String a+unexpectedToken tok loc = Left $ "unexpected token " ++ show tok+ ++ ", in context " ++ show loc++unexpectedEof :: Loc -> Either String a+unexpectedEof loc = Left $ "unexpected end of input in context " ++ show loc++validateBytes :: Loc -> Int -> [TermToken] -> Either String [TermToken]+validateBytes _ _ (TkBreak : ts) = return ts+validateBytes ploc i (TkBytes _ : ts) = validateBytes ploc (i+1) ts+validateBytes ploc i (tok : _) = unexpectedToken tok (InBytes i ploc)+validateBytes ploc i [] = unexpectedEof (InBytes i ploc)++validateString :: Loc -> Int -> [TermToken] -> Either String [TermToken]+validateString _ _ (TkBreak : ts) = return ts+validateString ploc i (TkString _ : ts) = validateString ploc (i+1) ts+validateString ploc i (tok : _) = unexpectedToken tok (InString i ploc)+validateString ploc i [] = unexpectedEof (InString i ploc)++validateListN :: Loc -> Int -> Int -> [TermToken] -> Either String [TermToken]+validateListN _ i len ts | i == len = return ts+validateListN ploc i len ts = do+ ts' <- validateTerm (InListN i len ploc) ts+ validateListN ploc (i+1) len ts'++validateList :: Loc -> Int -> [TermToken] -> Either String [TermToken]+validateList _ _ (TkBreak : ts) = return ts+validateList ploc i ts = do+ ts' <- validateTerm (InList i ploc) ts+ validateList ploc (i+1) ts'++validateMapN :: Loc -> Int -> Int -> [TermToken] -> Either String [TermToken]+validateMapN _ i len ts | i == len = return ts+validateMapN ploc i len ts = do+ ts' <- validateTerm (InMapNKey i len ploc) ts+ ts'' <- validateTerm (InMapNVal i len ploc) ts'+ validateMapN ploc (i+1) len ts''++validateMap :: Loc -> Int -> [TermToken] -> Either String [TermToken]+validateMap _ _ (TkBreak : ts) = return ts+validateMap ploc i ts = do+ ts' <- validateTerm (InMapKey i ploc) ts+ ts'' <- validateTerm (InMapVal i ploc) ts'+ validateMap ploc (i+1) ts''++--------------------------------------------------------------------------------+-- Utilities++maxInt, minInt, maxWord :: Num n => n+maxInt = fromIntegral (maxBound :: Int)+minInt = fromIntegral (minBound :: Int)+maxWord = fromIntegral (maxBound :: Word)++maxInt8, minInt8, maxWord8 :: Num n => n+maxInt8 = fromIntegral (maxBound :: Int8)+minInt8 = fromIntegral (minBound :: Int8)+maxWord8 = fromIntegral (maxBound :: Word8)++maxInt16, minInt16, maxWord16 :: Num n => n+maxInt16 = fromIntegral (maxBound :: Int16)+minInt16 = fromIntegral (minBound :: Int16)+maxWord16 = fromIntegral (maxBound :: Word16)++maxInt32, minInt32, maxWord32 :: Num n => n+maxInt32 = fromIntegral (maxBound :: Int32)+minInt32 = fromIntegral (minBound :: Int32)+maxWord32 = fromIntegral (maxBound :: Word32)++-- | Do a careful check to ensure an @'Int'@ is in the+-- range of a @'Word32'@.+intIsValidWord32 :: Int -> Bool+intIsValidWord32 n = b1 && b2+ where+ -- NOTE: this first comparison must use Int for+ -- the check, not Word32, in case a negative value+ -- is given. Otherwise this check would fail due to+ -- overflow.+ b1 = n >= 0+ -- NOTE: we must convert n to Word32, otherwise,+ -- maxWord32 is inferred as Int, and because+ -- the maxBound of Word32 is greater than Int,+ -- it overflows and this check fails.+ b2 = (fromIntegral n :: Word32) <= maxWord32++unI# :: Int -> Int#+unI# (I# i#) = i#++unW# :: Word -> Word#+unW# (W# w#) = w#++unW8# :: Word8 -> Word#+unW8# (W8# w#) = w#++unF# :: Float -> Float#+unF# (F# f#) = f#++unD# :: Double -> Double#+unD# (D# f#) = f#++#if defined(ARCH_32bit)+unW64# :: Word64 -> Word64#+unW64# (W64# w#) = w#++unI64# :: Int64 -> Int64#+unI64# (I64# i#) = i#+#endif
+ src/Codec/CBOR/FlatTerm.hs-boot view
@@ -0,0 +1,10 @@+module Codec.CBOR.FlatTerm where++import {-# SOURCE #-} Codec.CBOR.Encoding++type FlatTerm = [TermToken]++data TermToken+instance Show TermToken++toFlatTerm :: Encoding -> FlatTerm
+ src/Codec/CBOR/Magic.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module : Codec.CBOR.Magic+-- Copyright : (c) Duncan Coutts 2015-2017+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : duncan@community.haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- An internal module for doing magical, low-level, and unholy things+-- in the name of efficiency.+--+module Codec.CBOR.Magic+ ( -- * Word utilities+ grabWord8 -- :: Ptr () -> Word+ , grabWord16 -- :: Ptr () -> Word+ , grabWord32 -- :: Ptr () -> Word+ , grabWord64 -- :: Ptr () -> Word64++ -- * @'ByteString'@ utilities+ , eatTailWord8 -- :: ByteString -> Word+ , eatTailWord16 -- :: ByteString -> Word+ , eatTailWord32 -- :: ByteString -> Word+ , eatTailWord64 -- :: ByteString -> Word64++ -- * Half-floats+ , wordToFloat16 -- :: Word -> Float+ , floatToWord16 -- :: Float -> Word16++ -- * Float\/Word conversion+ , wordToFloat32 -- :: Word -> Float+ , wordToFloat64 -- :: Word64 -> Double++ -- * @'Integer'@ utilities+ , nintegerFromBytes -- :: ByteString -> Integer+ , uintegerFromBytes -- :: ByteString -> Integer++ -- * Simple mutable counters+ , Counter -- :: * -> *+ , newCounter -- :: Int -> ST s (Counter s)+ , readCounter -- :: Counter s -> ST s Int+ , writeCounter -- :: Counter s -> Int -> ST s ()+ , incCounter -- :: Counter s -> ST s ()+ , decCounter -- :: Counter s -> ST s ()++ -- * Array support+ , copyByteStringToByteArray+ , copyByteArrayToByteString+ ) where++#include "cbor.h"++import GHC.Exts+import GHC.ST (ST(ST))+import GHC.IO (IO(IO), unsafeDupablePerformIO)+import GHC.Word+import Foreign.Ptr++#if defined(OPTIMIZE_GMP)+import qualified GHC.Integer.GMP.Internals as Gmp+#endif++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Unsafe as BS+import Data.Primitive.ByteArray as Prim++import Foreign.ForeignPtr (withForeignPtr)++import qualified Numeric.Half as Half++#if !defined(HAVE_BYTESWAP_PRIMOPS) || !defined(MEM_UNALIGNED_OPS)+import Data.Bits ((.|.), unsafeShiftL)++#if defined(ARCH_32bit)+import GHC.IntWord64 (wordToWord64#)+#endif+#endif++--------------------------------------------------------------------------------++-- | Grab a 8-bit @'Word'@ given a @'Ptr'@ to some address.+grabWord8 :: Ptr () -> Word+{-# INLINE grabWord8 #-}++-- | Grab a 16-bit @'Word'@ given a @'Ptr'@ to some address.+grabWord16 :: Ptr () -> Word+{-# INLINE grabWord16 #-}++-- | Grab a 32-bit @'Word'@ given a @'Ptr'@ to some address.+grabWord32 :: Ptr () -> Word+{-# INLINE grabWord32 #-}++-- | Grab a 64-bit @'Word64'@ given a @'Ptr'@ to some address.+grabWord64 :: Ptr () -> Word64+{-# INLINE grabWord64 #-}++--+-- Machine-dependent implementation+--++-- 8-bit word case is always the same...+grabWord8 (Ptr ip#) = W# (indexWord8OffAddr# ip# 0#)++-- ... but the remaining cases arent+#if defined(HAVE_BYTESWAP_PRIMOPS) && \+ defined(MEM_UNALIGNED_OPS) && \+ !defined(WORDS_BIGENDIAN)+-- On x86 machines with GHC 7.10, we have byteswap primitives+-- available to make this conversion very fast.++grabWord16 (Ptr ip#) = W# (narrow16Word# (byteSwap16# (indexWord16OffAddr# ip# 0#)))+grabWord32 (Ptr ip#) = W# (narrow32Word# (byteSwap32# (indexWord32OffAddr# ip# 0#)))+#if defined(ARCH_64bit)+grabWord64 (Ptr ip#) = W64# (byteSwap# (indexWord64OffAddr# ip# 0#))+#else+grabWord64 (Ptr ip#) = W64# (byteSwap64# (indexWord64OffAddr# ip# 0#))+#endif++#elif defined(MEM_UNALIGNED_OPS) && \+ defined(WORDS_BIGENDIAN)+-- In some theoretical future-verse where there are unaligned memory+-- accesses on the machine, but it is also big-endian, we need to be+-- able to decode these numbers efficiently, still.++grabWord16 (Ptr ip#) = W# (indexWord16OffAddr# ip# 0#)+grabWord32 (Ptr ip#) = W# (indexWord32OffAddr# ip# 0#)+grabWord64 (Ptr ip#) = W64# (indexWord64OffAddr# ip# 0#)++#else+-- Otherwise, we fall back to the much slower, inefficient case+-- of writing out each of the 8 bits of the output word at+-- a time.++grabWord16 (Ptr ip#) =+ case indexWord8OffAddr# ip# 0# of+ w0# ->+ case indexWord8OffAddr# ip# 1# of+ w1# -> W# w0# `unsafeShiftL` 8 .|.+ W# w1#++grabWord32 (Ptr ip#) =+ case indexWord8OffAddr# ip# 0# of+ w0# ->+ case indexWord8OffAddr# ip# 1# of+ w1# ->+ case indexWord8OffAddr# ip# 2# of+ w2# ->+ case indexWord8OffAddr# ip# 3# of+ w3# -> W# w0# `unsafeShiftL` 24 .|.+ W# w1# `unsafeShiftL` 16 .|.+ W# w2# `unsafeShiftL` 8 .|.+ W# w3#++grabWord64 (Ptr ip#) =+ case indexWord8OffAddr# ip# 0# of+ w0# ->+ case indexWord8OffAddr# ip# 1# of+ w1# ->+ case indexWord8OffAddr# ip# 2# of+ w2# ->+ case indexWord8OffAddr# ip# 3# of+ w3# ->+ case indexWord8OffAddr# ip# 4# of+ w4# ->+ case indexWord8OffAddr# ip# 5# of+ w5# ->+ case indexWord8OffAddr# ip# 6# of+ w6# ->+ case indexWord8OffAddr# ip# 7# of+ w7# -> w w0# `unsafeShiftL` 56 .|.+ w w1# `unsafeShiftL` 48 .|.+ w w2# `unsafeShiftL` 40 .|.+ w w3# `unsafeShiftL` 32 .|.+ w w4# `unsafeShiftL` 24 .|.+ w w5# `unsafeShiftL` 16 .|.+ w w6# `unsafeShiftL` 8 .|.+ w w7#+ where+#if defined(ARCH_64bit)+ w w# = W64# w#+#else+ w w# = W64# (wordToWord64# w#)+#endif++#endif++--------------------------------------------------------------------------------+-- ByteString shennanigans++-- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the+-- resulting byte(s) as an 8-bit word value. The input @'ByteString'@ MUST be at+-- least 2 bytes long: one byte to drop from the front, and one to read as a+-- @'Word'@ value. This is not checked, and failure to ensure this will result+-- in undefined behavior.+eatTailWord8 :: ByteString -> Word+eatTailWord8 xs = withBsPtr grabWord8 (BS.unsafeTail xs)+{-# INLINE eatTailWord8 #-}++-- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the+-- resulting byte(s) as a 16-bit word value. The input @'ByteString'@ MUST be at+-- least 3 bytes long: one byte to drop from the front, and two to read as a+-- 16-bit @'Word'@ value. This is not checked, and failure to ensure this will+-- result in undefined behavior.+eatTailWord16 :: ByteString -> Word+eatTailWord16 xs = withBsPtr grabWord16 (BS.unsafeTail xs)+{-# INLINE eatTailWord16 #-}++-- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the+-- resulting byte(s) as a 32-bit word value. The input @'ByteString'@ MUST be at+-- least 5 bytes long: one byte to drop from the front, and four to read as a+-- 32-bit @'Word'@ value. This is not checked, and failure to ensure this will+-- result in undefined behavior.+eatTailWord32 :: ByteString -> Word+eatTailWord32 xs = withBsPtr grabWord32 (BS.unsafeTail xs)+{-# INLINE eatTailWord32 #-}++-- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the+-- resulting byte(s) as a 64-bit word value. The input @'ByteString'@ MUST be at+-- least 9 bytes long: one byte to drop from the front, and eight to read as a+-- 64-bit @'Word64'@ value. This is not checked, and failure to ensure this will+-- result in undefined behavior.+eatTailWord64 :: ByteString -> Word64+eatTailWord64 xs = withBsPtr grabWord64 (BS.unsafeTail xs)+{-# INLINE eatTailWord64 #-}++-- | Unsafely take a @'Ptr'@ to a @'ByteString'@ and do unholy things+-- 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 #-}++--------------------------------------------------------------------------------+-- Half floats++-- | Convert a @'Word'@ to a half-sized @'Float'@.+wordToFloat16 :: Word -> Float+wordToFloat16 = \x -> Half.fromHalf (Half.Half (fromIntegral x))+{-# INLINE wordToFloat16 #-}++-- | Convert a half-sized @'Float'@ to a @'Word'@.+floatToWord16 :: Float -> Word16+floatToWord16 = \x -> fromIntegral (Half.getHalf (Half.toHalf x))+{-# INLINE floatToWord16 #-}++--------------------------------------------------------------------------------+-- Casting words to floats++-- We have to go via a word rather than reading directly from memory because of+-- endian issues. A little endian machine cannot read a big-endian float direct+-- from memory, so we read a word, bswap it and then convert to float.+--+-- Currently there are no primops for casting word <-> float, see+-- https://ghc.haskell.org/trac/ghc/ticket/4092+--+-- In this implementation, we're avoiding doing the extra indirection (and+-- closure allocation) of the runSTRep stuff, but we have to be very careful+-- here, we cannot allow the "constant" newByteArray# 8# realWorld# to be+-- floated out and shared and aliased across multiple concurrent calls. So we+-- do manual worker/wrapper with the worker not being inlined.++-- | Cast a @'Word'@ to a @'Float'@.+wordToFloat32 :: Word -> Float+wordToFloat32 (W# w#) = F# (wordToFloat32# w#)+{-# INLINE wordToFloat32 #-}++-- | Cast a @'Word64'@ to a @'Float'@.+wordToFloat64 :: Word64 -> Double+wordToFloat64 (W64# w#) = D# (wordToFloat64# w#)+{-# INLINE wordToFloat64 #-}++-- | Cast an unboxed word to an unboxed float.+wordToFloat32# :: Word# -> Float#+wordToFloat32# w# =+ case newByteArray# 4# realWorld# of+ (# s', mba# #) ->+ case writeWord32Array# mba# 0# w# s' of+ s'' ->+ case readFloatArray# mba# 0# s'' of+ (# _, f# #) -> f#+{-# NOINLINE wordToFloat32# #-}++-- | Cast an unboxed word to an unboxed double.+#if defined(ARCH_64bit)+wordToFloat64# :: Word# -> Double#+#else+wordToFloat64# :: Word64# -> Double#+#endif+wordToFloat64# w# =+ case newByteArray# 8# realWorld# of+ (# s', mba# #) ->+ case writeWord64Array# mba# 0# w# s' of+ s'' ->+ case readDoubleArray# mba# 0# s'' of+ (# _, f# #) -> f#+{-# NOINLINE wordToFloat64# #-}++--------------------------------------------------------------------------------+-- Integer utilities++-- | Create a negative @'Integer'@ out of a raw @'BS.ByteString'@.+nintegerFromBytes :: BS.ByteString -> Integer+nintegerFromBytes bs = -1 - uintegerFromBytes bs++-- | Create an @'Integer'@ out of a raw @'BS.ByteString'@.+uintegerFromBytes :: BS.ByteString -> Integer++#if defined(OPTIMIZE_GMP)+uintegerFromBytes (BS.PS fp (I# off#) (I# len#)) =+ -- This should be safe since we're simply reading from ByteString (which is+ -- immutable) and GMP allocates a new memory for the Integer, i.e., there is+ -- no mutation involved.+ unsafeDupablePerformIO $+ withForeignPtr fp $ \(Ptr addr#) ->+ let addrOff# = addr# `plusAddr#` off#+ -- The last parmaeter (`1#`) tells the import function to use big+ -- endian encoding.+ in Gmp.importIntegerFromAddr addrOff# (int2Word# len#) 1#+#else+uintegerFromBytes bs =+ case BS.uncons bs of+ Nothing -> 0+ Just (w0, ws0) -> go (fromIntegral w0) ws0+ where+ go !acc ws =+ case BS.uncons ws of+ Nothing -> acc+ Just (w, ws') -> go (acc `unsafeShiftL` 8 + fromIntegral w) ws'+#endif++--------------------------------------------------------------------------------+-- Mutable counters++-- | An efficient, mutable counter. Designed to be used inside+-- @'ST'@ or other primitive monads, hence it carries an abstract+-- rank-2 @s@ type parameter.+data Counter s = Counter (MutableByteArray# s)++-- | Create a new counter with a starting @'Int'@ value.+newCounter :: Int -> ST s (Counter s)+newCounter (I# n#) =+ ST (\s ->+ case newByteArray# 8# s of+ (# s', mba# #) ->+ case writeIntArray# mba# 0# n# s' of+ s'' -> (# s'', Counter mba# #))+{-# INLINE newCounter #-}++-- | Read the current value of a @'Counter'@.+readCounter :: Counter s -> ST s Int+readCounter (Counter mba#) =+ ST (\s ->+ case readIntArray# mba# 0# s of+ (# s', n# #) -> (# s', I# n# #))+{-# INLINE readCounter #-}++-- | Write a new value into the @'Counter'@.+writeCounter :: Counter s -> Int -> ST s ()+writeCounter (Counter mba#) (I# n#) =+ ST (\s ->+ case writeIntArray# mba# 0# n# s of+ s' -> (# s', () #))+{-# INLINE writeCounter #-}++-- | Increment a @'Counter'@ by one.+incCounter :: Counter s -> ST s ()+incCounter c = do+ x <- readCounter c+ writeCounter c (x+1)+{-# INLINE incCounter #-}++-- | Decrement a @'Counter'@ by one.+decCounter :: Counter s -> ST s ()+decCounter c = do+ x <- readCounter c+ writeCounter c (x-1)+{-# INLINE decCounter #-}++--------------------------------------------------------------------------------+-- Array support++-- | Copy a @'BS.ByteString'@ and create a primitive @'Prim.ByteArray'@ from it.+copyByteStringToByteArray :: BS.ByteString -> Prim.ByteArray+copyByteStringToByteArray (BS.PS fp off len) =+ unsafeDupablePerformIO $+ withForeignPtr fp $ \ptr -> do+ mba <- Prim.newByteArray len+ copyPtrToMutableByteArray (ptr `plusPtr` off) mba 0 len+ Prim.unsafeFreezeByteArray mba++-- TODO FIXME: can do better here: can do non-copying for larger pinned arrays+-- or copy directly into the builder buffer++-- | Copy a @'Prim.ByteArray'@ at a certain offset and length into a+-- @'BS.ByteString'@.+copyByteArrayToByteString :: Prim.ByteArray+ -- ^ @'Prim.ByteArray'@ to copy from.+ -> Int+ -- ^ Offset into the @'Prim.ByteArray'@ to start with.+ -> Int+ -- ^ Length of the data to copy.+ -> BS.ByteString+copyByteArrayToByteString ba off len =+ unsafeDupablePerformIO $ do+ fp <- BS.mallocByteString len+ withForeignPtr fp $ \ptr -> do+ copyByteArrayToPtr ba off ptr len+ return (BS.PS fp 0 len)++-- | Copy the data pointed to by a @'Ptr'@ into a @'MutableByteArray'.+copyPtrToMutableByteArray :: Ptr a+ -- ^ @'Ptr'@ to buffer to copy from.+ -> MutableByteArray RealWorld+ -- ^ @'MutableByteArray'@ to copy into.+ -> Int+ -- ^ Offset to start copying from.+ -> Int+ -- ^ Length of the data to copy.+ -> IO ()+copyPtrToMutableByteArray (Ptr addr#) (MutableByteArray mba#) (I# off#) (I# len#) =+ IO (\s ->+ case copyAddrToByteArray# addr# mba# off# len# s of+ s' -> (# s', () #))++-- | Copy a @'ByteArray'@ into a @'Ptr'@ with a given offset and length.+copyByteArrayToPtr :: ByteArray+ -- ^ @'ByteArray'@ to copy.+ -> Int+ -- ^ Offset into the @'ByteArray'@ of where to start copying.+ -> Ptr a+ -- ^ Pointer to destination buffer.+ -> Int+ -- ^ Length of the data to copy into the destination buffer.+ -> IO ()+copyByteArrayToPtr (ByteArray ba#) (I# off#) (Ptr addr#) (I# len#) =+ IO (\s ->+ case copyByteArrayToAddr# ba# off# addr# len# s of+ s' -> (# s', () #))
+ src/Codec/CBOR/Pretty.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module : Codec.CBOR.Pretty+-- Copyright : (c) Duncan Coutts 2015-2017+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : duncan@community.haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- Pretty printing tools for debugging and analysis.+--+module Codec.CBOR.Pretty+ ( prettyHexEnc -- :: Encoding -> String+ ) where++#include "cbor.h"++import Data.Word++import qualified Data.ByteString as S+import qualified Data.Text as T++import Codec.CBOR.Encoding+import Codec.CBOR.Write++import qualified Control.Monad.Fail as Fail+import Control.Monad (replicateM_)+import Numeric+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++--------------------------------------------------------------------------------++newtype PP a = PP (Tokens -> Int -> ShowS -> Either String (Tokens,Int,ShowS,a))++-- | Pretty prints an @'Encoding'@ in an annotated, hexadecimal format+-- that maps CBOR values to their types. The output format is similar+-- to the format used on http://cbor.me/.+--+-- For example, with the term:+--+-- @+-- 'Prelude.putStrLn' . 'prettyHexEnc' . 'Codec.CBOR.encode' $+-- ( True+-- , [1,2,3::Int]+-- , ('Data.Map.fromList' [(\"Hello\",True),(\"World\",False)], "This is a long string which wraps")+-- )+-- @+--+-- You get:+--+-- @+-- 83 # list(3)+-- f5 # bool(true)+-- 9f # list(*)+-- 01 # int(1)+-- 02 # int(2)+-- 03 # int(3)+-- ff # break+-- 82 # list(2)+-- a2 # map(2)+-- 65 48 65 6c 6c 6f # text(\"Hello\")+-- f5 # bool(true)+-- 65 57 6f 72 6c 64 # text(\"World\")+-- f4 # bool(false)+-- 78 21 54 68 69 73 20 69 73 20 61 20 6c 6f 6e 67+-- 20 73 74 72 69 6e 67 20 77 68 69 63 68 20 77 72+-- 61 70 73 # text("This is a long string which wraps")+-- @+--+-- @since 0.2.0.0+prettyHexEnc :: Encoding -> String+prettyHexEnc e = case runPP pprint e of+ Left s -> s+ Right (TkEnd,_,ss,_) -> ss ""+ Right (toks,_,ss,_) -> ss $ "\nprettyEnc: Not all input was consumed (this is probably a problem with the pretty printing code). Tokens left: " ++ show toks++runPP :: PP a -> Encoding -> Either String (Tokens, Int, ShowS, a)+runPP (PP f) (Encoding enc) = f (enc TkEnd) 0 id++deriving instance Functor PP++instance Applicative PP where+ pure a = PP (\toks ind ss -> Right (toks, ind, ss, a))+ (PP f) <*> (PP x) = PP $ \toks ind ss -> case f toks ind ss of+ Left s -> Left s+ Right (toks', ind',ss',f') -> case x toks' ind' ss' of+ Left s -> Left s+ Right (toks'', ind'', ss'', x') -> Right (toks'', ind'', ss'', f' x')++instance Monad PP where+ (PP f) >>= g = PP $ \toks ind ss -> case f toks ind ss of+ Left s -> Left s+ Right (toks', ind', ss', x) -> let PP g' = g x+ in g' toks' ind' ss'+ return = pure+ fail = Fail.fail++instance Fail.MonadFail PP where+ fail s = PP $ \_ _ _ -> Left s++indent :: PP ()+indent = PP (\toks ind ss -> Right (toks,ind,ss . (replicate ind ' ' ++),()))++nl :: PP ()+nl = PP (\toks ind ss -> Right (toks,ind,ss . ('\n':), ()))++inc :: Int -> PP ()+inc i = PP (\toks ind ss -> Right (toks,ind+i,ss,()))++dec :: Int -> PP ()+dec i = inc (-i)++getTerm :: PP Tokens+getTerm = PP $ \toks ind ss ->+ case unconsToken toks of+ Just (tk,rest) -> Right (rest,ind,ss,tk)+ Nothing -> Left "getTok: Unexpected end of input"++peekTerm :: PP Tokens+peekTerm = PP $ \toks ind ss ->+ case unconsToken toks of+ Just (tk,_) -> Right (toks,ind,ss,tk)+ Nothing -> Left "peekTerm: Unexpected end of input"++appShowS :: ShowS -> PP ()+appShowS s = PP $ \toks ind ss -> Right (toks,ind,ss . s,())++str :: String -> PP ()+str = appShowS . showString++shown :: Show a => a -> PP ()+shown = appShowS . shows++parens :: PP a -> PP a+parens pp = str "(" *> pp <* str ")"++indef :: PP () -> PP ()+indef pp = do+ tk <- peekTerm+ case tk of+ TkBreak TkEnd -> dec 3 >> pprint+ _ -> pp >> indef pp+++pprint :: PP ()+pprint = do+ nl+ term <- getTerm+ hexRep term+ str " "+ case term of+ TkInt i TkEnd -> ppTkInt i+ TkInteger i TkEnd -> ppTkInteger i+ TkWord w TkEnd -> ppTkWord w+ TkBytes bs TkEnd -> ppTkBytes bs+ TkBytesBegin TkEnd -> ppTkBytesBegin+ TkString t TkEnd -> ppTkString t+ TkStringBegin TkEnd -> ppTkStringBegin+ TkListLen w TkEnd -> ppTkListLen w+ TkListBegin TkEnd -> ppTkListBegin+ TkMapLen w TkEnd -> ppTkMapLen w+ TkMapBegin TkEnd -> ppTkMapBegin+ TkBreak TkEnd -> ppTkBreak+ TkTag w TkEnd -> ppTkTag w+ TkBool b TkEnd -> ppTkBool b+ TkNull TkEnd -> ppTkNull+ TkSimple w TkEnd -> ppTkSimple w+ TkFloat16 f TkEnd -> ppTkFloat16 f+ TkFloat32 f TkEnd -> ppTkFloat32 f+ TkFloat64 f TkEnd -> ppTkFloat64 f+ TkEnd -> str "# End of input"+ _ -> fail $ unwords ["pprint: Unexpected token:", show term]++ppTkInt :: Int -> PP ()+ppTkInt i = str "# int" >> parens (shown i)++ppTkInteger :: Integer -> PP ()+ppTkInteger i = str "# integer" >> parens (shown i)++ppTkWord :: Word -> PP ()+ppTkWord w = str "# word" >> parens (shown w)++ppTkBytes :: S.ByteString -> PP ()+ppTkBytes bs = str "# bytes" >> parens (shown (S.length bs))++ppTkBytesBegin :: PP ()+ppTkBytesBegin = str "# bytes(*)" >> inc 3 >> indef pprint++ppTkString :: T.Text -> PP ()+ppTkString t = str "# text" >> parens (shown t)++ppTkStringBegin:: PP ()+ppTkStringBegin = str "# text(*)" >> inc 3 >> indef pprint++ppTkListLen :: Word -> PP ()+ppTkListLen n = do+ str "# list"+ parens (shown n)+ inc 3+ replicateM_ (fromIntegral n) pprint+ dec 3++ppTkListBegin :: PP ()+ppTkListBegin = str "# list(*)" >> inc 3 >> indef pprint++ppMapPairs :: PP ()+ppMapPairs = do+ nl+ inc 3+ indent+ str " # key"+ pprint+ dec 3+ -- str " [end map key]"+ nl+ inc 3+ indent+ str " # value"+ pprint+ dec 3+ -- str " [end map value]"++ppTkMapLen :: Word -> PP ()+ppTkMapLen w = do+ str "# map"+ parens (shown w)+ -- inc 3+ replicateM_ (fromIntegral w) ppMapPairs+ -- dec 3++ppTkMapBegin :: PP ()+ppTkMapBegin = str "# map(*)" >> inc 3 >> indef ppMapPairs++ppTkBreak :: PP ()+ppTkBreak = str "# break"++ppTkTag :: Word -> PP ()+ppTkTag w = do+ str "# tag"+ parens (shown w)+ inc 3+ pprint+ dec 3++ppTkBool :: Bool -> PP ()+ppTkBool True = str "# bool" >> parens (str "true")+ppTkBool False = str "# bool" >> parens (str "false")++ppTkNull :: PP ()+ppTkNull = str "# null"++ppTkSimple :: Word8 -> PP ()+ppTkSimple w = str "# simple" >> parens (shown w)++ppTkFloat16 :: Float -> PP ()+ppTkFloat16 f = str "# float16" >> parens (shown f)++ppTkFloat32 :: Float -> PP ()+ppTkFloat32 f = str "# float32" >> parens (shown f)++ppTkFloat64 :: Double -> PP ()+ppTkFloat64 f = str "# float64" >> parens (shown f)++unconsToken :: Tokens -> Maybe (Tokens, Tokens)+unconsToken TkEnd = Nothing+unconsToken (TkWord w tks) = Just (TkWord w TkEnd,tks)+unconsToken (TkWord64 w tks) = Just (TkWord64 w TkEnd,tks)+unconsToken (TkInt i tks) = Just (TkInt i TkEnd,tks)+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 (TkString t tks) = Just (TkString t TkEnd,tks)+unconsToken (TkStringBegin tks) = Just (TkStringBegin 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)+unconsToken (TkMapBegin tks) = Just (TkMapBegin TkEnd,tks)+unconsToken (TkTag w tks) = Just (TkTag w TkEnd,tks)+unconsToken (TkTag64 w64 tks) = Just (TkTag64 w64 TkEnd,tks)+unconsToken (TkInteger i tks) = Just (TkInteger i TkEnd,tks)+unconsToken (TkNull tks) = Just (TkNull TkEnd,tks)+unconsToken (TkUndef tks) = Just (TkUndef TkEnd,tks)+unconsToken (TkBool b tks) = Just (TkBool b TkEnd,tks)+unconsToken (TkSimple w8 tks) = Just (TkSimple w8 TkEnd,tks)+unconsToken (TkFloat16 f16 tks) = Just (TkFloat16 f16 TkEnd,tks)+unconsToken (TkFloat32 f32 tks) = Just (TkFloat32 f32 TkEnd,tks)+unconsToken (TkFloat64 f64 tks) = Just (TkFloat64 f64 TkEnd,tks)+unconsToken (TkBreak tks) = Just (TkBreak TkEnd,tks)++hexRep :: Tokens -> PP ()+hexRep tk = go . toStrictByteString . Encoding $ const tk where+ go bs | S.length bs > 16 = case S.splitAt 16 bs of+ (h,t) -> indent >> appShowS (hexBS h) >> nl >> go t+ | otherwise = indent >> appShowS (hexBS bs)++hexBS :: S.ByteString -> ShowS+hexBS = foldr (.) id . map (\n -> ((if n < 16 then ('0':) else id) . showHex n . (' ':))) . S.unpack
+ src/Codec/CBOR/Read.hs view
@@ -0,0 +1,1952 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- 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 #-}++-- |+-- Module : Codec.CBOR.Read+-- Copyright : (c) Duncan Coutts 2015-2017+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : duncan@community.haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- Tools for reading values in a CBOR-encoded format+-- back into ordinary values.+--+module Codec.CBOR.Read+ ( deserialiseFromBytes -- :: Decoder a -> ByteString -> Either String (ByteString, a)+ , deserialiseIncremental -- :: Decoder a -> ST s (IDecode s a)+ , DeserialiseFailure(..)+ , IDecode(..)+ , ByteOffset+ ) where++#include "cbor.h"++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import GHC.Int++import Control.Monad (ap)+import Control.Monad.ST+import Data.Array.IArray+import Data.Array.Unboxed+import qualified Data.Array.Base as A+import Data.Monoid+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Internal as LBS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word+import GHC.Word+import GHC.Exts+import GHC.Float (float2Double)+import Data.Typeable+import Control.Exception++import Codec.CBOR.Decoding hiding (DecodeAction(Done, Fail))+import Codec.CBOR.Decoding (DecodeAction)+import qualified Codec.CBOR.Decoding as D+import Codec.CBOR.Magic++--------------------------------------------------------------------------------++-- | An exception type that may be returned (by pure functions) or+-- thrown (by IO actions) that fail to deserialise a given input.+--+-- @since 0.2.0.0+data DeserialiseFailure = DeserialiseFailure ByteOffset String+ deriving (Show, Typeable)++instance Exception DeserialiseFailure where+#if MIN_VERSION_base(4,8,0)+ displayException (DeserialiseFailure off msg) =+ "Codec.CBOR: deserialising failed at offset "+ ++ show off ++ " : " ++ msg+#endif++-- | An Incremental decoder, used to represent the result of+-- attempting to run a decoder over a given input, and return a value+-- of type @a@.+data IDecode s a+ = -- | The decoder has consumed the available input and needs more+ -- to continue. Provide @'Just'@ if more input is available and+ -- @'Nothing'@ otherwise, and you will get a new @'IDecode'@.+ Partial (Maybe BS.ByteString -> ST s (IDecode s a))++ -- | The decoder has successfully finished. Except for the output+ -- value you also get any unused input as well as the number of+ -- bytes consumed.+ | Done !BS.ByteString {-# UNPACK #-} !ByteOffset a++ -- | The decoder ran into an error. The decoder either used+ -- @'fail'@ or was not provided enough input. Contains any+ -- unconsumed input, the number of bytes consumed, and a+ -- @'DeserialiseFailure'@ exception describing the reason why the+ -- failure occurred.+ | Fail !BS.ByteString {-# UNPACK #-} !ByteOffset DeserialiseFailure++-- | Given a @'Decoder'@ and some @'LBS.ByteString'@ representing+-- an encoded CBOR value, return @'Either'@ the decoded CBOR value+-- or an error. In addition to the decoded value return any remaining input+-- content.+--+-- @since 0.2.0.0+deserialiseFromBytes :: (forall s. Decoder s a)+ -> LBS.ByteString+ -> Either DeserialiseFailure (LBS.ByteString, a)+deserialiseFromBytes d lbs =+ runIDecode (deserialiseIncremental d) lbs+++runIDecode :: (forall s. ST s (IDecode s a))+ -> LBS.ByteString+ -> Either DeserialiseFailure (LBS.ByteString, 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'++-- | Run a @'Decoder'@ incrementally, returning a continuation+-- representing the result of the incremental decode.+--+-- @since 0.2.0.0+deserialiseIncremental :: Decoder s a -> ST s (IDecode s a)+deserialiseIncremental decoder = do+ da <- getDecodeAction decoder+ runIncrementalDecoder (runDecodeAction da)++----------------------------------------------+-- A monad for building incremental decoders+--++-- | Simple alias for @'Int64'@, used to make types more descriptive.+type ByteOffset = Int64++newtype IncrementalDecoder s a = IncrementalDecoder {+ unIncrementalDecoder ::+ forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r)+ }++instance Functor (IncrementalDecoder s) where+ fmap f a = a >>= return . f++instance Applicative (IncrementalDecoder s) where+ pure x = IncrementalDecoder $ \k -> k x+ (<*>) = ap++instance Monad (IncrementalDecoder s) where+ return = pure++ {-# INLINE (>>=) #-}+ m >>= f = IncrementalDecoder $ \k ->+ unIncrementalDecoder m $ \x ->+ unIncrementalDecoder (f x) k++runIncrementalDecoder :: IncrementalDecoder s (ByteString, ByteOffset, a)+ -> ST s (IDecode s a)+runIncrementalDecoder (IncrementalDecoder f) =+ f (\(trailing, off, x) -> return $ Done trailing off x)++decodeFail :: ByteString -> ByteOffset -> String -> IncrementalDecoder s a+decodeFail trailing off msg = IncrementalDecoder $ \_ -> return $ Fail trailing off exn+ where exn = DeserialiseFailure off msg++needChunk :: IncrementalDecoder s (Maybe ByteString)+needChunk = IncrementalDecoder $ \k -> return $ Partial $ \mbs -> k mbs++lift :: ST s a -> IncrementalDecoder s a+lift action = IncrementalDecoder (\k -> action >>= k)++--------------------------------------------+-- The main decoder+--++-- The top level entry point+runDecodeAction :: DecodeAction s a+ -> IncrementalDecoder s (ByteString, ByteOffset, a)+runDecodeAction (D.Fail msg) = decodeFail BS.empty 0 msg+runDecodeAction (D.Done x) = return (BS.empty, 0, x)+runDecodeAction (D.PeekAvailable k) = lift (k 0#) >>= runDecodeAction+runDecodeAction da = do+ mbs <- needChunk+ case mbs of+ Nothing -> decodeFail BS.empty 0 "end of input"+ Just bs -> go_slow da bs 0++-- The decoder is split into a fast path and a slow path. The fast path is+-- used for a single input chunk. It decodes as far as it can, reading only+-- whole tokens that fit within the input chunk. When it cannot read any+-- further it returns control to the slow path. The slow path fixes up all the+-- complicated corner cases with tokens that span chunk boundaries, gets more+-- input and then goes back into the fast path.+--+-- The idea is that chunks are usually large, and we can use simpler and+-- faster code if we don't make it deal with the general case of tokens that+-- span chunk boundaries.++-- These are all the ways in which the fast path can finish, and return+-- control to the slow path. In particular there are three different cases+-- 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+++-- The main fast path. The fast path itself is actually split into two parts+-- the main version 'go_fast' and a version used when we are near the end of+-- the chunk, 'go_fast_end'.+--+-- This version can then do fewer tests when we're not near the end of the+-- chunk, in particular we just check if there's enough input buffer space+-- left for the largest possible fixed-size token (8+1 bytes).+--+go_fast :: ByteString -> DecodeAction s a -> ST s (SlowPath s a)++go_fast !bs da | BS.length bs < 9 = go_fast_end bs da++go_fast !bs da@(ConsumeWord k) =+ case tryConsumeWord (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeWord8 k) =+ case tryConsumeWord (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (W# w#) ->+ case gtWord# w# 0xff## of+ 0# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+ _ -> go_fast_end bs da++go_fast !bs da@(ConsumeWord16 k) =+ case tryConsumeWord (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (W# w#) ->+ case gtWord# w# 0xffff## of+ 0# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+ _ -> go_fast_end bs da++go_fast !bs da@(ConsumeWord32 k) =+ case tryConsumeWord (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (W# w#) ->+#if defined(ARCH_32bit)+ k w# >>= go_fast (BS.unsafeDrop sz bs)+#else+ case gtWord# w# 0xffffffff## of+ 0# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+ _ -> go_fast_end bs da+#endif++go_fast !bs da@(ConsumeNegWord k) =+ case tryConsumeNegWord (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeInt k) =+ case tryConsumeInt (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeInt8 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# -> k n# >>= go_fast (BS.unsafeDrop sz bs)+ _ -> go_fast_end bs da++go_fast !bs da@(ConsumeInt16 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# -> k n# >>= go_fast (BS.unsafeDrop sz bs)+ _ -> go_fast_end bs da++go_fast !bs da@(ConsumeInt32 k) =+ case tryConsumeInt (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (I# n#) ->+#if defined(ARCH_32bit)+ k n# >>= go_fast (BS.unsafeDrop sz bs)+#else+ case (n# ># 0x7fffffff#) `orI#` (n# <# -0x80000000#) of+ 0# -> k n# >>= go_fast (BS.unsafeDrop sz bs)+ _ -> go_fast_end bs da+#endif++go_fast !bs da@(ConsumeListLen k) =+ case tryConsumeListLen (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeMapLen k) =+ case tryConsumeMapLen (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeTag k) =+ case tryConsumeTag (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs)++#if defined(ARCH_32bit)+go_fast !bs da@(ConsumeWord64 k) =+ case tryConsumeWord64 (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@(ConsumeNegWord64 k) =+ case tryConsumeNegWord64 (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@(ConsumeInt64 k) =+ case tryConsumeInt64 (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (I64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeListLen64 k) =+ case tryConsumeListLen64 (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (I64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeMapLen64 k) =+ case tryConsumeMapLen64 (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (I64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeTag64 k) =+ 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)+#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++go_fast !bs da@(ConsumeFloat k) =+ case tryConsumeFloat (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (F# f#) -> k f# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeDouble k) =+ case tryConsumeDouble (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (D# f#) -> k f# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeBytes k) =+ case tryConsumeBytes (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ 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@(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 (TooLong len) -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len++go_fast !bs da@(ConsumeBool k) =+ case tryConsumeBool (BS.unsafeHead bs) of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz b -> k b >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeSimple k) =+ case tryConsumeSimple (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeBytesIndef k) =+ case tryConsumeBytesIndef (BS.unsafeHead bs) of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeStringIndef k) =+ case tryConsumeStringIndef (BS.unsafeHead bs) of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeListLenIndef k) =+ case tryConsumeListLenIndef (BS.unsafeHead bs) of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeMapLenIndef k) =+ case tryConsumeMapLenIndef (BS.unsafeHead bs) of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeNull k) =+ case tryConsumeNull (BS.unsafeHead bs) of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeListLenOrIndef k) =+ case tryConsumeListLenOrIndef (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs da@(ConsumeMapLenOrIndef k) =+ case tryConsumeMapLenOrIndef (BS.unsafeHead bs) bs of+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs (ConsumeBreakOr k) =+ case tryConsumeBreakOr (BS.unsafeHead bs) of+ DecodeFailure -> k False >>= go_fast bs+ DecodedToken sz _ -> k True >>= go_fast (BS.unsafeDrop sz bs)++go_fast !bs (PeekTokenType k) =+ let !hdr = BS.unsafeHead bs+ !tkty = decodeTokenTypeTable `A.unsafeAt` fromIntegral hdr+ in k tkty >>= go_fast bs++go_fast !bs (PeekAvailable k) = k (case BS.length bs of I# len# -> len#) >>= go_fast bs++go_fast !bs da@D.Fail{} = go_fast_end bs da+go_fast !bs da@D.Done{} = go_fast_end bs da+++-- This variant of the fast path has to do a few more checks because we're+-- near the end of the chunk. The guarantee we provide here is that we will+-- decode any tokens where the whole token fits within the input buffer. So+-- if we return with input buffer space still unconsumed (and we're not done+-- or failed) then there's one remaining token that spans the end of the+-- input chunk (the slow path fixup code relies on this guarantee).+--+go_fast_end :: ByteString -> DecodeAction s a -> ST s (SlowPath s a)++-- these three cases don't need any input++go_fast_end !bs (D.Fail msg) = return $! SlowFail bs msg+go_fast_end !bs (D.Done x) = return $! FastDone bs x+go_fast_end !bs (PeekAvailable k) = k (case BS.length bs of I# len# -> len#) >>= go_fast_end bs++-- the next two cases only need the 1 byte token header+go_fast_end !bs da | BS.null bs = return $! SlowDecodeAction bs da++go_fast_end !bs (ConsumeBreakOr k) =+ case tryConsumeBreakOr (BS.unsafeHead bs) of+ DecodeFailure -> k False >>= go_fast_end bs+ DecodedToken sz _ -> k True >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (PeekTokenType k) =+ let !hdr = BS.unsafeHead bs+ !tkty = decodeTokenTypeTable `A.unsafeAt` fromIntegral hdr+ in k tkty >>= go_fast_end bs++-- all the remaining cases have to decode the current token++go_fast_end !bs da+ | let !hdr = BS.unsafeHead bs+ , BS.length bs < tokenSize hdr+ = return $! SlowDecodeAction bs da++go_fast_end !bs (ConsumeWord k) =+ case tryConsumeWord (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected word"+ DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeWord8 k) =+ case tryConsumeWord (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected word8"+ DecodedToken sz (W# w#) ->+ case gtWord# w# 0xff## of+ 0# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+ _ -> return $! SlowFail bs "expected word8"++go_fast_end !bs (ConsumeWord16 k) =+ case tryConsumeWord (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected word16"+ DecodedToken sz (W# w#) ->+ case gtWord# w# 0xffff## of+ 0# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+ _ -> return $! SlowFail bs "expected word16"++go_fast_end !bs (ConsumeWord32 k) =+ case tryConsumeWord (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected word32"+ DecodedToken sz (W# w#) ->+#if defined(ARCH_32bit)+ k w# >>= go_fast_end (BS.unsafeDrop sz bs)+#else+ case gtWord# w# 0xffffffff## of+ 0# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+ _ -> return $! SlowFail bs "expected word32"+#endif++go_fast_end !bs (ConsumeNegWord k) =+ case tryConsumeNegWord (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected negative int"+ DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeInt k) =+ case tryConsumeInt (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected int"+ DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeInt8 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# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+ _ -> return $! SlowFail bs "expected int8"++go_fast_end !bs (ConsumeInt16 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# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+ _ -> return $! SlowFail bs "expected int16"++go_fast_end !bs (ConsumeInt32 k) =+ case tryConsumeInt (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected int32"+ DecodedToken sz (I# n#) ->+#if defined(ARCH_32bit)+ k n# >>= go_fast_end (BS.unsafeDrop sz bs)+#else+ case (n# ># 0x7fffffff#) `orI#` (n# <# -0x80000000#) of+ 0# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+ _ -> return $! SlowFail bs "expected int32"+#endif++go_fast_end !bs (ConsumeListLen k) =+ case tryConsumeListLen (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected list len"+ DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeMapLen k) =+ case tryConsumeMapLen (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected map len"+ DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeTag k) =+ case tryConsumeTag (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected tag"+ DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)++#if defined(ARCH_32bit)+go_fast_end !bs (ConsumeWord64 k) =+ case tryConsumeWord64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected word64"+ DecodedToken sz (W64# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeNegWord64 k) =+ case tryConsumeNegWord64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected negative word64"+ DecodedToken sz (W64# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeInt64 k) =+ case tryConsumeInt64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected int64"+ DecodedToken sz (I64# i#) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeListLen64 k) =+ case tryConsumeListLen64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected list len 64"+ DecodedToken sz (I64# i#) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeMapLen64 k) =+ case tryConsumeMapLen64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected map len 64"+ DecodedToken sz (I64# i#) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeTag64 k) =+ case tryConsumeTag64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected tag64"+ DecodedToken sz (W64# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+#endif++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 (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 (ConsumeFloat k) =+ case tryConsumeFloat (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected float"+ DecodedToken sz (F# f#) -> k f# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeDouble k) =+ case tryConsumeDouble (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected double"+ DecodedToken sz (D# f#) -> k f# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeBytes k) =+ case tryConsumeBytes (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected bytes"+ 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 (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 (TooLong len) -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len++go_fast_end !bs (ConsumeBool k) =+ case tryConsumeBool (BS.unsafeHead bs) of+ DecodeFailure -> return $! SlowFail bs "expected bool"+ DecodedToken sz b -> k b >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeSimple k) =+ case tryConsumeSimple (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected simple"+ DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeBytesIndef k) =+ case tryConsumeBytesIndef (BS.unsafeHead bs) of+ DecodeFailure -> return $! SlowFail bs "expected bytes start"+ DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeStringIndef k) =+ case tryConsumeStringIndef (BS.unsafeHead bs) of+ DecodeFailure -> return $! SlowFail bs "expected string start"+ DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeListLenIndef k) =+ case tryConsumeListLenIndef (BS.unsafeHead bs) of+ DecodeFailure -> return $! SlowFail bs "expected list start"+ DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeMapLenIndef k) =+ case tryConsumeMapLenIndef (BS.unsafeHead bs) of+ DecodeFailure -> return $! SlowFail bs "expected map start"+ DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeNull k) =+ case tryConsumeNull (BS.unsafeHead bs) of+ DecodeFailure -> return $! SlowFail bs "expected null"+ DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeListLenOrIndef k) =+ case tryConsumeListLenOrIndef (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected list len or indef"+ DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeMapLenOrIndef k) =+ case tryConsumeMapLenOrIndef (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected map len or indef"+ DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs)+++-- The slow path starts off by running the fast path on the current chunk+-- then looking at where it finished, fixing up the chunk boundary issues,+-- getting more input and going around again.+--+-- The offset here is the offset after of all data consumed so far,+-- so not including the current chunk.+--+go_slow :: DecodeAction s a -> ByteString -> ByteOffset+ -> IncrementalDecoder s (ByteString, ByteOffset, a)+go_slow da bs !offset = do+ slowpath <- lift $ go_fast bs da+ case slowpath of+ FastDone bs' x -> return (bs', offset', x)+ where+ !offset' = offset + fromIntegral (BS.length bs - BS.length bs')++ SlowConsumeTokenBytes bs' k len -> do+ (bstr, bs'') <- getTokenVarLen len bs' offset'+ lift (k bstr) >>= \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+ 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+ -- so we can get more input and carry on+ mbs <- needChunk+ case mbs of+ Nothing -> decodeFail bs' offset' "end of input"+ Just bs'' -> go_slow da' bs'' offset'+ where+ !offset' = offset + fromIntegral (BS.length bs - BS.length bs')++ SlowDecodeAction bs' da' ->+ -- of course we should only end up here when we really are out of+ -- input, otherwise go_fast_end could have continued+ assert (BS.length bs' < tokenSize (BS.head bs')) $+ go_slow_fixup da' bs' offset'+ where+ !offset' = offset + fromIntegral (BS.length bs - BS.length bs')++ SlowFail bs' msg -> decodeFail bs' offset' msg+ where+ !offset' = offset + fromIntegral (BS.length bs - BS.length bs')++-- The complicated case is when a token spans a chunk boundary.+--+-- Our goal is to get enough input so that go_fast_end can consume exactly one+-- token without need for further fixups.+--+go_slow_fixup :: DecodeAction s a -> ByteString -> ByteOffset+ -> IncrementalDecoder s (ByteString, ByteOffset, a)+go_slow_fixup da !bs !offset = do+ let !hdr = BS.head bs+ !sz = tokenSize hdr+ mbs <- needChunk+ case mbs of+ Nothing -> decodeFail bs offset "end of input"++ Just bs'+ -- We have enough input now, try reading one final token+ | BS.length bs + BS.length bs' >= sz+ -> go_slow_overlapped da sz bs bs' offset++ -- We still don't have enough input, get more+ | otherwise+ -> go_slow_fixup da (bs <> bs') offset++-- We've now got more input, but we have one token that spanned the old and+-- new input buffers, so we have to decode that one before carrying on+go_slow_overlapped :: DecodeAction s a -> Int -> ByteString -> ByteString+ -> ByteOffset+ -> IncrementalDecoder s (ByteString, ByteOffset, a)+go_slow_overlapped da sz bs_cur bs_next !offset =++ -- we have:+ -- sz the size of the pending input token+ -- bs_cur the tail end of the previous input buffer+ -- bs_next the next input chunk++ -- we know the old buffer is too small, but the combo is enough+ assert (BS.length bs_cur < sz) $+ assert (BS.length bs_cur + BS.length bs_next >= sz) $++ -- we make:+ -- bs_tok a buffer containing only the pending input token+ -- bs' the tail of the next input chunk,+ -- which will become the next input buffer++ let bs_tok = bs_cur <> BS.unsafeTake (sz - BS.length bs_cur) bs_next+ bs' = BS.unsafeDrop (sz - BS.length bs_cur) bs_next+ offset' = offset + fromIntegral sz in++ -- so the token chunk should be exactly the right size+ assert (BS.length bs_tok == sz) $+ -- and overall we shouldn't loose any input+ assert (BS.length bs_cur + BS.length bs_next == sz + BS.length bs') $ do++ -- so now we can run the fast path to consume just this one token+ slowpath <- lift $ go_fast_end bs_tok da+ case slowpath of++ -- typically we'll fall out of the fast path having+ -- consumed exactly one token, now with no trailing data+ SlowDecodeAction bs_empty da' ->+ assert (BS.null bs_empty) $+ go_slow da' bs' offset'++ -- but the other possibilities can happen too+ FastDone bs_empty x ->+ 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)++ SlowConsumeTokenString 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+ 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+-- can still stream the utf8 validation/converstion++-- TODO FIXME: also consider sharing or not sharing here, and possibly+-- rechunking.++getTokenVarLen :: Int -> ByteString -> ByteOffset+ -> IncrementalDecoder s (ByteString, ByteString)+getTokenVarLen len bs offset =+ assert (len > BS.length bs) $ do+ mbs <- needChunk+ case mbs of+ Nothing -> decodeFail BS.empty offset "end of input"+ Just bs'+ | let n = len - BS.length bs+ , BS.length bs' >= n ->+ let !tok = bs <> BS.unsafeTake n bs'+ in return (tok, BS.drop n bs')++ | otherwise -> getTokenVarLenSlow+ [bs',bs]+ (len - (BS.length bs + BS.length bs'))+ offset++getTokenVarLenSlow :: [ByteString] -> Int -> ByteOffset+ -> IncrementalDecoder s (ByteString, ByteString)+getTokenVarLenSlow bss n offset = do+ mbs <- needChunk+ case mbs of+ Nothing -> decodeFail BS.empty offset "end of input"+ Just bs+ | BS.length bs >= n ->+ let !tok = BS.concat (reverse (BS.unsafeTake n bs : bss))+ in return (tok, BS.drop n bs)+ | otherwise -> getTokenVarLenSlow (bs:bss) (n - BS.length bs) offset++++tokenSize :: Word8 -> Int+tokenSize hdr =+ fromIntegral $+ decodeTableSz `A.unsafeAt` (fromIntegral hdr .&. 0x1f)++decodeTableSz :: UArray Word8 Word8+decodeTableSz =+ array (0, 0x1f) $+ [ (encodeHeader 0 n, 1) | n <- [0..0x1f] ]+ ++ [ (encodeHeader 0 n, s) | (n, s) <- zip [24..27] [2,3,5,9] ]++decodeTokenTypeTable :: Array Word8 TokenType+decodeTokenTypeTable =+ array (minBound, maxBound) $+ [ (encodeHeader 0 n, TypeUInt) | n <- [0..26] ]+ ++ [ (encodeHeader 0 27, TypeUInt64)+ , (encodeHeader 0 31, TypeInvalid) ]++ ++ [ (encodeHeader 1 n, TypeNInt) | n <- [0..26] ]+ ++ [ (encodeHeader 1 27, TypeNInt64)+ , (encodeHeader 1 31, TypeInvalid) ]++ ++ [ (encodeHeader 2 n, TypeBytes) | n <- [0..27] ]+ ++ [ (encodeHeader 2 31, TypeBytesIndef) ]++ ++ [ (encodeHeader 3 n, TypeString) | n <- [0..27] ]+ ++ [ (encodeHeader 3 31, TypeStringIndef) ]++ ++ [ (encodeHeader 4 n, TypeListLen) | n <- [0..26] ]+ ++ [ (encodeHeader 4 27, TypeListLen64)+ , (encodeHeader 4 31, TypeListLenIndef) ]++ ++ [ (encodeHeader 5 n, TypeMapLen) | n <- [0..26] ]+ ++ [ (encodeHeader 5 27, TypeMapLen64)+ , (encodeHeader 5 31, TypeMapLenIndef) ]++ ++ [ (encodeHeader 6 n, TypeTag) | n <- 0:1:[4..26] ]+ ++ [ (encodeHeader 6 2, TypeInteger)+ , (encodeHeader 6 3, TypeInteger)+ , (encodeHeader 6 27, TypeTag64)+ , (encodeHeader 6 31, TypeInvalid) ]++ ++ [ (encodeHeader 7 n, TypeSimple) | n <- [0..19] ]+ ++ [ (encodeHeader 7 20, TypeBool)+ , (encodeHeader 7 21, TypeBool)+ , (encodeHeader 7 22, TypeNull)+ , (encodeHeader 7 23, TypeSimple)+ , (encodeHeader 7 24, TypeSimple)+ , (encodeHeader 7 25, TypeFloat16)+ , (encodeHeader 7 26, TypeFloat32)+ , (encodeHeader 7 27, TypeFloat64)+ , (encodeHeader 7 31, TypeBreak) ]++ ++ [ (encodeHeader mt n, TypeInvalid) | mt <- [0..7], n <- [28..30] ]++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+++-- 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+-- division. Whereas for Int or Word it does the right thing.++{-# INLINE tryConsumeWord #-}+tryConsumeWord :: Word8 -> ByteString -> DecodedToken Word+tryConsumeWord hdr !bs = case fromIntegral hdr :: Word of+ -- Positive integers (type 0)+ 0x00 -> DecodedToken 1 0+ 0x01 -> DecodedToken 1 1+ 0x02 -> DecodedToken 1 2+ 0x03 -> DecodedToken 1 3+ 0x04 -> DecodedToken 1 4+ 0x05 -> DecodedToken 1 5+ 0x06 -> DecodedToken 1 6+ 0x07 -> DecodedToken 1 7+ 0x08 -> DecodedToken 1 8+ 0x09 -> DecodedToken 1 9+ 0x0a -> DecodedToken 1 10+ 0x0b -> DecodedToken 1 11+ 0x0c -> DecodedToken 1 12+ 0x0d -> DecodedToken 1 13+ 0x0e -> DecodedToken 1 14+ 0x0f -> DecodedToken 1 15+ 0x10 -> DecodedToken 1 16+ 0x11 -> DecodedToken 1 17+ 0x12 -> DecodedToken 1 18+ 0x13 -> DecodedToken 1 19+ 0x14 -> DecodedToken 1 20+ 0x15 -> DecodedToken 1 21+ 0x16 -> DecodedToken 1 22+ 0x17 -> DecodedToken 1 23+ 0x18 -> DecodedToken 2 (eatTailWord8 bs)+ 0x19 -> DecodedToken 3 (eatTailWord16 bs)+ 0x1a -> DecodedToken 5 (eatTailWord32 bs)+ 0x1b -> DecodedToken 9 (fromIntegral $ eatTailWord64 bs) -- TODO FIXME: overflow+ _ -> DecodeFailure+++{-# INLINE tryConsumeNegWord #-}+tryConsumeNegWord :: Word8 -> ByteString -> DecodedToken Word+tryConsumeNegWord hdr !bs = case fromIntegral hdr :: Word of+ -- Positive integers (type 0)+ 0x20 -> DecodedToken 1 0+ 0x21 -> DecodedToken 1 1+ 0x22 -> DecodedToken 1 2+ 0x23 -> DecodedToken 1 3+ 0x24 -> DecodedToken 1 4+ 0x25 -> DecodedToken 1 5+ 0x26 -> DecodedToken 1 6+ 0x27 -> DecodedToken 1 7+ 0x28 -> DecodedToken 1 8+ 0x29 -> DecodedToken 1 9+ 0x2a -> DecodedToken 1 10+ 0x2b -> DecodedToken 1 11+ 0x2c -> DecodedToken 1 12+ 0x2d -> DecodedToken 1 13+ 0x2e -> DecodedToken 1 14+ 0x2f -> DecodedToken 1 15+ 0x30 -> DecodedToken 1 16+ 0x31 -> DecodedToken 1 17+ 0x32 -> DecodedToken 1 18+ 0x33 -> DecodedToken 1 19+ 0x34 -> DecodedToken 1 20+ 0x35 -> DecodedToken 1 21+ 0x36 -> DecodedToken 1 22+ 0x37 -> DecodedToken 1 23+ 0x38 -> DecodedToken 2 (eatTailWord8 bs)+ 0x39 -> DecodedToken 3 (eatTailWord16 bs)+ 0x3a -> DecodedToken 5 (eatTailWord32 bs)+ 0x3b -> DecodedToken 9 (fromIntegral $ eatTailWord64 bs) -- TODO FIXME: overflow+ _ -> DecodeFailure+++{-# INLINE tryConsumeInt #-}+tryConsumeInt :: Word8 -> ByteString -> DecodedToken Int+tryConsumeInt hdr !bs = case fromIntegral hdr :: Word of+ -- Positive integers (type 0)+ 0x00 -> DecodedToken 1 0+ 0x01 -> DecodedToken 1 1+ 0x02 -> DecodedToken 1 2+ 0x03 -> DecodedToken 1 3+ 0x04 -> DecodedToken 1 4+ 0x05 -> DecodedToken 1 5+ 0x06 -> DecodedToken 1 6+ 0x07 -> DecodedToken 1 7+ 0x08 -> DecodedToken 1 8+ 0x09 -> DecodedToken 1 9+ 0x0a -> DecodedToken 1 10+ 0x0b -> DecodedToken 1 11+ 0x0c -> DecodedToken 1 12+ 0x0d -> DecodedToken 1 13+ 0x0e -> DecodedToken 1 14+ 0x0f -> DecodedToken 1 15+ 0x10 -> DecodedToken 1 16+ 0x11 -> DecodedToken 1 17+ 0x12 -> DecodedToken 1 18+ 0x13 -> DecodedToken 1 19+ 0x14 -> DecodedToken 1 20+ 0x15 -> DecodedToken 1 21+ 0x16 -> DecodedToken 1 22+ 0x17 -> DecodedToken 1 23+ 0x18 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0x19 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0x1a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0x1b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow++ -- Negative integers (type 1)+ 0x20 -> DecodedToken 1 (-1)+ 0x21 -> DecodedToken 1 (-2)+ 0x22 -> DecodedToken 1 (-3)+ 0x23 -> DecodedToken 1 (-4)+ 0x24 -> DecodedToken 1 (-5)+ 0x25 -> DecodedToken 1 (-6)+ 0x26 -> DecodedToken 1 (-7)+ 0x27 -> DecodedToken 1 (-8)+ 0x28 -> DecodedToken 1 (-9)+ 0x29 -> DecodedToken 1 (-10)+ 0x2a -> DecodedToken 1 (-11)+ 0x2b -> DecodedToken 1 (-12)+ 0x2c -> DecodedToken 1 (-13)+ 0x2d -> DecodedToken 1 (-14)+ 0x2e -> DecodedToken 1 (-15)+ 0x2f -> DecodedToken 1 (-16)+ 0x30 -> DecodedToken 1 (-17)+ 0x31 -> DecodedToken 1 (-18)+ 0x32 -> DecodedToken 1 (-19)+ 0x33 -> DecodedToken 1 (-20)+ 0x34 -> DecodedToken 1 (-21)+ 0x35 -> DecodedToken 1 (-22)+ 0x36 -> DecodedToken 1 (-23)+ 0x37 -> DecodedToken 1 (-24)+ 0x38 -> DecodedToken 2 (-1 - fromIntegral (eatTailWord8 bs))+ 0x39 -> DecodedToken 3 (-1 - fromIntegral (eatTailWord16 bs))+ 0x3a -> DecodedToken 5 (-1 - fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0x3b -> DecodedToken 9 (-1 - fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure+++{-# INLINE tryConsumeInteger #-}+tryConsumeInteger :: Word8 -> ByteString -> DecodedToken (BigIntToken Integer)+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)))++ -- 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)))++ 0xc2 -> readBigUInt bs+ 0xc3 -> readBigNInt bs++ _ -> DecodeFailure+++{-# INLINE tryConsumeBytes #-}+tryConsumeBytes :: Word8 -> ByteString -> DecodedToken (LongToken ByteString)+tryConsumeBytes hdr !bs = case fromIntegral hdr :: Word of++ -- Bytes (type 2)+ 0x40 -> readBytesSmall 0 bs+ 0x41 -> readBytesSmall 1 bs+ 0x42 -> readBytesSmall 2 bs+ 0x43 -> readBytesSmall 3 bs+ 0x44 -> readBytesSmall 4 bs+ 0x45 -> readBytesSmall 5 bs+ 0x46 -> readBytesSmall 6 bs+ 0x47 -> readBytesSmall 7 bs+ 0x48 -> readBytesSmall 8 bs+ 0x49 -> readBytesSmall 9 bs+ 0x4a -> readBytesSmall 10 bs+ 0x4b -> readBytesSmall 11 bs+ 0x4c -> readBytesSmall 12 bs+ 0x4d -> readBytesSmall 13 bs+ 0x4e -> readBytesSmall 14 bs+ 0x4f -> readBytesSmall 15 bs+ 0x50 -> readBytesSmall 16 bs+ 0x51 -> readBytesSmall 17 bs+ 0x52 -> readBytesSmall 18 bs+ 0x53 -> readBytesSmall 19 bs+ 0x54 -> readBytesSmall 20 bs+ 0x55 -> readBytesSmall 21 bs+ 0x56 -> readBytesSmall 22 bs+ 0x57 -> readBytesSmall 23 bs+ 0x58 -> readBytes8 bs+ 0x59 -> readBytes16 bs+ 0x5a -> readBytes32 bs+ 0x5b -> readBytes64 bs+ _ -> DecodeFailure+++{-# INLINE tryConsumeString #-}+tryConsumeString :: Word8 -> ByteString -> DecodedToken (LongToken T.Text)+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+ _ -> DecodeFailure+++{-# INLINE tryConsumeListLen #-}+tryConsumeListLen :: Word8 -> ByteString -> DecodedToken Int+tryConsumeListLen hdr !bs = case fromIntegral hdr :: Word of+ -- List structures (type 4)+ 0x80 -> DecodedToken 1 0+ 0x81 -> DecodedToken 1 1+ 0x82 -> DecodedToken 1 2+ 0x83 -> DecodedToken 1 3+ 0x84 -> DecodedToken 1 4+ 0x85 -> DecodedToken 1 5+ 0x86 -> DecodedToken 1 6+ 0x87 -> DecodedToken 1 7+ 0x88 -> DecodedToken 1 8+ 0x89 -> DecodedToken 1 9+ 0x8a -> DecodedToken 1 10+ 0x8b -> DecodedToken 1 11+ 0x8c -> DecodedToken 1 12+ 0x8d -> DecodedToken 1 13+ 0x8e -> DecodedToken 1 14+ 0x8f -> DecodedToken 1 15+ 0x90 -> DecodedToken 1 16+ 0x91 -> DecodedToken 1 17+ 0x92 -> DecodedToken 1 18+ 0x93 -> DecodedToken 1 19+ 0x94 -> DecodedToken 1 20+ 0x95 -> DecodedToken 1 21+ 0x96 -> DecodedToken 1 22+ 0x97 -> DecodedToken 1 23+ 0x98 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0x99 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0x9a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0x9b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure+++{-# INLINE tryConsumeMapLen #-}+tryConsumeMapLen :: Word8 -> ByteString -> DecodedToken Int+tryConsumeMapLen hdr !bs = case fromIntegral hdr :: Word of+ -- Map structures (type 5)+ 0xa0 -> DecodedToken 1 0+ 0xa1 -> DecodedToken 1 1+ 0xa2 -> DecodedToken 1 2+ 0xa3 -> DecodedToken 1 3+ 0xa4 -> DecodedToken 1 4+ 0xa5 -> DecodedToken 1 5+ 0xa6 -> DecodedToken 1 6+ 0xa7 -> DecodedToken 1 7+ 0xa8 -> DecodedToken 1 8+ 0xa9 -> DecodedToken 1 9+ 0xaa -> DecodedToken 1 10+ 0xab -> DecodedToken 1 11+ 0xac -> DecodedToken 1 12+ 0xad -> DecodedToken 1 13+ 0xae -> DecodedToken 1 14+ 0xaf -> DecodedToken 1 15+ 0xb0 -> DecodedToken 1 16+ 0xb1 -> DecodedToken 1 17+ 0xb2 -> DecodedToken 1 18+ 0xb3 -> DecodedToken 1 19+ 0xb4 -> DecodedToken 1 20+ 0xb5 -> DecodedToken 1 21+ 0xb6 -> DecodedToken 1 22+ 0xb7 -> DecodedToken 1 23+ 0xb8 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0xb9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0xba -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0xbb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure+++{-# INLINE tryConsumeListLenIndef #-}+tryConsumeListLenIndef :: Word8 -> DecodedToken ()+tryConsumeListLenIndef hdr = case fromIntegral hdr :: Word of+ 0x9f -> DecodedToken 1 ()+ _ -> DecodeFailure+++{-# INLINE tryConsumeMapLenIndef #-}+tryConsumeMapLenIndef :: Word8 -> DecodedToken ()+tryConsumeMapLenIndef hdr = case fromIntegral hdr :: Word of+ 0xbf -> DecodedToken 1 ()+ _ -> DecodeFailure+++{-# INLINE tryConsumeListLenOrIndef #-}+tryConsumeListLenOrIndef :: Word8 -> ByteString -> DecodedToken Int+tryConsumeListLenOrIndef hdr !bs = case fromIntegral hdr :: Word of++ -- List structures (type 4)+ 0x80 -> DecodedToken 1 0+ 0x81 -> DecodedToken 1 1+ 0x82 -> DecodedToken 1 2+ 0x83 -> DecodedToken 1 3+ 0x84 -> DecodedToken 1 4+ 0x85 -> DecodedToken 1 5+ 0x86 -> DecodedToken 1 6+ 0x87 -> DecodedToken 1 7+ 0x88 -> DecodedToken 1 8+ 0x89 -> DecodedToken 1 9+ 0x8a -> DecodedToken 1 10+ 0x8b -> DecodedToken 1 11+ 0x8c -> DecodedToken 1 12+ 0x8d -> DecodedToken 1 13+ 0x8e -> DecodedToken 1 14+ 0x8f -> DecodedToken 1 15+ 0x90 -> DecodedToken 1 16+ 0x91 -> DecodedToken 1 17+ 0x92 -> DecodedToken 1 18+ 0x93 -> DecodedToken 1 19+ 0x94 -> DecodedToken 1 20+ 0x95 -> DecodedToken 1 21+ 0x96 -> DecodedToken 1 22+ 0x97 -> DecodedToken 1 23+ 0x98 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0x99 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0x9a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0x9b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x9f -> DecodedToken 1 (-1) -- indefinite length+ _ -> DecodeFailure+++{-# INLINE tryConsumeMapLenOrIndef #-}+tryConsumeMapLenOrIndef :: Word8 -> ByteString -> DecodedToken Int+tryConsumeMapLenOrIndef hdr !bs = case fromIntegral hdr :: Word of++ -- Map structures (type 5)+ 0xa0 -> DecodedToken 1 0+ 0xa1 -> DecodedToken 1 1+ 0xa2 -> DecodedToken 1 2+ 0xa3 -> DecodedToken 1 3+ 0xa4 -> DecodedToken 1 4+ 0xa5 -> DecodedToken 1 5+ 0xa6 -> DecodedToken 1 6+ 0xa7 -> DecodedToken 1 7+ 0xa8 -> DecodedToken 1 8+ 0xa9 -> DecodedToken 1 9+ 0xaa -> DecodedToken 1 10+ 0xab -> DecodedToken 1 11+ 0xac -> DecodedToken 1 12+ 0xad -> DecodedToken 1 13+ 0xae -> DecodedToken 1 14+ 0xaf -> DecodedToken 1 15+ 0xb0 -> DecodedToken 1 16+ 0xb1 -> DecodedToken 1 17+ 0xb2 -> DecodedToken 1 18+ 0xb3 -> DecodedToken 1 19+ 0xb4 -> DecodedToken 1 20+ 0xb5 -> DecodedToken 1 21+ 0xb6 -> DecodedToken 1 22+ 0xb7 -> DecodedToken 1 23+ 0xb8 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0xb9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0xba -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0xbb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0xbf -> DecodedToken 1 (-1) -- indefinite length+ _ -> DecodeFailure+++{-# INLINE tryConsumeTag #-}+tryConsumeTag :: Word8 -> ByteString -> DecodedToken Word+tryConsumeTag hdr !bs = case fromIntegral hdr :: Word of++ -- Tagged values (type 6)+ 0xc0 -> DecodedToken 1 0+ 0xc1 -> DecodedToken 1 1+ 0xc2 -> DecodedToken 1 2+ 0xc3 -> DecodedToken 1 3+ 0xc4 -> DecodedToken 1 4+ 0xc5 -> DecodedToken 1 5+ 0xc6 -> DecodedToken 1 6+ 0xc7 -> DecodedToken 1 7+ 0xc8 -> DecodedToken 1 8+ 0xc9 -> DecodedToken 1 9+ 0xca -> DecodedToken 1 10+ 0xcb -> DecodedToken 1 11+ 0xcc -> DecodedToken 1 12+ 0xcd -> DecodedToken 1 13+ 0xce -> DecodedToken 1 14+ 0xcf -> DecodedToken 1 15+ 0xd0 -> DecodedToken 1 16+ 0xd1 -> DecodedToken 1 17+ 0xd2 -> DecodedToken 1 18+ 0xd3 -> DecodedToken 1 19+ 0xd4 -> DecodedToken 1 20+ 0xd5 -> DecodedToken 1 21+ 0xd6 -> DecodedToken 1 22+ 0xd7 -> DecodedToken 1 23+ 0xd8 -> DecodedToken 2 (eatTailWord8 bs)+ 0xd9 -> DecodedToken 3 (eatTailWord16 bs)+ 0xda -> DecodedToken 5 (eatTailWord32 bs)+ 0xdb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure++--+-- 64-on-32 bit code paths+--++#if defined(ARCH_32bit)+tryConsumeWord64 :: Word8 -> ByteString -> DecodedToken Word64+tryConsumeWord64 hdr !bs = case fromIntegral hdr :: Word of+ -- Positive integers (type 0)+ 0x00 -> DecodedToken 1 0+ 0x01 -> DecodedToken 1 1+ 0x02 -> DecodedToken 1 2+ 0x03 -> DecodedToken 1 3+ 0x04 -> DecodedToken 1 4+ 0x05 -> DecodedToken 1 5+ 0x06 -> DecodedToken 1 6+ 0x07 -> DecodedToken 1 7+ 0x08 -> DecodedToken 1 8+ 0x09 -> DecodedToken 1 9+ 0x0a -> DecodedToken 1 10+ 0x0b -> DecodedToken 1 11+ 0x0c -> DecodedToken 1 12+ 0x0d -> DecodedToken 1 13+ 0x0e -> DecodedToken 1 14+ 0x0f -> DecodedToken 1 15+ 0x10 -> DecodedToken 1 16+ 0x11 -> DecodedToken 1 17+ 0x12 -> DecodedToken 1 18+ 0x13 -> DecodedToken 1 19+ 0x14 -> DecodedToken 1 20+ 0x15 -> DecodedToken 1 21+ 0x16 -> DecodedToken 1 22+ 0x17 -> DecodedToken 1 23+ 0x18 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0x19 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0x1a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs))+ 0x1b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure+{-# INLINE tryConsumeWord64 #-}++tryConsumeNegWord64 :: Word8 -> ByteString -> DecodedToken Word64+tryConsumeNegWord64 hdr !bs = case fromIntegral hdr :: Word of+ -- Positive integers (type 0)+ 0x20 -> DecodedToken 1 0+ 0x21 -> DecodedToken 1 1+ 0x22 -> DecodedToken 1 2+ 0x23 -> DecodedToken 1 3+ 0x24 -> DecodedToken 1 4+ 0x25 -> DecodedToken 1 5+ 0x26 -> DecodedToken 1 6+ 0x27 -> DecodedToken 1 7+ 0x28 -> DecodedToken 1 8+ 0x29 -> DecodedToken 1 9+ 0x2a -> DecodedToken 1 10+ 0x2b -> DecodedToken 1 11+ 0x2c -> DecodedToken 1 12+ 0x2d -> DecodedToken 1 13+ 0x2e -> DecodedToken 1 14+ 0x2f -> DecodedToken 1 15+ 0x30 -> DecodedToken 1 16+ 0x31 -> DecodedToken 1 17+ 0x32 -> DecodedToken 1 18+ 0x33 -> DecodedToken 1 19+ 0x34 -> DecodedToken 1 20+ 0x35 -> DecodedToken 1 21+ 0x36 -> DecodedToken 1 22+ 0x37 -> DecodedToken 1 23+ 0x38 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0x39 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0x3a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs))+ 0x3b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure+{-# INLINE tryConsumeNegWord64 #-}++tryConsumeInt64 :: Word8 -> ByteString -> DecodedToken Int64+tryConsumeInt64 hdr !bs = case fromIntegral hdr :: Word of+ -- Positive integers (type 0)+ 0x00 -> DecodedToken 1 0+ 0x01 -> DecodedToken 1 1+ 0x02 -> DecodedToken 1 2+ 0x03 -> DecodedToken 1 3+ 0x04 -> DecodedToken 1 4+ 0x05 -> DecodedToken 1 5+ 0x06 -> DecodedToken 1 6+ 0x07 -> DecodedToken 1 7+ 0x08 -> DecodedToken 1 8+ 0x09 -> DecodedToken 1 9+ 0x0a -> DecodedToken 1 10+ 0x0b -> DecodedToken 1 11+ 0x0c -> DecodedToken 1 12+ 0x0d -> DecodedToken 1 13+ 0x0e -> DecodedToken 1 14+ 0x0f -> DecodedToken 1 15+ 0x10 -> DecodedToken 1 16+ 0x11 -> DecodedToken 1 17+ 0x12 -> DecodedToken 1 18+ 0x13 -> DecodedToken 1 19+ 0x14 -> DecodedToken 1 20+ 0x15 -> DecodedToken 1 21+ 0x16 -> DecodedToken 1 22+ 0x17 -> DecodedToken 1 23+ 0x18 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0x19 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0x1a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0x1b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow++ -- Negative integers (type 1)+ 0x20 -> DecodedToken 1 (-1)+ 0x21 -> DecodedToken 1 (-2)+ 0x22 -> DecodedToken 1 (-3)+ 0x23 -> DecodedToken 1 (-4)+ 0x24 -> DecodedToken 1 (-5)+ 0x25 -> DecodedToken 1 (-6)+ 0x26 -> DecodedToken 1 (-7)+ 0x27 -> DecodedToken 1 (-8)+ 0x28 -> DecodedToken 1 (-9)+ 0x29 -> DecodedToken 1 (-10)+ 0x2a -> DecodedToken 1 (-11)+ 0x2b -> DecodedToken 1 (-12)+ 0x2c -> DecodedToken 1 (-13)+ 0x2d -> DecodedToken 1 (-14)+ 0x2e -> DecodedToken 1 (-15)+ 0x2f -> DecodedToken 1 (-16)+ 0x30 -> DecodedToken 1 (-17)+ 0x31 -> DecodedToken 1 (-18)+ 0x32 -> DecodedToken 1 (-19)+ 0x33 -> DecodedToken 1 (-20)+ 0x34 -> DecodedToken 1 (-21)+ 0x35 -> DecodedToken 1 (-22)+ 0x36 -> DecodedToken 1 (-23)+ 0x37 -> DecodedToken 1 (-24)+ 0x38 -> DecodedToken 2 (-1 - fromIntegral (eatTailWord8 bs))+ 0x39 -> DecodedToken 3 (-1 - fromIntegral (eatTailWord16 bs))+ 0x3a -> DecodedToken 5 (-1 - fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0x3b -> DecodedToken 9 (-1 - fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure+{-# INLINE tryConsumeInt64 #-}++tryConsumeListLen64 :: Word8 -> ByteString -> DecodedToken Int64+tryConsumeListLen64 hdr !bs = case fromIntegral hdr :: Word of+ -- List structures (type 4)+ 0x80 -> DecodedToken 1 0+ 0x81 -> DecodedToken 1 1+ 0x82 -> DecodedToken 1 2+ 0x83 -> DecodedToken 1 3+ 0x84 -> DecodedToken 1 4+ 0x85 -> DecodedToken 1 5+ 0x86 -> DecodedToken 1 6+ 0x87 -> DecodedToken 1 7+ 0x88 -> DecodedToken 1 8+ 0x89 -> DecodedToken 1 9+ 0x8a -> DecodedToken 1 10+ 0x8b -> DecodedToken 1 11+ 0x8c -> DecodedToken 1 12+ 0x8d -> DecodedToken 1 13+ 0x8e -> DecodedToken 1 14+ 0x8f -> DecodedToken 1 15+ 0x90 -> DecodedToken 1 16+ 0x91 -> DecodedToken 1 17+ 0x92 -> DecodedToken 1 18+ 0x93 -> DecodedToken 1 19+ 0x94 -> DecodedToken 1 20+ 0x95 -> DecodedToken 1 21+ 0x96 -> DecodedToken 1 22+ 0x97 -> DecodedToken 1 23+ 0x98 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0x99 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0x9a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0x9b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure+{-# INLINE tryConsumeListLen64 #-}++tryConsumeMapLen64 :: Word8 -> ByteString -> DecodedToken Int64+tryConsumeMapLen64 hdr !bs = case fromIntegral hdr :: Word of+ -- Map structures (type 5)+ 0xa0 -> DecodedToken 1 0+ 0xa1 -> DecodedToken 1 1+ 0xa2 -> DecodedToken 1 2+ 0xa3 -> DecodedToken 1 3+ 0xa4 -> DecodedToken 1 4+ 0xa5 -> DecodedToken 1 5+ 0xa6 -> DecodedToken 1 6+ 0xa7 -> DecodedToken 1 7+ 0xa8 -> DecodedToken 1 8+ 0xa9 -> DecodedToken 1 9+ 0xaa -> DecodedToken 1 10+ 0xab -> DecodedToken 1 11+ 0xac -> DecodedToken 1 12+ 0xad -> DecodedToken 1 13+ 0xae -> DecodedToken 1 14+ 0xaf -> DecodedToken 1 15+ 0xb0 -> DecodedToken 1 16+ 0xb1 -> DecodedToken 1 17+ 0xb2 -> DecodedToken 1 18+ 0xb3 -> DecodedToken 1 19+ 0xb4 -> DecodedToken 1 20+ 0xb5 -> DecodedToken 1 21+ 0xb6 -> DecodedToken 1 22+ 0xb7 -> DecodedToken 1 23+ 0xb8 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0xb9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0xba -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow+ 0xbb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure+{-# INLINE tryConsumeMapLen64 #-}++tryConsumeTag64 :: Word8 -> ByteString -> DecodedToken Word64+tryConsumeTag64 hdr !bs = case fromIntegral hdr :: Word of+ -- Tagged values (type 6)+ 0xc0 -> DecodedToken 1 0+ 0xc1 -> DecodedToken 1 1+ 0xc2 -> DecodedToken 1 2+ 0xc3 -> DecodedToken 1 3+ 0xc4 -> DecodedToken 1 4+ 0xc5 -> DecodedToken 1 5+ 0xc6 -> DecodedToken 1 6+ 0xc7 -> DecodedToken 1 7+ 0xc8 -> DecodedToken 1 8+ 0xc9 -> DecodedToken 1 9+ 0xca -> DecodedToken 1 10+ 0xcb -> DecodedToken 1 11+ 0xcc -> DecodedToken 1 12+ 0xcd -> DecodedToken 1 13+ 0xce -> DecodedToken 1 14+ 0xcf -> DecodedToken 1 15+ 0xd0 -> DecodedToken 1 16+ 0xd1 -> DecodedToken 1 17+ 0xd2 -> DecodedToken 1 18+ 0xd3 -> DecodedToken 1 19+ 0xd4 -> DecodedToken 1 20+ 0xd5 -> DecodedToken 1 21+ 0xd6 -> DecodedToken 1 22+ 0xd7 -> DecodedToken 1 23+ 0xd8 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))+ 0xd9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))+ 0xda -> DecodedToken 5 (fromIntegral (eatTailWord32 bs))+ 0xdb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ _ -> DecodeFailure+{-# INLINE tryConsumeTag64 #-}+#endif++{-# INLINE tryConsumeFloat #-}+tryConsumeFloat :: Word8 -> ByteString -> DecodedToken Float+tryConsumeFloat hdr !bs = case fromIntegral hdr :: Word of+ 0xf9 -> DecodedToken 3 (wordToFloat16 (eatTailWord16 bs))+ 0xfa -> DecodedToken 5 (wordToFloat32 (eatTailWord32 bs))+ _ -> DecodeFailure+++{-# INLINE tryConsumeDouble #-}+tryConsumeDouble :: Word8 -> ByteString -> DecodedToken Double+tryConsumeDouble hdr !bs = case fromIntegral hdr :: Word of+ 0xf9 -> DecodedToken 3 (float2Double $ wordToFloat16 (eatTailWord16 bs))+ 0xfa -> DecodedToken 5 (float2Double $ wordToFloat32 (eatTailWord32 bs))+ 0xfb -> DecodedToken 9 (wordToFloat64 (eatTailWord64 bs))+ _ -> DecodeFailure+++{-# INLINE tryConsumeBool #-}+tryConsumeBool :: Word8 -> DecodedToken Bool+tryConsumeBool hdr = case fromIntegral hdr :: Word of+ 0xf4 -> DecodedToken 1 False+ 0xf5 -> DecodedToken 1 True+ _ -> DecodeFailure+++{-# INLINE tryConsumeSimple #-}+tryConsumeSimple :: Word8 -> ByteString -> DecodedToken Word+tryConsumeSimple hdr !bs = case fromIntegral hdr :: Word of++ -- Simple and floats (type 7)+ 0xe0 -> DecodedToken 1 0+ 0xe1 -> DecodedToken 1 1+ 0xe2 -> DecodedToken 1 2+ 0xe3 -> DecodedToken 1 3+ 0xe4 -> DecodedToken 1 4+ 0xe5 -> DecodedToken 1 5+ 0xe6 -> DecodedToken 1 6+ 0xe7 -> DecodedToken 1 7+ 0xe8 -> DecodedToken 1 8+ 0xe9 -> DecodedToken 1 9+ 0xea -> DecodedToken 1 10+ 0xeb -> DecodedToken 1 11+ 0xec -> DecodedToken 1 12+ 0xed -> DecodedToken 1 13+ 0xee -> DecodedToken 1 14+ 0xef -> DecodedToken 1 15+ 0xf0 -> DecodedToken 1 16+ 0xf1 -> DecodedToken 1 17+ 0xf2 -> DecodedToken 1 18+ 0xf3 -> DecodedToken 1 19+ 0xf4 -> DecodedToken 1 20+ 0xf5 -> DecodedToken 1 21+ 0xf6 -> DecodedToken 1 22+ 0xf7 -> DecodedToken 1 23+ 0xf8 -> DecodedToken 2 (eatTailWord8 bs)+ _ -> DecodeFailure+++{-# INLINE tryConsumeBytesIndef #-}+tryConsumeBytesIndef :: Word8 -> DecodedToken ()+tryConsumeBytesIndef hdr = case fromIntegral hdr :: Word of+ 0x5f -> DecodedToken 1 ()+ _ -> DecodeFailure+++{-# INLINE tryConsumeStringIndef #-}+tryConsumeStringIndef :: Word8 -> DecodedToken ()+tryConsumeStringIndef hdr = case fromIntegral hdr :: Word of+ 0x7f -> DecodedToken 1 ()+ _ -> DecodeFailure+++{-# INLINE tryConsumeNull #-}+tryConsumeNull :: Word8 -> DecodedToken ()+tryConsumeNull hdr = case fromIntegral hdr :: Word of+ 0xf6 -> DecodedToken 1 ()+ _ -> DecodeFailure+++{-# INLINE tryConsumeBreakOr #-}+tryConsumeBreakOr :: Word8 -> DecodedToken ()+tryConsumeBreakOr hdr = case fromIntegral hdr :: Word of+ 0xff -> DecodedToken 1 ()+ _ -> DecodeFailure+++readBytesSmall :: Int -> ByteString -> DecodedToken (LongToken ByteString)+readBytesSmall n bs+ -- if n <= bound then ok return it all+ | n + hdrsz <= BS.length bs+ = DecodedToken (n+hdrsz) $ Fits $+ BS.unsafeTake n (BS.unsafeDrop hdrsz bs)++ -- if n > bound then slow path, multi-chunk+ | otherwise+ = DecodedToken hdrsz $ TooLong n+ where+ hdrsz = 1++readBytes8, readBytes16, readBytes32, readBytes64+ :: ByteString -> DecodedToken (LongToken ByteString)++readBytes8 bs+ | n <= BS.length bs - hdrsz+ = DecodedToken (n+hdrsz) $ Fits $+ BS.unsafeTake n (BS.unsafeDrop hdrsz bs)++ -- if n > bound then slow path, multi-chunk+ | otherwise+ = DecodedToken hdrsz $ TooLong n+ where+ hdrsz = 2+ n = fromIntegral (eatTailWord8 bs)++readBytes16 bs+ | n <= BS.length bs - hdrsz+ = DecodedToken (n+hdrsz) $ Fits $+ BS.unsafeTake n (BS.unsafeDrop hdrsz bs)++ -- if n > bound then slow path, multi-chunk+ | otherwise+ = DecodedToken hdrsz $ TooLong n+ where+ hdrsz = 3+ n = fromIntegral (eatTailWord16 bs)++readBytes32 bs+ | n <= BS.length bs - hdrsz+ = DecodedToken (n+hdrsz) $ Fits $+ BS.unsafeTake n (BS.unsafeDrop hdrsz bs)++ -- if n > bound then slow path, multi-chunk+ | otherwise+ = DecodedToken hdrsz $ TooLong n+ where+ hdrsz = 5+ -- TODO FIXME: int overflow+ n = fromIntegral (eatTailWord32 bs)++readBytes64 bs+ | n <= BS.length bs - hdrsz+ = DecodedToken (n+hdrsz) $ Fits $+ BS.unsafeTake n (BS.unsafeDrop hdrsz bs)++ -- if n > bound then slow path, multi-chunk+ | otherwise+ = DecodedToken hdrsz $ TooLong n+ where+ hdrsz = 5+ -- 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+--++-- Big ints consist of two CBOR tokens: a tag token (2 for positive, 3 for+-- negative) followed by a bytes token. Our usual invariant (for go_fast and+-- go_fast_end) only guarantees that we've got enough space to decode the+-- first token. So given that there's two tokens and the second is variable+-- length then there are several points where we can discover we're out of+-- input buffer space.+--+-- In those cases we need to break out of the fast path but we must arrange+-- things so that we can continue later once we've got more input buffer.+--+-- In particular, we might run out of space when:+-- 1. trying to decode the header of the second token (bytes); or+-- 2. trying to read the bytes body+--+--- The existing mechanisms we've got to drop out of the fast path are:+-- * SlowDecodeAction to re-read a whole token+-- * SlowConsumeTokenBytes to read the body of a bytes token+--+-- Of course when we resume we need to convert the bytes into an integer.+-- Rather than making new fast path return mechanisms we can reuse the+-- existing ones, so long as we're prepared to allocate new continuation+-- closures. This seems a reasonable price to pay to reduce complexity since+-- 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+ | BigUIntNeedBody Int+ | BigNIntNeedBody Int+ | BigUIntNeedHeader+ | BigNIntNeedHeader++-- So when we have to break out because we can't read the whole bytes body+-- in one go then we need to use SlowConsumeTokenBytes but we can adjust the+-- continuation so that when we get the ByteString back we convert it to an+-- Integer before calling the original continuation.++adjustContBigUIntNeedBody, adjustContBigNIntNeedBody+ :: (Integer -> ST s (DecodeAction s a))+ -> (ByteString -> ST s (DecodeAction s a))++adjustContBigUIntNeedBody k = \bs -> k $! uintegerFromBytes bs+adjustContBigNIntNeedBody k = \bs -> k $! nintegerFromBytes bs++-- And when we have to break out because we can't read the bytes token header+-- in one go then we need to use SlowDecodeAction but we have to make two+-- adjustments. When we resume we need to read a bytes token, not a big int.+-- That is we don't want to re-read the tag token. Indeed we cannot even if we+-- wanted to because the slow path code only guarantees to arrange for one+-- complete token header in the input buffer. So we must pretend that we did+-- in fact want to read a bytes token using ConsumeBytes, and then we can+-- adjust the continuation for that in the same way as above.++adjustContBigUIntNeedHeader, adjustContBigNIntNeedHeader+ :: (Integer -> ST s (DecodeAction s a))+ -> DecodeAction s a++adjustContBigUIntNeedHeader k = ConsumeBytes (\bs -> k $! uintegerFromBytes bs)+adjustContBigNIntNeedHeader k = ConsumeBytes (\bs -> k $! nintegerFromBytes bs)++-- So finally when reading the input buffer we check if we have enough space+-- to read the header of the bytes token and then try to read the bytes body,+-- using the appropriate break-out codes as above.++{-# INLINE readBigUInt #-}+readBigUInt :: ByteString -> DecodedToken (BigIntToken a)+readBigUInt bs+ | let bs' = BS.unsafeTail bs+ , not (BS.null bs')+ , let !hdr = BS.unsafeHead bs'+ , BS.length bs' >= tokenSize hdr+ = case tryConsumeBytes hdr bs' of+ DecodeFailure -> DecodeFailure+ DecodedToken sz (Fits bstr) -> DecodedToken (1+sz) (BigIntToken (uintegerFromBytes bstr))+ DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigUIntNeedBody len)++ | otherwise+ = DecodedToken 1 BigUIntNeedHeader++{-# INLINE readBigNInt #-}+readBigNInt :: ByteString -> DecodedToken (BigIntToken a)+readBigNInt bs+ | let bs' = BS.unsafeTail bs+ , not (BS.null bs')+ , let !hdr = BS.unsafeHead bs'+ , BS.length bs' >= tokenSize hdr+ = case tryConsumeBytes hdr bs' of+ DecodeFailure -> DecodeFailure+ DecodedToken sz (Fits bstr) -> DecodedToken (1+sz) (BigIntToken (nintegerFromBytes bstr))+ DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigNIntNeedBody len)++ | otherwise+ = DecodedToken 1 BigNIntNeedHeader
+ src/Codec/CBOR/Term.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}++-- |+-- Module : Codec.CBOR.Term+-- Copyright : (c) Duncan Coutts 2015-2017+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : duncan@community.haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module provides an interface for decoding and encoding arbitrary+-- CBOR values (ones that, for example, may not have been generated by this+-- library).+--+-- Using @'decodeTerm'@, you can decode an arbitrary CBOR value given to you+-- into a @'Term'@, which represents a CBOR value as an AST.+--+-- Similarly, if you wanted to encode some value into a CBOR value directly,+-- you can wrap it in a @'Term'@ constructor and use @'encodeTerm'@. This+-- would be useful, as an example, if you needed to serialise some value into+-- a CBOR term that is not compatible with that types @'Serialise'@ instance.+--+-- Because this interface gives you the ability to decode or encode any+-- arbitrary CBOR term, it can also be seen as an alternative interface to the+-- @'Codec.CBOR.Encoding'@ and+-- @'Codec.CBOR.Decoding'@ modules.+--+module Codec.CBOR.Term+ ( Term(..) -- :: *+ , encodeTerm -- :: Term -> Encoding+ , decodeTerm -- :: Decoder Term+ ) where++#include "cbor.h"++import Codec.CBOR.Encoding hiding (Tokens(..))+import Codec.CBOR.Decoding++import Data.Word+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Monoid+import Control.Applicative++import Prelude hiding (encodeFloat, decodeFloat)++--------------------------------------------------------------------------------+-- Types++-- | A general CBOR term, which can be used to serialise or deserialise+-- arbitrary CBOR terms for interoperability or debugging. This type is+-- essentially a direct reflection of the CBOR abstract syntax tree as a+-- Haskell data type.+--+-- The @'Term'@ type also comes with a @'Serialise'@ instance, so you can+-- easily use @'decode' :: 'Decoder' 'Term'@ to directly decode any arbitrary+-- CBOR value into Haskell with ease, and likewise with @'encode'@.+--+-- @since 0.2.0.0+data Term+ = TInt {-# UNPACK #-} !Int+ | TInteger !Integer+ | TBytes !BS.ByteString+ | TBytesI !LBS.ByteString+ | TString !T.Text+ | TStringI !LT.Text+ | TList ![Term]+ | TListI ![Term]+ | TMap ![(Term, Term)]+ | TMapI ![(Term, Term)]+ | TTagged {-# UNPACK #-} !Word64 !Term+ | TBool !Bool+ | TNull+ | TSimple {-# UNPACK #-} !Word8+ | THalf {-# UNPACK #-} !Float+ | TFloat {-# UNPACK #-} !Float+ | TDouble {-# UNPACK #-} !Double+ deriving (Eq, Ord, Show, Read)++--------------------------------------------------------------------------------+-- Main API++-- | Encode an arbitrary @'Term'@ into an @'Encoding'@ for later serialization.+--+-- @since 0.2.0.0+encodeTerm :: Term -> Encoding+encodeTerm (TInt n) = encodeInt n+encodeTerm (TInteger n) = encodeInteger n+encodeTerm (TBytes bs) = encodeBytes bs+encodeTerm (TString st) = encodeString st+encodeTerm (TBytesI bss) = encodeBytesIndef+ <> mconcat [ encodeBytes bs+ | bs <- LBS.toChunks bss ]+ <> encodeBreak+encodeTerm (TStringI sts) = encodeStringIndef+ <> mconcat [ encodeString str+ | str <- LT.toChunks sts ]+ <> encodeBreak+encodeTerm (TList ts) = encodeListLen (fromIntegral $ length ts)+ <> mconcat [ encodeTerm t | t <- ts ]+encodeTerm (TListI ts) = encodeListLenIndef+ <> mconcat [ encodeTerm t | t <- ts ]+ <> encodeBreak+encodeTerm (TMap ts) = encodeMapLen (fromIntegral $ length ts)+ <> mconcat [ encodeTerm t <> encodeTerm t'+ | (t, t') <- ts ]+encodeTerm (TMapI ts) = encodeMapLenIndef+ <> mconcat [ encodeTerm t <> encodeTerm t'+ | (t, t') <- ts ]+ <> encodeBreak+encodeTerm (TTagged w t) = encodeTag64 w <> encodeTerm t+encodeTerm (TBool b) = encodeBool b+encodeTerm TNull = encodeNull+encodeTerm (TSimple w) = encodeSimple w+encodeTerm (THalf f) = encodeFloat16 f+encodeTerm (TFloat f) = encodeFloat f+encodeTerm (TDouble f) = encodeDouble f++-- | Decode some arbitrary CBOR value into a @'Term'@.+--+-- @since 0.2.0.0+decodeTerm :: Decoder s Term+decodeTerm = do+ tkty <- peekTokenType+ case tkty of+ TypeUInt -> do w <- decodeWord+ return $! fromWord w+ where+ fromWord :: Word -> Term+ fromWord w+ | w <= fromIntegral (maxBound :: Int)+ = TInt (fromIntegral w)+ | otherwise = TInteger (fromIntegral w)++ TypeUInt64 -> do w <- decodeWord64+ return $! fromWord64 w+ where+ fromWord64 w+ | w <= fromIntegral (maxBound :: Int)+ = TInt (fromIntegral w)+ | otherwise = TInteger (fromIntegral w)++ TypeNInt -> do w <- decodeNegWord+ return $! fromNegWord w+ where+ fromNegWord w+ | w <= fromIntegral (maxBound :: Int)+ = TInt (-1 - fromIntegral w)+ | otherwise = TInteger (-1 - fromIntegral w)++ TypeNInt64 -> do w <- decodeNegWord64+ return $! fromNegWord64 w+ where+ fromNegWord64 w+ | w <= fromIntegral (maxBound :: Int)+ = TInt (-1 - fromIntegral w)+ | otherwise = TInteger (-1 - fromIntegral w)++ TypeInteger -> do !x <- decodeInteger+ return (TInteger x)+ TypeFloat16 -> do !x <- decodeFloat+ return (THalf x)+ TypeFloat32 -> do !x <- decodeFloat+ return (TFloat x)+ TypeFloat64 -> do !x <- decodeDouble+ return (TDouble x)++ TypeBytes -> do !x <- decodeBytes+ return (TBytes x)+ TypeBytesIndef -> decodeBytesIndef >> decodeBytesIndefLen []+ TypeString -> do !x <- decodeString+ return (TString x)+ TypeStringIndef -> decodeStringIndef >> decodeStringIndefLen []++ TypeListLen -> decodeListLen >>= flip decodeListN []+ TypeListLen64 -> decodeListLen >>= flip decodeListN []+ TypeListLenIndef -> decodeListLenIndef >> decodeListIndefLen []+ TypeMapLen -> decodeMapLen >>= flip decodeMapN []+ TypeMapLen64 -> decodeMapLen >>= flip decodeMapN []+ TypeMapLenIndef -> decodeMapLenIndef >> decodeMapIndefLen []+ TypeTag -> do !x <- decodeTag64+ !y <- decodeTerm+ return (TTagged x y)+ TypeTag64 -> do !x <- decodeTag64+ !y <- decodeTerm+ return (TTagged x y)++ TypeBool -> do !x <- decodeBool+ return (TBool x)+ TypeNull -> TNull <$ decodeNull+ TypeSimple -> do !x <- decodeSimple+ return (TSimple x)+ TypeBreak -> fail "unexpected break"+ TypeInvalid -> fail "invalid token encoding"++--------------------------------------------------------------------------------+-- Internal utilities++decodeBytesIndefLen :: [BS.ByteString] -> Decoder s Term+decodeBytesIndefLen acc = do+ stop <- decodeBreakOr+ if stop then return $! TBytesI (LBS.fromChunks (reverse acc))+ else do !bs <- decodeBytes+ decodeBytesIndefLen (bs : acc)+++decodeStringIndefLen :: [T.Text] -> Decoder s Term+decodeStringIndefLen acc = do+ stop <- decodeBreakOr+ if stop then return $! TStringI (LT.fromChunks (reverse acc))+ else do !str <- decodeString+ decodeStringIndefLen (str : acc)+++decodeListN :: Int -> [Term] -> Decoder s Term+decodeListN !n acc =+ case n of+ 0 -> return $! TList (reverse acc)+ _ -> do !t <- decodeTerm+ decodeListN (n-1) (t : acc)+++decodeListIndefLen :: [Term] -> Decoder s Term+decodeListIndefLen acc = do+ stop <- decodeBreakOr+ if stop then return $! TListI (reverse acc)+ else do !tm <- decodeTerm+ decodeListIndefLen (tm : acc)+++decodeMapN :: Int -> [(Term, Term)] -> Decoder s Term+decodeMapN !n acc =+ case n of+ 0 -> return $! TMap (reverse acc)+ _ -> do !tm <- decodeTerm+ !tm' <- decodeTerm+ decodeMapN (n-1) ((tm, tm') : acc)+++decodeMapIndefLen :: [(Term, Term)] -> Decoder s Term+decodeMapIndefLen acc = do+ stop <- decodeBreakOr+ if stop then return $! TMapI (reverse acc)+ else do !tm <- decodeTerm+ !tm' <- decodeTerm+ decodeMapIndefLen ((tm, tm') : acc)+
+ src/Codec/CBOR/Write.hs view
@@ -0,0 +1,590 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module : Codec.CBOR.Write+-- Copyright : (c) Duncan Coutts 2015-2017+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : duncan@community.haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- Tools for writing out CBOR @'Encoding'@ values in+-- a variety of forms.+--+module Codec.CBOR.Write+ ( toBuilder -- :: Encoding -> B.Builder+ , toLazyByteString -- :: Encoding -> L.ByteString+ , toStrictByteString -- :: Encoding -> S.ByteString+ ) where++#include "cbor.h"++import Data.Bits+import Data.Int+import Data.Monoid+import Data.Word+import Foreign.Ptr++import qualified Data.ByteString as S+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Internal as BI+import Data.ByteString.Builder.Prim (condB, (>$<), (>*<))+import qualified Data.ByteString.Builder.Prim as P+import qualified Data.ByteString.Builder.Prim.Internal as PI+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++#if defined(OPTIMIZE_GMP)+import Control.Exception.Base (assert)+import GHC.Exts+import qualified GHC.Integer.GMP.Internals as Gmp+#if __GLASGOW_HASKELL__ < 710+import GHC.Word+#endif+#endif++import Codec.CBOR.Encoding+import Codec.CBOR.Magic++--------------------------------------------------------------------------------++-- | Turn an @'Encoding'@ into a lazy @'L.ByteString'@ in CBOR binary+-- format.+--+-- @since 0.2.0.0+toLazyByteString :: Encoding -- ^ The @'Encoding'@ of a CBOR value.+ -> L.ByteString -- ^ The encoded CBOR value.+toLazyByteString = B.toLazyByteString . toBuilder++-- | Turn an @'Encoding'@ into a strict @'S.ByteString'@ in CBOR binary+-- format.+--+-- @since 0.2.0.0+toStrictByteString :: Encoding -- ^ The @'Encoding'@ of a CBOR value.+ -> S.ByteString -- ^ The encoded value.+toStrictByteString = L.toStrict . B.toLazyByteString . toBuilder++-- | Turn an @'Encoding'@ into a @'L.ByteString'@ @'B.Builder'@ in CBOR+-- binary format.+--+-- @since 0.2.0.0+toBuilder :: Encoding -- ^ The @'Encoding'@ of a CBOR value.+ -> B.Builder -- ^ The encoded value as a @'B.Builder'@.+toBuilder =+ \(Encoding vs0) -> BI.builder (step (vs0 TkEnd))+ where+ step vs1 k (BI.BufferRange op0 ope0) =+ go vs1 op0+ where+ go vs !op+ | op `plusPtr` bound <= ope0 = case vs of+ TkWord x vs' -> PI.runB wordMP x op >>= go vs'+ TkWord64 x vs' -> PI.runB word64MP x op >>= go vs'++ TkInt x vs' -> PI.runB intMP x op >>= go vs'+ TkInt64 x vs' -> PI.runB int64MP x op >>= go vs'++ TkBytes x vs' -> BI.runBuilderWith (bytesMP x) (step vs' k) (BI.BufferRange op ope0)+ TkBytesBegin vs' -> PI.runB bytesBeginMP () op >>= go vs'++ TkString x vs' -> BI.runBuilderWith (stringMP x) (step vs' k) (BI.BufferRange op ope0)+ TkStringBegin vs'-> PI.runB stringBeginMP () op >>= go vs'++ TkListLen x vs' -> PI.runB arrayLenMP x op >>= go vs'+ TkListBegin vs' -> PI.runB arrayBeginMP () op >>= go vs'++ TkMapLen x vs' -> PI.runB mapLenMP x op >>= go vs'+ TkMapBegin vs' -> PI.runB mapBeginMP () op >>= go vs'++ TkTag x vs' -> PI.runB tagMP x op >>= go vs'+ TkTag64 x vs' -> PI.runB tag64MP x op >>= go vs'++#if defined(OPTIMIZE_GMP)+ -- This code is specialized for GMP implementation of Integer. By+ -- looking directly at the constructors we can avoid some checks.+ -- S# hold an Int, so we can just use intMP.+ TkInteger (Gmp.S# i) vs' -> PI.runB intMP (I# i) op >>= go vs'+ -- Jp# is guaranteed to be > 0.+ TkInteger integer@(Gmp.Jp# bigNat) vs'+ | integer <= fromIntegral (maxBound :: Word64) ->+ PI.runB word64MP (fromIntegral integer) op >>= go vs'+ | otherwise ->+ let buffer = BI.BufferRange op ope0+ in BI.runBuilderWith (bigNatMP bigNat) (step vs' k) buffer+ -- Jn# is guaranteed to be < 0.+ TkInteger integer@(Gmp.Jn# bigNat) vs'+ | integer >= -1 - fromIntegral (maxBound :: Word64) ->+ PI.runB negInt64MP (fromIntegral (-1 - integer)) op >>= go vs'+ | otherwise ->+ let buffer = BI.BufferRange op ope0+ in BI.runBuilderWith (negBigNatMP bigNat) (step vs' k) buffer+#else+ TkInteger x vs'+ | x >= 0+ , x <= fromIntegral (maxBound :: Word64)+ -> PI.runB word64MP (fromIntegral x) op >>= go vs'+ | x < 0+ , x >= -1 - fromIntegral (maxBound :: Word64)+ -> PI.runB negInt64MP (fromIntegral (-1 - x)) op >>= go vs'+ | otherwise -> BI.runBuilderWith (integerMP x) (step vs' k) (BI.BufferRange op ope0)+#endif++ TkBool False vs' -> PI.runB falseMP () op >>= go vs'+ TkBool True vs' -> PI.runB trueMP () op >>= go vs'+ TkNull vs' -> PI.runB nullMP () op >>= go vs'+ TkUndef vs' -> PI.runB undefMP () op >>= go vs'+ TkSimple w vs' -> PI.runB simpleMP w op >>= go vs'+ TkFloat16 f vs' -> PI.runB halfMP f op >>= go vs'+ TkFloat32 f vs' -> PI.runB floatMP f op >>= go vs'+ TkFloat64 f vs' -> PI.runB doubleMP f op >>= go vs'+ TkBreak vs' -> PI.runB breakMP () op >>= go vs'++ TkEnd -> k (BI.BufferRange op ope0)++ | otherwise = return $ BI.bufferFull bound op (step vs k)++ -- The maximum size in bytes of the fixed-size encodings+ bound :: Int+ bound = 9+++header :: P.BoundedPrim Word8+header = P.liftFixedToBounded P.word8++constHeader :: Word8 -> P.BoundedPrim ()+constHeader h = P.liftFixedToBounded (const h >$< P.word8)++withHeader :: P.FixedPrim a -> P.BoundedPrim (Word8, a)+withHeader p = P.liftFixedToBounded (P.word8 >*< p)++withConstHeader :: Word8 -> P.FixedPrim a -> P.BoundedPrim a+withConstHeader h p = P.liftFixedToBounded ((,) h >$< (P.word8 >*< p))+++{-+From RFC 7049:++ Major type 0: an unsigned integer. The 5-bit additional information+ is either the integer itself (for additional information values 0+ through 23) or the length of additional data. Additional+ information 24 means the value is represented in an additional+ uint8_t, 25 means a uint16_t, 26 means a uint32_t, and 27 means a+ uint64_t. For example, the integer 10 is denoted as the one byte+ 0b000_01010 (major type 0, additional information 10). The+ integer 500 would be 0b000_11001 (major type 0, additional+ information 25) followed by the two bytes 0x01f4, which is 500 in+ decimal.++-}++{-# INLINE wordMP #-}+wordMP :: P.BoundedPrim Word+wordMP =+ condB (<= 0x17) (fromIntegral >$< header) $+ condB (<= 0xff) (fromIntegral >$< withConstHeader 24 P.word8) $+ condB (<= 0xffff) (fromIntegral >$< withConstHeader 25 P.word16BE) $+#if defined(ARCH_64bit)+ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 26 P.word32BE) $+ (fromIntegral >$< withConstHeader 27 P.word64BE)+#else+ (fromIntegral >$< withConstHeader 26 P.word32BE)+#endif++{-# INLINE word64MP #-}+word64MP :: P.BoundedPrim Word64+word64MP =+ condB (<= 0x17) (fromIntegral >$< header) $+ condB (<= 0xff) (fromIntegral >$< withConstHeader 24 P.word8) $+ condB (<= 0xffff) (fromIntegral >$< withConstHeader 25 P.word16BE) $+ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 26 P.word32BE) $+ (fromIntegral >$< withConstHeader 27 P.word64BE)++{-+From RFC 7049:++ Major type 1: a negative integer. The encoding follows the rules+ for unsigned integers (major type 0), except that the value is+ then -1 minus the encoded unsigned integer. For example, the+ integer -500 would be 0b001_11001 (major type 1, additional+ information 25) followed by the two bytes 0x01f3, which is 499 in+ decimal.+-}++negInt64MP :: P.BoundedPrim Word64+negInt64MP =+ condB (<= 0x17) (fromIntegral . (0x20 +) >$< header) $+ condB (<= 0xff) (fromIntegral >$< withConstHeader 0x38 P.word8) $+ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0x39 P.word16BE) $+ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0x3a P.word32BE) $+ (fromIntegral >$< withConstHeader 0x3b P.word64BE)++{-+ Major types 0 and 1 are designed in such a way that they can be+ encoded in C from a signed integer without actually doing an if-then-+ else for positive/negative (Figure 2). This uses the fact that+ (-1-n), the transformation for major type 1, is the same as ~n+ (bitwise complement) in C unsigned arithmetic; ~n can then be+ expressed as (-1)^n for the negative case, while 0^n leaves n+ unchanged for non-negative. The sign of a number can be converted to+ -1 for negative and 0 for non-negative (0 or positive) by arithmetic-+ shifting the number by one bit less than the bit length of the number+ (for example, by 63 for 64-bit numbers).++ void encode_sint(int64_t n) {+ uint64t ui = n >> 63; // extend sign to whole length+ mt = ui & 0x20; // extract major type+ ui ^= n; // complement negatives+ if (ui < 24)+ *p++ = mt + ui;+ else if (ui < 256) {+ *p++ = mt + 24;+ *p++ = ui;+ } else+ ...++ Figure 2: Pseudocode for Encoding a Signed Integer+-}++{-# INLINE intMP #-}+intMP :: P.BoundedPrim Int+intMP =+ prep >$< (+ condB ((<= 0x17) . snd) (encIntSmall >$< header) $+ condB ((<= 0xff) . snd) (encInt8 >$< withHeader P.word8) $+ condB ((<= 0xffff) . snd) (encInt16 >$< withHeader P.word16BE) $+#if defined(ARCH_64bit)+ condB ((<= 0xffffffff) . snd) (encInt32 >$< withHeader P.word32BE)+ (encInt64 >$< withHeader P.word64BE)+#else+ (encInt32 >$< withHeader P.word32BE)+#endif+ )+ where+ prep :: Int -> (Word8, Word)+ prep n = (mt, ui)+ where+ sign :: Word -- extend sign to whole length+ sign = fromIntegral (n `unsafeShiftR` intBits)+#if MIN_VERSION_base(4,7,0)+ intBits = finiteBitSize (undefined :: Int) - 1+#else+ intBits = bitSize (undefined :: Int) - 1+#endif++ mt :: Word8 -- select major type+ mt = fromIntegral (sign .&. 0x20)++ ui :: Word -- complement negatives+ ui = fromIntegral n `xor` sign++ encIntSmall :: (Word8, Word) -> Word8+ encIntSmall (mt, ui) = mt + fromIntegral ui+ encInt8 (mt, ui) = (mt + 24, fromIntegral ui)+ encInt16 (mt, ui) = (mt + 25, fromIntegral ui)+ encInt32 (mt, ui) = (mt + 26, fromIntegral ui)+#if defined(ARCH_64bit)+ encInt64 (mt, ui) = (mt + 27, fromIntegral ui)+#endif+++{-# INLINE int64MP #-}+int64MP :: P.BoundedPrim Int64+int64MP =+ prep >$< (+ condB ((<= 0x17) . snd) (encIntSmall >$< header) $+ condB ((<= 0xff) . snd) (encInt8 >$< withHeader P.word8) $+ condB ((<= 0xffff) . snd) (encInt16 >$< withHeader P.word16BE) $+ condB ((<= 0xffffffff) . snd) (encInt32 >$< withHeader P.word32BE)+ (encInt64 >$< withHeader P.word64BE)+ )+ where+ prep :: Int64 -> (Word8, Word64)+ prep n = (mt, ui)+ where+ sign :: Word64 -- extend sign to whole length+ sign = fromIntegral (n `unsafeShiftR` intBits)+#if MIN_VERSION_base(4,7,0)+ intBits = finiteBitSize (undefined :: Int64) - 1+#else+ intBits = bitSize (undefined :: Int64) - 1+#endif++ mt :: Word8 -- select major type+ mt = fromIntegral (sign .&. 0x20)++ ui :: Word64 -- complement negatives+ ui = fromIntegral n `xor` sign++ encIntSmall (mt, ui) = mt + fromIntegral ui+ encInt8 (mt, ui) = (mt + 24, fromIntegral ui)+ encInt16 (mt, ui) = (mt + 25, fromIntegral ui)+ encInt32 (mt, ui) = (mt + 26, fromIntegral ui)+ encInt64 (mt, ui) = (mt + 27, fromIntegral ui)++{-+ Major type 2: a byte string. The string's length in bytes is+ represented following the rules for positive integers (major type+ 0). For example, a byte string whose length is 5 would have an+ initial byte of 0b010_00101 (major type 2, additional information+ 5 for the length), followed by 5 bytes of binary content. A byte+ string whose length is 500 would have 3 initial bytes of+ 0b010_11001 (major type 2, additional information 25 to indicate a+ two-byte length) followed by the two bytes 0x01f4 for a length of+ 500, followed by 500 bytes of binary content.+-}++bytesMP :: S.ByteString -> B.Builder+bytesMP bs =+ P.primBounded bytesLenMP (fromIntegral $ S.length bs) <> B.byteString bs++bytesLenMP :: P.BoundedPrim Word+bytesLenMP =+ condB (<= 0x17) (fromIntegral . (0x40 +) >$< header) $+ condB (<= 0xff) (fromIntegral >$< withConstHeader 0x58 P.word8) $+ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0x59 P.word16BE) $+ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0x5a P.word32BE) $+ (fromIntegral >$< withConstHeader 0x5b P.word64BE)++bytesBeginMP :: P.BoundedPrim ()+bytesBeginMP = constHeader 0x5f++{-+ Major type 3: a text string, specifically a string of Unicode+ characters that is encoded as UTF-8 [RFC3629]. The format of this+ type is identical to that of byte strings (major type 2), that is,+ as with major type 2, the length gives the number of bytes. This+ type is provided for systems that need to interpret or display+ human-readable text, and allows the differentiation between+ unstructured bytes and text that has a specified repertoire and+ encoding. In contrast to formats such as JSON, the Unicode+ characters in this type are never escaped. Thus, a newline+ character (U+000A) is always represented in a string as the byte+ 0x0a, and never as the bytes 0x5c6e (the characters "\" and "n")+ or as 0x5c7530303061 (the characters "\", "u", "0", "0", "0", and+ "a").+-}++stringMP :: T.Text -> B.Builder+stringMP t =+ P.primBounded stringLenMP (fromIntegral $ S.length bs) <> B.byteString bs+ where+ bs = T.encodeUtf8 t++stringLenMP :: P.BoundedPrim Word+stringLenMP =+ condB (<= 0x17) (fromIntegral . (0x60 +) >$< header) $+ condB (<= 0xff) (fromIntegral >$< withConstHeader 0x78 P.word8) $+ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0x79 P.word16BE) $+ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0x7a P.word32BE) $+ (fromIntegral >$< withConstHeader 0x7b P.word64BE)++stringBeginMP :: P.BoundedPrim ()+stringBeginMP = constHeader 0x7f++{-+ Major type 4: an array of data items. Arrays are also called lists,+ sequences, or tuples. The array's length follows the rules for+ byte strings (major type 2), except that the length denotes the+ number of data items, not the length in bytes that the array takes+ up. Items in an array do not need to all be of the same type.+ For example, an array that contains 10 items of any type would+ have an initial byte of 0b100_01010 (major type of 4, additional+ information of 10 for the length) followed by the 10 remaining+ items.+-}++arrayLenMP :: P.BoundedPrim Word+arrayLenMP =+ condB (<= 0x17) (fromIntegral . (0x80 +) >$< header) $+ condB (<= 0xff) (fromIntegral >$< withConstHeader 0x98 P.word8) $+ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0x99 P.word16BE) $+ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0x9a P.word32BE) $+ (fromIntegral >$< withConstHeader 0x9b P.word64BE)++arrayBeginMP :: P.BoundedPrim ()+arrayBeginMP = constHeader 0x9f++{-+ Major type 5: a map of pairs of data items. Maps are also called+ tables, dictionaries, hashes, or objects (in JSON). A map is+ comprised of pairs of data items, each pair consisting of a key+ that is immediately followed by a value. The map's length follows+ the rules for byte strings (major type 2), except that the length+ denotes the number of pairs, not the length in bytes that the map+ takes up. For example, a map that contains 9 pairs would have an+ initial byte of 0b101_01001 (major type of 5, additional+ information of 9 for the number of pairs) followed by the 18+ remaining items. The first item is the first key, the second item+ is the first value, the third item is the second key, and so on.+ A map that has duplicate keys may be well-formed, but it is not+ valid, and thus it causes indeterminate decoding; see also+ Section 3.7.+-}++mapLenMP :: P.BoundedPrim Word+mapLenMP =+ condB (<= 0x17) (fromIntegral . (0xa0 +) >$< header) $+ condB (<= 0xff) (fromIntegral >$< withConstHeader 0xb8 P.word8) $+ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0xb9 P.word16BE) $+ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0xba P.word32BE) $+ (fromIntegral >$< withConstHeader 0xbb P.word64BE)++mapBeginMP :: P.BoundedPrim ()+mapBeginMP = constHeader 0xbf++{-+ Major type 6: optional semantic tagging of other major types.++ In CBOR, a data item can optionally be preceded by a tag to give it+ additional semantics while retaining its structure. The tag is major+ type 6, and represents an integer number as indicated by the tag's+ integer value; the (sole) data item is carried as content data.++ The initial bytes of the tag follow the rules for positive integers+ (major type 0).+-}++tagMP :: P.BoundedPrim Word+tagMP =+ condB (<= 0x17) (fromIntegral . (0xc0 +) >$< header) $+ condB (<= 0xff) (fromIntegral >$< withConstHeader 0xd8 P.word8) $+ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0xd9 P.word16BE) $+#if defined(ARCH_64bit)+ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0xda P.word32BE) $+ (fromIntegral >$< withConstHeader 0xdb P.word64BE)+#else+ (fromIntegral >$< withConstHeader 0xda P.word32BE)+#endif++tag64MP :: P.BoundedPrim Word64+tag64MP =+ condB (<= 0x17) (fromIntegral . (0xc0 +) >$< header) $+ condB (<= 0xff) (fromIntegral >$< withConstHeader 0xd8 P.word8) $+ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0xd9 P.word16BE) $+ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0xda P.word32BE) $+ (fromIntegral >$< withConstHeader 0xdb P.word64BE)++{-+ Major type 7: floating-point numbers and simple data types that need+ no content, as well as the "break" stop code.++ Major type 7 is for two types of data: floating-point numbers and+ "simple values" that do not need any content. Each value of the+ 5-bit additional information in the initial byte has its own separate+ meaning, as defined in Table 1. Like the major types for integers,+ items of this major type do not carry content data; all the+ information is in the initial bytes.++ +-------------+--------------------------------------------------++ | 5-Bit Value | Semantics |+ +-------------+--------------------------------------------------++ | 0..23 | Simple value (value 0..23) |+ | | |+ | 24 | Simple value (value 32..255 in following byte) |+ | | |+ | 25 | IEEE 754 Half-Precision Float (16 bits follow) |+ | | |+ | 26 | IEEE 754 Single-Precision Float (32 bits follow) |+ | | |+ | 27 | IEEE 754 Double-Precision Float (64 bits follow) |+ | | |+ | 28-30 | (Unassigned) |+ | | |+ | 31 | "break" stop code for indefinite-length items |+ +-------------+--------------------------------------------------++-}++simpleMP :: P.BoundedPrim Word8+simpleMP =+ condB (<= 0x17) ((0xe0 +) >$< header) $+ (withConstHeader 0xf8 P.word8)++falseMP :: P.BoundedPrim ()+falseMP = constHeader 0xf4++trueMP :: P.BoundedPrim ()+trueMP = constHeader 0xf5++nullMP :: P.BoundedPrim ()+nullMP = constHeader 0xf6++undefMP :: P.BoundedPrim ()+undefMP = constHeader 0xf7++halfMP :: P.BoundedPrim Float+halfMP = floatToWord16 >$<+ withConstHeader 0xf9 P.word16BE++floatMP :: P.BoundedPrim Float+floatMP = withConstHeader 0xfa P.floatBE++doubleMP :: P.BoundedPrim Double+doubleMP = withConstHeader 0xfb P.doubleBE++breakMP :: P.BoundedPrim ()+breakMP = constHeader 0xff++#if defined(OPTIMIZE_GMP)+-- ---------------------------------------- --+-- Implementation optimized for integer-gmp --+-- ---------------------------------------- --+bigNatMP :: Gmp.BigNat -> B.Builder+bigNatMP n = P.primBounded header 0xc2 <> bigNatToBuilder n++negBigNatMP :: Gmp.BigNat -> B.Builder+negBigNatMP n =+ -- If value `n` is stored in CBOR, it is interpreted as -1 - n. Since BigNat+ -- already represents n (note: it's unsigned), we simply decrement it to get+ -- the correct encoding.+ P.primBounded header 0xc3+ <> bigNatToBuilder (Gmp.minusBigNatWord n (int2Word# 1#))++bigNatToBuilder :: Gmp.BigNat -> B.Builder+bigNatToBuilder = bigNatBuilder+ where+ bigNatBuilder :: Gmp.BigNat -> B.Builder+ bigNatBuilder bigNat =+ let sizeW# = Gmp.sizeInBaseBigNat bigNat 256#+ bounded = PI.boudedPrim (I# (word2Int# sizeW#)) (dumpBigNat sizeW#)+ in P.primBounded bytesLenMP (W# sizeW#) <> P.primBounded bounded bigNat++ dumpBigNat :: Word# -> Gmp.BigNat -> Ptr a -> IO (Ptr a)+ dumpBigNat sizeW# bigNat ptr@(Ptr addr#) = do+ -- The last parameter (`1#`) makes the export function use big endian+ -- encoding.+ (W# written#) <- Gmp.exportBigNatToAddr bigNat addr# 1#+ let !newPtr = ptr `plusPtr` (I# (word2Int# written#))+ sanity = isTrue# (sizeW# `eqWord#` written#)+ return $ assert sanity newPtr++#else++-- ---------------------- --+-- Generic implementation --+-- ---------------------- --+integerMP :: Integer -> B.Builder+integerMP n+ | n >= 0 = P.primBounded header 0xc2 <> integerToBuilder n+ | otherwise = P.primBounded header 0xc3 <> integerToBuilder (-1 - n)++integerToBuilder :: Integer -> B.Builder+integerToBuilder n = bytesMP (integerToBytes n)++integerToBytes :: Integer -> S.ByteString+integerToBytes n0+ | n0 == 0 = S.pack [0]+ | otherwise = S.pack (reverse (go n0))+ where+ go n | n == 0 = []+ | otherwise = narrow n : go (n `shiftR` 8)++ narrow :: Integer -> Word8+ narrow = fromIntegral+#endif
+ src/cbits/cbor.h view
@@ -0,0 +1,48 @@+/* Needed GHC definitions */+#include "MachDeps.h"++/*+** GHC 7.10 and above include efficient byte-swapping primitives,+** which are useful for efficient byte-mangling routines.+*/+#if __GLASGOW_HASKELL__ >= 710+#define HAVE_BYTESWAP_PRIMOPS+#endif++/*+** On Intel 32/64 bit machines, memory access to unaligned addresses+** is permitted (and generally efficient, too). With this in mind,+** some operations can be implemented more efficiently.+*/+#if i386_HOST_ARCH || x86_64_HOST_ARCH+#define MEM_UNALIGNED_OPS+#endif++/*+** Determine whether or not we can use more efficient code paths for+** integer-gmp.+*/++#if !defined(MIN_VERSION_integer_gmp)+/*+** In case this isn't defined, then just bail. If someone isn't using+** integer-gmp, then it won't be in the dependency list, so this macro+** might not(?) be generated by Cabal.+*/+#define MIN_VERSION_integer_gmp(x,y,z) 0+#endif++#if defined(FLAG_OPTIMIZE_GMP) && MIN_VERSION_integer_gmp(1,0,0)+#define OPTIMIZE_GMP+#endif++/*+** Establish the word-size of the machine, or fail.+*/+#if WORD_SIZE_IN_BITS == 64+#define ARCH_64bit+#elif WORD_SIZE_IN_BITS == 32+#define ARCH_32bit+#else+#error expected WORD_SIZE_IN_BITS to be 32 or 64+#endif