{-# 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 -> String
(Int -> Json -> ShowS)
-> (Json -> String) -> ([Json] -> ShowS) -> Show Json
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Json -> ShowS
showsPrec :: Int -> Json -> ShowS
$cshow :: Json -> String
show :: Json -> String
$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) = 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
"\"" (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)