Last active
December 29, 2020 20:20
-
-
Save lunalunaa/78d9500cd00b478a33ac040033d7168e to your computer and use it in GitHub Desktop.
a json parser written from scratch
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE LambdaCase #-} | |
| module MonoJSonParser where | |
| import Data.Char | |
| import Control.Monad | |
| import Control.Applicative | |
| import Data.Foldable | |
| import Data.Maybe | |
| -- The parser combinators | |
| newtype Parser a = Parser { parse :: String -> [(a, String)] } | |
| runParser :: Parser a -> String -> a | |
| runParser m s = | |
| case parse m s of | |
| [(res, [])] -> res | |
| [(_, _:_)] -> error "Parser did not consume entire stream." | |
| _ -> error "Parser error." | |
| -- takes the head of the input string | |
| item :: Parser Char | |
| item = Parser $ | |
| \case | |
| (x:xs) -> [(x, xs)] | |
| _ -> [] | |
| -- the parser that does nothing | |
| unit :: a -> Parser a | |
| unit a = Parser $ \s -> [(a, s)] | |
| -- the parser that always fails | |
| failure :: Parser a | |
| failure = Parser $ const [] | |
| -- implementing instances | |
| instance Functor Parser where | |
| fmap f (Parser p) = Parser $ \s -> [(f a, str) | (a, str) <- p s] | |
| instance Applicative Parser where | |
| pure = unit | |
| (Parser a) <*> (Parser b) = Parser $ \s -> [ (f e, str2) | (f, str1) <- a s, (e, str2) <- b str1] | |
| instance Monad Parser where | |
| (Parser a) >>= f = Parser $ \s -> [(c, str2) | (b, str1) <- a s, (c, str2) <- parse (f b) str1] | |
| instance Alternative Parser where | |
| empty = failure | |
| -- attempt to parse a, if failed then uncommit and proceed to parse b | |
| a <|> b = Parser $ \s -> | |
| case parse a s of | |
| [] -> parse b s | |
| res -> res | |
| -- supporting ambiguous input | |
| instance MonadPlus Parser where | |
| mplus a b = Parser $ \s -> parse a s ++ parse b s | |
| -- helper functions | |
| -- create a parser that consumes one char `ch`, succeed if `ch` satisfies the given condition | |
| satisfy :: (Char -> Bool) -> Parser Char | |
| satisfy cond = item >>= \c -> if cond c then pure c else failure | |
| -- create a parser that consumes one char `ch`, succeeds if `ch` is one of `chs` | |
| oneOf :: String -> Parser Char | |
| oneOf chs = satisfy (`elem` chs) | |
| -- create a parser that consumes one char `ch`, succeeds if `ch` is not any one of `chs` | |
| notAnyOf :: String -> Parser Char | |
| notAnyOf chs = satisfy (`notElem` chs) | |
| -- creare a parser that consumes one char, succeed if it is exactly `ch` | |
| char :: Char -> Parser Char | |
| char ch = satisfy (==ch) | |
| -- create a parser that consumes one string `str`, succeed if it is exactly `str` | |
| string :: String -> Parser String | |
| string [] = pure [] | |
| string (c:cs) = char c >> string cs >> return (c:cs) | |
| -- parse a digit | |
| digit :: Parser Char | |
| digit = satisfy isDigit | |
| -- parse a natural number | |
| natural :: Parser Integer | |
| natural = read <$> some digit | |
| -- parse an integer | |
| int :: Parser Int | |
| int = do | |
| s <- string "-" <|> return [] | |
| n <- some digit | |
| pure (read $ s ++ n) | |
| -- parse a double | |
| double :: Parser Double | |
| double = do | |
| s <- string "-" <|> return [] | |
| n <- some digit | |
| d <- (char '.' >> some digit) <|> return [] | |
| pure (read $ s ++ n ++ d) | |
| -- parse zero or more whitespaces | |
| spaces :: Parser String | |
| spaces = many $ oneOf " \n\r\t" | |
| -- create a parser that allows spaces following the matching string | |
| token :: Parser a -> Parser a | |
| token p = do | |
| a <- p | |
| _ <- spaces | |
| pure a | |
| -- reserved token | |
| reserved :: String -> Parser String | |
| reserved s = token $ string s | |
| -- parse string literals surrounded by " | |
| stringLit :: Parser String | |
| stringLit = string "\"" *> many (notAnyOf "\"") <* reserved "\"" | |
| -- parse strings like "a,b" and "a,b,c": one or more `p` seperated by `s` ending with one `p` | |
| sepBy1 :: Parser a -> Parser b -> Parser [a] | |
| p `sepBy1` s = do a <- p; rest [a] | |
| where rest as = (do _ <- s | |
| a' <- p | |
| rest $ as ++ [a']) | |
| <|> pure as | |
| -- allows parsing "a", "a,b", "a,b,c": one `p`, or many `p` seperated by `s` ending with one `p` | |
| sepBy :: Parser a -> Parser b -> Parser [a] | |
| p `sepBy` s = p `sepBy1` s <|> (do a <- p; pure [a]) | |
| -- the JSON datatype | |
| data MonoJSON = | |
| JNull | |
| | JBool Bool | |
| | JNum Rational | |
| | JString String | |
| | JArray [MonoJSON] | |
| | JObject (MonoJSONObject MonoJSON) | |
| deriving (Show, Read, Eq, Ord) | |
| newtype MonoJSONObject a = MonoJSONObject {fromJSONObject :: [(String, a)]} deriving (Show, Read, Eq, Ord) | |
| jnull :: Parser MonoJSON | |
| jnull = reserved "null" >> pure JNull | |
| jtrue :: Parser MonoJSON | |
| jtrue = reserved "true" >> pure (JBool True) | |
| jfalse :: Parser MonoJSON | |
| jfalse = reserved "false" >> pure (JBool False) | |
| jbool :: Parser MonoJSON | |
| jbool = jtrue <|> jfalse | |
| jnum :: Parser MonoJSON | |
| jnum = token $ JNum . toRational <$> double | |
| jstring :: Parser MonoJSON | |
| jstring = JString <$> stringLit | |
| jarray :: Parser MonoJSON | |
| jarray = JArray <$> (reserved "[" *> jsons <* reserved "]") | |
| where jsons = jsonval `sepBy` reserved "," <|> pure [] | |
| jobject :: Parser MonoJSON | |
| jobject = | |
| do | |
| ps <- reserved "{" *> pairs <* reserved "}" | |
| pure . JObject . MonoJSONObject $ ps | |
| where | |
| jkvpair = do | |
| str <- stringLit <* reserved ":" | |
| val <- jsonval | |
| pure (str,val) | |
| pairs = fromMaybe [] <$> optional (jkvpair `sepBy` reserved ",") | |
| jsonval :: Parser MonoJSON | |
| jsonval = asum [jnull, jtrue, jfalse, jbool, jnum, jstring, jobject, jarray] | |
| parseJSON :: String -> MonoJSON | |
| parseJSON = runParser jobject |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment