{-# LANGUAGE
BangPatterns,
OverloadedStrings,
NoImplicitPrelude
  #-}

{- |
Efficiently serialize a JSON value.

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 Json.Internal.Encode.Text
(
  encodeToText,
  encodeToTextWith,

  -- * Encoding to Builders
  encodeToTextBuilder,
  encodeToTextBuilderWith,
)
where

import BasePrelude

import Json.Internal.Types

import Data.Scientific (FPFormat(..), Scientific, base10Exponent)
import Data.Text.Lazy.Builder as Builder
import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as V

-- TODO: perhaps encoding to ByteString and then decoding is actually faster?
-- should benchmark
encodeToText :: Json -> TL.Text
encodeToText = toLazyText . encodeToTextBuilder
{-# INLINE encodeToText #-}

encodeToTextWith :: EncodingOptions -> Json -> TL.Text
encodeToTextWith opts = toLazyText . encodeToTextBuilderWith opts
{-# INLINE encodeToTextWith #-}

{- |
Encode a JSON value to a "Data.Text" 'Builder'.

Don't use this function – 'Json.decode' already can encode to 'Builder'.
-}
encodeToTextBuilder :: Json -> Builder
encodeToTextBuilder =
    go
  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

{- |
Don't use this function – 'Json.decode' already can encode to 'Builder'.
-}
encodeToTextBuilderWith :: EncodingOptions -> Json -> Builder
encodeToTextBuilderWith opts = go
  where
    string' = if escapeAngleBrackets opts
                then stringEscapeBrackets else string
    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' doesn't mention \n, \r and \t because they are handled by
    -- the “< '\x20'” case; yes, later 'escape' escapes them differently,
    -- but it's irrelevant
    isEscape c = c == '\"' ||
                 c == '\\' ||
                 c < '\x20'
    escape '\"' = "\\\""
    escape '\\' = "\\\\"
    escape '\n' = "\\n"
    escape '\r' = "\\r"
    escape '\t' = "\\t"

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

stringEscapeBrackets :: T.Text -> Builder
stringEscapeBrackets s =
  {-# SCC "stringEscapeBrackets" #-} 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 == '<'  ||
                 c == '>'  ||
                 c < '\x20'
    escape '\"' = "\\\""
    escape '\\' = "\\\\"
    escape '\n' = "\\n"
    escape '\r' = "\\r"
    escape '\t' = "\\t"
    escape '<'  = "\\u003c"
    escape '>'  = "\\u003e"

    escape c
        | c < '\x20' = Builder.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)
