-- | Basic support for working with JSON values.

module Text.JSON.String 
     ( 
       -- * Parsing
       --
       GetJSON
     , runGetJSON

       -- ** Reading JSON
     , readJSNull
     , readJSBool
     , readJSString
     , readJSRational
     , readJSArray
     , readJSObject

     , readJSValue
     , readJSTopType

       -- ** Writing JSON
     , showJSNull
     , showJSBool
     , showJSArray
     , showJSObject
     , showJSRational
     , showJSRational'

     , showJSValue
     , showJSTopType
     ) where

import Prelude hiding (fail)
import Text.JSON.Types (JSValue(..),
                        JSString, toJSString, fromJSString,
                        JSObject, toJSObject, fromJSObject)

import Control.Monad (liftM, ap)
import Control.Monad.Fail (MonadFail (..))
import Control.Applicative((<$>))
import qualified Control.Applicative as A
import Data.Char (isSpace, isDigit, digitToInt)
import Data.Ratio (numerator, denominator, (%))
import Numeric (readHex, readDec, showHex, readSigned, readFloat)

-- -----------------------------------------------------------------
-- | Parsing JSON

-- | The type of JSON parsers for String
newtype GetJSON a = GetJSON { forall a. GetJSON a -> String -> Either String (a, String)
un :: String -> Either String (a,String) }

instance Functor GetJSON where fmap :: forall a b. (a -> b) -> GetJSON a -> GetJSON b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance A.Applicative GetJSON where
  pure :: forall a. a -> GetJSON a
pure  = forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: forall a b. GetJSON (a -> b) -> GetJSON a -> GetJSON b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad GetJSON where
  return :: forall a. a -> GetJSON a
return a
x        = forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\String
s -> forall a b. b -> Either a b
Right (a
x,String
s))
  GetJSON String -> Either String (a, String)
m >>= :: forall a b. GetJSON a -> (a -> GetJSON b) -> GetJSON b
>>= a -> GetJSON b
f = forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\String
s -> case String -> Either String (a, String)
m String
s of
                                     Left String
err -> forall a b. a -> Either a b
Left String
err
                                     Right (a
a,String
s1) -> forall a. GetJSON a -> String -> Either String (a, String)
un (a -> GetJSON b
f a
a) String
s1)

instance MonadFail GetJSON where
  fail :: forall a. String -> GetJSON a
fail String
x          = forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\String
_ -> forall a b. a -> Either a b
Left String
x)

-- | Run a JSON reader on an input String, returning some Haskell value.
-- All input will be consumed.
runGetJSON :: GetJSON a -> String -> Either String a
runGetJSON :: forall a. GetJSON a -> String -> Either String a
runGetJSON (GetJSON String -> Either String (a, String)
m) String
s = case String -> Either String (a, String)
m String
s of
     Left String
err    -> forall a b. a -> Either a b
Left String
err
     Right (a
a,String
t) -> case String
t of
                        [] -> forall a b. b -> Either a b
Right a
a
                        String
_  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Invalid tokens at end of JSON string: "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Int -> [a] -> [a]
take Int
10 String
t)

getInput   :: GetJSON String
getInput :: GetJSON String
getInput    = forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\String
s -> forall a b. b -> Either a b
Right (String
s,String
s))

setInput   :: String -> GetJSON ()
setInput :: String -> GetJSON ()
setInput String
s  = forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\String
_ -> forall a b. b -> Either a b
Right ((),String
s))

-------------------------------------------------------------------------

-- | Find 8 chars context, for error messages
context :: String -> String
context :: String -> String
context String
s = forall a. Int -> [a] -> [a]
take Int
8 String
s

-- | Read the JSON null type
readJSNull :: GetJSON JSValue
readJSNull :: GetJSON JSValue
readJSNull = do
  String
xs <- GetJSON String
getInput
  case String
xs of
    Char
'n':Char
'u':Char
'l':Char
'l':String
xs1 -> String -> GetJSON ()
setInput String
xs1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
JSNull
    String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON null: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
xs

tryJSNull :: GetJSON JSValue -> GetJSON JSValue
tryJSNull :: GetJSON JSValue -> GetJSON JSValue
tryJSNull GetJSON JSValue
k = do
  String
xs <- GetJSON String
getInput
  case String
xs of
    Char
'n':Char
'u':Char
'l':Char
'l':String
xs1 -> String -> GetJSON ()
setInput String
xs1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
JSNull
    String
_ -> GetJSON JSValue
k 

-- | Read the JSON Bool type
readJSBool :: GetJSON JSValue
readJSBool :: GetJSON JSValue
readJSBool = do
  String
xs <- GetJSON String
getInput
  case String
xs of
    Char
't':Char
'r':Char
'u':Char
'e':String
xs1 -> String -> GetJSON ()
setInput String
xs1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> JSValue
JSBool Bool
True)
    Char
'f':Char
'a':Char
'l':Char
's':Char
'e':String
xs1 -> String -> GetJSON ()
setInput String
xs1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> JSValue
JSBool Bool
False)
    String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON Bool: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
xs

-- | Read the JSON String type
readJSString :: GetJSON JSValue
readJSString :: GetJSON JSValue
readJSString = do
  String
x <- GetJSON String
getInput
  case String
x of
       Char
'"' : String
cs -> String -> String -> GetJSON JSValue
parse [] String
cs
       String
_        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Malformed JSON: expecting string: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
x
 where 
  parse :: String -> String -> GetJSON JSValue
parse String
rs String
cs = 
    case String
cs of
      Char
'\\' : Char
c : String
ds -> String -> Char -> String -> GetJSON JSValue
esc String
rs Char
c String
ds
      Char
'"'  : String
ds     -> do String -> GetJSON ()
setInput String
ds
                          forall (m :: * -> *) a. Monad m => a -> m a
return (JSString -> JSValue
JSString (String -> JSString
toJSString (forall a. [a] -> [a]
reverse String
rs)))
      Char
c    : String
ds
       | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x20' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\xff'    -> String -> String -> GetJSON JSValue
parse (Char
cforall a. a -> [a] -> [a]
:String
rs) String
ds
       | Char
c forall a. Ord a => a -> a -> Bool
< Char
'\x20'     -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Illegal unescaped character in string: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
       | Integer
i forall a. Ord a => a -> a -> Bool
<= Integer
0x10ffff  -> String -> String -> GetJSON JSValue
parse (Char
cforall a. a -> [a] -> [a]
:String
rs) String
ds
       | Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Illegal unescaped character in string: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
       where
        i :: Integer
i = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum Char
c) :: Integer)
      String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON String: unterminated String: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs

  esc :: String -> Char -> String -> GetJSON JSValue
esc String
rs Char
c String
cs = case Char
c of
   Char
'\\' -> String -> String -> GetJSON JSValue
parse (Char
'\\' forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'"'  -> String -> String -> GetJSON JSValue
parse (Char
'"'  forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'n'  -> String -> String -> GetJSON JSValue
parse (Char
'\n' forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'r'  -> String -> String -> GetJSON JSValue
parse (Char
'\r' forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
't'  -> String -> String -> GetJSON JSValue
parse (Char
'\t' forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'f'  -> String -> String -> GetJSON JSValue
parse (Char
'\f' forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'b'  -> String -> String -> GetJSON JSValue
parse (Char
'\b' forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'/'  -> String -> String -> GetJSON JSValue
parse (Char
'/'  forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'u'  -> case String
cs of
             Char
d1 : Char
d2 : Char
d3 : Char
d4 : String
cs' ->
               case forall a. (Eq a, Num a) => ReadS a
readHex [Char
d1,Char
d2,Char
d3,Char
d4] of
                 [(Int
n,String
"")] -> String -> String -> GetJSON JSValue
parse (forall a. Enum a => Int -> a
toEnum Int
n forall a. a -> [a] -> [a]
: String
rs) String
cs'

                 [(Int, String)]
x -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON String: invalid hex: " forall a. [a] -> [a] -> [a]
++ String -> String
context (forall a. Show a => a -> String
show [(Int, String)]
x)
             String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON String: invalid hex: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
   Char
_ ->  forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON String: invalid escape char: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Char
c


-- | Read an Integer or Double in JSON format, returning a Rational
readJSRational :: GetJSON Rational
readJSRational :: GetJSON Rational
readJSRational = do
  String
cs <- GetJSON String
getInput
  case (forall a. Read a => ReadS a
reads String
cs, forall a. Real a => ReadS a -> ReadS a
readSigned forall a. RealFrac a => ReadS a
readFloat String
cs) of
    ([(Double
x,String
_)], [(Rational, String)]
_)
      | forall a. RealFloat a => a -> Bool
isInfinite (Double
x :: Double) ->
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"JSON Rational out of range: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs)
    ([(Double, String)]
_, [(Rational
y,String
cs')]) -> String -> GetJSON ()
setInput String
cs' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Rational
y
    ([(Double, String)], [(Rational, String)])
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unable to parse JSON Rational: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs)


-- | Read a list in JSON format
readJSArray  :: GetJSON JSValue
readJSArray :: GetJSON JSValue
readJSArray  = Char -> Char -> Char -> GetJSON [JSValue]
readSequence Char
'[' Char
']' Char
',' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JSValue] -> JSValue
JSArray

-- | Read an object in JSON format
readJSObject :: GetJSON JSValue
readJSObject :: GetJSON JSValue
readJSObject = Char -> Char -> Char -> GetJSON [(String, JSValue)]
readAssocs Char
'{' Char
'}' Char
',' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSObject JSValue -> JSValue
JSObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(String, a)] -> JSObject a
toJSObject


-- | Read a sequence of items
readSequence :: Char -> Char -> Char -> GetJSON [JSValue]
readSequence :: Char -> Char -> Char -> GetJSON [JSValue]
readSequence Char
start Char
end Char
sep = do
  String
zs <- GetJSON String
getInput
  case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
zs of
    Char
c : String
cs | Char
c forall a. Eq a => a -> a -> Bool
== Char
start ->
        case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
cs of
            Char
d : String
ds | Char
d forall a. Eq a => a -> a -> Bool
== Char
end -> String -> GetJSON ()
setInput (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
ds) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
            String
ds                -> String -> GetJSON ()
setInput String
ds forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [JSValue] -> GetJSON [JSValue]
parse []
    String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON sequence: sequence stars with invalid character: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
zs

  where parse :: [JSValue] -> GetJSON [JSValue]
parse [JSValue]
rs = [JSValue]
rs seq :: forall a b. a -> b -> b
`seq` do
          JSValue
a  <- GetJSON JSValue
readJSValue
          String
ds <- GetJSON String
getInput
          case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
ds of
            Char
e : String
es | Char
e forall a. Eq a => a -> a -> Bool
== Char
sep -> do String -> GetJSON ()
setInput (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
es)
                                    [JSValue] -> GetJSON [JSValue]
parse (JSValue
aforall a. a -> [a] -> [a]
:[JSValue]
rs)
                   | Char
e forall a. Eq a => a -> a -> Bool
== Char
end -> do String -> GetJSON ()
setInput (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
es)
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse (JSValue
aforall a. a -> [a] -> [a]
:[JSValue]
rs))
            String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON array: unterminated array: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
ds


-- | Read a sequence of JSON labelled fields
readAssocs :: Char -> Char -> Char -> GetJSON [(String,JSValue)]
readAssocs :: Char -> Char -> Char -> GetJSON [(String, JSValue)]
readAssocs Char
start Char
end Char
sep = do
  String
zs <- GetJSON String
getInput
  case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
zs of
    Char
c:String
cs | Char
c forall a. Eq a => a -> a -> Bool
== Char
start -> case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
cs of
            Char
d:String
ds | Char
d forall a. Eq a => a -> a -> Bool
== Char
end -> String -> GetJSON ()
setInput (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
ds) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
            String
ds              -> String -> GetJSON ()
setInput String
ds forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(String, JSValue)] -> GetJSON [(String, JSValue)]
parsePairs []
    String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse JSON object: unterminated object"

  where parsePairs :: [(String, JSValue)] -> GetJSON [(String, JSValue)]
parsePairs [(String, JSValue)]
rs = [(String, JSValue)]
rs seq :: forall a b. a -> b -> b
`seq` do
          (String, JSValue)
a  <- do String
k  <- do JSValue
x <- GetJSON JSValue
readJSString ; case JSValue
x of
                                JSString JSString
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (JSString -> String
fromJSString JSString
s)
                                JSValue
_          -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Malformed JSON field labels: object keys must be quoted strings."
                   String
ds <- GetJSON String
getInput
                   case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
ds of
                       Char
':':String
es -> do String -> GetJSON ()
setInput (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
es)
                                    JSValue
v <- GetJSON JSValue
readJSValue
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (String
k,JSValue
v)
                       String
_      -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Malformed JSON labelled field: " forall a. [a] -> [a] -> [a]
++ String -> String
context String
ds

          String
ds <- GetJSON String
getInput
          case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
ds of
            Char
e : String
es | Char
e forall a. Eq a => a -> a -> Bool
== Char
sep -> do String -> GetJSON ()
setInput (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
es)
                                    [(String, JSValue)] -> GetJSON [(String, JSValue)]
parsePairs ((String, JSValue)
aforall a. a -> [a] -> [a]
:[(String, JSValue)]
rs)
                   | Char
e forall a. Eq a => a -> a -> Bool
== Char
end -> do String -> GetJSON ()
setInput (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
es)
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse ((String, JSValue)
aforall a. a -> [a] -> [a]
:[(String, JSValue)]
rs))
            String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON object: unterminated sequence: "
                            forall a. [a] -> [a] -> [a]
++ String -> String
context String
ds

-- | Read one of several possible JS types
readJSValue :: GetJSON JSValue
readJSValue :: GetJSON JSValue
readJSValue = do
  String
cs <- GetJSON String
getInput
  case String
cs of
    Char
'"' : String
_ -> GetJSON JSValue
readJSString
    Char
'[' : String
_ -> GetJSON JSValue
readJSArray
    Char
'{' : String
_ -> GetJSON JSValue
readJSObject
    Char
't' : String
_ -> GetJSON JSValue
readJSBool
    Char
'f' : String
_ -> GetJSON JSValue
readJSBool
    (Char
x:String
_) | Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'-' -> Bool -> Rational -> JSValue
JSRational Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetJSON Rational
readJSRational
    String
xs -> GetJSON JSValue -> GetJSON JSValue
tryJSNull
             (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Malformed JSON: invalid token in this context " forall a. [a] -> [a] -> [a]
++ String -> String
context String
xs)

-- | Top level JSON can only be Arrays or Objects
readJSTopType :: GetJSON JSValue
readJSTopType :: GetJSON JSValue
readJSTopType = do
  String
cs <- GetJSON String
getInput
  case String
cs of
    Char
'[' : String
_ -> GetJSON JSValue
readJSArray
    Char
'{' : String
_ -> GetJSON JSValue
readJSObject
    String
_       -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid JSON: a JSON text a serialized object or array at the top level."

-- -----------------------------------------------------------------
-- | Writing JSON

-- | Show strict JSON top level types. Values not permitted
-- at the top level are wrapped in a singleton array.
showJSTopType :: JSValue -> ShowS
showJSTopType :: JSValue -> String -> String
showJSTopType (JSArray [JSValue]
a)    = [JSValue] -> String -> String
showJSArray [JSValue]
a
showJSTopType (JSObject JSObject JSValue
o)   = JSObject JSValue -> String -> String
showJSObject JSObject JSValue
o
showJSTopType JSValue
x              = JSValue -> String -> String
showJSTopType forall a b. (a -> b) -> a -> b
$ [JSValue] -> JSValue
JSArray [JSValue
x]

-- | Show JSON values
showJSValue :: JSValue -> ShowS
showJSValue :: JSValue -> String -> String
showJSValue JSValue
jv =
  case JSValue
jv of
    JSNull{}         -> String -> String
showJSNull
    JSBool Bool
b         -> Bool -> String -> String
showJSBool Bool
b
    JSRational Bool
asF Rational
r -> Bool -> Rational -> String -> String
showJSRational' Bool
asF Rational
r
    JSArray [JSValue]
a        -> [JSValue] -> String -> String
showJSArray [JSValue]
a
    JSString JSString
s       -> JSString -> String -> String
showJSString JSString
s
    JSObject JSObject JSValue
o       -> JSObject JSValue -> String -> String
showJSObject JSObject JSValue
o

-- | Write the JSON null type
showJSNull :: ShowS
showJSNull :: String -> String
showJSNull = String -> String -> String
showString String
"null"

-- | Write the JSON Bool type
showJSBool :: Bool -> ShowS
showJSBool :: Bool -> String -> String
showJSBool Bool
True  = String -> String -> String
showString String
"true"
showJSBool Bool
False = String -> String -> String
showString String
"false"

-- | Write the JSON String type
showJSString :: JSString -> ShowS
showJSString :: JSString -> String -> String
showJSString JSString
x String
xs = String -> String
quote (JSString -> String -> String
encJSString JSString
x (String -> String
quote String
xs))
  where
        quote :: String -> String
quote = Char -> String -> String
showChar Char
'"'

-- | Show a Rational in JSON format
showJSRational :: Rational -> ShowS
showJSRational :: Rational -> String -> String
showJSRational Rational
r = Bool -> Rational -> String -> String
showJSRational' Bool
False Rational
r

showJSRational' :: Bool -> Rational -> ShowS
showJSRational' :: Bool -> Rational -> String -> String
showJSRational' Bool
asFloat Rational
r 
 | forall a. Ratio a -> a
denominator Rational
r forall a. Eq a => a -> a -> Bool
== Integer
1      = forall a. Show a => a -> String -> String
shows forall a b. (a -> b) -> a -> b
$ forall a. Ratio a -> a
numerator Rational
r
 | forall a. RealFloat a => a -> Bool
isInfinite Double
x Bool -> Bool -> Bool
|| forall a. RealFloat a => a -> Bool
isNaN Double
x = String -> String
showJSNull
 | Bool
asFloat                 = forall a. Show a => a -> String -> String
shows Float
xf
 | Bool
otherwise               = forall a. Show a => a -> String -> String
shows Double
x
 where 
   x :: Double
   x :: Double
x = forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
r
   
   xf :: Float
   xf :: Float
xf = forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
r



-- | Show a list in JSON format
showJSArray :: [JSValue] -> ShowS
showJSArray :: [JSValue] -> String -> String
showJSArray = Char -> Char -> Char -> [JSValue] -> String -> String
showSequence Char
'[' Char
']' Char
','

-- | Show an association list in JSON format
showJSObject :: JSObject JSValue -> ShowS
showJSObject :: JSObject JSValue -> String -> String
showJSObject = Char -> Char -> Char -> [(String, JSValue)] -> String -> String
showAssocs Char
'{' Char
'}' Char
',' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. JSObject e -> [(String, e)]
fromJSObject

-- | Show a generic sequence of pairs in JSON format
showAssocs :: Char -> Char -> Char -> [(String,JSValue)] -> ShowS
showAssocs :: Char -> Char -> Char -> [(String, JSValue)] -> String -> String
showAssocs Char
start Char
end Char
sep [(String, JSValue)]
xs String
rest = Char
start forall a. a -> [a] -> [a]
: [(String, JSValue)] -> String
go [(String, JSValue)]
xs
  where
  go :: [(String, JSValue)] -> String
go [(String
k,JSValue
v)]     = Char
'"' forall a. a -> [a] -> [a]
: JSString -> String -> String
encJSString (String -> JSString
toJSString String
k)
                            (Char
'"' forall a. a -> [a] -> [a]
: Char
':' forall a. a -> [a] -> [a]
: JSValue -> String -> String
showJSValue JSValue
v ([(String, JSValue)] -> String
go []))
  go ((String
k,JSValue
v):[(String, JSValue)]
kvs) = Char
'"' forall a. a -> [a] -> [a]
: JSString -> String -> String
encJSString (String -> JSString
toJSString String
k)
                            (Char
'"' forall a. a -> [a] -> [a]
: Char
':' forall a. a -> [a] -> [a]
: JSValue -> String -> String
showJSValue JSValue
v (Char
sep forall a. a -> [a] -> [a]
: [(String, JSValue)] -> String
go [(String, JSValue)]
kvs))
  go []          = Char
end forall a. a -> [a] -> [a]
: String
rest

-- | Show a generic sequence in JSON format
showSequence :: Char -> Char -> Char -> [JSValue] -> ShowS
showSequence :: Char -> Char -> Char -> [JSValue] -> String -> String
showSequence Char
start Char
end Char
sep [JSValue]
xs String
rest = Char
start forall a. a -> [a] -> [a]
: [JSValue] -> String
go [JSValue]
xs
  where
  go :: [JSValue] -> String
go [JSValue
y]        = JSValue -> String -> String
showJSValue JSValue
y ([JSValue] -> String
go [])
  go (JSValue
y:[JSValue]
ys)     = JSValue -> String -> String
showJSValue JSValue
y (Char
sep forall a. a -> [a] -> [a]
: [JSValue] -> String
go [JSValue]
ys)
  go []         = Char
end forall a. a -> [a] -> [a]
: String
rest

encJSString :: JSString -> ShowS
encJSString :: JSString -> String -> String
encJSString JSString
jss String
ss = String -> String
go (JSString -> String
fromJSString JSString
jss)
  where
  go :: String -> String
go String
s1 =
    case String
s1 of
      (Char
x   :String
xs) | Char
x forall a. Ord a => a -> a -> Bool
< Char
'\x20' -> Char
'\\' forall a. a -> [a] -> [a]
: Char -> String -> String
encControl Char
x (String -> String
go String
xs)
      (Char
'"' :String
xs)              -> Char
'\\' forall a. a -> [a] -> [a]
: Char
'"'  forall a. a -> [a] -> [a]
: String -> String
go String
xs
      (Char
'\\':String
xs)              -> Char
'\\' forall a. a -> [a] -> [a]
: Char
'\\' forall a. a -> [a] -> [a]
: String -> String
go String
xs
      (Char
x   :String
xs)              -> Char
x    forall a. a -> [a] -> [a]
: String -> String
go String
xs
      String
""                     -> String
ss

  encControl :: Char -> String -> String
encControl Char
x String
xs = case Char
x of
    Char
'\b' -> Char
'b' forall a. a -> [a] -> [a]
: String
xs
    Char
'\f' -> Char
'f' forall a. a -> [a] -> [a]
: String
xs
    Char
'\n' -> Char
'n' forall a. a -> [a] -> [a]
: String
xs
    Char
'\r' -> Char
'r' forall a. a -> [a] -> [a]
: String
xs
    Char
'\t' -> Char
't' forall a. a -> [a] -> [a]
: String
xs
    Char
_ | Char
x forall a. Ord a => a -> a -> Bool
< Char
'\x10'   -> Char
'u' forall a. a -> [a] -> [a]
: Char
'0' forall a. a -> [a] -> [a]
: Char
'0' forall a. a -> [a] -> [a]
: Char
'0' forall a. a -> [a] -> [a]
: String
hexxs
      | Char
x forall a. Ord a => a -> a -> Bool
< Char
'\x100'  -> Char
'u' forall a. a -> [a] -> [a]
: Char
'0' forall a. a -> [a] -> [a]
: Char
'0' forall a. a -> [a] -> [a]
: String
hexxs
      | Char
x forall a. Ord a => a -> a -> Bool
< Char
'\x1000' -> Char
'u' forall a. a -> [a] -> [a]
: Char
'0' forall a. a -> [a] -> [a]
: String
hexxs
      | Bool
otherwise    -> Char
'u' forall a. a -> [a] -> [a]
: String
hexxs
      where hexxs :: String
hexxs = forall a. (Integral a, Show a) => a -> String -> String
showHex (forall a. Enum a => a -> Int
fromEnum Char
x) String
xs