Json.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}

module Json where

import Test.SmallCheck.Series
import GHC.Generics

import Data.List (intercalate)
import qualified Text.ParserCombinators.Parsec.Token as Token
import Text.ParserCombinators.Parsec (ParseError, Parser, choice)
import qualified Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec.Char (char)
import Text.ParserCombinators.Parsec.Language (emptyDef)
import Control.Applicative ((<$>), (<|>), (<$), (*>), (<*), (<*>))

data Json = JString String
  | JNumber Double
  | JBool Bool
  | JNull
  | JArray [Json]
  | JObject [(String, Json)]
  deriving (Eq, Show, Generic)
           

instance Monad m => Serial m Json

lexer = Token.makeTokenParser emptyDef

symbol = Token.symbol lexer
stringLiteral = Token.stringLiteral lexer
float = Token.float lexer
brackets = Token.brackets lexer
braces = Token.braces lexer
commaSep = Token.commaSep lexer

parser ::  Parser Json
parser = choice [
  JString <$> stringLiteral,
  JBool <$> boolean,
  JNumber <$> float,
  (JNumber . negate) <$> (char '-' *> float),
  JArray <$> (brackets . commaSep) parser, 
  JNull <$ symbol "null",
  JObject <$> (braces . commaSep) assoc
  ]

assoc :: Parser (String, Json)
assoc = (,) <$> (stringLiteral <* symbol ":") <*> parser

boolean :: Parser Bool
boolean = True <$ symbol "true" <|> 
          False <$ symbol "false"

parse :: String -> Either ParseError Json
parse = Parsec.parse parser ""

prettyPrint :: Json -> String
prettyPrint (JString s) = show s
prettyPrint (JNumber d) = show d
prettyPrint (JBool True) = "true"
prettyPrint (JBool False) = "false"
prettyPrint JNull = "null"
prettyPrint (JArray arr) = "[" ++ intercalate ", " (map prettyPrint arr) ++ "]"
prettyPrint (JObject assocList) = "{" ++ 
                                  intercalate ", " (map (\(k, v) -> show k ++ ": " ++ prettyPrint v) assocList)
                                  ++ "}"

JsonSpec.hs

module JsonSpec where

import Json (parse, prettyPrint)

import Test.Hspec
import Test.Hspec.SmallCheck (property)


main :: IO ()
main = hspec $ do

  describe "parse" $ 
    it "should be the same when pretty-printed then reparsed" $ do 
      property $ \json -> case (parse . prettyPrint) json of
        Left _ -> False
        Right result -> result == json