cborg-0.2.10.0: src/Codec/CBOR/Term.hs
{-# 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)