diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..2256053 --- /dev/null +++ b/Main.hs @@ -0,0 +1,116 @@ +module Main where + +import Data.Char +import Control.Applicative + +data JsonValue + = JsonNull + | JsonBool Bool + | JsonNumber Integer -- NOTE: no support for floats + | JsonString String + | JsonArray [JsonValue] + | JsonObject [(String, JsonValue)] + deriving (Show, Eq) + +-- NOTE: no proper error reporting +newtype Parser a = Parser + { runParser :: String -> Maybe (String, a) + } + +instance Functor Parser where + fmap f (Parser p) = + Parser $ \input -> do + (input', x) <- p input + Just (input', f x) + +instance Applicative Parser where + pure x = Parser $ \input -> Just (input, x) + (Parser p1) <*> (Parser p2) = + Parser $ \input -> do + (input', f) <- p1 input + (input'', a) <- p2 input' + Just (input'', f a) + +instance Alternative Parser where + empty = Parser $ \_ -> Nothing + (Parser p1) <|> (Parser p2) = + Parser $ \input -> p1 input <|> p2 input + +jsonNull :: Parser JsonValue +jsonNull = (\_ -> JsonNull) <$> stringP "null" + +charP :: Char -> Parser Char +charP x = Parser f + where + f (y:ys) + | y == x = Just (ys, x) + | otherwise = Nothing + f [] = Nothing + +stringP :: String -> Parser String +stringP = sequenceA . map charP + +jsonBool :: Parser JsonValue +jsonBool = f <$> (stringP "true" <|> stringP "false") + where f "true" = JsonBool True + f "false" = JsonBool False + -- This should never happen + f _ = undefined + +spanP :: (Char -> Bool) -> Parser String +spanP f = + Parser $ \input -> + let (token, rest) = span f input + in Just (rest, token) + +notNull :: Parser [a] -> Parser [a] +notNull (Parser p) = + Parser $ \input -> do + (input', xs) <- p input + if null xs + then Nothing + else Just (input', xs) + +jsonNumber :: Parser JsonValue +jsonNumber = f <$> notNull (spanP isDigit) + where f ds = JsonNumber $ read ds + +-- NOTE: no escape support +stringLiteral :: Parser String +stringLiteral = charP '"' *> spanP (/= '"') <* charP '"' + +jsonString :: Parser JsonValue +jsonString = JsonString <$> stringLiteral + +ws :: Parser String +ws = spanP isSpace + +sepBy :: Parser a -> Parser b -> Parser [b] +sepBy sep element = (:) <$> element <*> many (sep *> element) <|> pure [] + +jsonArray :: Parser JsonValue +jsonArray = JsonArray <$> (charP '[' *> ws *> + elements + <* ws <* charP ']') + where + elements = sepBy (ws *> charP ',' <* ws) jsonValue + +jsonObject :: Parser JsonValue +jsonObject = + JsonObject <$> (charP '{' *> ws *> sepBy (ws *> charP ',' <* ws) pair <* ws <* charP '}') + where + pair = + (\key _ value -> (key, value)) <$> stringLiteral <*> + (ws *> charP ':' <* ws) <*> + jsonValue + +jsonValue :: Parser JsonValue +jsonValue = jsonNull <|> jsonBool <|> jsonNumber <|> jsonString <|> jsonArray <|> jsonObject + +parseFile :: FilePath -> Parser a -> IO (Maybe a) +parseFile fileName parser = do + input <- readFile fileName + return (snd <$> runParser parser input) + +main :: IO () +main = undefined