@@ -1,8 +1,7 @@
1{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
1{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
4−{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE RecordWildCards, TemplateHaskell #-}
5−{-# LANGUAGE PolyKinds #-}
8Module: Database.PostgreSQL.Simple.FromField
7Module: Database.PostgreSQL.Simple.FromField
@@ -24,24 +23,6 @@ the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit
24since a 'Double' might lose precision if representing PostgreSQL's 64-bit
23since a 'Double' might lose precision if representing PostgreSQL's 64-bit
25@bigint@, the two are /not/ considered compatible.
24@bigint@, the two are /not/ considered compatible.
27−Note that the 'Float' and 'Double' instances use attoparsec's 'double'
28−conversion routine, which sacrifices some accuracy for speed. If you
29−need accuracy, consider first converting data to a 'Scientific' or 'Rational'
30−type, and then converting to a floating-point type. If you are defining
31−your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
33−@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
34−this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@
35−types. If this is unacceptable, you may find
36−'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.
38−Also note that while converting to a 'Double' through the 'Scientific' type
39−is likely somewhat faster than converting through the 'Rational' type,
40−the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values.
41−Thus, if you need precision conversion of regular floating point values
42−and the possibility of receiving these special values from the backend,
43−stick with 'Rational'.
45Because 'FromField' is a typeclass, one may provide conversions to
26Because 'FromField' is a typeclass, one may provide conversions to
46additional Haskell types without modifying postgresql-simple. This is
27additional Haskell types without modifying postgresql-simple. This is
47particularly useful for supporting PostgreSQL types that postgresql-simple
28particularly useful for supporting PostgreSQL types that postgresql-simple
@@ -106,38 +87,32 @@ module Database.PostgreSQL.Simple.FromField
106 , typeOid
87 , typeOid
107 , PQ.Oid(..)
88 , PQ.Oid(..)
108 , PQ.Format(..)
89 , PQ.Format(..)
109− , pgArrayFieldParser
113 , fromJSONField
91 , fromJSONField
114− , fromFieldJSONByteString
117#include "MachDeps.h"
94#include "MachDeps.h"
119−import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
96+import Control.Applicative
120−import Control.Concurrent.MVar (MVar, newMVar)
97+ ( Applicative, (<|>), (<$>), pure )
121−import Control.Exception (Exception (toException, fromException))
98+import Control.Exception (Exception)
122import qualified Data.Aeson as JSON
99import qualified Data.Aeson as JSON
123−import Data.Attoparsec.ByteString.Char8 hiding (Result)
100+import Data.Attoparsec.Char8 hiding (Result)
124import Data.ByteString (ByteString)
101import Data.ByteString (ByteString)
125import qualified Data.ByteString.Char8 as B
102import qualified Data.ByteString.Char8 as B
126−import Data.Functor.Identity (Identity(Identity))
127import Data.Int (Int16, Int32, Int64)
103import Data.Int (Int16, Int32, Int64)
128−import Data.IORef (IORef, newIORef)
129import Data.Ratio (Ratio)
104import Data.Ratio (Ratio)
130−import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
105+import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
131import Data.Typeable (Typeable, typeOf)
106import Data.Typeable (Typeable, typeOf)
132import Data.Vector (Vector)
107import Data.Vector (Vector)
133−import Data.Vector.Mutable (IOVector)
134import qualified Data.Vector as V
108import qualified Data.Vector as V
135import Database.PostgreSQL.Simple.Internal
109import Database.PostgreSQL.Simple.Internal
136import Database.PostgreSQL.Simple.Compat
110import Database.PostgreSQL.Simple.Compat
137import Database.PostgreSQL.Simple.Ok
111import Database.PostgreSQL.Simple.Ok
138−import Database.PostgreSQL.Simple.Types
112+import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))
139import Database.PostgreSQL.Simple.TypeInfo as TI
113import Database.PostgreSQL.Simple.TypeInfo as TI
140import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
114import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
115+import Database.PostgreSQL.Simple.TypeInfo.Macro as TI
141import Database.PostgreSQL.Simple.Time
116import Database.PostgreSQL.Simple.Time
142import Database.PostgreSQL.Simple.Arrays as Arrays
117import Database.PostgreSQL.Simple.Arrays as Arrays
143import qualified Database.PostgreSQL.LibPQ as PQ
118import qualified Database.PostgreSQL.LibPQ as PQ
@@ -147,14 +122,6 @@ import qualified Data.ByteString.Lazy as LB
147import qualified Data.Text as ST
122import qualified Data.Text as ST
148import qualified Data.Text.Encoding as ST
123import qualified Data.Text.Encoding as ST
149import qualified Data.Text.Lazy as LT
124import qualified Data.Text.Lazy as LT
150−import Data.CaseInsensitive (CI)
151−import qualified Data.CaseInsensitive as CI
152−import Data.UUID.Types (UUID)
153−import qualified Data.UUID.Types as UUID
154−import Data.Scientific (Scientific)
155−import GHC.Real (infinity, notANumber)
157−import qualified Data.Aeson.Types as JSON
159-- | Exception thrown if conversion from a SQL value to a Haskell
126-- | Exception thrown if conversion from a SQL value to a Haskell
160-- value fails.
127-- value fails.
@@ -182,9 +149,7 @@ data ResultError = Incompatible { errSQLType :: String
182 -- between metadata and actual data in a row).
149 -- between metadata and actual data in a row).
183 deriving (Eq, Show, Typeable)
150 deriving (Eq, Show, Typeable)
185−instance Exception ResultError where
152+instance Exception ResultError
186− toException = postgresqlExceptionToException
187− fromException = postgresqlExceptionFromException
189left :: Exception a => a -> Conversion b
154left :: Exception a => a -> Conversion b
190left = conversionError
155left = conversionError
@@ -200,15 +165,16 @@ class FromField a where
200 -- library instances, this will usually be a single 'ResultError', but
165 -- library instances, this will usually be a single 'ResultError', but
201 -- may be a 'UnicodeException'.
166 -- may be a 'UnicodeException'.
203− -- Note that retaining any reference to the 'Field' argument causes
168+ -- Note that retaining any reference to the 'Field' or 'ByteString'
204− -- the entire @LibPQ.'PQ.Result'@ to be retained. Thus, implementations
169+ -- arguments causes the entire @LibPQ.'PQ.Result'@ to be retained.
205− -- of 'fromField' should return results that do not refer to this value
170+ -- Thus, as a rule of thumb, implementations of 'fromField' should
206− -- after the result have been evaluated to WHNF.
171+ -- not refer to these values after the result has been evaluated
172+ -- to WHNF. But it can be profitable to break this rule when you
173+ -- know it won't cause memory management problems.
208− -- Note that as of @postgresql-simple-0.4.0.0@, the 'ByteString' value
175+ -- The instances included with postgresql-simple follow this rule
209− -- has already been copied out of the @LibPQ.'PQ.Result'@ before it has
176+ -- of thumb (modulo bugs). For example, the instance for 'ByteString'
210− -- been passed to 'fromField'. This is because for short strings, it's
177+ -- uses 'B.copy' to avoid such a reference.
211− -- cheaper to copy the string than to set up a finalizer.
213-- | Returns the data type name. This is the preferred way of identifying
179-- | Returns the data type name. This is the preferred way of identifying
214-- types that do not have a stable type oid, such as types provided by
180-- types that do not have a stable type oid, such as types provided by
@@ -225,7 +191,7 @@ typename field = typname <$> typeInfo field
226typeInfo :: Field -> Conversion TypeInfo
192typeInfo :: Field -> Conversion TypeInfo
227typeInfo Field{..} = Conversion $ \conn -> do
193typeInfo Field{..} = Conversion $ \conn -> do
228− Ok <$> (getTypeInfo conn typeOid)
194+ Ok <$> (getTypeInfo conn =<< PQ.ftype result column)
230typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
196typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
231typeInfoByOid oid = Conversion $ \conn -> do
197typeInfoByOid oid = Conversion $ \conn -> do
@@ -250,11 +216,9 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column
250 then Nothing
216 then Nothing
251 else Just x
217 else Just x
253−-- | If the column has a table associated with it, this returns the
219+-- | If the column has a table associated with it, this returns the number
254−-- number of the associated table column. Table columns have
220+-- off the associated table column. Numbering starts from 0. Analogous
255−-- nonzero numbers. Zero is returned if the specified column is not
256−-- a simple reference to a table column, or when using pre-3.0
257−-- protocol. Analogous to libpq's @PQftablecol@.
221+-- to libpq's @PQftablecol@.
259tableColumn :: Field -> Int
223tableColumn :: Field -> Int
260tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
224tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
@@ -270,33 +234,16 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
271instance FromField () where
235instance FromField () where
272 fromField f _bs
236 fromField f _bs
273− | typeOid f /= TI.voidOid = returnError Incompatible f ""
237+ | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""
274 | otherwise = pure ()
238 | otherwise = pure ()
276−instance (FromField a) => FromField (Const a b) where
277− fromField f bs = Const <$> fromField f bs
279−instance (FromField a) => FromField (Identity a) where
280− fromField f bs = Identity <$> fromField f bs
282-- | For dealing with null values. Compatible with any postgresql type
240-- | For dealing with null values. Compatible with any postgresql type
283-- compatible with type @a@. Note that the type is not checked if
241-- compatible with type @a@. Note that the type is not checked if
284-- the value is null, although it is inadvisable to rely on this
242-- the value is null, although it is inadvisable to rely on this
285-- behavior.
243-- behavior.
286−instance FromField a => FromField (Maybe a) where
244+instance (FromField a) => FromField (Maybe a) where
287− fromField = optionalField fromField
289−-- | For dealing with SQL @null@ values outside of the 'FromField' class.
290−-- Alternatively, one could use 'Control.Applicative.optional', but that
291−-- also turns type and conversion errors into 'Nothing', whereas this is
292−-- more specific and turns only @null@ values into 'Nothing'.
294−optionalField :: FieldParser a -> FieldParser (Maybe a)
295−optionalField p f mv =
297− Nothing -> pure Nothing
245+ fromField _ Nothing = pure Nothing
298− Just _ -> Just <$> p f mv
246+ fromField f bs = Just <$> fromField f bs
299−{-# INLINE optionalField #-}
301-- | compatible with any data type, but the value must be null
248-- | compatible with any data type, but the value must be null
302instance FromField Null where
249instance FromField Null where
@@ -306,30 +253,30 @@ instance FromField Null where
307instance FromField Bool where
254instance FromField Bool where
308 fromField f bs
255 fromField f bs
309− | typeOid f /= TI.boolOid = returnError Incompatible f ""
256+ | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
310 | bs == Nothing = returnError UnexpectedNull f ""
257 | bs == Nothing = returnError UnexpectedNull f ""
311 | bs == Just "t" = pure True
258 | bs == Just "t" = pure True
312 | bs == Just "f" = pure False
259 | bs == Just "f" = pure False
313 | otherwise = returnError ConversionFailed f ""
260 | otherwise = returnError ConversionFailed f ""
315−-- | \"char\", bpchar
262+-- | \"char\"
316instance FromField Char where
263instance FromField Char where
317− fromField f bs0 =
264+ fromField f bs =
318− if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
265+ if typeOid f /= $(inlineTypoid TI.char)
266+ then returnError Incompatible f ""
319− then case bs0 of
267+ else case bs of
320 Nothing -> returnError UnexpectedNull f ""
268 Nothing -> returnError UnexpectedNull f ""
321 Just bs -> if B.length bs /= 1
269 Just bs -> if B.length bs /= 1
322 then returnError ConversionFailed f "length not 1"
270 then returnError ConversionFailed f "length not 1"
323 else return $! (B.head bs)
271 else return $! (B.head bs)
324− else returnError Incompatible f ""
327instance FromField Int16 where
274instance FromField Int16 where
328− fromField = attoFieldParser ok16 $ signed decimal
275+ fromField = atto ok16 $ signed decimal
330-- | int2, int4
277-- | int2, int4
331instance FromField Int32 where
278instance FromField Int32 where
332− fromField = attoFieldParser ok32 $ signed decimal
279+ fromField = atto ok32 $ signed decimal
334#if WORD_SIZE_IN_BITS < 64
281#if WORD_SIZE_IN_BITS < 64
335-- | int2, int4, and if compiled as 64-bit code, int8 as well.
282-- | int2, int4, and if compiled as 64-bit code, int8 as well.
@@ -339,64 +286,43 @@ instance FromField Int32 where
339-- This library was compiled as 64-bit code.
286-- This library was compiled as 64-bit code.
341instance FromField Int where
288instance FromField Int where
342− fromField = attoFieldParser okInt $ signed decimal
289+ fromField = atto okInt $ signed decimal
344-- | int2, int4, int8
291-- | int2, int4, int8
345instance FromField Int64 where
292instance FromField Int64 where
346− fromField = attoFieldParser ok64 $ signed decimal
293+ fromField = atto ok64 $ signed decimal
348-- | int2, int4, int8
295-- | int2, int4, int8
349instance FromField Integer where
296instance FromField Integer where
350− fromField = attoFieldParser ok64 $ signed decimal
297+ fromField = atto ok64 $ signed decimal
352−-- | int2, float4 (Uses attoparsec's 'double' routine, for
299+-- | int2, float4
353−-- better accuracy convert to 'Scientific' or 'Rational' first)
354instance FromField Float where
300instance FromField Float where
355− fromField = attoFieldParser ok (realToFrac <$> pg_double)
301+ fromField = atto ok (realToFrac <$> double)
356− where ok = eq TI.float4Oid \/ eq TI.int2Oid
302+ where ok = $(mkCompats [TI.float4,TI.int2])
358−-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
304+-- | int2, int4, float4, float8
359−-- better accuracy convert to 'Scientific' or 'Rational' first)
360instance FromField Double where
305instance FromField Double where
361− fromField = attoFieldParser ok pg_double
306+ fromField = atto ok double
362− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
307+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])
364−-- | int2, int4, int8, float4, float8, numeric
309+-- | int2, int4, float4, float8, numeric
365instance FromField (Ratio Integer) where
310instance FromField (Ratio Integer) where
366− fromField = attoFieldParser ok pg_rational
311+ fromField = atto ok rational
367− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
369−-- | int2, int4, int8, float4, float8, numeric
312+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])
370−instance FromField Scientific where
371− fromField = attoFieldParser ok rational
372− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
374unBinary :: Binary t -> t
314unBinary :: Binary t -> t
375unBinary (Binary x) = x
315unBinary (Binary x) = x
377−pg_double :: Parser Double
379− = (string "NaN" *> pure ( 0 / 0))
380− <|> (string "Infinity" *> pure ( 1 / 0))
381− <|> (string "-Infinity" *> pure (-1 / 0))
384−pg_rational :: Parser Rational
386− = (string "NaN" *> pure notANumber )
387− <|> (string "Infinity" *> pure infinity )
388− <|> (string "-Infinity" *> pure (-infinity))
391-- | bytea, name, text, \"char\", bpchar, varchar, unknown
317-- | bytea, name, text, \"char\", bpchar, varchar, unknown
392instance FromField SB.ByteString where
318instance FromField SB.ByteString where
393− fromField f dat = if typeOid f == TI.byteaOid
319+ fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
394 then unBinary <$> fromField f dat
320 then unBinary <$> fromField f dat
395− else doFromField f okText' pure dat
321+ else doFromField f okText' (pure . B.copy) dat
398instance FromField PQ.Oid where
324instance FromField PQ.Oid where
399− fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
325+ fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat
401-- | bytea, name, text, \"char\", bpchar, varchar, unknown
327-- | bytea, name, text, \"char\", bpchar, varchar, unknown
402instance FromField LB.ByteString where
328instance FromField LB.ByteString where
@@ -404,7 +330,7 @@ instance FromField LB.ByteString where
405unescapeBytea :: Field -> SB.ByteString
331unescapeBytea :: Field -> SB.ByteString
406 -> Conversion (Binary SB.ByteString)
332 -> Conversion (Binary SB.ByteString)
407−unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
333+unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
334 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
409 Just str -> pure (Binary str)
335 Just str -> pure (Binary str)
@@ -412,7 +338,7 @@ unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
412instance FromField (Binary SB.ByteString) where
338instance FromField (Binary SB.ByteString) where
413 fromField f dat = case format f of
339 fromField f dat = case format f of
414 PQ.Text -> doFromField f okBinary (unescapeBytea f) dat
340 PQ.Text -> doFromField f okBinary (unescapeBytea f) dat
415− PQ.Binary -> doFromField f okBinary (pure . Binary) dat
341+ PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat
417-- | bytea
343-- | bytea
418instance FromField (Binary LB.ByteString) where
344instance FromField (Binary LB.ByteString) where
@@ -427,85 +353,54 @@ instance FromField ST.Text where
427instance FromField LT.Text where
353instance FromField LT.Text where
428 fromField f dat = LT.fromStrict <$> fromField f dat
354 fromField f dat = LT.fromStrict <$> fromField f dat
431−instance FromField (CI ST.Text) where
432− fromField f mdat = do
435− then returnError Incompatible f ""
437− Nothing -> returnError UnexpectedNull f ""
438− Just dat -> either left (pure . CI.mk)
439− (ST.decodeUtf8' dat)
442−instance FromField (CI LT.Text) where
443− fromField f mdat = do
446− then returnError Incompatible f ""
448− Nothing -> returnError UnexpectedNull f ""
449− Just dat -> either left (pure . CI.mk . LT.fromStrict)
450− (ST.decodeUtf8' dat)
452-- | name, text, \"char\", bpchar, varchar
356-- | name, text, \"char\", bpchar, varchar
453instance FromField [Char] where
357instance FromField [Char] where
454 fromField f dat = ST.unpack <$> fromField f dat
358 fromField f dat = ST.unpack <$> fromField f dat
456-- | timestamptz
360-- | timestamptz
457instance FromField UTCTime where
361instance FromField UTCTime where
458− fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime
362+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime
460-- | timestamptz
364-- | timestamptz
461instance FromField ZonedTime where
365instance FromField ZonedTime where
462− fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime
366+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime
464-- | timestamp
368-- | timestamp
465instance FromField LocalTime where
369instance FromField LocalTime where
466− fromField = ff TI.timestampOid "LocalTime" parseLocalTime
370+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime
469instance FromField Day where
373instance FromField Day where
470− fromField = ff TI.dateOid "Day" parseDay
374+ fromField = ff $(inlineTypoid TI.date) "Day" parseDay
473instance FromField TimeOfDay where
377instance FromField TimeOfDay where
474− fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay
378+ fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay
476-- | timestamptz
380-- | timestamptz
477instance FromField UTCTimestamp where
381instance FromField UTCTimestamp where
478− fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp
382+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp
480-- | timestamptz
384-- | timestamptz
481instance FromField ZonedTimestamp where
385instance FromField ZonedTimestamp where
482− fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp
386+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp
484-- | timestamp
388-- | timestamp
485instance FromField LocalTimestamp where
389instance FromField LocalTimestamp where
486− fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp
390+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp
489instance FromField Date where
393instance FromField Date where
490− fromField = ff TI.dateOid "Date" parseDate
394+ fromField = ff $(inlineTypoid TI.date) "Date" parseDate
492−-- | interval. Requires you to configure intervalstyle as @iso_8601@.
494−-- You can configure intervalstyle on every connection with a @SET@ command,
495−-- but for better performance you may want to configure it permanently in the
496−-- file found with @SHOW config_file;@ .
498−instance FromField CalendarDiffTime where
499− fromField = ff TI.intervalOid "CalendarDiffTime" parseCalendarDiffTime
501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
396ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
502 -> Field -> Maybe B8.ByteString -> Conversion a
397 -> Field -> Maybe B8.ByteString -> Conversion a
503−ff compatOid hsType parseBS f mstr =
398+ff compatOid hsType parse f mstr =
504 if typeOid f /= compatOid
399 if typeOid f /= compatOid
505 then err Incompatible ""
400 then err Incompatible ""
506 else case mstr of
401 else case mstr of
507 Nothing -> err UnexpectedNull ""
402 Nothing -> err UnexpectedNull ""
508− Just str -> case parseBS str of
403+ Just str -> case parse str of
509 Left msg -> err ConversionFailed msg
404 Left msg -> err ConversionFailed msg
510 Right val -> return val
405 Right val -> return val
@@ -526,73 +421,43 @@ instance (FromField a, FromField b) => FromField (Either a b) where
526 <|> (Left <$> fromField f dat)
421 <|> (Left <$> fromField f dat)
528-- | any postgresql array whose elements are compatible with type @a@
423-- | any postgresql array whose elements are compatible with type @a@
529−instance (FromField a, Typeable a) => FromField (PGArray a) where
424+instance (FromField a, Typeable a) => FromField (Vector a) where
530− fromField = pgArrayFieldParser fromField
425+ fromField f mdat = do
532−pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)
533−pgArrayFieldParser fieldParser f mdat = do
534 info <- typeInfo f
426 info <- typeInfo f
535 case info of
427 case info of
536 TI.Array{} ->
428 TI.Array{} ->
537 case mdat of
429 case mdat of
538 Nothing -> returnError UnexpectedNull f ""
430 Nothing -> returnError UnexpectedNull f ""
539 Just dat -> do
431 Just dat -> do
540− case parseOnly (fromArray fieldParser info f) dat of
432+ case parseOnly (fromArray info f) dat of
541 Left err -> returnError ConversionFailed f err
433 Left err -> returnError ConversionFailed f err
542− Right conv -> PGArray <$> conv
434+ Right conv -> V.fromList <$> conv
543 _ -> returnError Incompatible f ""
435 _ -> returnError Incompatible f ""
437+fromArray :: (FromField a)
545−fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
438+ => TypeInfo -> Field -> Parser (Conversion [a])
546−fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
439+fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim
548− delim = typdelim (typelem typInfo)
441+ delim = typdelim (typelem typeInfo)
549− fElem = f{ typeOid = typoid (typelem typInfo) }
442+ fElem = f{ typeOid = typoid (typelem typeInfo) }
551− parseIt item =
443+ parseIt item = (fromField f' . Just . fmt delim) item
552− fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
554− item' = fmt delim item
555− f' | Arrays.Array _ <- item = f
444+ where f' | Arrays.Array _ <- item = f
556− | otherwise = fElem
445+ | otherwise = fElem
558−instance (FromField a, Typeable a) => FromField (Vector a) where
559− fromField f v = V.fromList . fromPGArray <$> fromField f v
561−instance (FromField a, Typeable a) => FromField (IOVector a) where
562− fromField f v = liftConversion . V.unsafeThaw =<< fromField f v
564−-- | uuid
447+-- | json
565−instance FromField UUID where
448+instance FromField JSON.Value where
566 fromField f mbs =
449 fromField f mbs =
567− if typeOid f /= TI.uuidOid
450+ if typeOid f /= $(inlineTypoid TI.json)
568 then returnError Incompatible f ""
451 then returnError Incompatible f ""
569 else case mbs of
452 else case mbs of
570 Nothing -> returnError UnexpectedNull f ""
453 Nothing -> returnError UnexpectedNull f ""
571 Just bs ->
454 Just bs ->
572− case UUID.fromASCIIBytes bs of
573− Nothing -> returnError ConversionFailed f "Invalid UUID"
574− Just uuid -> pure uuid
577−instance FromField JSON.Value where
578− fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
579− where parseBS bs = case JSON.eitherDecodeStrict' bs of
455+ case JSON.eitherDecodeStrict' bs of
580 Left err -> returnError ConversionFailed f err
456 Left err -> returnError ConversionFailed f err
581 Right val -> pure val
457 Right val -> pure val
583−-- | Return the JSON ByteString directly
586−fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
587−fromFieldJSONByteString f mbs =
588− if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
589− then returnError Incompatible f ""
591− Nothing -> returnError UnexpectedNull f ""
594-- | Parse a field to a JSON 'JSON.Value' and convert that into a
459-- | Parse a field to a JSON 'JSON.Value' and convert that into a
595−-- Haskell value using the 'JSON.FromJSON' instance.
460+-- Haskell value using 'JSON.fromJSON'.
597-- This can be used as the default implementation for the 'fromField'
462-- This can be used as the default implementation for the 'fromField'
598-- method for Haskell types that have a JSON representation in
463-- method for Haskell types that have a JSON representation in
@@ -600,66 +465,31 @@ fromFieldJSONByteString f mbs =
601-- The 'Typeable' constraint is required to show more informative
466-- The 'Typeable' constraint is required to show more informative
602-- error messages when parsing fails.
467-- error messages when parsing fails.
604−-- Note that @fromJSONField :: FieldParser ('Maybe' Foo)@ will return
605−-- @'Nothing'@ on the json @null@ value, and return an exception on SQL @null@
606−-- value. Alternatively, one could write @'optionalField' fromJSONField@
607−-- that will return @Nothing@ on SQL @null@, and otherwise will call
608−-- @fromJSONField :: FieldParser Foo@ and then return @'Just'@ the
609−-- result value, or return its exception. If one would
610−-- like to return @Nothing@ on both the SQL @null@ and json @null@ values,
611−-- one way to do it would be to write
612−-- @\\f mv -> 'Control.Monad.join' '<$>' optionalField fromJSONField f mv@
613fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
468fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
614fromJSONField f mbBs = do
469fromJSONField f mbBs = do
615 value <- fromField f mbBs
470 value <- fromField f mbBs
616− case JSON.ifromJSON value of
471+ case JSON.fromJSON value of
617− JSON.IError path err -> returnError ConversionFailed f $
472+ JSON.Error err -> returnError ConversionFailed f $
618− "JSON decoding error: " ++ (JSON.formatError path err)
473+ "JSON decoding error: " ++ err
619− JSON.ISuccess x -> pure x
474+ JSON.Success x -> pure x
621−-- | Compatible with the same set of types as @a@. Note that
622−-- modifying the 'IORef' does not have any effects outside
623−-- the local process on the local machine.
624−instance FromField a => FromField (IORef a) where
625− fromField f v = liftConversion . newIORef =<< fromField f v
627−-- | Compatible with the same set of types as @a@. Note that
628−-- modifying the 'MVar' does not have any effects outside
629−-- the local process on the local machine.
630−instance FromField a => FromField (MVar a) where
631− fromField f v = liftConversion . newMVar =<< fromField f v
633type Compat = PQ.Oid -> Bool
476type Compat = PQ.Oid -> Bool
635okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
478okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
636−okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
479+okText = $( mkCompats [ TI.name, TI.text, TI.char,
637− \/ eq TI.bpcharOid \/ eq TI.varcharOid
480+ TI.bpchar, TI.varchar ] )
638−okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
481+okText' = $( mkCompats [ TI.name, TI.text, TI.char,
639− \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid
482+ TI.bpchar, TI.varchar, TI.unknown ] )
640−okBinary = eq TI.byteaOid
483+okBinary = (== $( inlineTypoid TI.bytea ))
641−ok16 = eq TI.int2Oid
484+ok16 = (== $( inlineTypoid TI.int2 ))
642−ok32 = eq TI.int2Oid \/ eq TI.int4Oid
485+ok32 = $( mkCompats [TI.int2,TI.int4] )
643−ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid
486+ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )
644#if WORD_SIZE_IN_BITS < 64
487#if WORD_SIZE_IN_BITS < 64
645okInt = ok32
488okInt = ok32
647okInt = ok64
490okInt = ok64
650−-- | eq and \/ are used to imlement what Macro stuff did,
651−-- i.e. mkCompats and inlineTypoid
652−eq :: PQ.Oid -> PQ.Oid -> Bool
657−(\/) :: (PQ.Oid -> Bool)
660−f \/ g = \x -> f x || g x
663doFromField :: forall a . (Typeable a)
493doFromField :: forall a . (Typeable a)
664 => Field -> Compat -> (ByteString -> Conversion a)
494 => Field -> Compat -> (ByteString -> Conversion a)
665 -> Maybe ByteString -> Conversion a
495 -> Maybe ByteString -> Conversion a
@@ -684,22 +514,10 @@ returnError mkErr f msg = do
684 (show (typeOf (undefined :: a)))
514 (show (typeOf (undefined :: a)))
687−-- | Construct a field parser from an attoparsec parser. An 'Incompatible' error is thrown if the
688−-- PostgreSQL oid does not match the specified predicate.
691−-- instance FromField Int16 where
692−-- fromField = attoFieldParser ok16 (signed decimal)
696−attoFieldParser :: forall a. (Typeable a)
517+atto :: forall a. (Typeable a)
697− => (PQ.Oid -> Bool)
518+ => Compat -> Parser a -> Field -> Maybe ByteString
698− -- ^ Predicate for whether the postgresql type oid is compatible with this parser
519+ -> Conversion a
700− -- ^ An attoparsec parser.
702−attoFieldParser types p0 f dat = doFromField f types (go p0) dat
520+atto types p0 f dat = doFromField f types (go p0) dat
704 go :: Parser a -> ByteString -> Conversion a
522 go :: Parser a -> ByteString -> Conversion a