module Data.JSON2.Parser
( encodeJson
, parseJson
)
where
import Data.JSON2.Types
import Data.Char
import Data.Map (Map)
import qualified Data.Map as Map
import Numeric
import Control.Monad
import Text.ParserCombinators.Parsec
encodeJson :: String -> Json
encodeJson s = case parseJson s of
Right j -> j
Left e -> error $ show e
parseJson :: String -> Either ParseError Json
parseJson s = parse jsonP' "user input" s
jsonP' = do
spaces
js <- jsonP
eof
return js
jsonP :: GenParser Char () Json
jsonP = (JNull <$ tok nullP)
<|> (JBool <$> tok boolP )
<|> (JString <$> tok stringP)
<|> (JNumber . fst . head . readSigned readFloat) <$> (tok numP)
<|> (JArray <$> tok arrayP)
<|> ((JObject . Map.fromList) <$> tok objectP)
nullP :: GenParser Char st String
nullP = tok (string "null")
boolP :: GenParser Char () Bool
boolP = ( True <$ string "true") <|> (False <$ string "false")
stringP :: GenParser Char () String
stringP = char '"' >> manyTill (escCharP <|> anyChar) (char '"')
where
escCharP = (char '\\') >>
( (char '"') <|> (char '\\') <|>
(char '/') <|> ('\b' <$ char 'b') <|>
('\f' <$ char 'f') <|> ('\n' <$ char 'n') <|>
('\r' <$ char 'r') <|> ('\t' <$ char 't') <|>
(char 'u'>> uniP)
)
uniP = (chr . fst . head . readHex) <$> (count 4 hexDigit)
numP = (try $ liftM2 (++) int frac_exp)
<|> int
digits = many digit
digits1 = many1 digit
digit19 = oneOf "123456789"
nat1 = consP digit19 digits
nat = ("0" <$ char '0') <|> nat1
neg = consP (char '-') nat
int = neg <|> nat
frac = consP (char '.') digits1
numz = consP (oneOf "+-") digits1
expp = consP (oneOf "eE") (numz <|> digits1)
frac_exp = (try $ liftM2 (++) frac expp)
<|> (try expp)
<|> frac
arrayP :: CharParser () [Json]
arrayP = between (tok (char '[')) (tok (char ']'))
$ jsonP `sepBy` tok (char ',')
objectP :: GenParser Char () [(String, Json)]
objectP = between (tok $ char '{' ) (tok $ char '}')
$ pairP `sepBy` tok (char ',')
where
pairP = do
k <- tok stringP
tok $ char ':'
v <- tok jsonP
return (k, v)
tok :: CharParser st b -> CharParser st b
tok p = do {x <- p; spaces; return x}
consP :: CharParser () Char -> CharParser () String -> CharParser () String
consP = liftM2 (\x y -> [x] ++ y)
(<$) :: a -> CharParser () b -> CharParser () a
x <$ m = m >> return x
(<$>) :: (a -> b) -> CharParser () a -> CharParser () b
(<$>) = fmap