-- | Basic support for working with JSON5 values.

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

       -- ** Reading JSON5
     , readJSNull
     , readJSBool
     , readJSString
     , readJSRational
     , readJSInfNaN
     , readJSArray
     , readJSObject

     , readJSValue
     , readJSTopType

       -- ** Writing JSON5
     , showJSNull
     , showJSBool
     , showJSArray
     , showJSObject
     , showJSRational
     , showJSInfNaN

     , showJSValue
     , showJSTopType
     ) where

import Text.JSON5.Types (JSValue(..),
                         JSNumber(..), fromJSInfNaN, fromJSRational,
                         JSString, toJSString, fromJSString,
                         JSObject, toJSObject, fromJSObject)

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

-- -----------------------------------------------------------------
-- | Parsing JSON5

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

instance Functor GetJSON where
  fmap :: (a -> b) -> GetJSON a -> GetJSON b
fmap = (a -> b) -> GetJSON a -> GetJSON b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance A.Applicative GetJSON where
  pure :: a -> GetJSON a
pure  = a -> GetJSON a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: GetJSON (a -> b) -> GetJSON a -> GetJSON 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 :: a -> GetJSON a
return a
x        = (String -> Either String (a, String)) -> GetJSON a
forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\String
s -> (a, String) -> Either String (a, String)
forall a b. b -> Either a b
Right (a
x,String
s))
  GetJSON String -> Either String (a, String)
m >>= :: GetJSON a -> (a -> GetJSON b) -> GetJSON b
>>= a -> GetJSON b
f = (String -> Either String (b, String)) -> GetJSON b
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 -> String -> Either String (b, String)
forall a b. a -> Either a b
Left String
err
                                     Right (a
a,String
s1) -> GetJSON b -> String -> Either String (b, String)
forall a. GetJSON a -> String -> Either String (a, String)
un (a -> GetJSON b
f a
a) String
s1)

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

-- | Run a JSON5 reader on an input String, returning some Haskell value.
-- All input will be consumed.
runGetJSON :: GetJSON a -> String -> Either String a
runGetJSON :: 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    -> String -> Either String a
forall a b. a -> Either a b
Left String
err
     Right (a
a,String
t) -> case String
t of
                        [] -> a -> Either String a
forall a b. b -> Either a b
Right a
a
                        String
_  -> String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"Invalid tokens at end of JSON5 string: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
t

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

setInput :: String -> GetJSON ()
setInput :: String -> GetJSON ()
setInput String
s = (String -> Either String ((), String)) -> GetJSON ()
forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\String
_ -> ((), String) -> Either String ((), 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 = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
8 String
s

-- | Read the JSON5 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 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSValue -> GetJSON JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
JSNull
    String
_ -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 null: " String -> String -> String
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 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSValue -> GetJSON JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
JSNull
    String
_ -> GetJSON JSValue
k

-- | Read the JSON5 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 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSValue -> GetJSON JSValue
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 GetJSON () -> GetJSON JSValue -> GetJSON JSValue
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JSValue -> GetJSON JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> JSValue
JSBool Bool
False)
    String
_ -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 Bool: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
xs


-- | Strings

-- Strings may be single quoted.
-- Strings may span multiple lines by escaping new line characters.
-- Strings may include character escapes.

-- | Read the JSON5 String type
readJSString :: Char -> GetJSON JSValue
readJSString :: Char -> GetJSON JSValue
readJSString Char
sep = do
  String
x <- GetJSON String
getInput
  case String
x of
       Char
sep : String
cs -> String -> String -> GetJSON JSValue
parse [] String
cs
       String
_        -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Malformed JSON5: expecting string: " String -> String -> 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
c   : String
ds
       | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
sep -> do String -> GetJSON ()
setInput String
ds
                        JSValue -> GetJSON JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return (JSString -> JSValue
JSString (String -> JSString
toJSString (String -> String
forall a. [a] -> [a]
reverse String
rs)))
       | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\x20' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xff' -> String -> String -> GetJSON JSValue
parse (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
rs) String
ds
       | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x20'     -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Illegal unescaped character in string: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
       | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0x10ffff  -> String -> String -> GetJSON JSValue
parse (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
rs) String
ds
       | Bool
otherwise -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Illegal unescaped character in string: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
       where
        i :: Integer
i = (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) :: Integer)
      String
_ -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 String: unterminated String: " String -> String -> 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
'\n' -> String -> String -> GetJSON JSValue
parse String
rs String
cs
   Char
'\\' -> String -> String -> GetJSON JSValue
parse (Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'"'  -> String -> String -> GetJSON JSValue
parse (Char
'"'  Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'\'' -> String -> String -> GetJSON JSValue
parse (Char
'\'' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'n'  -> String -> String -> GetJSON JSValue
parse (Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'r'  -> String -> String -> GetJSON JSValue
parse (Char
'\r' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
't'  -> String -> String -> GetJSON JSValue
parse (Char
'\t' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'f'  -> String -> String -> GetJSON JSValue
parse (Char
'\f' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'b'  -> String -> String -> GetJSON JSValue
parse (Char
'\b' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
   Char
'/'  -> String -> String -> GetJSON JSValue
parse (Char
'/'  Char -> String -> String
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 ReadS Int
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 (Int -> Char
forall a. Enum a => Int -> a
toEnum Int
n Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs'
                 [(Int, String)]
x -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 String: invalid hex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context ([(Int, String)] -> String
forall a. Show a => a -> String
show [(Int, String)]
x)
             String
_ -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 String: invalid hex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs

   Char
_ -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 String: invalid escape char: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c


-- | Numbers

-- Numbers may be hexadecimal.
-- Numbers may have a leading or trailing decimal point.
-- Numbers may be IEEE 754 positive infinity, negative infinity, and NaN.
-- Numbers may begin with an explicit plus sign.

-- | Read an Integer or Double in JSON5 format, returning a Rational
readJSRational :: GetJSON Rational
readJSRational :: GetJSON Rational
readJSRational = do
  String
cs <- GetJSON String
getInput
  case String
cs of
    Char
'-' : String
ds -> Rational -> Rational
forall a. Num a => a -> a
negate (Rational -> Rational) -> GetJSON Rational -> GetJSON Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> GetJSON Rational
pos String
ds
    Char
'+' : String
ds -> String -> GetJSON Rational
pos String
ds
    Char
'.' : String
_  -> Rational -> String -> GetJSON Rational
frac Rational
0 String
cs
    String
_        -> String -> GetJSON Rational
pos String
cs

  where
   pos :: String -> GetJSON Rational
pos [] = String -> GetJSON Rational
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON Rational) -> String -> GetJSON Rational
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 Rational: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context []
   pos String
cs =
     case String
cs of
       Char
'.':String
ds -> Rational -> String -> GetJSON Rational
frac Rational
0 String
cs
       Char
'0':Char
'x':String
ds -> String -> GetJSON Rational
forall b. Num b => String -> GetJSON b
hex String
ds
       Char
c  : String
ds
        | Char -> Bool
isDigit Char
c -> Integer -> String -> GetJSON Rational
readDigits (Char -> Integer
digitToIntI Char
c) String
ds
        | Bool
otherwise -> String -> GetJSON Rational
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON Rational) -> String -> GetJSON Rational
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 Rational: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs

   readDigits :: Integer -> String -> GetJSON Rational
readDigits Integer
acc [] = Rational -> String -> GetJSON Rational
frac (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
acc) []
   readDigits Integer
acc (Char
x:String
xs)
    | Char -> Bool
isDigit Char
x = let acc' :: Integer
acc' = Integer
10Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
acc Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Char -> Integer
digitToIntI Char
x in
                      Integer
acc' Integer -> GetJSON Rational -> GetJSON Rational
`seq` Integer -> String -> GetJSON Rational
readDigits Integer
acc' String
xs
    | Bool
otherwise = Rational -> String -> GetJSON Rational
frac (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
acc) (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)

   hex :: String -> GetJSON b
hex String
cs = case ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex String
cs of
      [(Integer
a,String
ds)] -> do String -> GetJSON ()
setInput String
ds
                     b -> GetJSON b
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
a)
      [(Integer, String)]
_        -> String -> GetJSON b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON b) -> String -> GetJSON b
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 hexadecimal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs

   frac :: Rational -> String -> GetJSON Rational
frac Rational
n (Char
'.' : String
ds) =
       case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
ds of
         ([],String
_)  -> String -> GetJSON ()
setInput String
ds GetJSON () -> GetJSON Rational -> GetJSON Rational
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rational -> GetJSON Rational
forall (m :: * -> *) a. Monad m => a -> m a
return Rational
n
         (String
as,String
bs) -> let x :: Integer
x = String -> Integer
forall a. Read a => String -> a
read String
as :: Integer
                        y :: Integer
y = Integer
10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
as) :: Integer)
                    in Rational -> String -> GetJSON Rational
exponent' (Rational
n Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Integer
x Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
y)) String
bs
   frac Rational
n String
cs = Rational -> String -> GetJSON Rational
exponent' Rational
n String
cs

   exponent' :: Rational -> String -> GetJSON Rational
exponent' Rational
n (Char
c:String
cs)
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'e' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'E' = (Rational
nRational -> Rational -> Rational
forall a. Num a => a -> a -> a
*) (Rational -> Rational) -> GetJSON Rational -> GetJSON Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> GetJSON Rational
exp_num String
cs
   exponent' Rational
n String
cs = String -> GetJSON ()
setInput String
cs GetJSON () -> GetJSON Rational -> GetJSON Rational
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rational -> GetJSON Rational
forall (m :: * -> *) a. Monad m => a -> m a
return Rational
n

   exp_num :: String -> GetJSON Rational
   exp_num :: String -> GetJSON Rational
exp_num (Char
'+':String
cs)  = String -> GetJSON Rational
exp_digs String
cs
   exp_num (Char
'-':String
cs)  = Rational -> Rational
forall a. Fractional a => a -> a
recip (Rational -> Rational) -> GetJSON Rational -> GetJSON Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> GetJSON Rational
exp_digs String
cs
   exp_num String
cs        = String -> GetJSON Rational
exp_digs String
cs

   exp_digs :: String -> GetJSON Rational
   exp_digs :: String -> GetJSON Rational
exp_digs String
cs = case ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readDec String
cs of
      [(Integer
a,String
ds)] -> do String -> GetJSON ()
setInput String
ds
                     Rational -> GetJSON Rational
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Integer
10::Integer) Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
a::Integer)))
      [(Integer, String)]
_        -> String -> GetJSON Rational
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON Rational) -> String -> GetJSON Rational
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 exponential: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs

   digitToIntI :: Char -> Integer
   digitToIntI :: Char -> Integer
digitToIntI = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (Char -> Int) -> Char -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt

-- | Read an Infinity or NaN in JSON5 format, returning a Float
readJSInfNaN :: GetJSON Float
readJSInfNaN :: GetJSON Float
readJSInfNaN = do
  String
cs <- GetJSON String
getInput
  case String
cs of
    Char
'-' : String
ds -> Float -> Float
forall a. Num a => a -> a
negate (Float -> Float) -> GetJSON Float -> GetJSON Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> GetJSON Float
forall a. Floating a => String -> GetJSON a
pos String
ds
    Char
'+' : String
ds -> String -> GetJSON Float
forall a. Floating a => String -> GetJSON a
pos String
ds
    String
_        -> String -> GetJSON Float
forall a. Floating a => String -> GetJSON a
pos String
cs

  where
   pos :: String -> GetJSON a
pos [] = String -> GetJSON a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON a) -> String -> GetJSON a
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 InfNaN: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context []
   pos String
cs =
     case String
cs of
       Char
'I':Char
'n':Char
'f':Char
'i':Char
'n':Char
'i':Char
't':Char
'y':String
ds -> String -> GetJSON ()
setInput String
ds GetJSON () -> GetJSON a -> GetJSON a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> GetJSON a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0)
       Char
'N':Char
'a':Char
'N':String
ds -> String -> GetJSON ()
setInput String
ds GetJSON () -> GetJSON a -> GetJSON a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> GetJSON a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a
forall a. Floating a => a -> a
acos a
2)
       String
_ -> String -> GetJSON a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON a) -> String -> GetJSON a
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 InfNaN: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs

-- | Objects & Arrays

-- Object keys may be an ECMAScript 5.1 IdentifierName.
-- Objects may have a single trailing comma.
-- Arrays may have a single trailing comma.

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

-- | Read an object in JSON5 format
readJSObject :: GetJSON JSValue
readJSObject :: GetJSON JSValue
readJSObject = Char -> Char -> Char -> GetJSON [(String, JSValue)]
readAssocs Char
'{' Char
'}' Char
',' GetJSON [(String, JSValue)]
-> ([(String, JSValue)] -> GetJSON JSValue) -> GetJSON JSValue
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSValue -> GetJSON JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> GetJSON JSValue)
-> ([(String, JSValue)] -> JSValue)
-> [(String, JSValue)]
-> GetJSON JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSObject JSValue -> JSValue
JSObject (JSObject JSValue -> JSValue)
-> ([(String, JSValue)] -> JSObject JSValue)
-> [(String, JSValue)]
-> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, JSValue)] -> JSObject JSValue
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 (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
zs of
    Char
c : String
cs | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
start ->
        case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
cs of
            Char
d : String
ds | Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
end -> String -> GetJSON ()
setInput ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
ds) GetJSON () -> GetJSON [JSValue] -> GetJSON [JSValue]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [JSValue] -> GetJSON [JSValue]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            String
ds                -> String -> GetJSON ()
setInput String
ds GetJSON () -> GetJSON [JSValue] -> GetJSON [JSValue]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [JSValue] -> GetJSON [JSValue]
parse []
    String
_ -> String -> GetJSON [JSValue]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON [JSValue]) -> String -> GetJSON [JSValue]
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse JSON5 sequence: sequence stars with invalid character: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
zs

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


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

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

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

readJSKey :: GetJSON JSValue
readJSKey :: GetJSON JSValue
readJSKey = do
  String
zs <- GetJSON String
getInput
  case String
zs of
    Char
'"'  : String
_ -> Char -> GetJSON JSValue
readJSString Char
'"'
    Char
'\'' : String
_ -> Char -> GetJSON JSValue
readJSString Char
'\''
    String
_        -> String -> GetJSON JSValue
readSymbol String
zs
  where
    readSymbol :: String -> GetJSON JSValue
readSymbol [] = String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Malformed JSON5 object key-value pairs: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context []
    readSymbol xs :: String
xs@(Char
c:String
cs)
      | Char -> Bool
isStart Char
c = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSymbol String
xs of
              ([],String
_) -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Malformed JSON5 object key-value pairs: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
              (String
k,String
ds) -> do String -> GetJSON ()
setInput String
ds
                           JSValue -> GetJSON JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return (JSString -> JSValue
JSString (String -> JSString
toJSString String
k))

      | Bool
otherwise = String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Malformed JSON5 object key: started with illegal character: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
xs

    isStart :: Char -> Bool
isStart  Char
c = Char -> Bool
isAlpha Char
c    Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"_$"
    isSymbol :: Char -> Bool
isSymbol Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"-_"

-- | 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
_ -> Char -> GetJSON JSValue
readJSString Char
'"'
    Char
'\'': String
_ -> Char -> GetJSON JSValue
readJSString Char
'\''
    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
xs)
      | Char -> Bool
isSpace Char
x -> String -> GetJSON ()
setInput String
xs GetJSON () -> GetJSON JSValue -> GetJSON JSValue
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GetJSON JSValue
readJSValue
      | Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' -> Rational -> JSValue
fromJSRational (Rational -> JSValue) -> GetJSON Rational -> GetJSON JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetJSON Rational
readJSRational
      | Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"NI" -> Float -> JSValue
fromJSInfNaN (Float -> JSValue) -> GetJSON Float -> GetJSON JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetJSON Float
readJSInfNaN
      | Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"+-" -> case String
xs of
                            Char
'I' : String
_ -> Float -> JSValue
fromJSInfNaN (Float -> JSValue) -> GetJSON Float -> GetJSON JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetJSON Float
readJSInfNaN
                            String
_       -> Rational -> JSValue
fromJSRational (Rational -> JSValue) -> GetJSON Rational -> GetJSON JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetJSON Rational
readJSRational
    String
_ -> GetJSON JSValue -> GetJSON JSValue
tryJSNull
             (String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ String
"Malformed JSON5: invalid token in this context " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs)

-- | Top level JSON5 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
_       -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid JSON5: expecting a serialized object or array at the top level."

-- -----------------------------------------------------------------
-- | Writing JSON5

-- | Show strict JSON5 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 (JSValue -> String -> String) -> JSValue -> String -> String
forall a b. (a -> b) -> a -> b
$ [JSValue] -> JSValue
JSArray [JSValue
x]

-- | Show JSON5 values
showJSValue :: JSValue -> ShowS
showJSValue :: JSValue -> String -> String
showJSValue JSValue
v =
  case JSValue
v of
    JSNull{}         -> String -> String
showJSNull
    JSBool Bool
b         -> Bool -> String -> String
showJSBool Bool
b
    JSNumber JSNumber
jsn     -> JSNumber -> String -> String
showJSNumber JSNumber
jsn
    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 JSON5 null type
showJSNull :: ShowS
showJSNull :: String -> String
showJSNull = String -> String -> String
showString String
"null"

-- | Write the JSON5 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 JSON5 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
'"'

showJSNumber :: JSNumber -> ShowS
showJSNumber :: JSNumber -> String -> String
showJSNumber (JSRational Rational
r) = Rational -> String -> String
showJSRational Rational
r
showJSNumber (JSInfNaN Float
n)   = Float -> String -> String
showJSInfNaN Float
n

-- | Show a Rational in JSON5 format
showJSRational :: Rational -> ShowS
showJSRational :: Rational -> String -> String
showJSRational Rational
r
 | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1   = Integer -> String -> String
forall a. Show a => a -> String -> String
shows (Integer -> String -> String) -> Integer -> String -> String
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r
 | Bool
otherwise            = Double -> String -> String
forall a. Show a => a -> String -> String
shows (Double -> String -> String) -> Double -> String -> String
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
r

-- | Show a Infinity or NaN in JSON5 format
showJSInfNaN :: Float -> ShowS
showJSInfNaN :: Float -> String -> String
showJSInfNaN Float
n
  | Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
n     = String -> String -> String
showString String
"NaN"
  | Float
n Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0       = String -> String -> String
showString String
"Infinity"
  | Float
n Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0       = String -> String -> String
showString String
"-Infinity"


-- | 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
',' ([(String, JSValue)] -> String -> String)
-> (JSObject JSValue -> [(String, JSValue)])
-> JSObject JSValue
-> String
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSObject JSValue -> [(String, JSValue)]
forall a. JSObject a -> [(String, a)]
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 Char -> String -> String
forall a. a -> [a] -> [a]
: [(String, JSValue)] -> String
go [(String, JSValue)]
xs
  where
    go :: [(String, JSValue)] -> String
go [(String
k,JSValue
v)]     = Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: JSString -> String -> String
encJSString (String -> JSString
toJSString String
k)
                              (Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: JSValue -> String -> String
showJSValue JSValue
v ([(String, JSValue)] -> String
go []))
    go ((String
k,JSValue
v):[(String, JSValue)]
kvs) = Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: JSString -> String -> String
encJSString (String -> JSString
toJSString String
k)
                              (Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: JSValue -> String -> String
showJSValue JSValue
v (Char
sep Char -> String -> String
forall a. a -> [a] -> [a]
: [(String, JSValue)] -> String
go [(String, JSValue)]
kvs))
    go []          = Char
end Char -> String -> String
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 Char -> String -> String
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 Char -> String -> String
forall a. a -> [a] -> [a]
: [JSValue] -> String
go [JSValue]
ys)
    go []         = Char
end Char -> String -> String
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 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x20' -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> String -> String
encControl Char
x (String -> String
go String
xs)
        (Char
'"' :String
xs)              -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'"'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
        (Char
'\\':String
xs)              -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
        (Char
x   :String
xs)              -> Char
x    Char -> String -> String
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' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
      Char
'\f' -> Char
'f' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
      Char
'\n' -> Char
'n' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
      Char
'\r' -> Char
'r' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
      Char
'\t' -> Char
't' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
      Char
_ | Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x10'   -> Char
'u' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
: String
hexxs
        | Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x100'  -> Char
'u' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
: String
hexxs
        | Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x1000' -> Char
'u' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
: String
hexxs
        | Bool
otherwise    -> Char
'u' Char -> String -> String
forall a. a -> [a] -> [a]
: String
hexxs
        where hexxs :: String
hexxs = Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x) String
xs