JSON parser from scratch

JSONParser.hs

module JSONParser
  ( JSONValue
  , Parser(..)
  , parseExact
  , parseWhile
  , separateBy
  , jsonNull
  , jsonBool
  , jsonNumber
  , jsonString
  , jsonArray
  , jsonObject
  , jsonValue
  )
where

import           Control.Applicative            ( Alternative(..) )
import           Control.Monad                  ( Monad(..) )
import           Data.Tuple                     ( swap )
import           Data.Char                      ( isDigit
                                                , isSpace
                                                )
import           Text.Read                      ( readMaybe )

data JSONValue =
    JSONNull |
    JSONBool Bool |
    JSONNumber Integer |
    JSONString String |
    JSONArray [JSONValue] |
    JSONObject [(String, JSONValue)]
    deriving (Show, Eq)

newtype Parser a = Parser { runParser :: String -> Maybe (String, a) }

instance Functor Parser where
  fmap f p = Parser $ \s -> do
    (s', a) <- runParser p s
    return (s', f a)

instance Applicative Parser where
  pure a = Parser $ \s -> Just (s, a)
  l <*> r = Parser $ \s -> do
    (s' , f) <- runParser l s
    (s'', a) <- runParser r s'
    return (s'', f a)

instance Monad Parser where
  l >>= r = Parser $ \s -> do
    (s' , a) <- runParser l s
    (s'', a) <- runParser (r a) s'
    return (s'', a)

instance Alternative Parser where
  empty = Parser $ const Nothing
  l <|> r = Parser $ \s -> runParser l s <|> runParser r s

parseExact :: String -> Parser String
parseExact x = Parser $ \s -> do
  let (y, s') = splitAt (length x) s
  if x == y then Just (s', y) else Nothing

parseWhile :: (Char -> Bool) -> Parser String
parseWhile f = Parser $ Just . swap . span f

separateBy :: Parser a -> Parser b -> Parser [b]
separateBy sep element = (:) <$> element <*> many (sep *> element) <|> pure []

check :: Maybe a -> Parser a
check a = Parser $ \s -> do
  b <- a
  return (s, b)

jsonNull :: Parser JSONValue
jsonNull = do
  parseExact "null"
  return JSONNull

jsonBool :: Parser JSONValue
jsonBool = do
  x <- parseExact "true" <|> parseExact "false"
  return $ JSONBool (x == "true")

jsonNumber :: Parser JSONValue
jsonNumber = do
  x  <- parseWhile isDigit
  x' <- check (readMaybe x)
  return $ JSONNumber x'

jsonString :: Parser JSONValue
jsonString = do
  parseExact "\""
  x <- parseWhile (/= '"')
  parseExact "\""
  return $ JSONString x

jsonArray :: Parser JSONValue
jsonArray = do
  openBracket
  whitespace
  values <- separateBy (whitespace *> comma <* whitespace) jsonValue
  whitespace
  closeBracket
  return $ JSONArray values
 where
  openBracket  = parseExact "["
  closeBracket = parseExact "]"
  whitespace   = parseWhile isSpace
  comma        = parseExact ","

jsonObject :: Parser JSONValue
jsonObject = do
  openParenthesis
  whitespace
  entries <- separateBy (whitespace *> comma <* whitespace) entry
  whitespace
  closeParenthesis
  return $ JSONObject entries
 where
  openParenthesis  = parseExact "{"
  closeParenthesis = parseExact "}"
  whitespace       = parseWhile isSpace
  comma            = parseExact ","
  entry            = do
    key <- parseKey
    whitespace
    parseExact ":"
    whitespace
    value <- jsonValue
    return (key, value)
   where
    whitespace = parseWhile isSpace
    parseKey   = do
      parseExact "\""
      key <- parseWhile (/= '"')
      parseExact "\""
      return key

jsonValue :: Parser JSONValue
jsonValue =
  jsonNull
    <|> jsonBool
    <|> jsonNumber
    <|> jsonString
    <|> jsonArray
    <|> jsonObject

Main.hs

module Main where

import           System.Environment
import           System.Exit
import           Lib

main :: IO ()
main = do
    args <- getArgs
    cli args

cli :: [String] -> IO ()
cli []            = help
cli ["--help"   ] = help
cli ["-h"       ] = help
cli ["--version"] = version
cli ["-v"       ] = version
cli (s : _      ) = case runParser jsonValue s of
    Just (_, json) -> print json >> exitSuccess
    Nothing        -> putStrLn "Invalid input data" >> exitFailure

help = putStrLn "Usage: json-parser [-vh] [jsonstring...]" >> exitSuccess
version = putStrLn "json-parser 0.1.0.0" >> exitSuccess