content: {-# 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)
  
  