haskell json parser written in haskell

json-parser.hs

-- Json parser written in haskell
-- Credit: https://www.youtube.com/watch?v=N9RUqGYuGfw

{-# Language OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Parser (
    JValue(..)
    ,parseJson
    ,ParseResult
    ,Parse
    ,Error
) where

-- import Data.Text (Text)
-- import qualified Data.Text as Text
import Text.Printf
import Data.Char
import Control.Applicative

data JValue = JBool Bool | JNumber Int | JString String | JArray [JValue] | JObject [(String, JValue)] | JNull deriving Show
type Error = String
type Parse a = (String, a)
type ParseResult a = Either Error a

newtype Parser a = Parser{
    runParser :: String -> ParseResult (Parse a)
}

instance Functor Parser where
    fmap f (Parser rp) = 
        Parser $ \input -> do
            (input', v) <- rp input
            Right (input', f v)

instance Applicative Parser where
    pure x = Parser (\input -> Right (input, x))
    (Parser rp1) <*> (Parser rp2) =
        Parser $ \input -> do
            (input', f) <- rp1 input
            (input'', v) <- rp2 input'
            Right (input'', f v)

instance Alternative Parser where
    empty = Parser $ \input -> Left $ "Empty Parser"
    (Parser rp1) <|> (Parser rp2) =
        Parser $ \input -> case rp1 input of
            Left err           -> rp2 input
            Right (input', v)  -> Right (input', v)

parseJson :: String -> ParseResult (Parse JValue)
parseJson input =  runParser jsonValue input

charP :: Char -> Parser Char
charP ch = Parser f where
    f(c:cs)
     | c == ch  = Right $ (cs, ch)
     | otherwise = Left $  printf "Unexpected character '%c', expected '%c'" c ch
    f []  = Left $ "Empty input"

ws :: Parser String
ws = spanP isSpace

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

spanP :: (Char -> Bool) -> Parser String
spanP f = Parser fn where
    fn input =
      let (token, rest) = span f input
      in Right (rest, token)

notNull :: Parser [a] -> Parser[a]
notNull (Parser rp) = Parser $ \input -> do
    (input', rest) <- rp input
    if null rest then
        Left "Null value, when not null expected"
    else 
        Right (input', rest)

stringP :: String -> Parser String
stringP str = sequenceA p where
        p = (map charP str)

jsonBool :: Parser JValue
jsonBool = f <$> (stringP "true" <|> stringP "false") where
    f "true" = JBool True
    f "false" = JBool False
    f _ = undefined

jsonNull :: Parser JValue
jsonNull = (\_ -> JNull) <$> stringP "null"

jsonNumber :: Parser JValue
jsonNumber = (\num -> JNumber $ read num) <$> notNull (spanP isDigit)

jsonArray :: Parser JValue
jsonArray = JArray <$> ( charP '[' *> ws *> elements <* ws <* charP ']' ) where
    elements = sepBy (ws *> charP ',' <* ws) jsonValue

jsonObject :: Parser JValue
jsonObject = JObject <$> (charP '{' *> ws *> sepBy (ws *> charP ',' <* ws) pair <* ws <* charP '}') where
    pair = 
        (\key _ value -> (key, value)) <$> stringLiteral <*> 
        (ws *> charP ':' <* ws) <*>
        jsonValue


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

stringLiteral :: Parser String
stringLiteral = charP '"' *> (spanP $ \ch -> ch=='"') <* charP '"' 

jsonString :: Parser JValue
jsonString = JString <$> stringLiteral