-- | Display JSON values using pretty printing combinators.

module Text.JSON.Pretty
  ( module Text.JSON.Pretty
  , module Text.PrettyPrint.HughesPJ
  ) where

import Text.JSON.Types
import Text.PrettyPrint.HughesPJ
import qualified Text.PrettyPrint.HughesPJ as PP
import Data.Ratio
import Data.Char
import Numeric

pp_value         :: JSValue -> Doc
pp_value :: JSValue -> Doc
pp_value JSValue
v        = case JSValue
v of
    JSValue
JSNull       -> Doc
pp_null
    JSBool Bool
x     -> Bool -> Doc
pp_boolean Bool
x
    JSRational Bool
asf Rational
x -> Bool -> Rational -> Doc
pp_number Bool
asf Rational
x
    JSString JSString
x   -> JSString -> Doc
pp_js_string JSString
x
    JSArray [JSValue]
vs   -> [JSValue] -> Doc
pp_array [JSValue]
vs
    JSObject JSObject JSValue
xs  -> JSObject JSValue -> Doc
pp_js_object JSObject JSValue
xs

pp_null          :: Doc
pp_null :: Doc
pp_null           = String -> Doc
text String
"null"

pp_boolean       :: Bool -> Doc
pp_boolean :: Bool -> Doc
pp_boolean Bool
True   = String -> Doc
text String
"true"
pp_boolean Bool
False  = String -> Doc
text String
"false"

pp_number        :: Bool -> Rational -> Doc
pp_number :: Bool -> Rational -> Doc
pp_number Bool
_ Rational
x | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = Integer -> Doc
integer (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
x)
pp_number Bool
True Rational
x                   = Float -> Doc
float (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
x)
pp_number Bool
_    Rational
x                   = Double -> Doc
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x)

pp_array         :: [JSValue] -> Doc
pp_array :: [JSValue] -> Doc
pp_array [JSValue]
xs       = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (JSValue -> Doc) -> [JSValue] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map JSValue -> Doc
pp_value [JSValue]
xs

pp_string        :: String -> Doc
pp_string :: String -> Doc
pp_string String
x       = Doc -> Doc
doubleQuotes (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Char -> Doc) -> String -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Doc
pp_char String
x
  where pp_char :: Char -> Doc
pp_char Char
'\\'            = String -> Doc
text String
"\\\\"
        pp_char Char
'"'             = String -> Doc
text String
"\\\""
        pp_char Char
c | Char -> Bool
isControl Char
c = Char -> Doc
forall {a}. Enum a => a -> Doc
uni_esc Char
c
        pp_char Char
c               = Char -> Doc
char Char
c

        uni_esc :: a -> Doc
uni_esc a
c = String -> Doc
text String
"\\u" Doc -> Doc -> Doc
PP.<> String -> Doc
text (Int -> String -> String
pad Int
4 (Int -> String -> String
forall a. Integral a => a -> String -> String
showHex (a -> Int
forall a. Enum a => a -> Int
fromEnum a
c) String
""))

        pad :: Int -> String -> String
pad Int
n String
cs  | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n   = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
len) Char
'0' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cs
                  | Bool
otherwise = String
cs
          where len :: Int
len = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
cs

pp_object        :: [(String,JSValue)] -> Doc
pp_object :: [(String, JSValue)] -> Doc
pp_object [(String, JSValue)]
xs      = Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((String, JSValue) -> Doc) -> [(String, JSValue)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String, JSValue) -> Doc
pp_field [(String, JSValue)]
xs
  where pp_field :: (String, JSValue) -> Doc
pp_field (String
k,JSValue
v) = String -> Doc
pp_string String
k Doc -> Doc -> Doc
PP.<> Doc
colon Doc -> Doc -> Doc
<+> JSValue -> Doc
pp_value JSValue
v

pp_js_string     :: JSString -> Doc
pp_js_string :: JSString -> Doc
pp_js_string JSString
x    = String -> Doc
pp_string (JSString -> String
fromJSString JSString
x)

pp_js_object     :: JSObject JSValue -> Doc
pp_js_object :: JSObject JSValue -> Doc
pp_js_object JSObject JSValue
x    = [(String, JSValue)] -> Doc
pp_object (JSObject JSValue -> [(String, JSValue)]
forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
x)