-- | Parse JSON values using the Parsec combinators.

module Text.JSON.Parsec
  ( p_value
  , p_null
  , p_boolean
  , p_array
  , p_string
  , p_object
  , p_number
  , p_js_string
  , p_js_object
  , p_jvalue
  , module Text.ParserCombinators.Parsec
  ) where

import Text.JSON.Types
import Text.ParserCombinators.Parsec
import Control.Monad
import Data.Char
import Numeric

p_value :: CharParser () JSValue
p_value :: CharParser () JSValue
p_value = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall a b. CharParser () a -> CharParser () b -> CharParser () b
**> CharParser () JSValue
p_jvalue

tok              :: CharParser () a -> CharParser () a
tok :: forall a. CharParser () a -> CharParser () a
tok CharParser () a
p             = CharParser () a
p forall a b. CharParser () a -> CharParser () b -> CharParser () a
<** forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces

p_jvalue         :: CharParser () JSValue
p_jvalue :: CharParser () JSValue
p_jvalue          =  (JSValue
JSNull      forall a b. a -> CharParser () b -> CharParser () a
<$$  CharParser () ()
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 a b. (a -> b) -> CharParser () a -> CharParser () b
<$$> CharParser () 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 a b. (a -> b) -> CharParser () a -> CharParser () b
<$$> CharParser () [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 a b. (a -> b) -> CharParser () a -> CharParser () b
<$$> CharParser () JSString
p_js_string)
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (JSObject JSValue -> JSValue
JSObject    forall a b. (a -> b) -> CharParser () a -> CharParser () b
<$$> CharParser () (JSObject JSValue)
p_js_object)
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Bool -> Rational -> JSValue
JSRational Bool
False forall a b. (a -> b) -> CharParser () a -> CharParser () b
<$$> CharParser () Rational
p_number)
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"JSON value"

p_null           :: CharParser () ()
p_null :: CharParser () ()
p_null            = forall a. CharParser () a -> CharParser () 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        :: CharParser () Bool
p_boolean :: CharParser () Bool
p_boolean         = forall a. CharParser () a -> CharParser () a
tok
                      (  (Bool
True  forall a b. a -> CharParser () b -> CharParser () 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 a b. a -> CharParser () b -> CharParser () a
<$$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"false")
                      )

p_array          :: CharParser () [JSValue]
p_array :: CharParser () [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. CharParser () a -> CharParser () a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[')) (forall a. CharParser () a -> CharParser () 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
$ CharParser () 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. CharParser () a -> CharParser () a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')

p_string         :: CharParser () String
p_string :: CharParser () [Char]
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 a. CharParser () a -> CharParser () a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"')) (forall a. CharParser () a -> CharParser () 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 ParsecT [Char] () Identity Char
p_char)
  where p_char :: ParsecT [Char] () 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
>> ParsecT [Char] () 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 [Char] () Identity Char
p_esc     =  (Char
'"'   forall a b. a -> CharParser () b -> CharParser () 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 a b. a -> CharParser () b -> CharParser () 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 a b. a -> CharParser () b -> CharParser () 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
'\b'  forall a b. a -> CharParser () b -> CharParser () a
<$$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'b')
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Char
'\f'  forall a b. a -> CharParser () b -> CharParser () a
<$$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'f')
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Char
'\n'  forall a b. a -> CharParser () b -> CharParser () a
<$$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'n')
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Char
'\r'  forall a b. a -> CharParser () b -> CharParser () a
<$$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'r')
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Char
'\t'  forall a b. a -> CharParser () b -> CharParser () a
<$$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
't')
                 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 -> ParsecT s u m Char
char Char
'u' forall a b. CharParser () a -> CharParser () b -> CharParser () b
**> forall {u}. ParsecT [Char] u Identity Char
p_uni)
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"escape character"

        p_uni :: ParsecT [Char] u Identity Char
p_uni     = forall {m :: * -> *} {a}. (Enum a, MonadPlus m) => [Char] -> m a
check forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
4 (forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isHexDigit)
          where check :: [Char] -> m a
check [Char]
x | Int
code forall a. Ord a => a -> a -> Bool
<= Int
max_char  = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Enum a => Int -> a
toEnum Int
code)
                        | Bool
otherwise         = forall (m :: * -> *) a. MonadPlus m => m a
mzero
                  where code :: Int
code      = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Num a) => ReadS a
readHex [Char]
x
                        max_char :: Int
max_char  = forall a. Enum a => a -> Int
fromEnum (forall a. Bounded a => a
maxBound :: Char)

p_object         :: CharParser () [(String,JSValue)]
p_object :: CharParser () [([Char], 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. CharParser () a -> CharParser () a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{')) (forall a. CharParser () a -> CharParser () 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
$ CharParser () ([Char], 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. CharParser () a -> CharParser () a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')
  where p_field :: CharParser () ([Char], JSValue)
p_field   = (,) forall a b. (a -> b) -> CharParser () a -> CharParser () b
<$$> (CharParser () [Char]
p_string forall a b. CharParser () a -> CharParser () b -> CharParser () a
<** forall a. CharParser () a -> CharParser () a
tok (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':')) forall a b.
CharParser () (a -> b) -> CharParser () a -> CharParser () b
<**> CharParser () JSValue
p_jvalue

p_number         :: CharParser () Rational
p_number :: CharParser () Rational
p_number          = forall a. CharParser () a -> CharParser () a
tok
                  forall a b. (a -> b) -> a -> b
$ do [Char]
s <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
                       case (forall a. Read a => ReadS a
reads [Char]
s, forall a. Real a => ReadS a -> ReadS a
readSigned forall a. RealFrac a => ReadS a
readFloat [Char]
s) of
                         ([(Double
x,[Char]
_)], [(Rational, [Char])]
_)
                           | forall a. RealFloat a => a -> Bool
isInfinite (Double
x :: Double) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"number out of range"
                         ([(Double, [Char])]
_, [(Rational
y,[Char]
s')]) -> Rational
y forall a b. a -> CharParser () b -> CharParser () a
<$$ forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput [Char]
s'
                         ([(Double, [Char])], [(Rational, [Char])])
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"number"

p_js_string      :: CharParser () JSString
p_js_string :: CharParser () JSString
p_js_string       = [Char] -> JSString
toJSString forall a b. (a -> b) -> CharParser () a -> CharParser () b
<$$> CharParser () [Char]
p_string

p_js_object      :: CharParser () (JSObject JSValue)
p_js_object :: CharParser () (JSObject JSValue)
p_js_object       = forall a. [([Char], a)] -> JSObject a
toJSObject forall a b. (a -> b) -> CharParser () a -> CharParser () b
<$$> CharParser () [([Char], JSValue)]
p_object

--------------------------------------------------------------------------------
-- XXX: Because Parsec is not Applicative yet...

(<**>)  :: CharParser () (a -> b) -> CharParser () a -> CharParser () b
<**> :: forall a b.
CharParser () (a -> b) -> CharParser () a -> CharParser () b
(<**>)   = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

(**>)   :: CharParser () a -> CharParser () b -> CharParser () b
**> :: forall a b. CharParser () a -> CharParser () b -> CharParser () b
(**>)    = forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)

(<**)   :: CharParser () a -> CharParser () b -> CharParser () a
CharParser () a
m <** :: forall a b. CharParser () a -> CharParser () b -> CharParser () a
<** CharParser () b
n  = do a
x <- CharParser () a
m; b
_ <- CharParser () b
n; forall (m :: * -> *) a. Monad m => a -> m a
return a
x

(<$$>)  :: (a -> b) -> CharParser () a -> CharParser () b
<$$> :: forall a b. (a -> b) -> CharParser () a -> CharParser () b
(<$$>)   = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

(<$$)   :: a -> CharParser () b -> CharParser () a
a
x <$$ :: forall a b. a -> CharParser () b -> CharParser () a
<$$ CharParser () b
m  = CharParser () b
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
x