{-# LANGUAGE PatternGuards #-}

------------------------------------------------------------------------------
-- |
-- Module:      Database.PostgreSQL.Simple.Arrays
-- Copyright:   (c) 2012 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
-- Stability:   experimental
--
-- A Postgres array parser and pretty-printer.
------------------------------------------------------------------------------

module Database.PostgreSQL.Simple.Arrays where

import           Control.Applicative (Applicative(..), Alternative(..), (<$>))
import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import           Data.Monoid
import           Data.Attoparsec.ByteString.Char8


-- | Parse one of three primitive field formats: array, quoted and plain.
arrayFormat :: Char -> Parser ArrayFormat
arrayFormat :: Char -> Parser ArrayFormat
arrayFormat Char
delim  =  [ArrayFormat] -> ArrayFormat
Array  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser [ArrayFormat]
array Char
delim
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> ArrayFormat
Plain  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser ByteString
plain Char
delim
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> ArrayFormat
Quoted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
quoted

data ArrayFormat = Array [ArrayFormat]
                 | Plain ByteString
                 | Quoted ByteString
                   deriving (ArrayFormat -> ArrayFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArrayFormat -> ArrayFormat -> Bool
$c/= :: ArrayFormat -> ArrayFormat -> Bool
== :: ArrayFormat -> ArrayFormat -> Bool
$c== :: ArrayFormat -> ArrayFormat -> Bool
Eq, Int -> ArrayFormat -> ShowS
[ArrayFormat] -> ShowS
ArrayFormat -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ArrayFormat] -> ShowS
$cshowList :: [ArrayFormat] -> ShowS
show :: ArrayFormat -> [Char]
$cshow :: ArrayFormat -> [Char]
showsPrec :: Int -> ArrayFormat -> ShowS
$cshowsPrec :: Int -> ArrayFormat -> ShowS
Show, Eq ArrayFormat
ArrayFormat -> ArrayFormat -> Bool
ArrayFormat -> ArrayFormat -> Ordering
ArrayFormat -> ArrayFormat -> ArrayFormat
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArrayFormat -> ArrayFormat -> ArrayFormat
$cmin :: ArrayFormat -> ArrayFormat -> ArrayFormat
max :: ArrayFormat -> ArrayFormat -> ArrayFormat
$cmax :: ArrayFormat -> ArrayFormat -> ArrayFormat
>= :: ArrayFormat -> ArrayFormat -> Bool
$c>= :: ArrayFormat -> ArrayFormat -> Bool
> :: ArrayFormat -> ArrayFormat -> Bool
$c> :: ArrayFormat -> ArrayFormat -> Bool
<= :: ArrayFormat -> ArrayFormat -> Bool
$c<= :: ArrayFormat -> ArrayFormat -> Bool
< :: ArrayFormat -> ArrayFormat -> Bool
$c< :: ArrayFormat -> ArrayFormat -> Bool
compare :: ArrayFormat -> ArrayFormat -> Ordering
$ccompare :: ArrayFormat -> ArrayFormat -> Ordering
Ord)

array :: Char -> Parser [ArrayFormat]
array :: Char -> Parser [ArrayFormat]
array Char
delim = Char -> Parser Char
char Char
'{' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option [] (Parser [ArrayFormat]
arrays forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [ArrayFormat]
strings) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'}'
  where
    strings :: Parser [ArrayFormat]
strings = forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy1 (ByteString -> ArrayFormat
Quoted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
quoted forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> ArrayFormat
Plain forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser ByteString
plain Char
delim) (Char -> Parser Char
char Char
delim)
    arrays :: Parser [ArrayFormat]
arrays  = forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy1 ([ArrayFormat] -> ArrayFormat
Array forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser [ArrayFormat]
array Char
delim) (Char -> Parser Char
char Char
',')
    -- NB: Arrays seem to always be delimited by commas.

-- | Recognizes a quoted string.
quoted :: Parser ByteString
quoted :: Parser ByteString
quoted  = Char -> Parser Char
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option ByteString
"" Parser ByteString
contents forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'"'
  where
    esc' :: Parser Char
esc' = Char -> Parser Char
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Parser Char
char Char
'\\' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char Char
'"')
    unQ :: Parser ByteString
unQ = (Char -> Bool) -> Parser ByteString
takeWhile1 ([Char] -> Char -> Bool
notInClass [Char]
"\"\\")
    contents :: Parser ByteString
contents = forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser ByteString
unQ forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ByteString
B.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
esc')

-- | Recognizes a plain string literal, not containing quotes or brackets and
--   not containing the delimiter character.
plain :: Char -> Parser ByteString
plain :: Char -> Parser ByteString
plain Char
delim = (Char -> Bool) -> Parser ByteString
takeWhile1 ([Char] -> Char -> Bool
notInClass (Char
delimforall a. a -> [a] -> [a]
:[Char]
"\"{}"))

-- Mutually recursive 'fmt' and 'delimit' separate out value formatting
-- from the subtleties of delimiting.

-- | Format an array format item, using the delimiter character if the item is
--   itself an array.
fmt :: Char -> ArrayFormat -> ByteString
fmt :: Char -> ArrayFormat -> ByteString
fmt = Bool -> Char -> ArrayFormat -> ByteString
fmt' Bool
False

-- | Format a list of array format items, inserting the appropriate delimiter
--   between them. When the items are arrays, they will be delimited with
--   commas; otherwise, they are delimited with the passed-in-delimiter.
delimit :: Char -> [ArrayFormat] -> ByteString
delimit :: Char -> [ArrayFormat] -> ByteString
delimit Char
_      [] = ByteString
""
delimit Char
c     [ArrayFormat
x] = Bool -> Char -> ArrayFormat -> ByteString
fmt' Bool
True Char
c ArrayFormat
x
delimit Char
c (ArrayFormat
x:ArrayFormat
y:[ArrayFormat]
z) = (Bool -> Char -> ArrayFormat -> ByteString
fmt' Bool
True Char
c ArrayFormat
x ByteString -> Char -> ByteString
`B.snoc` Char
c') forall a. Monoid a => a -> a -> a
`mappend` Char -> [ArrayFormat] -> ByteString
delimit Char
c (ArrayFormat
yforall a. a -> [a] -> [a]
:[ArrayFormat]
z)
  where
    c' :: Char
c' | Array [ArrayFormat]
_ <- ArrayFormat
x = Char
','
       | Bool
otherwise    = Char
c

-- | Format an array format item, using the delimiter character if the item is
--   itself an array, optionally applying quoting rules. Creates copies for
--   safety when used in 'FromField' instances.
fmt' :: Bool -> Char -> ArrayFormat -> ByteString
fmt' :: Bool -> Char -> ArrayFormat -> ByteString
fmt' Bool
quoting Char
c ArrayFormat
x =
  case ArrayFormat
x of
    Array [ArrayFormat]
items          -> Char
'{' Char -> ByteString -> ByteString
`B.cons` (Char -> [ArrayFormat] -> ByteString
delimit Char
c [ArrayFormat]
items ByteString -> Char -> ByteString
`B.snoc` Char
'}')
    Plain ByteString
bytes          -> ByteString -> ByteString
B.copy ByteString
bytes
    Quoted ByteString
q | Bool
quoting   -> Char
'"' Char -> ByteString -> ByteString
`B.cons` (ByteString -> ByteString
esc ByteString
q ByteString -> Char -> ByteString
`B.snoc` Char
'"')
             | Bool
otherwise -> ByteString -> ByteString
B.copy ByteString
q
    -- NB: The 'snoc' and 'cons' functions always copy.

-- | Escape a string according to Postgres double-quoted string format.
esc :: ByteString -> ByteString
esc :: ByteString -> ByteString
esc = (Char -> ByteString) -> ByteString -> ByteString
B.concatMap Char -> ByteString
f
  where
    f :: Char -> ByteString
f Char
'"'  = ByteString
"\\\""
    f Char
'\\' = ByteString
"\\\\"
    f Char
c    = Char -> ByteString
B.singleton Char
c
  -- TODO: Implement easy performance improvements with unfoldr.