json parser

json.hs

import System.Environment

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 = jsonDouble <|> jsonInteger

jsonDouble :: ReadP JsonValue
jsonDouble = do
  num <- many1 (satisfy isDigit)
  dot <- char '.'
  num1 <- many1 (satisfy isDigit)
  return $ JsonNumber (read (num ++ [dot] ++ num1))

jsonInteger :: ReadP JsonValue
jsonInteger = do
  num <- many1 (satisfy isDigit)
  return $ JsonNumber (read num)

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

jsonString :: ReadP JsonValue
jsonString = do
  char '"'
  key <- many $ satisfy (\c -> 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 resultOrFail result
  where
    result = readP_to_S (jsonObject <* skipSpaces) xs

resultOrFail :: [(JsonValue,String)] -> Maybe JsonValue
resultOrFail result = if Prelude.null $ snd $ last result
                      then Just $ fst $ last result
                      else Nothing

main :: IO ()
main = do
  (file:_) <- getArgs
  contents <- readFile file
  putStr contents
  case parse contents of
    (Just json) -> print json
    Nothing     -> putStrLn "invalid json"