[Haskell-cafe] Text.JSON idiomatic use

[ntupel]

As a follow up to my previous JSON serialization post I came up with a
first draft of some simple record type serialization/deserialization. 

What I would like to know is, whether this is the right approach or what
better ways there are to make a custom data type an instance of class
JSON. Any chance to reduce the amount of boilerplate required to do
this? I would be grateful for any feedback (also general style comments
are much appreciated).

Many thanks!




module Test where

import Text.JSON

data Message =
    Error {
        event   :: String,
        channel :: String,
        id      :: String,
        cause   :: String,
        message :: String}
  | Join {
        event   :: String,
        channel :: String,
        id      :: String,
        name    :: String}
  | Leave {
        event   :: String,
        channel :: String,
        id      :: String,
        really  :: Bool}
  deriving (Eq, Show, Read)

asJSString :: String -> JSValue
asJSString = JSString . toJSString

asString :: JSValue -> String
asString (JSString s) = fromJSString s

asBool :: JSValue -> Bool
asBool (JSBool b) = b


showErrorJSON, showJoinJSON, showLeaveJSON :: Message -> JSValue

showErrorJSON (Test.Error evt cha id cau msg) =
    showJSON $ toJSObject [("event", evt), ("channel", cha), ("id", id), ("cause", cau), ("message", msg)]

showJoinJSON (Join evt cha id nme) =
    showJSON $ toJSObject [("event", evt), ("channel", cha), ("id", id), ("name", nme)]

showLeaveJSON (Leave evt cha id rly) =
    showJSON $ toJSObject [("event", asJSString evt), ("channel", asJSString cha), ("id", asJSString id), ("really", JSBool rly)]


createMessage, readErrorJSON, readJoinJSON, readLeaveJSON :: [(String, JSValue)] -> Maybe Message

readErrorJSON xs = do
    evt <- lookup "event" xs
    cha <- lookup "channel" xs
    id  <- lookup "id" xs
    cau <- lookup "cause" xs
    msg <- lookup "message" xs
    Just (Test.Error (asString evt) (asString cha) (asString id) (asString cau) (asString msg))

readJoinJSON xs = do
    evt <- lookup "event" xs
    cha <- lookup "channel" xs
    id  <- lookup "id" xs
    nme <- lookup "name" xs
    Just (Join (asString evt) (asString cha) (asString id) (asString nme))

readLeaveJSON xs = do
    evt <- lookup "event" xs
    cha <- lookup "channel" xs
    id  <- lookup "id" xs
    rly <- lookup "really" xs
    Just (Leave (asString evt) (asString cha) (asString id) (asBool rly))

createMessage obj = do
    evt <- lookup "event" obj
    case asString evt of
        "/error"  -> readErrorJSON obj
        "/me/add" -> readJoinJSON obj
        "/me/remove" -> readLeaveJSON obj
        _ -> Nothing

instance JSON Message where
    showJSON x@(Test.Join    _ _ _ _) = showJoinJSON x
    showJSON x@(Test.Leave   _ _ _ _) = showLeaveJSON x
    showJSON x@(Test.Error _ _ _ _ _) = showErrorJSON x

    readJSON (JSObject o) = 
        case createMessage . fromJSObject $ o of
            Just m  -> Ok m
            Nothing -> Text.JSON.Error "Parsing failed."

    readJSON _ = Text.JSON.Error "Records must be JSObjects"