git.iko.soy/typeable/postgresql-simple
on master help sign in
Fix typoid inlining

This is a bit of a kluge, but my suspicions confirmed that these constants weren't being properly folded.

commit1a390f5e1129edae493605a4101098eb844a58a7 authorLeon P Smith <leon@melding-monads.com> dateMon 19 Aug 2013, 21:22 (13 years ago) parent723f37e
2 files changed+31−25
compare with master
unifiedsplit
src/Database/PostgreSQL/Simple/FromField.hs+18−18 src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs+13−7
src/Database/PostgreSQL/Simple/FromField.hs+18−18
@@ -242,7 +242,7 @@ instance FromField Null where
242242-- | bool
243243instance FromField Bool where
244244 fromField f bs
245− | typeOid f /= typoid (TI.bool) = returnError Incompatible f ""
245+ | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
246246 | bs == Nothing = returnError UnexpectedNull f ""
247247 | bs == Just "t" = pure True
248248 | bs == Just "f" = pure False
@@ -251,7 +251,7 @@ instance FromField Bool where
251251-- | \"char\"
252252instance FromField Char where
253253 fromField f bs =
254− if typeOid f /= typoid (TI.char)
254+ if typeOid f /= $(inlineTypoid TI.char)
255255 then returnError Incompatible f ""
256256 else case bs of
257257 Nothing -> returnError UnexpectedNull f ""
@@ -305,13 +305,13 @@ unBinary (Binary x) = x
305305
306306-- | bytea, name, text, \"char\", bpchar, varchar, unknown
307307instance FromField SB.ByteString where
308− fromField f dat = if typeOid f == typoid TI.bytea
308+ fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
309309 then unBinary <$> fromField f dat
310310 else doFromField f okText' (pure . B.copy) dat
311311
312312-- | oid
313313instance 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
315315
316316-- | bytea, name, text, \"char\", bpchar, varchar, unknown
317317instance FromField LB.ByteString where
@@ -348,44 +348,44 @@ instance FromField [Char] where
348348
349349-- | timestamptz
350350instance FromField UTCTime where
351− fromField = ff TI.timestamptz "UTCTime" parseUTCTime
351+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime
352352
353353-- | timestamptz
354354instance FromField ZonedTime where
355− fromField = ff TI.timestamptz "ZonedTime" parseZonedTime
355+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime
356356
357357-- | timestamp
358358instance FromField LocalTime where
359− fromField = ff TI.timestamp "LocalTime" parseLocalTime
359+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime
360360
361361-- | date
362362instance FromField Day where
363− fromField = ff TI.date "Day" parseDay
363+ fromField = ff $(inlineTypoid TI.date) "Day" parseDay
364364
365365-- | time
366366instance FromField TimeOfDay where
367− fromField = ff TI.time "TimeOfDay" parseTimeOfDay
367+ fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay
368368
369369-- | timestamptz
370370instance FromField UTCTimestamp where
371− fromField = ff TI.timestamptz "UTCTimestamp" parseUTCTimestamp
371+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp
372372
373373-- | timestamptz
374374instance FromField ZonedTimestamp where
375− fromField = ff TI.timestamptz "ZonedTimestamp" parseZonedTimestamp
375+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp
376376
377377-- | timestamp
378378instance FromField LocalTimestamp where
379− fromField = ff TI.timestamp "LocalTimestamp" parseLocalTimestamp
379+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp
380380
381381-- | date
382382instance FromField Date where
383− fromField = ff TI.date "Date" parseDate
383+ fromField = ff $(inlineTypoid TI.date) "Date" parseDate
384384
385−ff :: TypeInfo -> String -> (B8.ByteString -> Either String a)
385+ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
386386 -> Field -> Maybe B8.ByteString -> Conversion a
387−ff pgType hsType parse f mstr =
388− if typeOid f /= typoid pgType
387+ff compatOid hsType parse f mstr =
388+ if typeOid f /= compatOid
389389 then err Incompatible ""
390390 else case mstr of
391391 Nothing -> err UnexpectedNull ""
@@ -440,8 +440,8 @@ okText = $( mkCompats [ TI.name, TI.text, TI.char,
440440 TI.bpchar, TI.varchar ] )
441441okText' = $( mkCompats [ TI.name, TI.text, TI.char,
442442 TI.bpchar, TI.varchar, TI.unknown ] )
443−okBinary = $( mkCompat TI.bytea )
444−ok16 = $( mkCompat TI.int2 )
443+okBinary = (== $( inlineTypoid TI.bytea ))
444+ok16 = (== $( inlineTypoid TI.int2 ))
445445ok32 = $( mkCompats [TI.int2,TI.int4] )
446446ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )
447447#if WORD_SIZE_IN_BITS < 64
src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs+13−7
@@ -8,31 +8,37 @@
88-- Maintainer: Leon P Smith <leon@melding-monads.com>
99-- Stability: experimental
1010--
11−-- A Template Haskell macro for efficiently checking membership in
11+-- A Template Haskell macro for efficiently checking membership in
1212-- a set of type oids.
1313--
1414------------------------------------------------------------------------------
1515
16−module Database.PostgreSQL.Simple.TypeInfo.Macro
17− ( mkCompat
18− , mkCompats
16+module Database.PostgreSQL.Simple.TypeInfo.Macro
17+ ( mkCompats
18+ , inlineTypoid
1919 ) where
2020
2121import Database.PostgreSQL.Simple.TypeInfo.Static
2222import Database.PostgreSQL.Simple.Types (Oid(..))
2323import Language.Haskell.TH
2424
25−mkCompat :: TypeInfo -> ExpQ
26−mkCompat ty = [| \(Oid x) -> x == $(litE (getTypoid ty)) |]
2725
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.
2828mkCompats :: [TypeInfo] -> ExpQ
2929mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]
3030 where
3131 alt :: TypeInfo -> MatchQ
3232 alt ty = match (litP (getTypoid ty)) (normalB [| True |]) []
33−
33+
3434 catchAll :: MatchQ
3535 catchAll = match wildP (normalB [| False |]) []
3636
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+
3743getTypoid :: TypeInfo -> Lit
3844getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x)