{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
module Codec.CBOR.Term
( Term(..)
, encodeTerm
, decodeTerm
) 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)
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 (Term -> Term -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Term -> Term -> Bool
$c/= :: Term -> Term -> Bool
== :: Term -> Term -> Bool
$c== :: Term -> Term -> Bool
Eq, Eq Term
Term -> Term -> Bool
Term -> Term -> Ordering
Term -> Term -> Term
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Term -> Term -> Term
$cmin :: Term -> Term -> Term
max :: Term -> Term -> Term
$cmax :: Term -> Term -> Term
>= :: Term -> Term -> Bool
$c>= :: Term -> Term -> Bool
> :: Term -> Term -> Bool
$c> :: Term -> Term -> Bool
<= :: Term -> Term -> Bool
$c<= :: Term -> Term -> Bool
< :: Term -> Term -> Bool
$c< :: Term -> Term -> Bool
compare :: Term -> Term -> Ordering
$ccompare :: Term -> Term -> Ordering
Ord, Int -> Term -> ShowS
[Term] -> ShowS
Term -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Term] -> ShowS
$cshowList :: [Term] -> ShowS
show :: Term -> String
$cshow :: Term -> String
showsPrec :: Int -> Term -> ShowS
$cshowsPrec :: Int -> Term -> ShowS
Show, ReadPrec [Term]
ReadPrec Term
Int -> ReadS Term
ReadS [Term]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Term]
$creadListPrec :: ReadPrec [Term]
readPrec :: ReadPrec Term
$creadPrec :: ReadPrec Term
readList :: ReadS [Term]
$creadList :: ReadS [Term]
readsPrec :: Int -> ReadS Term
$creadsPrec :: Int -> ReadS Term
Read)
encodeTerm :: Term -> Encoding
encodeTerm :: Term -> Encoding
encodeTerm (TInt Int
n) = Int -> Encoding
encodeInt Int
n
encodeTerm (TInteger Integer
n) = Integer -> Encoding
encodeInteger Integer
n
encodeTerm (TBytes ByteString
bs) = ByteString -> Encoding
encodeBytes ByteString
bs
encodeTerm (TString Text
st) = Text -> Encoding
encodeString Text
st
encodeTerm (TBytesI ByteString
bss) = Encoding
encodeBytesIndef
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Encoding
encodeBytes ByteString
bs
| ByteString
bs <- ByteString -> [ByteString]
LBS.toChunks ByteString
bss ]
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak
encodeTerm (TStringI Text
sts) = Encoding
encodeStringIndef
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [ Text -> Encoding
encodeString Text
str
| Text
str <- Text -> [Text]
LT.toChunks Text
sts ]
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak
encodeTerm (TList [Term]
ts) = Word -> Encoding
encodeListLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
ts)
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [ Term -> Encoding
encodeTerm Term
t | Term
t <- [Term]
ts ]
encodeTerm (TListI [Term]
ts) = Encoding
encodeListLenIndef
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [ Term -> Encoding
encodeTerm Term
t | Term
t <- [Term]
ts ]
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak
encodeTerm (TMap [(Term, Term)]
ts) = Word -> Encoding
encodeMapLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Term, Term)]
ts)
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [ Term -> Encoding
encodeTerm Term
t forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
encodeTerm Term
t'
| (Term
t, Term
t') <- [(Term, Term)]
ts ]
encodeTerm (TMapI [(Term, Term)]
ts) = Encoding
encodeMapLenIndef
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [ Term -> Encoding
encodeTerm Term
t forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
encodeTerm Term
t'
| (Term
t, Term
t') <- [(Term, Term)]
ts ]
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak
encodeTerm (TTagged Word64
w Term
t) = Word64 -> Encoding
encodeTag64 Word64
w forall a. Semigroup a => a -> a -> a
<> Term -> Encoding
encodeTerm Term
t
encodeTerm (TBool Bool
b) = Bool -> Encoding
encodeBool Bool
b
encodeTerm Term
TNull = Encoding
encodeNull
encodeTerm (TSimple Word8
w) = Word8 -> Encoding
encodeSimple Word8
w
encodeTerm (THalf Float
f) = Float -> Encoding
encodeFloat16 Float
f
encodeTerm (TFloat Float
f) = Float -> Encoding
encodeFloat Float
f
encodeTerm (TDouble Double
f) = Double -> Encoding
encodeDouble Double
f
decodeTerm :: Decoder s Term
decodeTerm :: forall s. Decoder s Term
decodeTerm = do
TokenType
tkty <- forall s. Decoder s TokenType
peekTokenType
case TokenType
tkty of
TokenType
TypeUInt -> do Word
w <- forall s. Decoder s Word
decodeWord
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Word -> Term
fromWord Word
w
where
fromWord :: Word -> Term
fromWord :: Word -> Term
fromWord Word
w
| Word
w forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int)
= Int -> Term
TInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)
| Bool
otherwise = Integer -> Term
TInteger (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w)
TokenType
TypeUInt64 -> do Word64
w <- forall s. Decoder s Word64
decodeWord64
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall {a}. Integral a => a -> Term
fromWord64 Word64
w
where
fromWord64 :: a -> Term
fromWord64 a
w
| a
w forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int)
= Int -> Term
TInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)
| Bool
otherwise = Integer -> Term
TInteger (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)
TokenType
TypeNInt -> do Word
w <- forall s. Decoder s Word
decodeNegWord
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall {a}. Integral a => a -> Term
fromNegWord Word
w
where
fromNegWord :: a -> Term
fromNegWord a
w
| a
w forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int)
= Int -> Term
TInt (-Int
1 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)
| Bool
otherwise = Integer -> Term
TInteger (-Integer
1 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)
TokenType
TypeNInt64 -> do Word64
w <- forall s. Decoder s Word64
decodeNegWord64
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall {a}. Integral a => a -> Term
fromNegWord64 Word64
w
where
fromNegWord64 :: a -> Term
fromNegWord64 a
w
| a
w forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int)
= Int -> Term
TInt (-Int
1 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)
| Bool
otherwise = Integer -> Term
TInteger (-Integer
1 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)
TokenType
TypeInteger -> do !Integer
x <- forall s. Decoder s Integer
decodeInteger
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Term
TInteger Integer
x)
TokenType
TypeFloat16 -> do !Float
x <- forall s. Decoder s Float
decodeFloat
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> Term
THalf Float
x)
TokenType
TypeFloat32 -> do !Float
x <- forall s. Decoder s Float
decodeFloat
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> Term
TFloat Float
x)
TokenType
TypeFloat64 -> do !Double
x <- forall s. Decoder s Double
decodeDouble
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Term
TDouble Double
x)
TokenType
TypeBytes -> do !ByteString
x <- forall s. Decoder s ByteString
decodeBytes
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Term
TBytes ByteString
x)
TokenType
TypeBytesIndef -> forall s. Decoder s ()
decodeBytesIndef forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. [ByteString] -> Decoder s Term
decodeBytesIndefLen []
TokenType
TypeString -> do !Text
x <- forall s. Decoder s Text
decodeString
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Term
TString Text
x)
TokenType
TypeStringIndef -> forall s. Decoder s ()
decodeStringIndef forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. [Text] -> Decoder s Term
decodeStringIndefLen []
TokenType
TypeListLen -> forall s. Decoder s Int
decodeListLen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. Int -> [Term] -> Decoder s Term
decodeListN []
TokenType
TypeListLen64 -> forall s. Decoder s Int
decodeListLen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. Int -> [Term] -> Decoder s Term
decodeListN []
TokenType
TypeListLenIndef -> forall s. Decoder s ()
decodeListLenIndef forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. [Term] -> Decoder s Term
decodeListIndefLen []
TokenType
TypeMapLen -> forall s. Decoder s Int
decodeMapLen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. Int -> [(Term, Term)] -> Decoder s Term
decodeMapN []
TokenType
TypeMapLen64 -> forall s. Decoder s Int
decodeMapLen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. Int -> [(Term, Term)] -> Decoder s Term
decodeMapN []
TokenType
TypeMapLenIndef -> forall s. Decoder s ()
decodeMapLenIndef forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. [(Term, Term)] -> Decoder s Term
decodeMapIndefLen []
TokenType
TypeTag -> do !Word64
x <- forall s. Decoder s Word64
decodeTag64
!Term
y <- forall s. Decoder s Term
decodeTerm
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Term -> Term
TTagged Word64
x Term
y)
TokenType
TypeTag64 -> do !Word64
x <- forall s. Decoder s Word64
decodeTag64
!Term
y <- forall s. Decoder s Term
decodeTerm
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Term -> Term
TTagged Word64
x Term
y)
TokenType
TypeBool -> do !Bool
x <- forall s. Decoder s Bool
decodeBool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Term
TBool Bool
x)
TokenType
TypeNull -> Term
TNull forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s. Decoder s ()
decodeNull
TokenType
TypeSimple -> do !Word8
x <- forall s. Decoder s Word8
decodeSimple
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Term
TSimple Word8
x)
TokenType
TypeBreak -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected break"
TokenType
TypeInvalid -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid token encoding"
decodeBytesIndefLen :: [BS.ByteString] -> Decoder s Term
decodeBytesIndefLen :: forall s. [ByteString] -> Decoder s Term
decodeBytesIndefLen [ByteString]
acc = do
Bool
stop <- forall s. Decoder s Bool
decodeBreakOr
if Bool
stop then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString -> Term
TBytesI ([ByteString] -> ByteString
LBS.fromChunks (forall a. [a] -> [a]
reverse [ByteString]
acc))
else do !ByteString
bs <- forall s. Decoder s ByteString
decodeBytes
forall s. [ByteString] -> Decoder s Term
decodeBytesIndefLen (ByteString
bs forall a. a -> [a] -> [a]
: [ByteString]
acc)
decodeStringIndefLen :: [T.Text] -> Decoder s Term
decodeStringIndefLen :: forall s. [Text] -> Decoder s Term
decodeStringIndefLen [Text]
acc = do
Bool
stop <- forall s. Decoder s Bool
decodeBreakOr
if Bool
stop then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Text -> Term
TStringI ([Text] -> Text
LT.fromChunks (forall a. [a] -> [a]
reverse [Text]
acc))
else do !Text
str <- forall s. Decoder s Text
decodeString
forall s. [Text] -> Decoder s Term
decodeStringIndefLen (Text
str forall a. a -> [a] -> [a]
: [Text]
acc)
decodeListN :: Int -> [Term] -> Decoder s Term
decodeListN :: forall s. Int -> [Term] -> Decoder s Term
decodeListN !Int
n [Term]
acc =
case Int
n of
Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [Term] -> Term
TList (forall a. [a] -> [a]
reverse [Term]
acc)
Int
_ -> do !Term
t <- forall s. Decoder s Term
decodeTerm
forall s. Int -> [Term] -> Decoder s Term
decodeListN (Int
nforall a. Num a => a -> a -> a
-Int
1) (Term
t forall a. a -> [a] -> [a]
: [Term]
acc)
decodeListIndefLen :: [Term] -> Decoder s Term
decodeListIndefLen :: forall s. [Term] -> Decoder s Term
decodeListIndefLen [Term]
acc = do
Bool
stop <- forall s. Decoder s Bool
decodeBreakOr
if Bool
stop then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [Term] -> Term
TListI (forall a. [a] -> [a]
reverse [Term]
acc)
else do !Term
tm <- forall s. Decoder s Term
decodeTerm
forall s. [Term] -> Decoder s Term
decodeListIndefLen (Term
tm forall a. a -> [a] -> [a]
: [Term]
acc)
decodeMapN :: Int -> [(Term, Term)] -> Decoder s Term
decodeMapN :: forall s. Int -> [(Term, Term)] -> Decoder s Term
decodeMapN !Int
n [(Term, Term)]
acc =
case Int
n of
Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [(Term, Term)] -> Term
TMap (forall a. [a] -> [a]
reverse [(Term, Term)]
acc)
Int
_ -> do !Term
tm <- forall s. Decoder s Term
decodeTerm
!Term
tm' <- forall s. Decoder s Term
decodeTerm
forall s. Int -> [(Term, Term)] -> Decoder s Term
decodeMapN (Int
nforall a. Num a => a -> a -> a
-Int
1) ((Term
tm, Term
tm') forall a. a -> [a] -> [a]
: [(Term, Term)]
acc)
decodeMapIndefLen :: [(Term, Term)] -> Decoder s Term
decodeMapIndefLen :: forall s. [(Term, Term)] -> Decoder s Term
decodeMapIndefLen [(Term, Term)]
acc = do
Bool
stop <- forall s. Decoder s Bool
decodeBreakOr
if Bool
stop then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [(Term, Term)] -> Term
TMapI (forall a. [a] -> [a]
reverse [(Term, Term)]
acc)
else do !Term
tm <- forall s. Decoder s Term
decodeTerm
!Term
tm' <- forall s. Decoder s Term
decodeTerm
forall s. [(Term, Term)] -> Decoder s Term
decodeMapIndefLen ((Term
tm, Term
tm') forall a. a -> [a] -> [a]
: [(Term, Term)]
acc)