{-# 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.Semigroup ((<>))
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 Null       = {-# SCC "go/Null" #-} "null"
    go (Bool b :: Bool
b)   = {-# SCC "go/Bool" #-} if Bool
b then "true" else "false"
    go (Number s :: Scientific
s) = {-# SCC "go/Number" #-} Scientific -> Builder
fromScientific Scientific
s
    go (String s :: Text
s) = {-# SCC "go/String" #-} Text -> Builder
string Text
s
    go (Array v :: Array
v)
        | Array -> Bool
forall a. Vector a -> Bool
V.null Array
v = {-# SCC "go/Array" #-} "[]"
        | Bool
otherwise = {-# SCC "go/Array" #-}
                      Char -> Builder
singleton '[' 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 ']') (Array -> Array
forall a. Vector a -> Vector a
V.unsafeTail Array
v)
      where f :: Value -> Builder -> Builder
f a :: Value
a z :: Builder
z = Char -> Builder
singleton ',' 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 m :: Object
m) = {-# SCC "go/Object" #-}
        case Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
H.toList Object
m of
          (x :: (Text, Value)
x:xs :: [(Text, Value)]
xs) -> Char -> Builder
singleton '{' 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 '}') [(Text, Value)]
xs
          _      -> "{}"
      where f :: (Text, Value) -> Builder -> Builder
f a :: (Text, Value)
a z :: Builder
z     = Char -> Builder
singleton ',' 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 (k :: Text
k,v :: Value
v) = Text -> Builder
string Text
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton ':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Value -> Builder
go Value
v

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

    escape c :: Char
c
        | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< '\x20' = String -> Builder
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ "\\u" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
h) '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) ""

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