JSON Parser

Main.hs

-- Inspired on the video from [Tscoding](https://youtu.be/N9RUqGYuGfw)

import Control.Applicative (Alternative, empty, many, (<|>))
import Data.Char (isDigit, isSpace)

data JsonValue
  = JsonNull
  | JsonBool Bool
  | JsonInteger Int
  | JsonFloat Float
  | JsonString String
  | JsonArray [JsonValue]
  | JsonObject [(String, JsonValue)]
  deriving (Show)

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

instance Functor Parser where
  fmap f (Parser a) = Parser $ \input -> do
    (input', x) <- a input
    return (input', f x)

instance Applicative Parser where
  pure a = Parser $ \input -> Just (input, a)
  (Parser a) <*> (Parser b) = Parser $ \input -> do
    (input', f) <- a input
    (input'', x) <- b input'
    return (input'', f x)

instance Alternative Parser where
  empty = Parser $ const Nothing
  (Parser a) <|> (Parser b) = Parser go
    where
      go input = a input <|> b input

charP :: Char -> Parser Char
charP c = Parser go
  where
    go :: String -> Maybe (String, Char)
    go [] = Nothing
    go (x : xs)
      | x == c = Just (xs, x)
      | otherwise = Nothing

stringP :: String -> Parser String
stringP = traverse charP

spanP :: (Char -> Bool) -> Parser String
spanP f = Parser go
  where
    go :: String -> Maybe (String, String)
    go (x : xs)
      | f x = case go xs of
        Nothing -> Just (xs, [x])
        Just (input, ys) -> Just (input, x : ys)
      | otherwise = Nothing
    go [] = Nothing

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

stringLiteral :: Parser String
stringLiteral = charP '"' *> spanP (/= '"') <* charP '"'

ws :: Parser ()
ws = () <$ spanP isSpace

comma :: Parser ()
comma = () <$ charP ','

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

jsonNull :: Parser JsonValue
jsonNull = JsonNull <$ stringP "null"

jsonBool :: Parser JsonValue
jsonBool = true <|> false
  where
    true = JsonBool True <$ stringP "true"
    false = JsonBool False <$ stringP "false"

jsonNumber :: Parser JsonValue
jsonNumber = jsonFloat <|> jsonInteger

jsonInteger :: Parser JsonValue
jsonInteger = JsonInteger . read <$> spanP isDigit

jsonFloat :: Parser JsonValue
jsonFloat = JsonFloat <$> floatP

floatP :: Parser Float
floatP = toFloat <$> spanP isDigit <*> (charP '.' *> spanP isDigit)
  where
    toFloat :: String -> String -> Float
    toFloat numerator denominator = read $ numerator ++ "." ++ denominator

jsonString :: Parser JsonValue
jsonString = JsonString <$> stringLiteral

jsonArray :: Parser JsonValue
jsonArray = JsonArray <$> (charP '[' *> elems <* charP ']')
  where
    elems :: Parser [JsonValue]
    elems = sepBy comma (many ws *> jsonValue <* many ws)

jsonObject :: Parser JsonValue
jsonObject = JsonObject <$> (charP '{' *> pairs <* charP '}')
  where
    pairs :: Parser [(String, JsonValue)]
    pairs = sepBy comma pair

    pair :: Parser (String, JsonValue)
    pair =
      (,)
        <$> (many ws *> stringLiteral <* many ws)
        <*> (charP ':' *> (many ws *> jsonValue <* many ws))

-- >>> runParser jsonValue "[123 , 123.3444, {}, {\"foo\":[null, false, 1.2, 123]} ]"
-- Just ("",JsonArray [JsonInteger 123,JsonFloat 123.3444,JsonObject [],JsonObject [("foo",JsonArray [JsonNull,JsonBool False,JsonFloat 1.2,JsonInteger 123])]])