{-# 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 (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)

--------------------------------------------------------------------------------
-- Main API

-- | Encode an arbitrary 'Term' into an 'Encoding' for later serialization.
--
-- @since 0.2.0.0
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

-- | Decode some arbitrary CBOR value into a 'Term'.
--
-- @since 0.2.0.0
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"

--------------------------------------------------------------------------------
-- Internal utilities

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)