Generic attoparsec-parseable fields for postgresql-simple with a hstore example.

PGSParseable.hs

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}

module PGSParseable where

import qualified Data.Attoparsec.Text as AP
import Data.Typeable (Typeable)

import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.ByteString.Char8 as BS

import qualified Data.Map as M

import qualified Database.PostgreSQL.Simple.FromField as PGF

-- * Generic

class ParseableField a where
    typeName :: a -> BS.ByteString
    allowNulls :: a -> Bool
    nullValue :: a
    parser :: AP.Parser a

instance (ParseableField a, Typeable a) => PGF.FromField a where
    fromField f _ | PGF.typename f /= typeName (undefined :: a) = PGF.returnError PGF.Incompatible f "incompatible types"
    fromField f Nothing = if allowNulls (undefined :: a) then return nullValue else PGF.returnError PGF.UnexpectedNull f ""
    fromField _ (Just dat) = either fail return $ AP.parseOnly parser (decodeUtf8 dat)

-- * Hstore

type HStore = M.Map T.Text T.Text

instance ParseableField HStore where
    typeName _ = "hstore"
    allowNulls _ = True
    nullValue = M.empty
    parser = hstoreParser

-- | Parse hstore-formatted value.
hstoreParser :: AP.Parser HStore
hstoreParser = do
    pairs <- kvPair `AP.sepBy` AP.string (T.pack ", ")
    return $! M.fromList pairs

-- | Parse one key-value pair.
kvPair :: AP.Parser (Text, Text)
kvPair = do
    key <- doubleQuoted
    AP.string $ T.pack "=>"
    value <- doubleQuoted
    return (key, value)

-- | Grab a value, unquote, unslash.
doubleQuoted :: AP.Parser Text
doubleQuoted = do
    AP.char '"'
    str <- AP.scan False $ \s c -> if s then Just False
                                        else if c == '"'
                                             then Nothing
                                             else Just (c == '\\')
    AP.char '"'

    return $! T.replace (T.pack "\\\"") (T.singleton '"') str

test.lhs

> [[hstore]] <- query_ pg "select hstore('spam', 'салат') || hstore('sausage', 'eggs')" :: IO [[HStore]]
> print hstore
> putStrLn $ T.unpack . fromJust $ M.lookup "spam" hstore

fromList [("sausage","eggs"),("spam","\1089\1072\1083\1072\1090")]
салат

This doesn't feel like a compelling abstraction to me, and (knowing a bit about how GHC tends to work) I think it would probably be better expressed as a function and not a typeclass, as functions are somewhat more likely to be inlined and indirections eliminated.