{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Extremely simple JSON helper. Don't do anything too fancy with this!

module Distribution.Utils.Json
    ( Json(..)
    , (.=)
    , renderJson
    ) where

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

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 -> String
(Int -> Json -> ShowS)
-> (Json -> String) -> ([Json] -> ShowS) -> Show Json
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Json] -> ShowS
$cshowList :: [Json] -> ShowS
show :: Json -> String
$cshow :: Json -> String
showsPrec :: Int -> Json -> ShowS
$cshowsPrec :: Int -> 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)    = String -> Builder
stringUtf8 String
"true"
    go (JsonBool Bool
False)   = String -> Builder
stringUtf8 String
"false"
    go  Json
JsonNull          = String -> Builder
stringUtf8 String
"null"
    go (JsonNumber Int
n)     = Int -> Builder
intDec Int
n
    go (JsonObject [(String, 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
$ ((String, Json) -> Builder) -> [(String, Json)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (String, Json) -> Builder
render [(String, Json)]
attrs
      where
        render :: (String, Json) -> Builder
render (String
k,Json
v) = (Builder -> Builder -> Builder -> Builder
surround Builder
"\"" Builder
"\"" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Builder
stringUtf8 (ShowS
escape String
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 String
s)     = Builder -> Builder -> Builder -> Builder
surround Builder
"\"" Builder
"\"" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Builder
stringUtf8 (ShowS
escape String
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
'\"':String
xs) = String
"\\\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape String
xs
escape (Char
'\\':String
xs) = String
"\\\\" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape String
xs
escape (Char
'\b':String
xs) = String
"\\b"  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape String
xs
escape (Char
'\f':String
xs) = String
"\\f"  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape String
xs
escape (Char
'\n':String
xs) = String
"\\n"  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape String
xs
escape (Char
'\r':String
xs) = String
"\\r"  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape String
xs
escape (Char
'\t':String
xs) = String
"\\t"  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
escape String
xs
escape (Char
x:String
xs)    = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
xs
escape []        = String
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)
String
k .= :: String -> Json -> (String, Json)
.= Json
v = (String
k, Json
v)