{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# 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 Prelude.Compat

import Data.Aeson.Types (Value(..), ToJSON(..))
import Data.Aeson.Encoding (encodingToLazyByteString)
import Data.Scientific (FPFormat(..), Scientific, base10Exponent)
import Data.Text.Lazy.Builder
import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)
import Numeric (showHex)
import qualified Data.HashMap.Strict as H
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 :: 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 :: 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       = {-# SCC "go/Null" #-} Builder
"null"
    go (Bool Bool
b)   = {-# SCC "go/Bool" #-} if Bool
b then Builder
"true" else Builder
"false"
    go (Number Scientific
s) = {-# SCC "go/Number" #-} Scientific -> Builder
fromScientific Scientific
s
    go (String Text
s) = {-# SCC "go/String" #-} Text -> Builder
string Text
s
    go (Array Array
v)
        | Array -> Bool
forall a. Vector a -> Bool
V.null Array
v = {-# SCC "go/Array" #-} Builder
"[]"
        | Bool
otherwise = {-# SCC "go/Array" #-}
                      Char -> Builder
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
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
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) = {-# SCC "go/Object" #-}
        case Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
H.toList Object
m of
          ((Text, Value)
x:[(Text, Value)]
xs) -> Char -> Builder
singleton Char
'{' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text, Value) -> Builder
one (Text, Value)
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((Text, Value) -> Builder -> Builder)
-> Builder -> [(Text, Value)] -> Builder
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, Value) -> Builder -> Builder
f (Char -> Builder
singleton Char
'}') [(Text, Value)]
xs
          [(Text, Value)]
_      -> Builder
"{}"
      where f :: (Text, Value) -> Builder -> Builder
f (Text, Value)
a Builder
z     = Char -> Builder
singleton Char
',' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text, Value) -> Builder
one (Text, Value)
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
z
            one :: (Text, Value) -> Builder
one (Text
k,Value
v) = Text -> Builder
string Text
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
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 = {-# SCC "string" #-} Char -> Builder
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
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
fromText Text
h
                Just (!Char
c,Text
t') -> Text -> Builder
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) = {-# SCC "break" #-} (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' = String -> Builder
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String
"\\u" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
h) Char
'0' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h
        | Bool
otherwise  = Char -> Builder
singleton Char
c
        where h :: String
h = Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) String
""

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)