Data/Aeson/Text.hs

{-# 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 Prelude ()
import Prelude.Compat

import Data.Aeson.Types (Value(..), ToJSON(..))
import Data.Aeson.Encoding (encodingToLazyByteString)
import Data.Monoid ((<>))
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 = LT.decodeUtf8 . encodingToLazyByteString . 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 'encodeToBuilder'
-- instead.
--
-- /Note:/ Uses 'toJSON'
encodeToTextBuilder :: ToJSON a => a -> Builder
encodeToTextBuilder =
 go . toJSON
 where
 go Null = {-# SCC "go/Null" #-} "null"
 go (Bool b) = {-# SCC "go/Bool" #-} if b then "true" else "false"
 go (Number s) = {-# SCC "go/Number" #-} fromScientific s
 go (String s) = {-# SCC "go/String" #-} string s
 go (Array v)
 | V.null v = {-# SCC "go/Array" #-} "[]"
 | otherwise = {-# SCC "go/Array" #-}
 singleton '[' <>
 go (V.unsafeHead v) <>
 V.foldr f (singleton ']') (V.unsafeTail v)
 where f a z = singleton ',' <> go a <> z
 go (Object m) = {-# SCC "go/Object" #-}
 case H.toList m of
 (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs
 _ -> "{}"
 where f a z = singleton ',' <> one a <> z
 one (k,v) = string k <> singleton ':' <> go v

string :: T.Text -> Builder
string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"'
 where
 quote q = case T.uncons t of
 Nothing -> fromText h
 Just (!c,t') -> fromText h <> escape c <> quote t'
 where (h,t) = {-# SCC "break" #-} T.break isEscape q
 isEscape c = c == '\"' ||
 c == '\\' ||
 c < '\x20'
 escape '\"' = "\\\""
 escape '\\' = "\\\\"
 escape '\n' = "\\n"
 escape '\r' = "\\r"
 escape '\t' = "\\t"

 escape c
 | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h
 | otherwise = singleton c
 where h = showHex (fromEnum c) ""

fromScientific :: Scientific -> Builder
fromScientific s = formatScientificBuilder format prec s
 where
 (format, prec)
 | base10Exponent s < 0 = (Generic, Nothing)
 | otherwise = (Fixed, Just 0)