@@ -0,0 +1,276 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+
6+------------------------------------------------------------------------------
7+-- |
8+-- Module: Database.PostgreSQL.Simple.Range
9+-- Copyright: (c) 2014-2015 Leonid Onokhov
10+-- (c) 2014-2015 Leon P Smith
11+-- License: BSD3
12+-- Maintainer: Leon P Smith <leon@melding-monads.com>
13+--
14+------------------------------------------------------------------------------
15+
16+module Database.PostgreSQL.Simple.Range
17+ ( RangeBound(..)
18+ , PGRange(..)
19+ , empty
20+ , isEmpty
21+ , isEmptyBy
22+ ) where
23+
24+import Control.Applicative hiding (empty)
25+import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly)
26+import qualified Data.Attoparsec.ByteString.Char8 as A
27+import qualified Data.ByteString as B
28+import Data.ByteString.Builder
29+ ( Builder, byteString, lazyByteString, char8
30+ , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec
31+ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
32+ , doubleDec, floatDec )
33+import Data.Int (Int16, Int32, Int64,
34+ Int8)
35+import Data.Function (on)
36+import Data.Monoid (mempty)
37+import Data.Scientific (Scientific)
38+import qualified Data.Text.Lazy.Builder as LT
39+import qualified Data.Text.Lazy.Encoding as LT
40+import Data.Time (Day, LocalTime,
41+ NominalDiffTime,
42+ TimeOfDay, UTCTime,
43+ ZonedTime,
44+ zonedTimeToUTC)
45+import Data.Typeable (Typeable)
46+import Data.Word (Word, Word16, Word32,
47+ Word64, Word8)
48+
49+import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString)
50+import Database.PostgreSQL.Simple.FromField
51+import Database.PostgreSQL.Simple.Time
52+ hiding (PosInfinity, NegInfinity)
53+-- import qualified Database.PostgreSQL.Simple.Time as Time
54+import Database.PostgreSQL.Simple.ToField
55+
56+-- | Represents boundary of a range
57+data RangeBound a = NegInfinity
58+ | Inclusive !a
59+ | Exclusive !a
60+ | PosInfinity
61+ deriving (Show, Typeable, Eq, Functor)
62+
63+-- | Generic range type
64+data PGRange a = PGRange !(RangeBound a) !(RangeBound a)
65+ deriving (Show, Typeable, Functor)
66+
67+empty :: PGRange a
68+empty = PGRange PosInfinity NegInfinity
69+
70+instance Ord a => Eq (PGRange a) where
71+ x == y = eq x y || (isEmpty x && isEmpty y)
72+ where eq (PGRange a m) (PGRange b n) = a == b && m == n
73+
74+isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool
75+isEmptyBy cmp v =
76+ case v of
77+ (PGRange PosInfinity _) -> True
78+ (PGRange _ NegInfinity) -> True
79+ (PGRange NegInfinity _) -> False
80+ (PGRange _ PosInfinity) -> False
81+ (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT
82+ (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT
83+ (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT
84+ (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT
85+
86+isEmpty :: Ord a => PGRange a -> Bool
87+isEmpty = isEmptyBy compare
88+
89+lowerBound :: Parser (a -> RangeBound a)
90+lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)
91+{-# INLINE lowerBound #-}
92+
93+upperBound :: Parser (a -> RangeBound a)
94+upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive)
95+{-# INLINE upperBound #-}
96+
97+-- | Generic range parser
98+pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString)
99+pgrange = do
100+ lb <- lowerBound
101+ v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',')
102+ v2 <- rangeElem $ \c -> c == ')' || c == ']'
103+ ub <- upperBound
104+ A.endOfInput
105+ let low = if B.null v1 then NegInfinity else lb v1
106+ up = if B.null v2 then PosInfinity else ub v2
107+ return (low, up)
108+
109+rangeElem :: (Char -> Bool) -> Parser B.ByteString
110+rangeElem end = (A.char '"' *> doubleQuoted)
111+ <|> A.takeTill end
112+{-# INLINE rangeElem #-}
113+
114+-- | Simple double quoted value parser
115+doubleQuoted :: Parser B.ByteString
116+doubleQuoted = toByteString <$> go mempty
117+ where
118+ go acc = do
119+ h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"')
120+ let rest = do
121+ start <- A.anyChar
122+ case start of
123+ '\\' -> do
124+ c <- A.anyChar
125+ go (acc <> h <> char8 c)
126+ '"' -> (A.char '"' *> go (acc <> h <> char8 '"'))
127+ <|> pure (acc <> h)
128+ _ -> error "impossible in doubleQuoted"
129+ rest
130+
131+rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder
132+rangeToBuilder = rangeToBuilderBy compare
133+
134+-- | Generic range to builder for plain values
135+rangeToBuilderBy :: (a -> a -> Ordering) => (a -> Builder) -> PGRange a -> Builder
136+rangeToBuilderBy cmp f x =
137+ if isEmptyBy cmp x
138+ then byteString "'empty'"
139+ else let (PGRange a b) = x
140+ in buildLB a <> buildUB b
141+ where
142+ buildLB NegInfinity = byteString "'[,"
143+ buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\","
144+ buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\","
145+ buildLB PosInfinity = error "impossible in rangeToBuilder"
146+
147+ buildUB NegInfinity = error "impossible in rangeToBuilder"
148+ buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'"
149+ buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'"
150+ buildUB PosInfinity = byteString "]'"
151+{-# INLINE rangeToBuilder #-}
152+
153+
154+instance (FromField a, Typeable a) => FromField (PGRange a) where
155+ fromField f mdat = do
156+ info <- typeInfo f
157+ case info of
158+ Range{} ->
159+ let f' = f { typeOid = typoid (rngsubtype info) }
160+ in case mdat of
161+ Nothing -> returnError UnexpectedNull f ""
162+ Just "empty" -> pure $ empty
163+ Just bs ->
164+ let parseIt NegInfinity = pure NegInfinity
165+ parseIt (Inclusive v) = Inclusive <$> fromField f' (Just v)
166+ parseIt (Exclusive v) = Exclusive <$> fromField f' (Just v)
167+ parseIt PosInfinity = pure PosInfinity
168+ in case parseOnly pgrange bs of
169+ Left e -> returnError ConversionFailed f e
170+ Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub
171+ _ -> returnError Incompatible f ""
172+
173+
174+instance ToField (PGRange Int8) where
175+ toField = Plain . rangeToBuilder int8Dec
176+ {-# INLINE toField #-}
177+
178+instance ToField (PGRange Int16) where
179+ toField = Plain . rangeToBuilder int16Dec
180+ {-# INLINE toField #-}
181+
182+instance ToField (PGRange Int32) where
183+ toField = Plain . rangeToBuilder int32Dec
184+ {-# INLINE toField #-}
185+
186+instance ToField (PGRange Int) where
187+ toField = Plain . rangeToBuilder intDec
188+ {-# INLINE toField #-}
189+
190+instance ToField (PGRange Int64) where
191+ toField = Plain . rangeToBuilder int64Dec
192+ {-# INLINE toField #-}
193+
194+instance ToField (PGRange Integer) where
195+ toField = Plain . rangeToBuilder integerDec
196+ {-# INLINE toField #-}
197+
198+instance ToField (PGRange Word8) where
199+ toField = Plain . rangeToBuilder word8Dec
200+ {-# INLINE toField #-}
201+
202+instance ToField (PGRange Word16) where
203+ toField = Plain . rangeToBuilder word16Dec
204+ {-# INLINE toField #-}
205+
206+instance ToField (PGRange Word32) where
207+ toField = Plain . rangeToBuilder word32Dec
208+ {-# INLINE toField #-}
209+
210+instance ToField (PGRange Word) where
211+ toField = Plain . rangeToBuilder wordDec
212+ {-# INLINE toField #-}
213+
214+instance ToField (PGRange Word64) where
215+ toField = Plain . rangeToBuilder word64Dec
216+ {-# INLINE toField #-}
217+
218+instance ToField (PGRange Float) where
219+ toField = Plain . rangeToBuilder floatDec
220+ {-# INLINE toField #-}
221+
222+instance ToField (PGRange Double) where
223+ toField = Plain . rangeToBuilder doubleDec
224+ {-# INLINE toField #-}
225+
226+instance ToField (PGRange Scientific) where
227+ toField = Plain . rangeToBuilder f
228+ where
229+ f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder
230+ {-# INLINE toField #-}
231+
232+instance ToField (PGRange UTCTime) where
233+ toField = Plain . rangeToBuilder utcTimeToBuilder
234+ {-# INLINE toField #-}
235+
236+instance ToField (PGRange ZonedTime) where
237+ toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder
238+ {-# INLINE toField #-}
239+
240+cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering
241+cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize
242+
243+instance ToField (PGRange LocalTime) where
244+ toField = Plain . rangeToBuilder localTimeToBuilder
245+ {-# INLINE toField #-}
246+
247+instance ToField (PGRange Day) where
248+ toField = Plain . rangeToBuilder dayToBuilder
249+ {-# INLINE toField #-}
250+
251+instance ToField (PGRange TimeOfDay) where
252+ toField = Plain . rangeToBuilder timeOfDayToBuilder
253+ {-# INLINE toField #-}
254+
255+instance ToField (PGRange UTCTimestamp) where
256+ toField = Plain . rangeToBuilder utcTimestampToBuilder
257+ {-# INLINE toField #-}
258+
259+instance ToField (PGRange ZonedTimestamp) where
260+ toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder
261+ {-# INLINE toField #-}
262+
263+cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering
264+cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>)
265+
266+instance ToField (PGRange LocalTimestamp) where
267+ toField = Plain . rangeToBuilder localTimestampToBuilder
268+ {-# INLINE toField #-}
269+
270+instance ToField (PGRange Date) where
271+ toField = Plain . rangeToBuilder dateToBuilder
272+ {-# INLINE toField #-}
273+
274+instance ToField (PGRange NominalDiffTime) where
275+ toField = Plain . rangeToBuilder nominalDiffTimeToBuilder
276+ {-# INLINE toField #-}