-- | Display JSON5 values using pretty printing combinators.

module Text.JSON5.Pretty
  ( ppJSValue

  , ppNull
  , ppBoolean

  , ppJSNumber
  , ppRational
  , ppInfNaN

  , ppArray
  , ppString
  , ppObject
  , ppJSString
  , ppJSObject
  ) where

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

ppJSValue        :: JSValue -> Doc
ppJSValue :: JSValue -> Doc
ppJSValue JSValue
v       = case JSValue
v of
    JSValue
JSNull       -> Doc
ppNull
    JSBool Bool
x     -> Bool -> Doc
ppBoolean Bool
x
    JSNumber JSNumber
jsn -> JSNumber -> Doc
ppJSNumber JSNumber
jsn
    JSString JSString
x   -> JSString -> Doc
ppJSString JSString
x
    JSArray [JSValue]
vs   -> [JSValue] -> Doc
ppArray [JSValue]
vs
    JSObject JSObject JSValue
xs  -> JSObject JSValue -> Doc
ppJSObject JSObject JSValue
xs

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

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

ppJSNumber :: JSNumber -> Doc
ppJSNumber :: JSNumber -> Doc
ppJSNumber (JSRational Rational
r) = Rational -> Doc
ppRational Rational
r
ppJSNumber (JSInfNaN Float
n)   = Float -> Doc
ppInfNaN Float
n

ppRational :: Rational -> Doc
ppRational :: Rational -> Doc
ppRational 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)
  | Bool
otherwise          = Double -> Doc
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x)

ppInfNaN :: Float -> Doc
ppInfNaN :: Float -> Doc
ppInfNaN Float
n
  | Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
n = String -> Doc
text String
"NaN"
  | Float
n Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0   = String -> Doc
text String
"Infinity"
  | Float
n Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0   = String -> Doc
text String
"-Infinity"

ppArray :: [JSValue] -> Doc
ppArray :: [JSValue] -> Doc
ppArray [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
ppJSValue [JSValue]
xs

ppString :: String -> Doc
ppString :: String -> Doc
ppString 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, Show 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 (t :: * -> *) a. Foldable t => t a -> Int
length String
cs

ppObject :: [(String,JSValue)] -> Doc
ppObject :: [(String, JSValue)] -> Doc
ppObject [(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
ppString String
k Doc -> Doc -> Doc
PP.<> Doc
colon Doc -> Doc -> Doc
<+> JSValue -> Doc
ppJSValue JSValue
v

ppJSString :: JSString -> Doc
ppJSString :: JSString -> Doc
ppJSString = String -> Doc
ppString (String -> Doc) -> (JSString -> String) -> JSString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> String
fromJSString

ppJSObject :: JSObject JSValue -> Doc
ppJSObject :: JSObject JSValue -> Doc
ppJSObject = [(String, JSValue)] -> Doc
ppObject ([(String, JSValue)] -> Doc)
-> (JSObject JSValue -> [(String, JSValue)])
-> JSObject JSValue
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSObject JSValue -> [(String, JSValue)]
forall a. JSObject a -> [(String, a)]
fromJSObject