/
Arrays.hs
92 lines (78 loc) · 3.4 KB
/
Arrays.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
{-# 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.Char8
-- | Parse one of three primitive field formats: array, quoted and plain.
arrayFormat :: Char -> Parser ArrayFormat
arrayFormat delim = Array <$> array delim
<|> Plain <$> plain delim
<|> Quoted <$> quoted
data ArrayFormat = Array [ArrayFormat]
| Plain ByteString
| Quoted ByteString
deriving (Eq, Show, Ord)
array :: Char -> Parser [ArrayFormat]
array delim = char '{' *> option [] (arrays <|> strings) <* char '}'
where
strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim)
arrays = sepBy1 (Array <$> array delim) (char ',')
-- NB: Arrays seem to always be delimited by commas.
-- | Recognizes a quoted string.
quoted :: Parser ByteString
quoted = char '"' *> option "" contents <* char '"'
where
esc = char '\\' *> (char '\\' <|> char '"')
unQ = takeWhile1 (notInClass "\"\\")
contents = mconcat <$> many (unQ <|> B.singleton <$> esc)
-- | Recognizes a plain string literal, not containing quotes or brackets and
-- not containing the delimiter character.
plain :: Char -> Parser ByteString
plain delim = takeWhile1 (notInClass (delim:"\"{}"))
-- 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 = fmt' 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 _ [] = ""
delimit c [x] = fmt' True c x
delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z)
where
c' | Array _ <- x = ','
| otherwise = 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' quoting c x =
case x of
Array items -> '{' `B.cons` (delimit c items `B.snoc` '}')
Plain bytes -> B.copy bytes
Quoted q | quoting -> '"' `B.cons` (esc q `B.snoc` '"')
| otherwise -> B.copy q
-- NB: The 'snoc' and 'cons' functions always copy.
-- | Escape a string according to Postgres double-quoted string format.
esc :: ByteString -> ByteString
esc = B.concatMap f
where
f '"' = "\\\""
f '\\' = "\\\\"
f c = B.singleton c
-- TODO: Implement easy performance improvements with unfoldr.