Look ma! I wrote a JSON parser

json.hs

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

lisp.hs

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

parser.hs

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)

test.json

{
  "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
  }
}

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.

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!