Using Aeson without type classes.

Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

{-

  build-depends:       base >=4.7 && <4.8
                     , aeson
                     , aeson-qq
                     , bytestring
                     , text
                     , unordered-containers
                     , vector

-}

module Main where

import Control.Applicative (pure, (<$>), (<*>))
import Data.Aeson (object)
import Data.Aeson.QQ (aesonQQ)
import Data.Aeson.Types (Parser, Value(..), parseMaybe)
import Data.HashMap.Strict ((!))
import Data.Text (Text)
import Data.Traversable (traverse)
import Data.Vector (fromList, toList)
import GHC.Stack (errorWithStackTrace)

-- User
newtype Name = Name { unName :: Text } deriving (Eq, Show)

data User = User { userName :: !Name
                 , userBlogPosts :: ![BlogPost]
                 } deriving (Eq, Show)

-- BlogPost
newtype Body = Body { unBody :: Text } deriving (Eq, Show)

data BlogPost = BlogPost { blogPostBody :: !Body} deriving (Eq, Show)


-- General notes
-- --------------
--
-- data Value = Object !Object
--            | Array !Array
--            | String !Text
--            | Number !Scientific
--            | Bool !Bool
--            | Null
--              deriving (Eq, Show, Typeable, Data)
--
-- type Object = HashMap Text Value
-- type Array = Vector Value
--

-- Deserialization
-- ----------------
--
-- class FromJSON a where
--   parseJSON :: Value -> Parser a
--
-- parseMaybe :: (a -> Parser b) -> a -> Maybe b
--

-- Take in an `aeson` `Value` and return a `Maybe User`
deserializeUser :: Value -> Maybe User
deserializeUser jsonValue = parseMaybe userParser jsonValue

userParser :: Value -> Parser User
userParser (Object o) = User
                        <$> (nameParser (o ! "name"))
                        <*> (listParser blogPostParser (o ! "blogPosts"))
userParser _ = errorWithStackTrace "expected Object"

listParser :: (Value -> Parser a) -> Value -> Parser [a]
listParser f (Array a) = traverse f (toList a)
listParser _ _ = errorWithStackTrace "expected Array"

nameParser :: Value -> Parser Name
nameParser (String t) = pure (Name t)
nameParser _ = errorWithStackTrace "expected String"

blogPostParser :: Value -> Parser BlogPost
blogPostParser (Object o) = BlogPost <$> (bodyParser (o ! "body"))
blogPostParser _ = errorWithStackTrace "expected Object"

bodyParser :: Value -> Parser Body
bodyParser (String t) = pure (Body t)
bodyParser _ = errorWithStackTrace "expected String"


-- Serialization
-- --------------
--
-- class ToJSON a where
--   toJSON :: a -> Value
--
-- object :: [Pair] -> Value
-- type Pair = (Text, Value)
--

-- Take in a `User` and return an `aeson` `Value`.
serializeUser :: User -> Value
serializeUser u = object [ ("name", String $ unName $ userName u)
                         , ("blogPosts", serializeList serializeBlogPost (userBlogPosts u))
                         ]

serializeList :: (a -> Value) -> [a] -> Value
serializeList f as = Array (fromList (fmap f as))

serializeBlogPost :: BlogPost -> Value
serializeBlogPost bp = object [ ("body", String $ unBody $ blogPostBody bp)
                              ]


-- Sample data
-- ------------


sampleUser :: User
sampleUser = User (Name "Sarah") samplePosts

samplePosts :: [BlogPost]
samplePosts = [ BlogPost (Body "This post is so awesome!")
              , BlogPost (Body "This post is so also awesome!")
              , BlogPost (Body "This post is even better!")
              ]

sampleUserJsonValue :: Value
sampleUserJsonValue = [aesonQQ|
  {
    "name": "Sarah",
    "blogPosts": [
      {
        "body": "This post is so awesome!"
      },
      {
        "body": "This post is so also awesome!"
      },
      {
        "body": "This post is even better!"
      }
    ]
  }
|]


-- main
-- -----

main :: IO ()
main = do
  putStrLn $ "userResult == sampleUser: " ++ show (userResult == Just sampleUser)
  putStrLn $ "jsonResult == sampleJson: " ++ show (jsonResult == sampleUserJsonValue)
  putStrLn "Done"
  where userResult = deserializeUser sampleUserJsonValue
        jsonResult = serializeUser sampleUser