Support ranges in postgresql-simple

fromFieldInstances.hs

instance (FromField a, Typeable a) => FromField (Ranges.Range a) where
    fromField f mdat = do
        info <- typeInfo f
        case info of
          TI.Range{} ->
              case mdat of
                Nothing  -> returnError UnexpectedNull f ""
                Just dat -> do
                   case parseOnly (fromRange info f) dat of
                     Left  err  -> returnError ConversionFailed f err
                     Right conv -> conv
          _ -> retuanError Incompatible f ""

fromRange :: (FromField a)
          => TypeInfo -> Field -> Parser (Conversion (Ranges.Range a))
fromRange typeInfo f = parseRange delim pf
  where
    delim  = typdelim typeInfo
    fBound = f{ typeOid = typoid (rngsubtype typeInfo) }
    pf     = fromField fBound . Just

Ranges.hs

module Database.PostgreSQL.Simple.Ranges
where

import           Control.Applicative
import           Data.Attoparsec.Char8
import qualified Data.ByteString as B

data Range a = Range a Bool a Bool | Empty deriving Show

parseRange :: Char -> (B.ByteString -> a) -> Parser (Range a)
parseRange delim pf = do
     emptyRange delim pf <|> presentRange delim pf

emptyRange :: Char -> (B.ByteString -> a) -> Parser (Range a)
emptyRange _ _ = string "empty" >> return Empty

presentRange :: Char -> (B.ByteString -> a) -> Parser (Range a)
presentRange delim pf = do
    lb  <- parseLowerBoundMarker
    lbvalue <- pf <$> takeWhile1 (/= delim)
    _ <- char delim
    ubvalue <- pf <$> takeWhile1 (notInClass "])")
    ub <- parseUpperBoundMarker
    return $ Range lbvalue lb ubvalue ub

parseLowerBoundMarker :: Parser Bool
parseLowerBoundMarker =
    (char '[' >> return True) <|> (char '(' >> return False)

parseUpperBoundMarker :: Parser Bool
parseUpperBoundMarker =
    (char ']' >> return True) <|> (char ')' >> return False)