{-# LANGUAGE OverloadedStrings #-}

module Drasil.Data.Formats.JSON.Render
  ( -- ** Rendering
    JSONRenderOptions,
    JSONStyle(..),
    jsonRenderOpts,
    renderJSON,
  )
where

import Drasil.Data.Formats.JSON.Core (JSON(..))

import Data.Char (ord, isControl)
import Data.Scientific (formatScientific, isInteger, FPFormat(..))
import Data.Text (Text)
import qualified Data.Text as T (concatMap, pack, singleton)
import Numeric.Natural (Natural)
import Prettyprinter (Doc, braces, brackets, colon, comma, dquotes, pretty,
  hcat, indent, lbrace, lbracket, punctuate, rbrace, rbracket, space, vcat)
import Text.Printf (printf)

-- | Options for rendering 'JSON'.
newtype JSONRenderOptions = JSONRO { JSONRenderOptions -> JSONStyle
style :: JSONStyle }

-- | JSON Style: How the overall JSON document is formatted.
data JSONStyle =
    -- | With as few characters as possible and no newlines.
    Minified
    -- | In a "pretty" human readable way, with given indent size.
  | Pretty Natural

-- | Create 'JSONRenderOptions'.
jsonRenderOpts :: JSONStyle -> JSONRenderOptions
jsonRenderOpts :: JSONStyle -> JSONRenderOptions
jsonRenderOpts = JSONStyle -> JSONRenderOptions
JSONRO

-- | Render 'JSON' to a 'Doc' with the given options.
renderJSON :: JSONRenderOptions -> JSON -> Doc ann
renderJSON :: forall ann. JSONRenderOptions -> JSON -> Doc ann
renderJSON JSONRenderOptions
_ (JObject []) = Doc ann
forall ann. Doc ann
lbrace Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
rbrace
renderJSON JSONRenderOptions
opts (JObject [(Text, JSON)]
m) =
  case JSONStyle
sty of
    JSONStyle
Minified -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat [Doc ann]
forall {ann}. [Doc ann]
content)
    Pretty Natural
i -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann
forall ann. Doc ann
lbrace, Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i) ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann]
forall {ann}. [Doc ann]
content), Doc ann
forall ann. Doc ann
rbrace]
  where
    sty :: JSONStyle
sty = JSONRenderOptions -> JSONStyle
style JSONRenderOptions
opts
    sep :: JSONStyle -> Doc ann
sep JSONStyle
Minified = Doc ann
forall ann. Doc ann
colon
    sep (Pretty Natural
_) = Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
space
    contents :: [Doc ann]
contents = ((Text, JSON) -> Doc ann) -> [(Text, JSON)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, JSON
v) -> Text -> Doc ann
forall ann. Text -> Doc ann
renderString Text
k Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> JSONStyle -> Doc ann
forall {ann}. JSONStyle -> Doc ann
sep JSONStyle
sty Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> JSONRenderOptions -> JSON -> Doc ann
forall ann. JSONRenderOptions -> JSON -> Doc ann
renderJSON JSONRenderOptions
opts JSON
v) [(Text, JSON)]
m
    content :: [Doc ann]
content = Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma [Doc ann]
forall {ann}. [Doc ann]
contents
renderJSON JSONRenderOptions
_ (JArray []) = Doc ann
forall ann. Doc ann
lbracket Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
rbracket
renderJSON JSONRenderOptions
opts (JArray [JSON]
a) =
  case JSONRenderOptions -> JSONStyle
style JSONRenderOptions
opts of
    JSONStyle
Minified -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat [Doc ann]
forall {ann}. [Doc ann]
content)
    Pretty Natural
i -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann
forall ann. Doc ann
lbracket, Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i) ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann]
forall {ann}. [Doc ann]
content), Doc ann
forall ann. Doc ann
rbracket]
  where
    contents :: [Doc ann]
contents = (JSON -> Doc ann) -> [JSON] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (JSONRenderOptions -> JSON -> Doc ann
forall ann. JSONRenderOptions -> JSON -> Doc ann
renderJSON JSONRenderOptions
opts) [JSON]
a
    content :: [Doc ann]
content = Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma [Doc ann]
forall {ann}. [Doc ann]
contents
renderJSON JSONRenderOptions
_ (JString Text
s) = Text -> Doc ann
forall ann. Text -> Doc ann
renderString Text
s
renderJSON JSONRenderOptions
_ (JNumber Scientific
n) =
  String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$
    if Scientific -> Bool
isInteger Scientific
n
      then FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Fixed (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) Scientific
n -- Avoid inclding .0 for integers
      else Scientific -> String
forall a. Show a => a -> String
show Scientific
n
renderJSON JSONRenderOptions
_ (JBool Bool
True) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text
"true" :: Text)
renderJSON JSONRenderOptions
_ (JBool Bool
False) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text
"false" :: Text)
renderJSON JSONRenderOptions
_ JSON
JNull = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text
"null" :: Text)

-- | Internal: Renders Text as a JSON string, with appropriate escaping.
renderString :: Text -> Doc ann
renderString :: forall ann. Text -> Doc ann
renderString Text
s = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escapeChar Text
s)

-- | Internal: Escapes a character for encoding in JSON.
escapeChar :: Char -> Text
escapeChar :: Char -> Text
escapeChar Char
'\"' = Text
"\\\""
escapeChar Char
'\\' = Text
"\\\\"
escapeChar Char
'\b' = Text
"\\b"
escapeChar Char
'\f' = Text
"\\f"
escapeChar Char
'\n' = Text
"\\n"
escapeChar Char
'\r' = Text
"\\r"
escapeChar Char
'\t' = Text
"\\t"
escapeChar Char
c =
  if Char -> Bool
isControl Char
c
    then String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"\\u%04X" (Char -> Int
ord Char
c)
    else Char -> Text
T.singleton Char
c