{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-- | Extremely simple JSON helper. Don't do anything too fancy with this!
module Distribution.Utils.Json
  ( Json (..)
  , (.=)
  , renderJson
  ) where

import Data.ByteString.Builder
  ( Builder
  , intDec
  , stringUtf8
  , toLazyByteString
  )
import qualified Data.ByteString.Lazy as LBS
import Distribution.Compat.Prelude

data Json
  = JsonArray [Json]
  | JsonBool !Bool
  | JsonNull
  | JsonNumber !Int -- No support for Floats, Doubles just yet
  | JsonObject [(String, Json)]
  | JsonString !String
  deriving (Int -> Json -> ShowS
[Json] -> ShowS
Json -> [Char]
(Int -> Json -> ShowS)
-> (Json -> [Char]) -> ([Json] -> ShowS) -> Show Json
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Json -> ShowS
showsPrec :: Int -> Json -> ShowS
$cshow :: Json -> [Char]
show :: Json -> [Char]
$cshowList :: [Json] -> ShowS
showList :: [Json] -> ShowS
Show)

-- | Convert a 'Json' into a 'ByteString'
renderJson :: Json -> LBS.ByteString
renderJson :: Json -> ByteString
renderJson Json
json = Builder -> ByteString
toLazyByteString (Json -> Builder
go Json
json)
  where
    go :: Json -> Builder
go (JsonArray [Json]
objs) =
      Builder -> Builder -> Builder -> Builder
surround Builder
"[" Builder
"]" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
"," ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (Json -> Builder) -> [Json] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Json -> Builder
go [Json]
objs
    go (JsonBool Bool
True) = [Char] -> Builder
stringUtf8 [Char]
"true"
    go (JsonBool Bool
False) = [Char] -> Builder
stringUtf8 [Char]
"false"
    go Json
JsonNull = [Char] -> Builder
stringUtf8 [Char]
"null"
    go (JsonNumber Int
n) = Int -> Builder
intDec Int
n
    go (JsonObject [([Char], Json)]
attrs) =
      Builder -> Builder -> Builder -> Builder
surround Builder
"{" Builder
"}" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
"," ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (([Char], Json) -> Builder) -> [([Char], Json)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Json) -> Builder
render [([Char], Json)]
attrs
      where
        render :: ([Char], Json) -> Builder
render ([Char]
k, Json
v) = Builder -> Builder -> Builder -> Builder
surround Builder
"\"" Builder
"\"" ([Char] -> Builder
stringUtf8 (ShowS
escape [Char]
k)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Json -> Builder
go Json
v
    go (JsonString [Char]
s) = Builder -> Builder -> Builder -> Builder
surround Builder
"\"" Builder
"\"" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [Char] -> Builder
stringUtf8 (ShowS
escape [Char]
s)

surround :: Builder -> Builder -> Builder -> Builder
surround :: Builder -> Builder -> Builder -> Builder
surround Builder
begin Builder
end Builder
middle = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder
begin, Builder
middle, Builder
end]

escape :: String -> String
escape :: ShowS
escape (Char
'\"' : [Char]
xs) = [Char]
"\\\"" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape [Char]
xs
escape (Char
'\\' : [Char]
xs) = [Char]
"\\\\" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape [Char]
xs
escape (Char
'\b' : [Char]
xs) = [Char]
"\\b" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape [Char]
xs
escape (Char
'\f' : [Char]
xs) = [Char]
"\\f" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape [Char]
xs
escape (Char
'\n' : [Char]
xs) = [Char]
"\\n" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape [Char]
xs
escape (Char
'\r' : [Char]
xs) = [Char]
"\\r" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape [Char]
xs
escape (Char
'\t' : [Char]
xs) = [Char]
"\\t" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape [Char]
xs
escape (Char
x : [Char]
xs) = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape [Char]
xs
escape [] = [Char]
forall a. Monoid a => a
mempty

-- | A shorthand for building up 'JsonObject's
-- >>> JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ]
-- JsonObject [("a",JsonNumber 42),("b",JsonBool True)]
(.=) :: String -> Json -> (String, Json)
[Char]
k .= :: [Char] -> Json -> ([Char], Json)
.= Json
v = ([Char]
k, Json
v)