Skip to content

Instantly share code, notes, and snippets.

@jarcane
Last active September 27, 2022 21:34
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save jarcane/025f5475418858bba8276f1dfcf215be to your computer and use it in GitHub Desktop.
Look ma! I wrote a JSON parser
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
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
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)
{
"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
}
}
@jarcane
Copy link
Author

jarcane commented Feb 21, 2019

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.

@jarcane
Copy link
Author

jarcane commented Feb 21, 2019

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.

@jarcane
Copy link
Author

jarcane commented Feb 22, 2019

The Lisp parser is now fixed. Needed some instead of many to make sure symbols have at least one character.

@jarcane
Copy link
Author

jarcane commented Feb 24, 2019

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