Last active
September 27, 2022 21:34
Star
You must be signed in to star a gist
Look ma! I wrote a JSON parser
This file contains 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
module JSON where | |
import Control.Applicative | |
import Data.Char | |
import Data.List | |
import System.IO | |
import Parser | |
data JsonVal | |
= JsonObject [(String, JsonVal)] | |
| JsonArray [JsonVal] | |
| JsonString String | |
| JsonFloat Float | |
| JsonBool Bool | |
| JsonNull | |
deriving (Eq) | |
instance Show JsonVal where | |
show jv = "JsonVal <" ++ showVal jv ++ ">" | |
where | |
showVal JsonNull = "null" | |
showVal (JsonBool x) = if x then "true" else "false" | |
showVal (JsonFloat x) = show x | |
showVal (JsonString s) = "\"" ++ s ++ "\"" | |
showVal (JsonArray xs) = "[" ++ ( intercalate ", " $ map showVal xs ) ++ "]" | |
showVal (JsonObject xs) = "{" ++ ( intercalate ", " $ map showPair xs) ++ "}" | |
showPair (key, val) = "\"" ++ key ++ "\": " ++ showVal val | |
stringLit :: Parser String | |
stringLit = do | |
char '"' | |
x <- many $ sat (not . (== '"')) | |
char '"' | |
return x | |
jsonString :: Parser JsonVal | |
jsonString = JsonString <$> stringLit | |
jsonBool :: Parser JsonVal | |
jsonBool = do | |
x <- symbol "true" | |
return (JsonBool True) | |
<|> do | |
x <- symbol "false" | |
return (JsonBool False) | |
jsonNull :: Parser JsonVal | |
jsonNull = do | |
symbol "null" | |
return JsonNull | |
ufloat :: Parser Float | |
ufloat = do | |
whole <- some digit | |
char '.' | |
decimal <- some digit | |
return (read $ whole ++ '.' : decimal) | |
float :: Parser Float | |
float = do | |
char '-' | |
n <- ufloat | |
return (-n) | |
<|> ufloat | |
efloat :: Parser Float | |
efloat = do | |
frac <- float | |
char 'e' <|> char 'E' | |
exp <- some digit | |
return (read $ show frac ++ "e" ++ exp) | |
jsonFloat :: Parser JsonVal | |
jsonFloat = do | |
n <- efloat <|> float | |
return (JsonFloat n) | |
<|> do | |
n <- integer | |
return (JsonFloat $ fromIntegral n) | |
jsonLits :: Parser JsonVal | |
jsonLits = jsonNull <|> jsonBool <|> jsonFloat <|> jsonString | |
jsonArray :: Parser JsonVal | |
jsonArray = do | |
symbol "[" | |
x <- jsonVal | |
xs <- many (do { symbol ","; jsonVal }) | |
symbol "]" | |
return (JsonArray (x:xs)) | |
<|> do | |
symbol "[" | |
symbol "]" | |
return (JsonArray []) | |
jsonPair :: Parser (String, JsonVal) | |
jsonPair = do | |
key <- stringLit | |
symbol ":" | |
val <- jsonVal | |
return (key, val) | |
jsonObject :: Parser JsonVal | |
jsonObject = do | |
symbol "{" | |
p <- jsonPair | |
ps <- many (do { symbol ","; jsonPair }) | |
symbol "}" | |
return (JsonObject (p:ps)) | |
<|> do | |
symbol "{" | |
symbol "}" | |
return (JsonObject []) | |
jsonVal :: Parser JsonVal | |
jsonVal = jsonLits <|> jsonArray <|> jsonObject | |
testVal :: JsonVal | |
testVal = JsonObject [ | |
("string", JsonString "string"), | |
("int", JsonFloat 45.0), | |
("nint", JsonFloat (-2.0)), | |
("float", JsonFloat 41.4), | |
("nfloat", JsonFloat (-3.2)), | |
("efloat", JsonFloat 9.2e11), | |
("tbool", JsonBool True), | |
("fbool", JsonBool False), | |
("null", JsonNull), | |
("array", JsonArray [ | |
JsonFloat 1.0, | |
JsonFloat 2.0, | |
JsonFloat 3.0, | |
JsonFloat 4.0 | |
]), | |
("object", JsonObject [ | |
("a", JsonFloat 1), | |
("b", JsonFloat 2) | |
]) | |
] | |
test :: IO () | |
test = do | |
handle <- openFile "test.json" ReadMode | |
contents <- hGetContents handle | |
let (parsed, _):_ = parse jsonVal contents | |
putStrLn $ show (parsed == testVal) | |
putStrLn $ show parsed |
This file contains 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
module Lisp where | |
import Control.Applicative | |
import Data.Char | |
import Parser | |
import JSON (stringLit) | |
data LispExpr | |
= LList [LispExpr] | |
| LSym String | |
| LString String | |
| LInt Int | |
| LBool Bool | |
deriving (Show) | |
llist :: Parser LispExpr | |
llist = do | |
symbol "(" | |
xs <- many lispExpr | |
symbol ")" | |
return (LList xs) | |
lsym :: Parser LispExpr | |
lsym = do | |
space | |
xs <- some alphanum | |
space | |
return (LSym xs) | |
lstring :: Parser LispExpr | |
lstring = LString <$> stringLit | |
lint :: Parser LispExpr | |
lint = LInt <$> integer | |
lbool :: Parser LispExpr | |
lbool = do | |
symbol "#t" | |
return (LBool True) | |
<|> do | |
symbol "#f" | |
return (LBool False) | |
lispExpr :: Parser LispExpr | |
lispExpr = lint <|> lstring <|> lbool <|> lsym <|> llist |
This file contains 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
module Parser where | |
{-- parser library code from _Programming in Haskell_, Graham Hutton, 2016 --} | |
import Control.Applicative | |
import Data.Char | |
newtype Parser a = P (String -> [(a, String)]) | |
instance Functor Parser where | |
-- fmap :: (a -> b) -> Parser a -> Parser b | |
fmap g p = P (\inp -> case parse p inp of | |
[] -> [] | |
[(v,out)] -> [(g v, out)]) | |
instance Applicative Parser where | |
-- pure :: a -> Parser a | |
pure v = P (\inp -> [(v, inp)]) | |
-- <*> :: Parser (a -> b) -> Parser a -> Parser b | |
pg <*> px = P (\inp -> case parse pg inp of | |
[] -> [] | |
[(g,out)] -> parse (fmap g px) out) | |
instance Monad Parser where | |
-- (>>=) :: Parser a -> (a -> Parser b) -> Parser b | |
p >>= f = P (\inp -> case parse p inp of | |
[] -> [] | |
[(v, out)] -> parse (f v) out) | |
instance Alternative Parser where | |
-- empty :: Parser a | |
empty = P (\_ -> []) | |
-- (<|>) :: Parser a -> Parser a -> Parser a | |
p <|> q = P (\inp -> case parse p inp of | |
[] -> parse q inp | |
[(v,out)] -> [(v,out)]) | |
parse :: Parser a -> String -> [(a, String)] | |
parse (P p) inp = p inp | |
item :: Parser Char | |
item = P (\inp -> case inp of | |
[] -> [] | |
(x:xs) -> [(x,xs)]) | |
sat :: (Char -> Bool) -> Parser Char | |
sat p = do | |
x <- item | |
if p x then return x else empty | |
digit :: Parser Char | |
digit = sat isDigit | |
lower :: Parser Char | |
lower = sat isLower | |
upper :: Parser Char | |
upper = sat isUpper | |
letter :: Parser Char | |
letter = sat isAlpha | |
alphanum :: Parser Char | |
alphanum = sat isAlphaNum | |
char :: Char -> Parser Char | |
char x = sat (== x) | |
string :: String -> Parser String | |
string [] = return [] | |
string (x:xs) = do | |
char x | |
string xs | |
return (x:xs) | |
ident :: Parser String | |
ident = do | |
x <- lower | |
xs <- many alphanum | |
return (x:xs) | |
nat :: Parser Int | |
nat = do | |
xs <- some digit | |
return (read xs) | |
space :: Parser () | |
space = do | |
many (sat isSpace) | |
return () | |
int :: Parser Int | |
int = | |
do | |
char '-' | |
n <- nat | |
return (-n) | |
<|> nat | |
token :: Parser a -> Parser a | |
token p = do | |
space | |
v <- p | |
space | |
return v | |
identifier :: Parser String | |
identifier = token ident | |
natural :: Parser Int | |
natural = token nat | |
integer :: Parser Int | |
integer = token int | |
symbol :: String -> Parser String | |
symbol xs = token (string xs) |
This file contains 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
{ | |
"string": "string", | |
"int": 45, | |
"nint": -2, | |
"float": 41.4, | |
"nfloat": -3.2, | |
"efloat": 9.2e11, | |
"tbool": true, | |
"fbool": false, | |
"null": null, | |
"array": [ | |
1, | |
2, | |
3, | |
4 | |
], | |
"object": { | |
"a": 1, | |
"b": 2 | |
} | |
} |
Also included an attempt at a parser for a simple Lisp dialect, but it seems to fail. :( The list parser gets trapped in an infinite loop until stack overflow.
The Lisp parser is now fixed. Needed some
instead of many
to make sure symbols have at least one character.
The JSON parser is now fully to spec as per json.org, and there's even a test included!
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
to run this, do
parse jsonVal "some json string here"
.Obv. it's a toy library, there's some things missing from the spec like
NaN
and exponential floats, but I was impressed by how easy it was to put together this far.