git.iko.soy/typeable/postgresql-simple
on master help sign in
Fix typoid inlining
1a390f5Leon P Smith
src/Database/PostgreSQL/Simple/FromField.hs+18−18
compare with master
unifiedsplit
@@ -242,7 +242,7 @@ instance FromField Null where
242-- | bool
242-- | bool
243instance FromField Bool where
243instance FromField Bool where
244 fromField f bs
244 fromField f bs
245− | typeOid f /= typoid (TI.bool) = returnError Incompatible f ""
245+ | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
246 | bs == Nothing = returnError UnexpectedNull f ""
246 | bs == Nothing = returnError UnexpectedNull f ""
247 | bs == Just "t" = pure True
247 | bs == Just "t" = pure True
248 | bs == Just "f" = pure False
248 | bs == Just "f" = pure False
@@ -251,7 +251,7 @@ instance FromField Bool where
251-- | \"char\"
251-- | \"char\"
252instance FromField Char where
252instance FromField Char where
253 fromField f bs =
253 fromField f bs =
254− if typeOid f /= typoid (TI.char)
254+ if typeOid f /= $(inlineTypoid TI.char)
255 then returnError Incompatible f ""
255 then returnError Incompatible f ""
256 else case bs of
256 else case bs of
257 Nothing -> returnError UnexpectedNull f ""
257 Nothing -> returnError UnexpectedNull f ""
@@ -305,13 +305,13 @@ unBinary (Binary x) = x
305
305
306-- | bytea, name, text, \"char\", bpchar, varchar, unknown
306-- | bytea, name, text, \"char\", bpchar, varchar, unknown
307instance FromField SB.ByteString where
307instance FromField SB.ByteString where
308− fromField f dat = if typeOid f == typoid TI.bytea
308+ fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
309 then unBinary <$> fromField f dat
309 then unBinary <$> fromField f dat
310 else doFromField f okText' (pure . B.copy) dat
310 else doFromField f okText' (pure . B.copy) dat
311
311
312-- | oid
312-- | oid
313instance FromField PQ.Oid where
313instance FromField PQ.Oid where
314− fromField f dat = PQ.Oid <$> atto $(mkCompat TI.oid) decimal f dat
314+ fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat
315
315
316-- | bytea, name, text, \"char\", bpchar, varchar, unknown
316-- | bytea, name, text, \"char\", bpchar, varchar, unknown
317instance FromField LB.ByteString where
317instance FromField LB.ByteString where
@@ -348,44 +348,44 @@ instance FromField [Char] where
348
348
349-- | timestamptz
349-- | timestamptz
350instance FromField UTCTime where
350instance FromField UTCTime where
351− fromField = ff TI.timestamptz "UTCTime" parseUTCTime
351+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime
352
352
353-- | timestamptz
353-- | timestamptz
354instance FromField ZonedTime where
354instance FromField ZonedTime where
355− fromField = ff TI.timestamptz "ZonedTime" parseZonedTime
355+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime
356
356
357-- | timestamp
357-- | timestamp
358instance FromField LocalTime where
358instance FromField LocalTime where
359− fromField = ff TI.timestamp "LocalTime" parseLocalTime
359+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime
360
360
361-- | date
361-- | date
362instance FromField Day where
362instance FromField Day where
363− fromField = ff TI.date "Day" parseDay
363+ fromField = ff $(inlineTypoid TI.date) "Day" parseDay
364
364
365-- | time
365-- | time
366instance FromField TimeOfDay where
366instance FromField TimeOfDay where
367− fromField = ff TI.time "TimeOfDay" parseTimeOfDay
367+ fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay
368
368
369-- | timestamptz
369-- | timestamptz
370instance FromField UTCTimestamp where
370instance FromField UTCTimestamp where
371− fromField = ff TI.timestamptz "UTCTimestamp" parseUTCTimestamp
371+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp
372
372
373-- | timestamptz
373-- | timestamptz
374instance FromField ZonedTimestamp where
374instance FromField ZonedTimestamp where
375− fromField = ff TI.timestamptz "ZonedTimestamp" parseZonedTimestamp
375+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp
376
376
377-- | timestamp
377-- | timestamp
378instance FromField LocalTimestamp where
378instance FromField LocalTimestamp where
379− fromField = ff TI.timestamp "LocalTimestamp" parseLocalTimestamp
379+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp
380
380
381-- | date
381-- | date
382instance FromField Date where
382instance FromField Date where
383− fromField = ff TI.date "Date" parseDate
383+ fromField = ff $(inlineTypoid TI.date) "Date" parseDate
384
384
385−ff :: TypeInfo -> String -> (B8.ByteString -> Either String a)
385+ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
386 -> Field -> Maybe B8.ByteString -> Conversion a
386 -> Field -> Maybe B8.ByteString -> Conversion a
387−ff pgType hsType parse f mstr =
387+ff compatOid hsType parse f mstr =
388− if typeOid f /= typoid pgType
388+ if typeOid f /= compatOid
389 then err Incompatible ""
389 then err Incompatible ""
390 else case mstr of
390 else case mstr of
391 Nothing -> err UnexpectedNull ""
391 Nothing -> err UnexpectedNull ""
@@ -440,8 +440,8 @@ okText = $( mkCompats [ TI.name, TI.text, TI.char,
440 TI.bpchar, TI.varchar ] )
440 TI.bpchar, TI.varchar ] )
441okText' = $( mkCompats [ TI.name, TI.text, TI.char,
441okText' = $( mkCompats [ TI.name, TI.text, TI.char,
442 TI.bpchar, TI.varchar, TI.unknown ] )
442 TI.bpchar, TI.varchar, TI.unknown ] )
443−okBinary = $( mkCompat TI.bytea )
443+okBinary = (== $( inlineTypoid TI.bytea ))
444−ok16 = $( mkCompat TI.int2 )
444+ok16 = (== $( inlineTypoid TI.int2 ))
445ok32 = $( mkCompats [TI.int2,TI.int4] )
445ok32 = $( mkCompats [TI.int2,TI.int4] )
446ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )
446ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )
447#if WORD_SIZE_IN_BITS < 64
447#if WORD_SIZE_IN_BITS < 64
src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs+13−7
@@ -8,31 +8,37 @@
8-- Maintainer: Leon P Smith <leon@melding-monads.com>
8-- Maintainer: Leon P Smith <leon@melding-monads.com>
9-- Stability: experimental
9-- Stability: experimental
10--
10--
11−-- A Template Haskell macro for efficiently checking membership in
11+-- A Template Haskell macro for efficiently checking membership in
12-- a set of type oids.
12-- a set of type oids.
13--
13--
14------------------------------------------------------------------------------
14------------------------------------------------------------------------------
15
15
16−module Database.PostgreSQL.Simple.TypeInfo.Macro
16+module Database.PostgreSQL.Simple.TypeInfo.Macro
17− ( mkCompat
17+ ( mkCompats
18− , mkCompats
18+ , inlineTypoid
19 ) where
19 ) where
20
20
21import Database.PostgreSQL.Simple.TypeInfo.Static
21import Database.PostgreSQL.Simple.TypeInfo.Static
22import Database.PostgreSQL.Simple.Types (Oid(..))
22import Database.PostgreSQL.Simple.Types (Oid(..))
23import Language.Haskell.TH
23import Language.Haskell.TH
24
24
25−mkCompat :: TypeInfo -> ExpQ
26−mkCompat ty = [| \(Oid x) -> x == $(litE (getTypoid ty)) |]
27
25
26+-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the
27+-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's.
28mkCompats :: [TypeInfo] -> ExpQ
28mkCompats :: [TypeInfo] -> ExpQ
29mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]
29mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]
30 where
30 where
31 alt :: TypeInfo -> MatchQ
31 alt :: TypeInfo -> MatchQ
32 alt ty = match (litP (getTypoid ty)) (normalB [| True |]) []
32 alt ty = match (litP (getTypoid ty)) (normalB [| True |]) []
33−
33+
34 catchAll :: MatchQ
34 catchAll :: MatchQ
35 catchAll = match wildP (normalB [| False |]) []
35 catchAll = match wildP (normalB [| False |]) []
36
36
37+-- | Literally substitute the value of a TypeInfo expression. Returns
38+-- an expression of type 'Oid'. Useful because GHC tends not to
39+-- fold constants.
40+inlineTypoid :: TypeInfo -> ExpQ
41+inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |]
42+
37getTypoid :: TypeInfo -> Lit
43getTypoid :: TypeInfo -> Lit
38getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x)
44getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x)