{-# LANGUAGE CPP #-}
--------------------------------------------------------------------
-- |
-- Module    : Text.JSON.Canonical.Parse
-- Copyright : (c) Galois, Inc. 2007-2009, Duncan Coutts 2015, 2017
--
--
-- Minimal implementation of Canonical JSON parsing and printing.
--
-- <http://wiki.laptop.org/go/Canonical_JSON>
--
-- TODO: Known bugs/limitations:
--
--  * Decoding/encoding Unicode code-points beyond @U+00ff@ is currently broken
--
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



------------------------------------------------------------------------------
-- rendering flat
--

-- | Render a JSON value in canonical form. This rendered form is canonical
-- and so allows repeatable hashes.
--
-- For pretty printing, see prettyCanonicalJSON.
--
-- NB: Canonical JSON's string escaping rules deviate from RFC 7159
-- JSON which requires
--
--    "All Unicode characters may be placed within the quotation
--    marks, except for the characters that must be escaped: quotation
--    mark, reverse solidus, and the control characters (@U+0000@
--    through @U+001F@)."
--
-- Whereas the current specification of Canonical JSON explicitly
-- requires to violate this by only escaping the quotation mark and
-- the reverse solidus. This, however, contradicts Canonical JSON's
-- statement that "Canonical JSON is parsable with any full JSON
-- parser"
--
-- Consequently, Canonical JSON is not a proper subset of RFC 7159.
--
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)      = Int54 -> ShowS
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 (((JSString, JSValue) -> (JSString, JSValue) -> Ordering)
-> [(JSString, JSValue)] -> [(JSString, JSValue)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (JSString -> JSString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (JSString -> JSString -> Ordering)
-> ((JSString, JSValue) -> JSString)
-> (JSString, JSValue)
-> (JSString, JSValue)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (JSString, JSValue) -> JSString
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
'"' ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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
'\\' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'"'
        s_char Char
'\\'  = Char -> ShowS
showChar Char
'\\' ShowS -> ShowS -> ShowS
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
'[' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ShowS
s_value JSValue
v0 ShowS -> ShowS -> ShowS
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
',' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ShowS
s_value JSValue
v ShowS -> ShowS -> ShowS
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
'{' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> ShowS
s_string JSString
k0
                          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
':' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ShowS
s_value JSValue
v0
                          ShowS -> ShowS -> ShowS
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
',' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> ShowS
s_string JSString
k
                          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
':' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ShowS
s_value JSValue
v
                          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(JSString, JSValue)] -> ShowS
showl [(JSString, JSValue)]
kvs

------------------------------------------------------------------------------
-- parsing
--

-- | Parse a canonical JSON format string as a JSON value. The input string
-- does not have to be in canonical form, just in the \"canonical JSON\"
-- format.
--
-- Use 'renderCanonicalJSON' to convert into canonical form.
--
parseCanonicalJSON :: BS.ByteString -> Either String JSValue
parseCanonicalJSON :: ByteString -> Either [Char] JSValue
parseCanonicalJSON = (ParseError -> Either [Char] JSValue)
-> (JSValue -> Either [Char] JSValue)
-> Either ParseError JSValue
-> Either [Char] JSValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Either [Char] JSValue
forall a b. a -> Either a b
Left ([Char] -> Either [Char] JSValue)
-> (ParseError -> [Char]) -> ParseError -> Either [Char] JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Char]
forall a. Show a => a -> [Char]
show) JSValue -> Either [Char] JSValue
forall a b. b -> Either a b
Right
                   (Either ParseError JSValue -> Either [Char] JSValue)
-> (ByteString -> Either ParseError JSValue)
-> ByteString
-> Either [Char] JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec ByteString () JSValue
-> [Char] -> ByteString -> Either ParseError JSValue
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec ByteString () JSValue
p_value [Char]
""

p_value :: Parser JSValue
p_value :: Parsec ByteString () JSValue
p_value = ParsecT ByteString () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT ByteString () Identity ()
-> Parsec ByteString () JSValue -> Parsec ByteString () JSValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec ByteString () JSValue
p_jvalue

tok              :: Parser a -> Parser a
tok :: Parser a -> Parser a
tok Parser a
p             = Parser a
p Parser a -> ParsecT ByteString () Identity () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT ByteString () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces

{-
value:
   string
   number
   object
   array
   true
   false
   null
-}
p_jvalue         :: Parser JSValue
p_jvalue :: Parsec ByteString () JSValue
p_jvalue          =  (JSValue
JSNull      JSValue
-> ParsecT ByteString () Identity ()
-> Parsec ByteString () JSValue
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  ParsecT ByteString () Identity ()
p_null)
                 Parsec ByteString () JSValue
-> Parsec ByteString () JSValue -> Parsec ByteString () JSValue
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Bool -> JSValue
JSBool      (Bool -> JSValue)
-> ParsecT ByteString () Identity Bool
-> Parsec ByteString () JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Bool
p_boolean)
                 Parsec ByteString () JSValue
-> Parsec ByteString () JSValue -> Parsec ByteString () JSValue
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ([JSValue] -> JSValue
JSArray     ([JSValue] -> JSValue)
-> ParsecT ByteString () Identity [JSValue]
-> Parsec ByteString () JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity [JSValue]
p_array)
                 Parsec ByteString () JSValue
-> Parsec ByteString () JSValue -> Parsec ByteString () JSValue
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (JSString -> JSValue
JSString    (JSString -> JSValue)
-> ParsecT ByteString () Identity JSString
-> Parsec ByteString () JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity JSString
p_string)
                 Parsec ByteString () JSValue
-> Parsec ByteString () JSValue -> Parsec ByteString () JSValue
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ([(JSString, JSValue)] -> JSValue
JSObject    ([(JSString, JSValue)] -> JSValue)
-> ParsecT ByteString () Identity [(JSString, JSValue)]
-> Parsec ByteString () JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity [(JSString, JSValue)]
p_object)
                 Parsec ByteString () JSValue
-> Parsec ByteString () JSValue -> Parsec ByteString () JSValue
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Int54 -> JSValue
JSNum       (Int54 -> JSValue)
-> ParsecT ByteString () Identity Int54
-> Parsec ByteString () JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Int54
p_number)
                 Parsec ByteString () JSValue
-> [Char] -> Parsec ByteString () JSValue
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"JSON value"

p_null           :: Parser ()
p_null :: ParsecT ByteString () Identity ()
p_null            = Parser [Char] -> Parser [Char]
forall a. Parser a -> Parser a
tok ([Char] -> Parser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"null") Parser [Char]
-> ParsecT ByteString () Identity ()
-> ParsecT ByteString () Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ParsecT ByteString () Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

p_boolean        :: Parser Bool
p_boolean :: ParsecT ByteString () Identity Bool
p_boolean         = ParsecT ByteString () Identity Bool
-> ParsecT ByteString () Identity Bool
forall a. Parser a -> Parser a
tok
                      (  (Bool
True  Bool -> Parser [Char] -> ParsecT ByteString () Identity Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"true")
                     ParsecT ByteString () Identity Bool
-> ParsecT ByteString () Identity Bool
-> ParsecT ByteString () Identity Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Bool
False Bool -> Parser [Char] -> ParsecT ByteString () Identity Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"false")
                      )
{-
array:
   []
   [ elements ]
elements:
   value
   value , elements
-}
p_array          :: Parser [JSValue]
p_array :: ParsecT ByteString () Identity [JSValue]
p_array           = ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity [JSValue]
-> ParsecT ByteString () Identity [JSValue]
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 (ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall a. Parser a -> Parser a
tok (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[')) (ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall a. Parser a -> Parser a
tok (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']'))
                  (ParsecT ByteString () Identity [JSValue]
 -> ParsecT ByteString () Identity [JSValue])
-> ParsecT ByteString () Identity [JSValue]
-> ParsecT ByteString () Identity [JSValue]
forall a b. (a -> b) -> a -> b
$ Parsec ByteString () JSValue
p_jvalue Parsec ByteString () JSValue
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity [JSValue]
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` ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall a. Parser a -> Parser a
tok (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')

{-
string:
   ""
   " chars "
chars:
   char
   char chars
char:
   any byte except hex 22 (") or hex 5C (\)
   \\
   \"
-}
p_string         :: Parser JSString
p_string :: ParsecT ByteString () Identity JSString
p_string          = ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity JSString
-> ParsecT ByteString () Identity JSString
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 (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"') (ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall a. Parser a -> Parser a
tok (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'))
                            (ParsecT ByteString () Identity Char -> Parser [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT ByteString () Identity Char
forall u. ParsecT ByteString u Identity Char
p_char Parser [Char]
-> ([Char] -> ParsecT ByteString () Identity JSString)
-> ParsecT ByteString () Identity JSString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
str -> JSString -> ParsecT ByteString () Identity JSString
forall (m :: * -> *) a. Monad m => a -> m a
return (JSString -> ParsecT ByteString () Identity JSString)
-> JSString -> ParsecT ByteString () Identity JSString
forall a b. (a -> b) -> a -> b
$! [Char] -> JSString
toJSString [Char]
str)
  where p_char :: ParsecT ByteString u Identity Char
p_char    =  (Char -> ParsecT ByteString u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT ByteString u Identity Char
forall u. ParsecT ByteString u Identity Char
p_esc)
                 ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ((Char -> Bool) -> ParsecT ByteString u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\'))

        p_esc :: ParsecT ByteString u Identity Char
p_esc     =  (Char
'"'   Char
-> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT ByteString u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"')
                 ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Char
'\\'  Char
-> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT ByteString u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\')
                 ParsecT ByteString u Identity Char
-> [Char] -> ParsecT ByteString u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"escape character"
{-
object:
    {}
    { members }
members:
   pair
   pair , members
pair:
   string : value
-}
p_object         :: Parser [(JSString, JSValue)]
p_object :: ParsecT ByteString () Identity [(JSString, JSValue)]
p_object          = ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity [(JSString, JSValue)]
-> ParsecT ByteString () Identity [(JSString, JSValue)]
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 (ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall a. Parser a -> Parser a
tok (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{')) (ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall a. Parser a -> Parser a
tok (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}'))
                  (ParsecT ByteString () Identity [(JSString, JSValue)]
 -> ParsecT ByteString () Identity [(JSString, JSValue)])
-> ParsecT ByteString () Identity [(JSString, JSValue)]
-> ParsecT ByteString () Identity [(JSString, JSValue)]
forall a b. (a -> b) -> a -> b
$ ParsecT ByteString () Identity (JSString, JSValue)
p_field ParsecT ByteString () Identity (JSString, JSValue)
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity [(JSString, JSValue)]
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` ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall a. Parser a -> Parser a
tok (Char -> ParsecT ByteString () Identity Char
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   = (,) (JSString -> JSValue -> (JSString, JSValue))
-> ParsecT ByteString () Identity JSString
-> ParsecT ByteString () Identity (JSValue -> (JSString, JSValue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT ByteString () Identity JSString
p_string ParsecT ByteString () Identity JSString
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity JSString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall a. Parser a -> Parser a
tok (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':')) ParsecT ByteString () Identity (JSValue -> (JSString, JSValue))
-> Parsec ByteString () JSValue
-> ParsecT ByteString () Identity (JSString, JSValue)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec ByteString () JSValue
p_jvalue

{-
number:
   int
int:
   digit
   digit1-9 digits
   - digit1-9
   - digit1-9 digits
digits:
   digit
   digit digits
-}

-- | Parse an int
--
-- TODO: Currently this allows for a maximum of 15 digits (i.e. a maximum value
-- of @999,999,999,999,999@) as a crude approximation of the 'Int54' range.
p_number         :: Parser Int54
p_number :: ParsecT ByteString () Identity Int54
p_number          = ParsecT ByteString () Identity Int54
-> ParsecT ByteString () Identity Int54
forall a. Parser a -> Parser a
tok
                      (  (Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Int54
-> ParsecT ByteString () Identity Int54
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int54 -> Int54
forall a. Num a => a -> a
negate (Int54 -> Int54)
-> ParsecT ByteString () Identity Int54
-> ParsecT ByteString () Identity Int54
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Int54
pnat))
                     ParsecT ByteString () Identity Int54
-> ParsecT ByteString () Identity Int54
-> ParsecT ByteString () Identity Int54
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT ByteString () Identity Int54
pnat
                     ParsecT ByteString () Identity Int54
-> ParsecT ByteString () Identity Int54
-> ParsecT ByteString () Identity Int54
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT ByteString () Identity Int54
forall u. ParsecT ByteString u Identity Int54
zero
                      )
  where pnat :: ParsecT ByteString () Identity Int54
pnat      = (\Char
d [Char]
ds -> [Char] -> Int54
strToInt (Char
dChar -> ShowS
forall a. a -> [a] -> [a]
:[Char]
ds)) (Char -> [Char] -> Int54)
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity ([Char] -> Int54)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Char
forall u. ParsecT ByteString u Identity Char
digit19 ParsecT ByteString () Identity ([Char] -> Int54)
-> Parser [Char] -> ParsecT ByteString () Identity Int54
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> ParsecT ByteString () Identity Char -> Parser [Char]
forall a. Int -> Parser a -> Parser [a]
manyN Int
14 ParsecT ByteString () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
        digit19 :: ParsecT ByteString u Identity Char
digit19   = (Char -> Bool) -> ParsecT ByteString u Identity Char
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'0') ParsecT ByteString u Identity Char
-> [Char] -> ParsecT ByteString u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"digit"
        strToInt :: [Char] -> Int54
strToInt  = (Int54 -> Char -> Int54) -> Int54 -> [Char] -> Int54
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int54
x Char
d -> Int54
10Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
*Int54
x Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
+ Char -> Int54
digitToInt54 Char
d) Int54
0
        zero :: ParsecT ByteString u Identity Int54
zero      = Int54
0 Int54
-> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity Int54
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT ByteString u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'0'

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

manyN :: Int -> Parser a -> Parser [a]
manyN :: Int -> Parser a -> Parser [a]
manyN Int
0 Parser a
_ =  [a] -> Parser [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
manyN Int
n Parser a
p =  ((:) (a -> [a] -> [a])
-> Parser a -> ParsecT ByteString () Identity ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p ParsecT ByteString () Identity ([a] -> [a])
-> Parser [a] -> Parser [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser a -> Parser [a]
forall a. Int -> Parser a -> Parser [a]
manyN (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Parser a
p)
         Parser [a] -> Parser [a] -> Parser [a]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [a] -> Parser [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

------------------------------------------------------------------------------
-- rendering nicely
--

-- | Render a JSON value in a reasonable human-readable form. This rendered
-- form is /not the canonical form/ used for repeatable hashes, use
-- 'renderCanonicalJSON' for that.

-- It is suitable however as an external form as any canonical JSON parser can
-- read it and convert it into the form used for repeatable hashes.
--
prettyCanonicalJSON :: JSValue -> String
prettyCanonicalJSON :: JSValue -> [Char]
prettyCanonicalJSON = Doc -> [Char]
render (Doc -> [Char]) -> (JSValue -> Doc) -> JSValue -> [Char]
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 (Int64 -> 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 (Doc -> Doc) -> (JSString -> Doc) -> JSString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hcat ([Doc] -> Doc) -> (JSString -> [Doc]) -> JSString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Doc) -> [Char] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Doc
jchar ([Char] -> [Doc]) -> (JSString -> [Char]) -> JSString -> [Doc]
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 ([Doc] -> Doc) -> ([JSValue] -> [Doc]) -> [JSValue] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc -> [Doc] -> [Doc]
punctuate' Doc
lbrack Doc
comma Doc
rbrack
       ([Doc] -> [Doc]) -> ([JSValue] -> [Doc]) -> [JSValue] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JSValue -> Doc) -> [JSValue] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map JSValue -> Doc
jvalue

jobject :: [(JSString, JSValue)] -> Doc
jobject :: [(JSString, JSValue)] -> Doc
jobject = [Doc] -> Doc
sep ([Doc] -> Doc)
-> ([(JSString, JSValue)] -> [Doc]) -> [(JSString, JSValue)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc -> Doc -> [Doc] -> [Doc]
punctuate' Doc
lbrace Doc
comma Doc
rbrace
        ([Doc] -> [Doc])
-> ([(JSString, JSValue)] -> [Doc])
-> [(JSString, JSValue)]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((JSString, JSValue) -> Doc) -> [(JSString, JSValue)] -> [Doc]
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 in this style:
--
-- > [ foo, bar ]
--
-- if it fits, or vertically otherwise:
--
-- > [ foo
-- > , bar
-- > ]
--
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 Doc -> [Doc] -> [Doc]
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) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc] -> [Doc]
go [Doc]
ys