{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module:      Data.Aeson.Text
-- Copyright:   (c) 2012-2016 Bryan O'Sullivan
--              (c) 2011 MailRank, Inc.
-- License:     BSD3
-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
-- Stability:   experimental
-- Portability: portable
--
-- Most frequently, you'll probably want to encode straight to UTF-8
-- (the standard JSON encoding) using 'encode'.
--
-- You can use the conversions to 'Builder's when embedding JSON messages as
-- parts of a protocol.

module Data.Aeson.Text
    (
      encodeToLazyText
    , encodeToTextBuilder
    ) where

import Data.Aeson.Internal.Prelude

import Data.Aeson.Types (Value(..), ToJSON(..))
import Data.Aeson.Encoding (encodingToLazyByteString)
import qualified Data.Aeson.KeyMap as KM
import Data.Scientific (FPFormat(..), base10Exponent)
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as TB
import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)
import Numeric (showHex)
import qualified Data.Aeson.Key as Key
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import qualified Data.Vector as V

-- | Encode a JSON 'Value' to a "Data.Text.Lazy"
--
-- /Note:/ uses 'toEncoding'
encodeToLazyText :: ToJSON a => a -> LT.Text
encodeToLazyText :: forall a. ToJSON a => a -> Text
encodeToLazyText = ByteString -> Text
LT.decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding' Value -> ByteString
forall a. Encoding' a -> ByteString
encodingToLazyByteString (Encoding' Value -> ByteString)
-> (a -> Encoding' Value) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
toEncoding

-- | Encode a JSON 'Value' to a "Data.Text" 'Builder', which can be
-- embedded efficiently in a text-based protocol.
--
-- If you are going to immediately encode straight to a
-- 'L.ByteString', it is more efficient to use 'encode' (lazy ByteString)
-- or @'fromEncoding' . 'toEncoding'@ (ByteString.Builder) instead.
--
-- /Note:/ Uses 'toJSON'
encodeToTextBuilder :: ToJSON a => a -> Builder
encodeToTextBuilder :: forall a. ToJSON a => a -> Builder
encodeToTextBuilder =
    Value -> Builder
go (Value -> Builder) -> (a -> Value) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON
  where
    go :: Value -> Builder
go Value
Null       = Builder
"null"
    go (Bool Bool
b)   = if Bool
b then Builder
"true" else Builder
"false"
    go (Number Scientific
s) = Scientific -> Builder
fromScientific Scientific
s
    go (String Text
s) = Text -> Builder
string Text
s
    go (Array Array
v)
        | Array -> Bool
forall a. Vector a -> Bool
V.null Array
v = Builder
"[]"
        | Bool
otherwise = 
                      Char -> Builder
TB.singleton Char
'[' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                      Value -> Builder
go (Array -> Value
forall a. Vector a -> a
V.unsafeHead Array
v) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                      (Value -> Builder -> Builder) -> Builder -> Array -> Builder
forall a b. (a -> b -> b) -> b -> Vector a -> b
V.foldr Value -> Builder -> Builder
f (Char -> Builder
TB.singleton Char
']') (Array -> Array
forall a. Vector a -> Vector a
V.unsafeTail Array
v)
      where f :: Value -> Builder -> Builder
f Value
a Builder
z = Char -> Builder
TB.singleton Char
',' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Value -> Builder
go Value
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
z
    go (Object Object
m) = 
        case Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
m of
          ((Key, Value)
x:[(Key, Value)]
xs) -> Char -> Builder
TB.singleton Char
'{' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Key, Value) -> Builder
one (Key, Value)
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((Key, Value) -> Builder -> Builder)
-> Builder -> [(Key, Value)] -> Builder
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Key, Value) -> Builder -> Builder
f (Char -> Builder
TB.singleton Char
'}') [(Key, Value)]
xs
          [(Key, Value)]
_      -> Builder
"{}"
      where f :: (Key, Value) -> Builder -> Builder
f (Key, Value)
a Builder
z     = Char -> Builder
TB.singleton Char
',' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Key, Value) -> Builder
one (Key, Value)
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
z
            one :: (Key, Value) -> Builder
one (Key
k,Value
v) = Text -> Builder
string (Key -> Text
Key.toText Key
k) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Value -> Builder
go Value
v

string :: T.Text -> Builder
string :: Text -> Builder
string Text
s = Char -> Builder
TB.singleton Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
quote Text
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
'"'
  where
    quote :: Text -> Builder
quote Text
q = case Text -> Maybe (Char, Text)
T.uncons Text
t of
                Maybe (Char, Text)
Nothing      -> Text -> Builder
TB.fromText Text
h
                Just (!Char
c,Text
t') -> Text -> Builder
TB.fromText Text
h Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
escape Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
quote Text
t'
        where (Text
h,Text
t) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isEscape Text
q
    isEscape :: Char -> Bool
isEscape Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"' Bool -> Bool -> Bool
||
                 Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
||
                 Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x20'
    escape :: Char -> Builder
escape Char
'\"' = Builder
"\\\""
    escape Char
'\\' = Builder
"\\\\"
    escape Char
'\n' = Builder
"\\n"
    escape Char
'\r' = Builder
"\\r"
    escape Char
'\t' = Builder
"\\t"

    escape Char
c
        | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x20' = [Char] -> Builder
TB.fromString ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ [Char]
"\\u" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
h) Char
'0' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
h
        | Bool
otherwise  = Char -> Builder
TB.singleton Char
c
        where h :: [Char]
h = Int -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showHex (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) [Char]
""

fromScientific :: Scientific -> Builder
fromScientific :: Scientific -> Builder
fromScientific Scientific
s = FPFormat -> Maybe Int -> Scientific -> Builder
formatScientificBuilder FPFormat
format Maybe Int
prec Scientific
s
  where
    (FPFormat
format, Maybe Int
prec)
      | Scientific -> Int
base10Exponent Scientific
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (FPFormat
Generic, Maybe Int
forall a. Maybe a
Nothing)
      | Bool
otherwise            = (FPFormat
Fixed,   Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)