{-# LANGUAGE CPP #-}
module Text.JSON.Canonical.Parse
( parseCanonicalJSON
, renderCanonicalJSON
, prettyCanonicalJSON
) where
import Text.JSON.Canonical.Types
import Text.Parsec
( (<|>), (<?>), many, between, sepBy
, satisfy, char, string, digit, spaces
, parse )
import Text.Parsec.ByteString.Lazy
( Parser )
import Text.PrettyPrint hiding (char)
import qualified Text.PrettyPrint as Doc
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative ((<$>), (<$), pure, (<*>), (<*), (*>))
#endif
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif
import Data.Char (isDigit, digitToInt)
import Data.Function (on)
import Data.List (foldl', sortBy)
import qualified Data.ByteString.Lazy.Char8 as BS
renderCanonicalJSON :: JSValue -> BS.ByteString
renderCanonicalJSON :: JSValue -> ByteString
renderCanonicalJSON JSValue
v = [Char] -> ByteString
BS.pack (JSValue -> ShowS
s_value JSValue
v [])
s_value :: JSValue -> ShowS
s_value :: JSValue -> ShowS
s_value JSValue
JSNull = [Char] -> ShowS
showString [Char]
"null"
s_value (JSBool Bool
False) = [Char] -> ShowS
showString [Char]
"false"
s_value (JSBool Bool
True) = [Char] -> ShowS
showString [Char]
"true"
s_value (JSNum Int54
n) = forall a. Show a => a -> ShowS
shows Int54
n
s_value (JSString JSString
s) = JSString -> ShowS
s_string JSString
s
s_value (JSArray [JSValue]
vs) = [JSValue] -> ShowS
s_array [JSValue]
vs
s_value (JSObject [(JSString, JSValue)]
fs) = [(JSString, JSValue)] -> ShowS
s_object (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) [(JSString, JSValue)]
fs)
s_string :: JSString -> ShowS
s_string :: JSString -> ShowS
s_string JSString
s = Char -> ShowS
showChar Char
'"' forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showl (JSString -> [Char]
fromJSString JSString
s)
where showl :: [Char] -> ShowS
showl [] = Char -> ShowS
showChar Char
'"'
showl (Char
c:[Char]
cs) = Char -> ShowS
s_char Char
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showl [Char]
cs
s_char :: Char -> ShowS
s_char Char
'"' = Char -> ShowS
showChar Char
'\\' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'"'
s_char Char
'\\' = Char -> ShowS
showChar Char
'\\' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\\'
s_char Char
c = Char -> ShowS
showChar Char
c
s_array :: [JSValue] -> ShowS
s_array :: [JSValue] -> ShowS
s_array [] = [Char] -> ShowS
showString [Char]
"[]"
s_array (JSValue
v0:[JSValue]
vs0) = Char -> ShowS
showChar Char
'[' forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ShowS
s_value JSValue
v0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JSValue] -> ShowS
showl [JSValue]
vs0
where showl :: [JSValue] -> ShowS
showl [] = Char -> ShowS
showChar Char
']'
showl (JSValue
v:[JSValue]
vs) = Char -> ShowS
showChar Char
',' forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ShowS
s_value JSValue
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JSValue] -> ShowS
showl [JSValue]
vs
s_object :: [(JSString, JSValue)] -> ShowS
s_object :: [(JSString, JSValue)] -> ShowS
s_object [] = [Char] -> ShowS
showString [Char]
"{}"
s_object ((JSString
k0,JSValue
v0):[(JSString, JSValue)]
kvs0) = Char -> ShowS
showChar Char
'{' forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> ShowS
s_string JSString
k0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
':' forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ShowS
s_value JSValue
v0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(JSString, JSValue)] -> ShowS
showl [(JSString, JSValue)]
kvs0
where showl :: [(JSString, JSValue)] -> ShowS
showl [] = Char -> ShowS
showChar Char
'}'
showl ((JSString
k,JSValue
v):[(JSString, JSValue)]
kvs) = Char -> ShowS
showChar Char
',' forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> ShowS
s_string JSString
k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
':' forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ShowS
s_value JSValue
v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(JSString, JSValue)] -> ShowS
showl [(JSString, JSValue)]
kvs
parseCanonicalJSON :: BS.ByteString -> Either String JSValue
parseCanonicalJSON :: ByteString -> Either [Char] JSValue
parseCanonicalJSON = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall a b. b -> Either a b
Right
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parser JSValue
p_value [Char]
""
p_value :: Parser JSValue
p_value :: Parser JSValue
p_value = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser JSValue
p_jvalue
tok :: Parser a -> Parser a
tok :: forall a. Parser a -> Parser a
tok Parser a
p = Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
p_jvalue :: Parser JSValue
p_jvalue :: Parser JSValue
p_jvalue = (JSValue
JSNull forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ()
p_null)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Bool -> JSValue
JSBool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bool
p_boolean)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ([JSValue] -> JSValue
JSArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [JSValue]
p_array)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (JSString -> JSValue
JSString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser JSString
p_string)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ([(JSString, JSValue)] -> JSValue
JSObject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [(JSString, JSValue)]
p_object)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Int54 -> JSValue
JSNum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int54
p_number)
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"JSON value"
p_null :: Parser ()
p_null :: Parser ()
p_null = forall a. Parser a -> Parser a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"null") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
p_boolean :: Parser Bool
p_boolean :: Parser Bool
p_boolean = forall a. Parser a -> Parser a
tok
( (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"true")
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"false")
)
p_array :: Parser [JSValue]
p_array :: Parser [JSValue]
p_array = forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall a. Parser a -> Parser a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[')) (forall a. Parser a -> Parser a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']'))
forall a b. (a -> b) -> a -> b
$ Parser JSValue
p_jvalue forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` forall a. Parser a -> Parser a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')
p_string :: Parser JSString
p_string :: Parser JSString
p_string = forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"') (forall a. Parser a -> Parser a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'))
(forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall {u}. ParsecT ByteString u Identity Char
p_char forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
str -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [Char] -> JSString
toJSString [Char]
str)
where p_char :: ParsecT ByteString u Identity Char
p_char = (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {u}. ParsecT ByteString u Identity Char
p_esc)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
x -> Char
x forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
'\\'))
p_esc :: ParsecT ByteString u Identity Char
p_esc = (Char
'"' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"')
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Char
'\\' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\')
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"escape character"
p_object :: Parser [(JSString, JSValue)]
p_object :: Parser [(JSString, JSValue)]
p_object = forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall a. Parser a -> Parser a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{')) (forall a. Parser a -> Parser a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}'))
forall a b. (a -> b) -> a -> b
$ ParsecT ByteString () Identity (JSString, JSValue)
p_field forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` forall a. Parser a -> Parser a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')
where p_field :: ParsecT ByteString () Identity (JSString, JSValue)
p_field = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser JSString
p_string forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser a -> Parser a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':')) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser JSValue
p_jvalue
p_number :: Parser Int54
p_number :: Parser Int54
p_number = forall a. Parser a -> Parser a
tok
( (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int54
pnat))
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Int54
pnat
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u}. ParsecT ByteString u Identity Int54
zero
)
where pnat :: Parser Int54
pnat = (\Char
d [Char]
ds -> [Char] -> Int54
strToInt (Char
dforall a. a -> [a] -> [a]
:[Char]
ds)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {u}. ParsecT ByteString u Identity Char
digit19 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Int -> Parser a -> Parser [a]
manyN Int
14 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
digit19 :: ParsecT ByteString u Identity Char
digit19 = forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'0') forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"digit"
strToInt :: [Char] -> Int54
strToInt = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int54
x Char
d -> Int54
10forall a. Num a => a -> a -> a
*Int54
x forall a. Num a => a -> a -> a
+ Char -> Int54
digitToInt54 Char
d) Int54
0
zero :: ParsecT ByteString u Identity Int54
zero = Int54
0 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'0'
digitToInt54 :: Char -> Int54
digitToInt54 :: Char -> Int54
digitToInt54 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt
manyN :: Int -> Parser a -> Parser [a]
manyN :: forall a. Int -> Parser a -> Parser [a]
manyN Int
0 Parser a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
manyN Int
n Parser a
p = ((:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Int -> Parser a -> Parser [a]
manyN (Int
n forall a. Num a => a -> a -> a
- Int
1) Parser a
p)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
prettyCanonicalJSON :: JSValue -> String
prettyCanonicalJSON :: JSValue -> [Char]
prettyCanonicalJSON = Doc -> [Char]
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> Doc
jvalue
jvalue :: JSValue -> Doc
jvalue :: JSValue -> Doc
jvalue JSValue
JSNull = [Char] -> Doc
text [Char]
"null"
jvalue (JSBool Bool
False) = [Char] -> Doc
text [Char]
"false"
jvalue (JSBool Bool
True) = [Char] -> Doc
text [Char]
"true"
jvalue (JSNum Int54
n) = Integer -> Doc
integer (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int54 -> Int64
int54ToInt64 Int54
n))
jvalue (JSString JSString
s) = JSString -> Doc
jstring JSString
s
jvalue (JSArray [JSValue]
vs) = [JSValue] -> Doc
jarray [JSValue]
vs
jvalue (JSObject [(JSString, JSValue)]
fs) = [(JSString, JSValue)] -> Doc
jobject [(JSString, JSValue)]
fs
jstring :: JSString -> Doc
jstring :: JSString -> Doc
jstring = Doc -> Doc
doubleQuotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Doc
jchar forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> [Char]
fromJSString
jchar :: Char -> Doc
jchar :: Char -> Doc
jchar Char
'"' = Char -> Doc
Doc.char Char
'\\' Doc -> Doc -> Doc
<> Char -> Doc
Doc.char Char
'"'
jchar Char
'\\' = Char -> Doc
Doc.char Char
'\\' Doc -> Doc -> Doc
<> Char -> Doc
Doc.char Char
'\\'
jchar Char
c = Char -> Doc
Doc.char Char
c
jarray :: [JSValue] -> Doc
jarray :: [JSValue] -> Doc
jarray = [Doc] -> Doc
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc -> [Doc] -> [Doc]
punctuate' Doc
lbrack Doc
comma Doc
rbrack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map JSValue -> Doc
jvalue
jobject :: [(JSString, JSValue)] -> Doc
jobject :: [(JSString, JSValue)] -> Doc
jobject = [Doc] -> Doc
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc -> [Doc] -> [Doc]
punctuate' Doc
lbrace Doc
comma Doc
rbrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(JSString
k,JSValue
v) -> [Doc] -> Doc
sep [JSString -> Doc
jstring JSString
k Doc -> Doc -> Doc
<> Doc
colon, Int -> Doc -> Doc
nest Int
2 (JSValue -> Doc
jvalue JSValue
v)])
punctuate' :: Doc -> Doc -> Doc -> [Doc] -> [Doc]
punctuate' :: Doc -> Doc -> Doc -> [Doc] -> [Doc]
punctuate' Doc
l Doc
_ Doc
r [] = [Doc
l Doc -> Doc -> Doc
<> Doc
r]
punctuate' Doc
l Doc
_ Doc
r [Doc
x] = [Doc
l Doc -> Doc -> Doc
<+> Doc
x Doc -> Doc -> Doc
<+> Doc
r]
punctuate' Doc
l Doc
p Doc
r (Doc
x:[Doc]
xs) = Doc
l Doc -> Doc -> Doc
<+> Doc
x forall a. a -> [a] -> [a]
: [Doc] -> [Doc]
go [Doc]
xs
where
go :: [Doc] -> [Doc]
go [] = []
go [Doc
y] = [Doc
p Doc -> Doc -> Doc
<+> Doc
y, Doc
r]
go (Doc
y:[Doc]
ys) = (Doc
p Doc -> Doc -> Doc
<+> Doc
y) forall a. a -> [a] -> [a]
: [Doc] -> [Doc]
go [Doc]
ys