123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279 |
- {-# LANGUAGE FlexibleInstances #-}
- {-# LANGUAGE ViewPatterns #-}
- module Json where
- import Control.Applicative
- import Data.Char
- import Numeric
- import System.Exit
- data Input = Input
- { inputLoc :: Int
- , inputStr :: String
- } deriving (Show, Eq)
- data JsonValue
- = JsonNull
- | JsonBool Bool
- | JsonNumber Double
- | JsonString String
- | JsonArray [JsonValue]
- | JsonObject [(String, JsonValue)]
- deriving (Show, Eq)
- data ParserError = ParserError Int String deriving (Show)
- newtype Parser a = Parser
- { runParser :: Input -> Either ParserError (Input, a)
- }
- instance Functor Parser where
- fmap f (Parser p) =
- Parser $ \input -> do
- (input', x) <- p input
- return (input', f x)
- instance Applicative Parser where
- pure x = Parser $ \input -> Right (input, x)
- (Parser p1) <*> (Parser p2) =
- Parser $ \input -> do
- (input', f) <- p1 input
- (input'', a) <- p2 input'
- return (input'', f a)
- instance Alternative (Either ParserError) where
- empty = Left $ ParserError 0 "empty"
- Left _ <|> e2 = e2
- e1 <|> _ = e1
- instance Alternative Parser where
- empty = Parser $ const empty
- (Parser p1) <|> (Parser p2) =
- Parser $ \input -> p1 input <|> p2 input
- -- | Pull the first character of the input if there is still input
- inputChar :: Input -> Maybe (Char, Input)
- inputChar (Input _ []) = Nothing
- inputChar (Input loc (x:xs)) = Just (x, Input (loc + 1) xs)
- -- | Parser for null json
- null :: Parser JsonValue
- null = JsonNull <$ parameterized_string "null"
- -- | Create a parser for a single specific character
- char :: Char -> Parser Char
- char x = Parser f
- where
- f input@(inputChar -> Just (y, ys))
- | y == x = Right (ys, x)
- | otherwise =
- Left $
- ParserError
- (inputLoc input)
- ("Expected '" ++ [x] ++ "', but found '" ++ [y] ++ "'")
- f input =
- Left $
- ParserError
- (inputLoc input)
- ("Expected '" ++ [x] ++ "', but reached end of string")
- -- | Create a parser for a specific string
- parameterized_string :: String -> Parser String
- parameterized_string str =
- Parser $ \input ->
- case runParser (traverse char str) input of
- Left _ ->
- Left $
- ParserError
- (inputLoc input)
- ("Expected \"" ++ str ++ "\", but found \"" ++ inputStr input ++ "\"")
- result -> result
- -- | Create a parser for boolean values
- bool :: Parser JsonValue
- bool = true <|> false
- where
- true = JsonBool True <$ parameterized_string "true"
- false = JsonBool False <$ parameterized_string "false"
- -- | Parser of a character that satisfies a predicate
- predicate_char :: String -> (Char -> Bool) -> Parser Char
- predicate_char desc f =
- Parser $ \input ->
- case input of
- (inputChar -> Just (y, ys))
- | f y -> Right (ys, y)
- | otherwise ->
- Left $
- ParserError
- (inputLoc input)
- ("Expected " ++ desc ++ ", but found '" ++ [y] ++ "'")
- _ ->
- Left $
- ParserError
- (inputLoc input)
- ("Expected " ++ desc ++ ", but reached end of string")
- -- | Parser of strings where all characters satifsfy a predicate
- predicate_string :: String -> (Char -> Bool) -> Parser String
- predicate_string desc = many . predicate_char desc
- {-
- See page 12 of
- http://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf
- -}
- -- | Parser for doubles
- double_literal :: Parser Double
- double_literal =
- double_from_parts
- <$> (minus <|> pure 1)
- <*> (read <$> digits)
- <*> ((read <$> (('0':) <$> ((:) <$> char '.' <*> digits))) <|> pure 0)
- <*> ((e *> ((*) <$> (plus <|> minus <|> pure 1) <*> (read <$> digits))) <|> pure 0)
- where
- digits = some $ predicate_char "digit" isDigit
- minus = (-1) <$ char '-'
- plus = 1 <$ char '+'
- e = char 'e' <|> char 'E'
- -- | Build a Double from its parts (sign, integral part, decimal part, exponent)
- double_from_parts :: Integer -- sign
- -> Integer -- integral part
- -> Double -- decimal part
- -> Integer -- exponent
- -> Double
- double_from_parts sign int dec expo =
- fromIntegral sign * (fromIntegral int + dec) * (10 ^^ expo)
- -- | Parser for json number values
- number :: Parser JsonValue
- number = JsonNumber <$> double_literal
- -- | Parser for hex encoded unicode characters in input
- escaped_unicode :: Parser Char
- escaped_unicode = chr . fst . head . readHex <$> sequenceA (replicate 4 (predicate_char "hex digit" isHexDigit))
- -- | Parser for escaped characters
- escaped_char :: Parser Char
- escaped_char = ('"' <$ parameterized_string "\\\"") <|>
- ('\\' <$ parameterized_string "\\\\") <|>
- ('/' <$ parameterized_string "\\/") <|>
- ('\b' <$ parameterized_string "\\b") <|>
- ('\f' <$ parameterized_string "\\f") <|>
- ('\n' <$ parameterized_string "\\n") <|>
- ('\r' <$ parameterized_string "\\r") <|>
- ('\t' <$ parameterized_string "\\t") <|>
- (parameterized_string "\\u" *> escaped_unicode)
- -- | Parser of a character that is not " or \\
- non_special_char :: Parser Char
- non_special_char = predicate_char "non-special character" ((&&) <$> (/= '"') <*> (/= '\\'))
- -- | Parser of a string that is between double quotes (not considering any double quots that are scaped)
- string_literal :: Parser String
- string_literal = char '"' *> many (non_special_char <|> escaped_char) <* char '"'
- -- | Parser of literal json string values
- string :: Parser JsonValue
- string = JsonString <$> string_literal
- -- | Parser for white spaces
- ws :: Parser String
- ws = predicate_string "whitespace character" isSpace
- -- | Creates a parser for a string of type "element1 sep1 element2 sep2 element3"
- -- from a parser for separators (sep1, sep2) and and a parser form elements (element1, element2, element3).
- separated_by :: Parser sep -> Parser el -> Parser [el]
- separated_by sep element = (:) <$> element <*> many (sep *> element) <|> pure []
- -- | Parser for json arrays
- array :: Parser JsonValue
- array = JsonArray <$> (char '[' *> ws *> (separated_by (ws *> char ',' <* ws) value) <* ws <* char ']')
- -- | Parser for json objects
- object :: Parser JsonValue
- object =
- JsonObject <$>
- (char '{' *> ws *> separated_by (ws *> char ',' <* ws) pair <* ws <* char '}')
- where
- pair = liftA2 (,) (string_literal <* ws <* char ':' <* ws) value
- -- | Parser for any json
- value :: Parser JsonValue
- value =
- Json.null <|> bool <|> number <|> string <|> array <|>
- object
- -- | Apply parser to content of file
- parse_file :: FilePath -> Parser a -> IO (Either ParserError a)
- parse_file fileName parser = do
- input <- readFile fileName
- case runParser parser $ Input 0 input of
- Left e -> return $ Left e
- Right (_, x) -> return $ Right x
- {-------------}
- test :: IO ()
- test = do
- putStrLn "[INFO] JSON:"
- putStrLn testJsonText
- case runParser value $ Input 0 testJsonText of
- Right (input, actualJsonAst) -> do
- putStrLn ("[INFO] Parsed as: " ++ show actualJsonAst)
- putStrLn
- ("[INFO] Remaining input (codes): " ++ show (map ord $ inputStr input))
- if actualJsonAst == expectedJsonAst
- then putStrLn "[SUCCESS] Parser produced expected result."
- else do
- putStrLn
- ("[ERROR] Parser produced unexpected result. Expected result was: " ++
- show expectedJsonAst)
- exitFailure
- Left (ParserError loc msg) -> do
- putStrLn $
- "[ERROR] Parser failed at character " ++ show loc ++ ": " ++ msg
- exitFailure
- where
- testJsonText =
- unlines
- [ "{"
- , " \"hello\": [false, true, null, 42, \"foo\\n\\u1234\\\"\", [1, -2, 3.1415, 4e-6, 5E6, 0.123e+1]],"
- , " \"world\": null"
- , "}"
- ]
- expectedJsonAst =
- JsonObject
- [ ( "hello"
- , JsonArray
- [ JsonBool False
- , JsonBool True
- , JsonNull
- , JsonNumber 42
- , JsonString "foo\n\4660\""
- , JsonArray
- [ JsonNumber 1.0
- , JsonNumber (-2.0)
- , JsonNumber 3.1415
- , JsonNumber 4e-6
- , JsonNumber 5000000
- , JsonNumber 1.23
- ]
- ])
- , ("world", JsonNull)
- ]
- -- >>> test
- -- [INFO] JSON:
- -- {
- -- "hello": [false, true, null, 42, "foo\n\u1234\"", [1, -2, 3.1415, 4e-6, 5E6, 0.123e+1]],
- -- "world": null
- -- }
- -- <BLANKLINE>
- -- [INFO] Parsed as: JsonObject [("hello",JsonArray [JsonBool False,JsonBool True,JsonNull,JsonNumber 42.0,JsonString "foo\n\4660\"",JsonArray [JsonNumber 1.0,JsonNumber (-2.0),JsonNumber 3.1415,JsonNumber 4.0e-6,JsonNumber 5000000.0,JsonNumber 1.23]]),("world",JsonNull)]
- -- [INFO] Remaining input (codes): [10]
- -- [SUCCESS] Parser produced expected result.
- --
|