stau.space
My omnium-gatherom of scripts and source code.
1module Main where
2
3import Control.Applicative
4import Data.Char
5
6{- Abstract Syntax Tree -}
7data JsonValue = JsonNull
8 | JsonBool Bool
9 | JsonNumber Integer -- no support for floats
10 | JsonString String -- no support for escaping
11 | JsonArray [JsonValue]
12 | JsonObject [(String, JsonValue)]
13 deriving (Show, Eq)
14
15-- NOTE: no proper error reporting
16newtype Parser a = Parser { runParser :: String -> Maybe (String, a) }
17
18instance Functor Parser where
19 fmap f (Parser p) = Parser $ \input -> do
20 (input', x) <- p input
21 Just (input', f x)
22
23instance Applicative Parser where
24 pure :: a -> Parser a
25 pure x = Parser . (Just .) . flip (,)
26
27 (<*>) :: Parser (a -> b) -> Parser a -> Parser b
28 (Parser p1) <*> (Parser p2) = Parser $ \input -> do
29 (input', f) <- p1 input
30 (input'', a) <- p2 input'
31 Just (input'', f a)
32
33instance Alternative Parser where
34 empty :: Parser a
35 empty = Parser $ const Nothing
36 (<|>) :: Parser a -> Parser a -> Parser a
37 (Parser p1) <|> (Parser p2) = Parser $ \input -> p1 input <|> p2 input
38
39spanP :: (Char -> Bool) -> Parser String
40spanP f = Parser $ \input -> let (token, rest) = span f input in Just (rest, token)
41
42notNull :: Parser [a] -> Parser [a]
43notNull (Parser p) = Parser $ \input -> do
44 (input', xs) <- p input
45 if null xs then Nothing else Just (input', xs)
46
47charP :: Char -> Parser Char
48charP x = Parser f
49 where
50 f (y:ys) | y == x = Just (ys, x)
51 | otherwise = Nothing
52 f [] = Nothing
53
54stringP :: String -> Parser String
55stringP = sequenceA . map charP
56
57ws :: Parser String
58ws = spanP isSpace
59
60sepBy :: Parser a -> Parser b -> Parser [b]
61sepBy sep element = (:) <$> element <*> (many (sep *> element)) <|> pure []
62
63jsonNull :: Parser JsonValue
64jsonNull = const JsonNull <$> stringP "null"
65
66jsonBool :: Parser JsonValue
67jsonBool = f <$> (stringP "true" <|> stringP "false")
68 where
69 f "true" = JsonBool True
70 f "false" = JsonBool False
71 f _ = undefined
72
73jsonNumber :: Parser JsonValue
74jsonNumber = f <$> notNull (spanP isDigit)
75 where f ds = JsonNumber $ read ds
76
77stringLiteral :: Parser String
78stringLiteral = charP '"' *> spanP (/= '"') <* charP '"'
79
80jsonString :: Parser JsonValue
81jsonString = JsonString <$> stringLiteral
82
83jsonArray :: Parser JsonValue
84jsonArray = JsonArray <$> (charP '[' *> ws *> elements <* ws <* charP ']')
85 where elements = sepBy (ws *> charP ',' <* ws) jsonValue
86
87jsonObject :: Parser JsonValue
88jsonObject = JsonObject <$> (charP '{' *> ws *> sepBy (ws *> charP ',' <* ws) pair <* ws <* charP '}')
89 where pair = (\key _ value -> (key, value)) <$> stringLiteral <*> (ws *> charP ':' <* ws) <*> jsonValue
90
91jsonValue :: Parser JsonValue
92jsonValue = jsonNull <|> jsonBool <|> jsonNumber <|> jsonString <|> jsonArray <|> jsonObject
93
94parseFile :: FilePath -> Parser a -> IO (Maybe a)
95parseFile filename parser = do
96 input <- readFile filename
97 return (snd <$> runParser parser input)