191 lines
5.8 KiB
Haskell
191 lines
5.8 KiB
Haskell
{-# LANGUAGE DeriveGeneric, TupleSections #-}
|
|
module JSONParser where
|
|
|
|
import Control.Applicative (Alternative(..), optional)
|
|
import Control.Monad (replicateM)
|
|
import Data.Char (isDigit, isHexDigit, isSpace, isControl, isAscii, chr, ord, digitToInt)
|
|
import Data.Functor (($>))
|
|
import Data.List (intercalate)
|
|
import GHC.Generics (Generic)
|
|
import Numeric (showHex)
|
|
|
|
newtype Parser i o = Parser { runParser :: i -> Maybe (i, o) }
|
|
|
|
instance Functor (Parser i) where
|
|
fmap f p = Parser $ fmap (fmap f) . runParser p
|
|
|
|
instance Applicative (Parser i) where
|
|
pure x = Parser $ pure . (, x)
|
|
pf <*> po = Parser $ \input -> case runParser pf input of
|
|
Nothing -> Nothing
|
|
Just (rest, f) -> fmap f <$> runParser po rest
|
|
|
|
instance Alternative (Parser i) where
|
|
empty = Parser $ const Nothing
|
|
p1 <|> p2 = Parser $ \input -> runParser p1 input <|> runParser p2 input
|
|
|
|
satisfy :: (a -> Bool) -> Parser [a] a
|
|
satisfy p = Parser $ \i -> case i of
|
|
(x:xs) | p x -> Just (xs, x)
|
|
_ -> Nothing
|
|
|
|
char :: Char -> Parser String Char
|
|
char c = satisfy (== c)
|
|
|
|
digit :: Parser String Int
|
|
digit = digitToInt <$> satisfy isDigit
|
|
|
|
hexDigit :: Parser String Int
|
|
hexDigit = digitToInt <$> satisfy isHexDigit
|
|
|
|
string :: String -> Parser String String
|
|
string "" = pure ""
|
|
string (c:cs) = (:) <$> char c <*> string cs
|
|
|
|
space :: Parser String Char
|
|
space = satisfy isSpace
|
|
|
|
digits :: Parser String [Int]
|
|
digits = some digit
|
|
|
|
spaces :: Parser String String
|
|
spaces = many space
|
|
|
|
surroundedBy :: Parser String a -> Parser String b -> Parser String a
|
|
surroundedBy p1 p2 = p2 *> p1 <* p2
|
|
|
|
separatedBy :: Parser i v -> Parser i s -> Parser i [v]
|
|
separatedBy v s = (:) <$> v <*> many (s *> v) <|> pure []
|
|
|
|
data JValue = JNull
|
|
| JBool Bool
|
|
| JString String
|
|
| JNumber { int :: Integer, frac :: [Int], exponent :: Integer}
|
|
| JArray [JValue]
|
|
| JObject [(String, JValue)]
|
|
deriving (Eq, Generic)
|
|
|
|
instance Show JValue where
|
|
show value = case value of
|
|
JNull -> "null"
|
|
JBool True -> "true"
|
|
JBool False -> "false"
|
|
JString s -> showJSONString s
|
|
JNumber s [] 0 -> show s
|
|
JNumber s f 0 -> show s ++ "." ++ concatMap show f
|
|
JNumber s [] e -> show s ++ "e" ++ show e
|
|
JNumber s f e -> show s ++ "." ++ concatMap show f ++ "e" ++ show e
|
|
JArray a -> "[" ++ intercalate ", " (map show a) ++ "]"
|
|
JObject o -> "{" ++ intercalate ", " (map (\(k, v) -> showJSONString k ++ ": " ++ show v) o) ++ "}"
|
|
where
|
|
showJSONString s = "\"" ++ concatMap showJSONChar s ++ "\""
|
|
|
|
showJSONChar :: Char -> String
|
|
showJSONChar c = case c of
|
|
'\'' -> "'"
|
|
'\"' -> "\\\""
|
|
'\\' -> "\\\\"
|
|
'/' -> "\\/"
|
|
'\b' -> "\\b"
|
|
'\f' -> "\\f"
|
|
'\n' -> "\\n"
|
|
'\r' -> "\\r"
|
|
'\t' -> "\\t"
|
|
_ | isAscii c -> [c]
|
|
_ -> "\\u" ++ showJSONNonASCIIChar c
|
|
|
|
showJSONNonASCIIChar c =
|
|
let a = "0000" ++ showHex (ord c) "" in drop (length a - 4) a
|
|
|
|
jNull :: Parser String JValue
|
|
jNull = string "null" $> JNull
|
|
|
|
jBool :: Parser String JValue
|
|
jBool = string "true" $> JBool True
|
|
<|> string "false" $> JBool False
|
|
|
|
digitsToNumber :: Int -> Integer -> [Int] -> Integer
|
|
digitsToNumber base = foldl (\num d -> num * fromIntegral base + fromIntegral d)
|
|
|
|
jString :: Parser String JValue
|
|
jString = JString <$> (char '"' *> many jsonChar <* char '"')
|
|
where
|
|
jsonChar = satisfy (\c -> not (c == '\"' || c == '\\' || isControl c))
|
|
<|> string "\\\"" $> '"'
|
|
<|> string "\\\\" $> '\\'
|
|
<|> string "\\/" $> '/'
|
|
<|> string "\\b" $> '\b'
|
|
<|> string "\\f" $> '\f'
|
|
<|> string "\\n" $> '\n'
|
|
<|> string "\\r" $> '\r'
|
|
<|> string "\\t" $> '\t'
|
|
<|> chr . fromIntegral . digitsToNumber 16 0 <$> (string "\\u" *> replicateM 4 hexDigit)
|
|
|
|
digit19 :: Parser String Int
|
|
digit19 = digitToInt <$> satisfy (\x -> isDigit x && x /= '0')
|
|
|
|
jUInt :: Parser String Integer
|
|
jUInt = (\d ds -> digitsToNumber 10 0 (d:ds)) <$> digit19 <*> digits
|
|
<|> fromIntegral <$> digit
|
|
|
|
data Sign = Positive | Negative
|
|
|
|
jInt' :: Parser String (Sign, Integer)
|
|
jInt' = mkInt <$> optional (char '-') <*> jUInt
|
|
where
|
|
mkInt (Just '-') i = (Negative, i)
|
|
mkInt _ i = (Positive, i)
|
|
|
|
applySign :: (Sign, Integer) -> Integer
|
|
applySign (Negative, i) = negate i
|
|
applySign (Positive, i) = i
|
|
|
|
jFrac :: Parser String [Int]
|
|
jFrac = char '.' *> digits
|
|
|
|
jExp :: Parser String Integer
|
|
jExp = (char 'e' <|> char 'E') *> (mkExp <$> optional (char '+' <|> char '-') <*> jUInt)
|
|
where
|
|
mkExp (Just '-') i = negate i
|
|
mkExp _ i = i
|
|
|
|
jInt :: Parser String JValue
|
|
jInt = JNumber <$> (applySign <$> jInt') <*> pure [] <*> pure 0
|
|
|
|
jIntExp :: Parser String JValue
|
|
jIntExp = JNumber <$> (applySign <$> jInt') <*> pure [] <*> jExp
|
|
|
|
jIntFrac :: Parser String JValue
|
|
jIntFrac =
|
|
(\(sign, i) f -> JNumber (applySign (sign, i)) f 0)
|
|
<$> jInt' <*> jFrac
|
|
|
|
jIntFracExp :: Parser String JValue
|
|
jIntFracExp = (\ ~(JNumber i f _) e -> JNumber i f e) <$> jIntFrac <*> jExp
|
|
|
|
jNumber :: Parser String JValue
|
|
jNumber = jIntFracExp <|> jIntExp <|> jIntFrac <|> jInt
|
|
|
|
jArray :: Parser String JValue
|
|
jArray = JArray <$> (char '[' *> (jValue `separatedBy` char ',' `surroundedBy` spaces) <* char ']')
|
|
|
|
jObject :: Parser String JValue
|
|
jObject = JObject <$> (char '{' *> pair `separatedBy` char ',' `surroundedBy` spaces <* char '}')
|
|
where
|
|
pair = (\ ~(JString s) j -> (s, j)) <$> (jString `surroundedBy` spaces) <* char ':' <*> jValue
|
|
|
|
jValue :: Parser String JValue
|
|
jValue = jValue' `surroundedBy` spaces
|
|
where
|
|
jValue' = jNull
|
|
<|> jBool
|
|
<|> jString
|
|
<|> jNumber
|
|
<|> jArray
|
|
<|> jObject
|
|
|
|
parseJSON :: String -> Maybe JValue
|
|
parseJSON s = case runParser jValue s of
|
|
Just ("", j) -> Just j
|
|
_ -> Nothing
|