json parser

json.hs

import Control.Applicative((<|>))
import Data.Char
  ( isAscii
  , isDigit
  )

import Data.Map
import Text.ParserCombinators.ReadP

data JsonValue =
    JsonNumber Double
  | JsonString String
  | JsonBool Bool
  | JsonNull
  | JsonArray [JsonValue]
  | JsonObject (Map String JsonValue)
  deriving Show

jsonNumber :: ReadP JsonValue
jsonNumber = do
  num <- many1 (satisfy isDigit)
  otherHalf <- option ".0" secondHalf
  return $ JsonNumber (read (num ++ otherHalf))
  where
    secondHalf = do
      dot <- char '.'
      num1 <- many1 (satisfy isDigit)
      return (dot : num1)
      

jsonNull :: ReadP JsonValue
jsonNull = do
  string "null"
  return JsonNull

jsonString :: ReadP JsonValue
jsonString = do
  char '"'
  key <- many1 $ satisfy (\c -> c /= '"' && isAscii c)
  char '"'
  return $ JsonString key

jsonTrue :: ReadP JsonValue
jsonTrue = do
  string "true"
  return $ JsonBool True

jsonFalse :: ReadP JsonValue
jsonFalse = do
  string "false"
  return $ JsonBool False

jsonBool :: ReadP JsonValue
jsonBool = jsonTrue <|> jsonFalse

jsonArray :: ReadP JsonValue
jsonArray = do
  char '['
  skipSpaces
  values <- sepBy jsonValue (skipSpaces *> char ',' <* skipSpaces)
  skipSpaces
  char ']'
  return $ JsonArray values

jsonValue :: ReadP JsonValue
jsonValue =
  skipSpaces *>
    jsonNumber <|> jsonString <|> jsonNull <|> jsonObject <|> jsonBool <|> jsonArray
  <* skipSpaces

jsonPair :: ReadP (String, JsonValue)
jsonPair = do
  skipSpaces
  (JsonString key) <- jsonString
  skipSpaces
  char ':'
  skipSpaces
  value <- jsonValue
  return (key, value)

jsonObject :: ReadP JsonValue
jsonObject = do
  char '{'
  skipSpaces
  pairs <- sepBy jsonPair (skipSpaces *> char ',' <* skipSpaces)
  skipSpaces
  char '}'
  return $ JsonObject $ fromList pairs

parse :: String -> Maybe JsonValue
parse xs = if Prelude.null result
           then Nothing
           else Just $ fst $ last result
  where result = readP_to_S (jsonObject <* eof) xs

main :: IO ()
main = do
  line <- getLine
  case parse line of
    (Just json) -> print json
    Nothing     -> putStrLn "invalid json"