module Text.JSON.String
(
GetJSON
, runGetJSON
, readJSNull
, readJSBool
, readJSString
, readJSRational
, readJSArray
, readJSObject
, readJSValue
, readJSTopType
, showJSNull
, showJSBool
, showJSArray
, showJSObject
, showJSRational
, showJSRational'
, showJSValue
, showJSTopType
) where
import Text.JSON.Types (JSValue(..),
JSString, toJSString, fromJSString,
JSObject, toJSObject, fromJSObject)
import Control.Monad (liftM, ap)
import qualified Control.Monad.Fail as Fail
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)
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 x :: a
x = (String -> Either String (a, String)) -> GetJSON a
forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\s :: String
s -> (a, String) -> Either String (a, String)
forall a b. b -> Either a b
Right (a
x,String
s))
GetJSON m :: String -> Either String (a, String)
m >>= :: GetJSON a -> (a -> GetJSON b) -> GetJSON b
>>= f :: a -> GetJSON b
f = (String -> Either String (b, String)) -> GetJSON b
forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\s :: String
s -> case String -> Either String (a, String)
m String
s of
Left err :: String
err -> String -> Either String (b, String)
forall a b. a -> Either a b
Left String
err
Right (a :: a
a,s1 :: 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 Fail.MonadFail GetJSON where
fail :: String -> GetJSON a
fail x :: String
x = (String -> Either String (a, String)) -> GetJSON a
forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\_ -> String -> Either String (a, String)
forall a b. a -> Either a b
Left String
x)
runGetJSON :: GetJSON a -> String -> Either String a
runGetJSON :: GetJSON a -> String -> Either String a
runGetJSON (GetJSON m :: String -> Either String (a, String)
m) s :: String
s = case String -> Either String (a, String)
m String
s of
Left err :: String
err -> String -> Either String a
forall a b. a -> Either a b
Left String
err
Right (a :: a
a,t :: String
t) -> case String
t of
[] -> a -> Either String a
forall a b. b -> Either a b
Right a
a
_ -> 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
$ "Invalid tokens at end of JSON string: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Int -> String -> String
forall a. Int -> [a] -> [a]
take 10 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 (\s :: 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 s :: String
s = (String -> Either String ((), String)) -> GetJSON ()
forall a. (String -> Either String (a, String)) -> GetJSON a
GetJSON (\_ -> ((), String) -> Either String ((), String)
forall a b. b -> Either a b
Right ((),String
s))
context :: String -> String
context :: String -> String
context s :: String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
take 8 String
s
readJSNull :: GetJSON JSValue
readJSNull :: GetJSON JSValue
readJSNull = do
String
xs <- GetJSON String
getInput
case String
xs of
'n':'u':'l':'l':xs1 :: 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
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ "Unable to parse JSON 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 k :: GetJSON JSValue
k = do
String
xs <- GetJSON String
getInput
case String
xs of
'n':'u':'l':'l':xs1 :: 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
_ -> GetJSON JSValue
k
readJSBool :: GetJSON JSValue
readJSBool :: GetJSON JSValue
readJSBool = do
String
xs <- GetJSON String
getInput
case String
xs of
't':'r':'u':'e':xs1 :: 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)
'f':'a':'l':'s':'e':xs1 :: 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 -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ "Unable to parse JSON Bool: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
xs
readJSString :: GetJSON JSValue
readJSString :: GetJSON JSValue
readJSString = do
String
x <- GetJSON String
getInput
case String
x of
'"' : cs :: String
cs -> String -> String -> GetJSON JSValue
parse [] String
cs
_ -> 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
$ "Malformed JSON: expecting string: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
x
where
parse :: String -> String -> GetJSON JSValue
parse rs :: String
rs cs :: String
cs =
case String
cs of
'\\' : c :: Char
c : ds :: String
ds -> String -> Char -> String -> GetJSON JSValue
esc String
rs Char
c String
ds
'"' : ds :: 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 -> String
forall a. [a] -> [a]
reverse String
rs)))
c :: Char
c : ds :: String
ds
| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '\x20' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\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
< '\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
$ "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
<= 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
$ "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 -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ "Unable to parse JSON String: unterminated String: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
esc :: String -> Char -> String -> GetJSON JSValue
esc rs :: String
rs c :: Char
c cs :: String
cs = case Char
c of
'\\' -> String -> String -> GetJSON JSValue
parse ('\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
'"' -> String -> String -> GetJSON JSValue
parse ('"' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
'n' -> String -> String -> GetJSON JSValue
parse ('\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
'r' -> String -> String -> GetJSON JSValue
parse ('\r' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
't' -> String -> String -> GetJSON JSValue
parse ('\t' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
'f' -> String -> String -> GetJSON JSValue
parse ('\f' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
'b' -> String -> String -> GetJSON JSValue
parse ('\b' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
'/' -> String -> String -> GetJSON JSValue
parse ('/' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs) String
cs
'u' -> case String
cs of
d1 :: Char
d1 : d2 :: Char
d2 : d3 :: Char
d3 : d4 :: Char
d4 : cs' :: String
cs' ->
case ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex [Char
d1,Char
d2,Char
d3,Char
d4] of
[(n :: Int
n,"")] -> 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'
x :: [(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
$ "Unable to parse JSON 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 -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON JSValue) -> String -> GetJSON JSValue
forall a b. (a -> b) -> a -> b
$ "Unable to parse JSON String: invalid hex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
_ -> 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
$ "Unable to parse JSON String: invalid escape char: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c
readJSRational :: GetJSON Rational
readJSRational :: GetJSON Rational
readJSRational = do
String
cs <- GetJSON String
getInput
case String
cs of
'-' : ds :: 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
_ -> 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
$ "Unable to parse JSON Rational: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context []
pos (c :: Char
c:cs :: String
cs) =
case Char
c of
'0' -> Rational -> String -> GetJSON Rational
frac 0 String
cs
_
| Bool -> Bool
not (Char -> Bool
isDigit Char
c) -> 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
$ "Unable to parse JSON Rational: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
| Bool
otherwise -> Integer -> String -> GetJSON Rational
readDigits (Char -> Integer
digitToIntI Char
c) String
cs
readDigits :: Integer -> String -> GetJSON Rational
readDigits acc :: Integer
acc [] = Rational -> String -> GetJSON Rational
frac (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
acc) []
readDigits acc :: Integer
acc (x :: Char
x:xs :: String
xs)
| Char -> Bool
isDigit Char
x = let acc' :: Integer
acc' = 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
forall a b. a -> b -> b
`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)
frac :: Rational -> String -> GetJSON Rational
frac n :: Rational
n ('.' : ds :: String
ds) =
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
ds of
([],_) -> 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
(as :: String
as,bs :: String
bs) -> let x :: Integer
x = String -> Integer
forall a. Read a => String -> a
read String
as :: Integer
y :: Integer
y = 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 n :: Rational
n cs :: String
cs = Rational -> String -> GetJSON Rational
exponent' Rational
n String
cs
exponent' :: Rational -> String -> GetJSON Rational
exponent' n :: Rational
n (c :: Char
c:cs :: String
cs)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'e' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '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' n :: Rational
n cs :: 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 ('+':cs :: String
cs) = String -> GetJSON Rational
exp_digs String
cs
exp_num ('-':cs :: 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 cs :: String
cs = String -> GetJSON Rational
exp_digs String
cs
exp_digs :: String -> GetJSON Rational
exp_digs :: String -> GetJSON Rational
exp_digs cs :: String
cs = case ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readDec String
cs of
[(a :: Integer
a,ds :: 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 ((10::Integer) Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
a::Integer)))
_ -> 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
$ "Unable to parse JSON exponential: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
cs
digitToIntI :: Char -> Integer
digitToIntI :: Char -> Integer
digitToIntI ch :: Char
ch = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
ch)
readJSArray :: GetJSON JSValue
readJSArray :: GetJSON JSValue
readJSArray = Char -> Char -> Char -> GetJSON [JSValue]
readSequence '[' ']' ',' 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
readJSObject :: GetJSON JSValue
readJSObject :: GetJSON JSValue
readJSObject = Char -> Char -> Char -> GetJSON [(String, JSValue)]
readAssocs '{' '}' ',' 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
readSequence :: Char -> Char -> Char -> GetJSON [JSValue]
readSequence :: Char -> Char -> Char -> GetJSON [JSValue]
readSequence start :: Char
start end :: Char
end sep :: 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
c :: Char
c : cs :: 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
d :: Char
d : ds :: 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 []
ds :: 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 -> GetJSON [JSValue]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON [JSValue]) -> String -> GetJSON [JSValue]
forall a b. (a -> b) -> a -> b
$ "Unable to parse JSON 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 rs :: [JSValue]
rs = [JSValue]
rs [JSValue] -> GetJSON [JSValue] -> GetJSON [JSValue]
forall a b. a -> b -> b
`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
e :: Char
e : es :: String
es | Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
sep -> do String -> GetJSON ()
setInput ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
es)
[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 -> GetJSON [JSValue]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON [JSValue]) -> String -> GetJSON [JSValue]
forall a b. (a -> b) -> a -> b
$ "Unable to parse JSON array: unterminated array: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
ds
readAssocs :: Char -> Char -> Char -> GetJSON [(String,JSValue)]
readAssocs :: Char -> Char -> Char -> GetJSON [(String, JSValue)]
readAssocs start :: Char
start end :: Char
end sep :: 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
c :: Char
c:cs :: 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
d :: Char
d:ds :: 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 []
ds :: 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 -> GetJSON [(String, JSValue)]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unable to parse JSON object: unterminated object"
where parsePairs :: [(String, JSValue)] -> GetJSON [(String, JSValue)]
parsePairs rs :: [(String, JSValue)]
rs = [(String, JSValue)]
rs [(String, JSValue)]
-> GetJSON [(String, JSValue)] -> GetJSON [(String, JSValue)]
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 s :: JSString
s -> String -> GetJSON String
forall (m :: * -> *) a. Monad m => a -> m a
return (JSString -> String
fromJSString JSString
s)
_ -> String -> GetJSON String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GetJSON String) -> String -> GetJSON String
forall a b. (a -> b) -> a -> b
$ "Malformed JSON field labels: object keys must be quoted strings."
String
ds <- GetJSON String
getInput
case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
ds of
':':es :: 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 -> 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
$ "Malformed JSON 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
e :: Char
e : es :: String
es | Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
sep -> 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)]
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 -> 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
$ "Unable to parse JSON object: unterminated sequence: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
ds
readJSValue :: GetJSON JSValue
readJSValue :: GetJSON JSValue
readJSValue = do
String
cs <- GetJSON String
getInput
case String
cs of
'"' : _ -> GetJSON JSValue
readJSString
'[' : _ -> GetJSON JSValue
readJSArray
'{' : _ -> GetJSON JSValue
readJSObject
't' : _ -> GetJSON JSValue
readJSBool
'f' : _ -> GetJSON JSValue
readJSBool
(x :: Char
x:_) | Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' -> Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> GetJSON Rational -> GetJSON JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetJSON Rational
readJSRational
xs :: String
xs -> 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
$ "Malformed JSON: invalid token in this context " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
context String
xs)
readJSTopType :: GetJSON JSValue
readJSTopType :: GetJSON JSValue
readJSTopType = do
String
cs <- GetJSON String
getInput
case String
cs of
'[' : _ -> GetJSON JSValue
readJSArray
'{' : _ -> GetJSON JSValue
readJSObject
_ -> String -> GetJSON JSValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Invalid JSON: a JSON text a serialized object or array at the top level."
showJSTopType :: JSValue -> ShowS
showJSTopType :: JSValue -> String -> String
showJSTopType (JSArray a :: [JSValue]
a) = [JSValue] -> String -> String
showJSArray [JSValue]
a
showJSTopType (JSObject o :: JSObject JSValue
o) = JSObject JSValue -> String -> String
showJSObject JSObject JSValue
o
showJSTopType x :: JSValue
x = JSValue -> String -> String
showJSTopType (JSValue -> String -> String) -> JSValue -> String -> String
forall a b. (a -> b) -> a -> b
$ [JSValue] -> JSValue
JSArray [JSValue
x]
showJSValue :: JSValue -> ShowS
showJSValue :: JSValue -> String -> String
showJSValue jv :: JSValue
jv =
case JSValue
jv of
JSNull{} -> String -> String
showJSNull
JSBool b :: Bool
b -> Bool -> String -> String
showJSBool Bool
b
JSRational asF :: Bool
asF r :: Rational
r -> Bool -> Rational -> String -> String
showJSRational' Bool
asF Rational
r
JSArray a :: [JSValue]
a -> [JSValue] -> String -> String
showJSArray [JSValue]
a
JSString s :: JSString
s -> JSString -> String -> String
showJSString JSString
s
JSObject o :: JSObject JSValue
o -> JSObject JSValue -> String -> String
showJSObject JSObject JSValue
o
showJSNull :: ShowS
showJSNull :: String -> String
showJSNull = String -> String -> String
showString "null"
showJSBool :: Bool -> ShowS
showJSBool :: Bool -> String -> String
showJSBool True = String -> String -> String
showString "true"
showJSBool False = String -> String -> String
showString "false"
showJSString :: JSString -> ShowS
showJSString :: JSString -> String -> String
showJSString x :: JSString
x xs :: 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 '"'
showJSRational :: Rational -> ShowS
showJSRational :: Rational -> String -> String
showJSRational r :: Rational
r = Bool -> Rational -> String -> String
showJSRational' Bool
False Rational
r
showJSRational' :: Bool -> Rational -> ShowS
showJSRational' :: Bool -> Rational -> String -> String
showJSRational' asFloat :: Bool
asFloat r :: Rational
r
| Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 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
| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
x Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
x = String -> String
showJSNull
| Bool
asFloat = Float -> String -> String
forall a. Show a => a -> String -> String
shows Float
xf
| Bool
otherwise = Double -> String -> String
forall a. Show a => a -> String -> String
shows Double
x
where
x :: Double
x :: Double
x = Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
r
xf :: Float
xf :: Float
xf = Rational -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
r
showJSArray :: [JSValue] -> ShowS
showJSArray :: [JSValue] -> String -> String
showJSArray = Char -> Char -> Char -> [JSValue] -> String -> String
showSequence '[' ']' ','
showJSObject :: JSObject JSValue -> ShowS
showJSObject :: JSObject JSValue -> String -> String
showJSObject = Char -> Char -> Char -> [(String, JSValue)] -> String -> String
showAssocs '{' '}' ',' ([(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 e. JSObject e -> [(String, e)]
fromJSObject
showAssocs :: Char -> Char -> Char -> [(String,JSValue)] -> ShowS
showAssocs :: Char -> Char -> Char -> [(String, JSValue)] -> String -> String
showAssocs start :: Char
start end :: Char
end sep :: Char
sep xs :: [(String, JSValue)]
xs rest :: 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 [(k :: String
k,v :: JSValue
v)] = '"' Char -> String -> String
forall a. a -> [a] -> [a]
: JSString -> String -> String
encJSString (String -> JSString
toJSString String
k)
('"' Char -> String -> String
forall a. a -> [a] -> [a]
: ':' Char -> String -> String
forall a. a -> [a] -> [a]
: JSValue -> String -> String
showJSValue JSValue
v ([(String, JSValue)] -> String
go []))
go ((k :: String
k,v :: JSValue
v):kvs :: [(String, JSValue)]
kvs) = '"' Char -> String -> String
forall a. a -> [a] -> [a]
: JSString -> String -> String
encJSString (String -> JSString
toJSString String
k)
('"' Char -> String -> String
forall a. a -> [a] -> [a]
: ':' 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
showSequence :: Char -> Char -> Char -> [JSValue] -> ShowS
showSequence :: Char -> Char -> Char -> [JSValue] -> String -> String
showSequence start :: Char
start end :: Char
end sep :: Char
sep xs :: [JSValue]
xs rest :: String
rest = Char
start Char -> String -> String
forall a. a -> [a] -> [a]
: [JSValue] -> String
go [JSValue]
xs
where
go :: [JSValue] -> String
go [y :: JSValue
y] = JSValue -> String -> String
showJSValue JSValue
y ([JSValue] -> String
go [])
go (y :: JSValue
y:ys :: [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 jss :: JSString
jss ss :: String
ss = String -> String
go (JSString -> String
fromJSString JSString
jss)
where
go :: String -> String
go s1 :: String
s1 =
case String
s1 of
(x :: Char
x :xs :: String
xs) | Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< '\x20' -> '\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> String -> String
encControl Char
x (String -> String
go String
xs)
('"' :xs :: String
xs) -> '\\' Char -> String -> String
forall a. a -> [a] -> [a]
: '"' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
('\\':xs :: String
xs) -> '\\' Char -> String -> String
forall a. a -> [a] -> [a]
: '\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
(x :: Char
x :xs :: String
xs) -> Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
"" -> String
ss
encControl :: Char -> String -> String
encControl x :: Char
x xs :: String
xs = case Char
x of
'\b' -> 'b' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
'\f' -> 'f' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
'\n' -> 'n' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
'\r' -> 'r' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
'\t' -> 't' Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
_ | Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< '\x10' -> 'u' Char -> String -> String
forall a. a -> [a] -> [a]
: '0' Char -> String -> String
forall a. a -> [a] -> [a]
: '0' Char -> String -> String
forall a. a -> [a] -> [a]
: '0' Char -> String -> String
forall a. a -> [a] -> [a]
: String
hexxs
| Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< '\x100' -> 'u' Char -> String -> String
forall a. a -> [a] -> [a]
: '0' Char -> String -> String
forall a. a -> [a] -> [a]
: '0' Char -> String -> String
forall a. a -> [a] -> [a]
: String
hexxs
| Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< '\x1000' -> 'u' Char -> String -> String
forall a. a -> [a] -> [a]
: '0' Char -> String -> String
forall a. a -> [a] -> [a]
: String
hexxs
| Bool
otherwise -> '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