-- | Parse JSON values using the ReadP combinators.

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

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

token            :: ReadP a -> ReadP a
token :: ReadP a -> ReadP a
token p :: ReadP a
p           = ReadP ()
skipSpaces ReadP () -> ReadP a -> ReadP a
forall a b. ReadP a -> ReadP b -> ReadP b
**> ReadP a
p

p_value          :: ReadP JSValue
p_value :: ReadP JSValue
p_value           =  (JSValue
JSNull      JSValue -> ReadP () -> ReadP JSValue
forall a b. a -> ReadP b -> ReadP a
<$$  ReadP ()
p_null)
                 ReadP JSValue -> ReadP JSValue -> ReadP JSValue
forall a. ReadP a -> ReadP a -> ReadP a
<||> (Bool -> JSValue
JSBool      (Bool -> JSValue) -> ReadP Bool -> ReadP JSValue
forall a b. (a -> b) -> ReadP a -> ReadP b
<$$> ReadP Bool
p_boolean)
                 ReadP JSValue -> ReadP JSValue -> ReadP JSValue
forall a. ReadP a -> ReadP a -> ReadP a
<||> ([JSValue] -> JSValue
JSArray     ([JSValue] -> JSValue) -> ReadP [JSValue] -> ReadP JSValue
forall a b. (a -> b) -> ReadP a -> ReadP b
<$$> ReadP [JSValue]
p_array)
                 ReadP JSValue -> ReadP JSValue -> ReadP JSValue
forall a. ReadP a -> ReadP a -> ReadP a
<||> (JSString -> JSValue
JSString    (JSString -> JSValue) -> ReadP JSString -> ReadP JSValue
forall a b. (a -> b) -> ReadP a -> ReadP b
<$$> ReadP JSString
p_js_string)
                 ReadP JSValue -> ReadP JSValue -> ReadP JSValue
forall a. ReadP a -> ReadP a -> ReadP a
<||> (JSObject JSValue -> JSValue
JSObject    (JSObject JSValue -> JSValue)
-> ReadP (JSObject JSValue) -> ReadP JSValue
forall a b. (a -> b) -> ReadP a -> ReadP b
<$$> ReadP (JSObject JSValue)
p_js_object)
                 ReadP JSValue -> ReadP JSValue -> ReadP JSValue
forall a. ReadP a -> ReadP a -> ReadP a
<||> (Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> ReadP Rational -> ReadP JSValue
forall a b. (a -> b) -> ReadP a -> ReadP b
<$$> ReadP Rational
p_number)

p_null           :: ReadP ()
p_null :: ReadP ()
p_null            = ReadP String -> ReadP String
forall a. ReadP a -> ReadP a
token (String -> ReadP String
string "null") ReadP String -> ReadP () -> ReadP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ReadP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

p_boolean        :: ReadP Bool
p_boolean :: ReadP Bool
p_boolean         = ReadP Bool -> ReadP Bool
forall a. ReadP a -> ReadP a
token
                      (  (Bool
True  Bool -> ReadP String -> ReadP Bool
forall a b. a -> ReadP b -> ReadP a
<$$ String -> ReadP String
string "true")
                     ReadP Bool -> ReadP Bool -> ReadP Bool
forall a. ReadP a -> ReadP a -> ReadP a
<||> (Bool
False Bool -> ReadP String -> ReadP Bool
forall a b. a -> ReadP b -> ReadP a
<$$ String -> ReadP String
string "false")
                      )

p_array          :: ReadP [JSValue]
p_array :: ReadP [JSValue]
p_array           = ReadP Char -> ReadP Char -> ReadP [JSValue] -> ReadP [JSValue]
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a
token (Char -> ReadP Char
char '[')) (ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a
token (Char -> ReadP Char
char ']'))
                  (ReadP [JSValue] -> ReadP [JSValue])
-> ReadP [JSValue] -> ReadP [JSValue]
forall a b. (a -> b) -> a -> b
$ ReadP JSValue
p_value ReadP JSValue -> ReadP Char -> ReadP [JSValue]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
`sepBy` ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a
token (Char -> ReadP Char
char ',')

p_string         :: ReadP String
p_string :: ReadP String
p_string          = ReadP Char -> ReadP Char -> ReadP String -> ReadP String
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a
token (Char -> ReadP Char
char '"')) (Char -> ReadP Char
char '"') (ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
many ReadP Char
p_char)
  where p_char :: ReadP Char
p_char    =  (Char -> ReadP Char
char '\\' ReadP Char -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP Char
p_esc)
                 ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<||> ((Char -> Bool) -> ReadP Char
satisfy (\x :: Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '"' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\\'))

        p_esc :: ReadP Char
p_esc     =  ('"'   Char -> ReadP Char -> ReadP Char
forall a b. a -> ReadP b -> ReadP a
<$$ Char -> ReadP Char
char '"')
                 ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<||> ('\\'  Char -> ReadP Char -> ReadP Char
forall a b. a -> ReadP b -> ReadP a
<$$ Char -> ReadP Char
char '\\')
                 ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<||> ('/'   Char -> ReadP Char -> ReadP Char
forall a b. a -> ReadP b -> ReadP a
<$$ Char -> ReadP Char
char '/')
                 ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<||> ('\b'  Char -> ReadP Char -> ReadP Char
forall a b. a -> ReadP b -> ReadP a
<$$ Char -> ReadP Char
char 'b')
                 ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<||> ('\f'  Char -> ReadP Char -> ReadP Char
forall a b. a -> ReadP b -> ReadP a
<$$ Char -> ReadP Char
char 'f')
                 ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<||> ('\n'  Char -> ReadP Char -> ReadP Char
forall a b. a -> ReadP b -> ReadP a
<$$ Char -> ReadP Char
char 'n')
                 ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<||> ('\r'  Char -> ReadP Char -> ReadP Char
forall a b. a -> ReadP b -> ReadP a
<$$ Char -> ReadP Char
char 'r')
                 ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<||> ('\t'  Char -> ReadP Char -> ReadP Char
forall a b. a -> ReadP b -> ReadP a
<$$ Char -> ReadP Char
char 't')
                 ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<||> (Char -> ReadP Char
char 'u' ReadP Char -> ReadP Char -> ReadP Char
forall a b. ReadP a -> ReadP b -> ReadP b
**> ReadP Char
p_uni)

        p_uni :: ReadP Char
p_uni     = String -> ReadP Char
forall a. Enum a => String -> ReadP a
check (String -> ReadP Char) -> ReadP String -> ReadP Char
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> ReadP Char -> ReadP String
forall a. Int -> ReadP a -> ReadP [a]
count 4 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isHexDigit)
          where check :: String -> ReadP a
check x :: String
x | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
max_char  = a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> a
forall a. Enum a => Int -> a
toEnum Int
code)
                        | Bool
otherwise         = ReadP a
forall a. ReadP a
pfail
                  where code :: Int
code      = (Int, String) -> Int
forall a b. (a, b) -> a
fst ((Int, String) -> Int) -> (Int, String) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, String)] -> (Int, String)
forall a. [a] -> a
head ([(Int, String)] -> (Int, String))
-> [(Int, String)] -> (Int, String)
forall a b. (a -> b) -> a -> b
$ ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex String
x
                        max_char :: Int
max_char  = Char -> Int
forall a. Enum a => a -> Int
fromEnum (Char
forall a. Bounded a => a
maxBound :: Char)

p_object         :: ReadP [(String,JSValue)]
p_object :: ReadP [(String, JSValue)]
p_object          = ReadP Char
-> ReadP Char
-> ReadP [(String, JSValue)]
-> ReadP [(String, JSValue)]
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a
token (Char -> ReadP Char
char '{')) (ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a
token (Char -> ReadP Char
char '}'))
                  (ReadP [(String, JSValue)] -> ReadP [(String, JSValue)])
-> ReadP [(String, JSValue)] -> ReadP [(String, JSValue)]
forall a b. (a -> b) -> a -> b
$ ReadP (String, JSValue)
p_field ReadP (String, JSValue) -> ReadP Char -> ReadP [(String, JSValue)]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
`sepBy` ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a
token (Char -> ReadP Char
char ',')
  where p_field :: ReadP (String, JSValue)
p_field   = (,) (String -> JSValue -> (String, JSValue))
-> ReadP String -> ReadP (JSValue -> (String, JSValue))
forall a b. (a -> b) -> ReadP a -> ReadP b
<$$> (ReadP String
p_string ReadP String -> ReadP Char -> ReadP String
forall a b. ReadP a -> ReadP b -> ReadP a
<** ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a
token (Char -> ReadP Char
char ':')) ReadP (JSValue -> (String, JSValue))
-> ReadP JSValue -> ReadP (String, JSValue)
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
<**> ReadP JSValue
p_value

p_number         :: ReadP Rational
p_number :: ReadP Rational
p_number          = ReadS Rational -> ReadP Rational
forall a. ReadS a -> ReadP a
readS_to_P (ReadS Rational -> ReadS Rational
forall a. Real a => ReadS a -> ReadS a
readSigned ReadS Rational
forall a. RealFrac a => ReadS a
readFloat)

p_js_string      :: ReadP JSString
p_js_string :: ReadP JSString
p_js_string       = String -> JSString
toJSString (String -> JSString) -> ReadP String -> ReadP JSString
forall a b. (a -> b) -> ReadP a -> ReadP b
<$$> ReadP String
p_string

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

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

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

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

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

(<||>)  :: ReadP a -> ReadP a -> ReadP a
<||> :: ReadP a -> ReadP a -> ReadP a
(<||>)   = ReadP a -> ReadP a -> ReadP a
forall a. ReadP a -> ReadP a -> ReadP a
(+++)

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

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