aa96786 · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on master help sign in

Eliminate BuiltinTypes from FromField

aa96786Leon P Smith13 years ago

postgresql-simple.cabal+1

compare with master

unifiedsplit

@@ -38,6 +38,7 @@ Library

38 Database.PostgreSQL.Simple.ToRow

39 Database.PostgreSQL.Simple.Transaction

40 Database.PostgreSQL.Simple.TypeInfo

41+ Database.PostgreSQL.Simple.TypeInfo.Macro

41 Database.PostgreSQL.Simple.TypeInfo.Static

42 Database.PostgreSQL.Simple.TypeInfo.Static

42 Database.PostgreSQL.Simple.Types

43 Database.PostgreSQL.Simple.Types

43 Database.PostgreSQL.Simple.Errors

44 Database.PostgreSQL.Simple.Errors

src/Database/PostgreSQL/Simple/FromField.hs+35−34

@@ -1,7 +1,7 @@

1{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}

2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}

4−{-# LANGUAGE RecordWildCards #-}

4+{-# LANGUAGE RecordWildCards, TemplateHaskell #-}

6{- |

7Module: Database.PostgreSQL.Simple.FromField

@@ -93,24 +93,22 @@ import Control.Applicative

93 ( Applicative, (<|>), (<$>), pure )

94import Control.Exception (Exception)

95import Data.Attoparsec.Char8 hiding (Result)

96−import Data.Bits ((.&.), (.|.), shiftL)

97import Data.ByteString (ByteString)

96import Data.ByteString (ByteString)

98import qualified Data.ByteString.Char8 as B

97import qualified Data.ByteString.Char8 as B

99import Data.Int (Int16, Int32, Int64)

98import Data.Int (Int16, Int32, Int64)

100−import Data.List (foldl')

101import Data.Ratio (Ratio)

99import Data.Ratio (Ratio)

102import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )

100import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )

103import Data.Typeable (Typeable, typeOf)

101import Data.Typeable (Typeable, typeOf)

104import Data.Vector (Vector)

102import Data.Vector (Vector)

105import qualified Data.Vector as V

103import qualified Data.Vector as V

106−import Data.Word (Word64)

107import Database.PostgreSQL.Simple.Internal

104import Database.PostgreSQL.Simple.Internal

108−import Database.PostgreSQL.Simple.BuiltinTypes

105+-- import Database.PostgreSQL.Simple.BuiltinTypes

109import Database.PostgreSQL.Simple.Compat

106import Database.PostgreSQL.Simple.Compat

110import Database.PostgreSQL.Simple.Ok

107import Database.PostgreSQL.Simple.Ok

111import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))

108import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))

112−import Database.PostgreSQL.Simple.TypeInfo as TypeInfo

109+import Database.PostgreSQL.Simple.TypeInfo as TI

113−import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TypeInfo

110+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI

111+import Database.PostgreSQL.Simple.TypeInfo.Macro as TI

114import Database.PostgreSQL.Simple.Time

112import Database.PostgreSQL.Simple.Time

115import Database.PostgreSQL.Simple.Arrays as Arrays

113import Database.PostgreSQL.Simple.Arrays as Arrays

116import qualified Database.PostgreSQL.LibPQ as PQ

114import qualified Database.PostgreSQL.LibPQ as PQ

@@ -243,7 +241,7 @@ instance FromField Null where

243-- | bool

241-- | bool

244instance FromField Bool where

242instance FromField Bool where

245 fromField f bs

243 fromField f bs

246− | typeOid f /= typoid (TypeInfo.bool) = returnError Incompatible f ""

244+ | typeOid f /= typoid (TI.bool) = returnError Incompatible f ""

247 | bs == Nothing = returnError UnexpectedNull f ""

245 | bs == Nothing = returnError UnexpectedNull f ""

248 | bs == Just "t" = pure True

246 | bs == Just "t" = pure True

249 | bs == Just "f" = pure False

247 | bs == Just "f" = pure False

@@ -252,7 +250,7 @@ instance FromField Bool where

252-- | \"char\"

250-- | \"char\"

253instance FromField Char where

251instance FromField Char where

254 fromField f bs =

252 fromField f bs =

255− if typeOid f /= typoid (TypeInfo.char)

253+ if typeOid f /= typoid (TI.char)

256 then returnError Incompatible f ""

254 then returnError Incompatible f ""

257 else case bs of

255 else case bs of

258 Nothing -> returnError UnexpectedNull f ""

256 Nothing -> returnError UnexpectedNull f ""

@@ -289,30 +287,30 @@ instance FromField Integer where

289-- | int2, float4

287-- | int2, float4

290instance FromField Float where

288instance FromField Float where

291 fromField = atto ok (realToFrac <$> double)

289 fromField = atto ok (realToFrac <$> double)

292− where ok = mkCompats [Float4,Int2]

290+ where ok = $(mkCompats [TI.float4,TI.int2])

293

291

294-- | int2, int4, float4, float8

292-- | int2, int4, float4, float8

295instance FromField Double where

293instance FromField Double where

296 fromField = atto ok double

294 fromField = atto ok double

297− where ok = mkCompats [Float4,Float8,Int2,Int4]

295+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])

298

296

299-- | int2, int4, float4, float8, numeric

297-- | int2, int4, float4, float8, numeric

300instance FromField (Ratio Integer) where

298instance FromField (Ratio Integer) where

301 fromField = atto ok rational

299 fromField = atto ok rational

302− where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]

300+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])

303

301

304unBinary :: Binary t -> t

302unBinary :: Binary t -> t

305unBinary (Binary x) = x

303unBinary (Binary x) = x

306

304

307-- | bytea, name, text, \"char\", bpchar, varchar, unknown

305-- | bytea, name, text, \"char\", bpchar, varchar, unknown

308instance FromField SB.ByteString where

306instance FromField SB.ByteString where

309− fromField f dat = if typeOid f == typoid TypeInfo.bytea

307+ fromField f dat = if typeOid f == typoid TI.bytea

310 then unBinary <$> fromField f dat

308 then unBinary <$> fromField f dat

311 else doFromField f okText' (pure . B.copy) dat

309 else doFromField f okText' (pure . B.copy) dat

312

310

313-- | oid

311-- | oid

314instance FromField PQ.Oid where

312instance FromField PQ.Oid where

315− fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat

313+ fromField f dat = PQ.Oid <$> atto $(mkCompat TI.oid) decimal f dat

316

314

317-- | bytea, name, text, \"char\", bpchar, varchar, unknown

315-- | bytea, name, text, \"char\", bpchar, varchar, unknown

318instance FromField LB.ByteString where

316instance FromField LB.ByteString where

@@ -349,39 +347,39 @@ instance FromField [Char] where

349

347

350-- | timestamptz

348-- | timestamptz

351instance FromField UTCTime where

349instance FromField UTCTime where

352− fromField = ff TypeInfo.timestamptz "UTCTime" parseUTCTime

350+ fromField = ff TI.timestamptz "UTCTime" parseUTCTime

353

351

354-- | timestamptz

352-- | timestamptz

355instance FromField ZonedTime where

353instance FromField ZonedTime where

356− fromField = ff TypeInfo.timestamptz "ZonedTime" parseZonedTime

354+ fromField = ff TI.timestamptz "ZonedTime" parseZonedTime

357

355

358-- | timestamp

356-- | timestamp

359instance FromField LocalTime where

357instance FromField LocalTime where

360− fromField = ff TypeInfo.timestamp "LocalTime" parseLocalTime

358+ fromField = ff TI.timestamp "LocalTime" parseLocalTime

361

359

362-- | date

360-- | date

363instance FromField Day where

361instance FromField Day where

364− fromField = ff TypeInfo.date "Day" parseDay

362+ fromField = ff TI.date "Day" parseDay

365

363

366-- | time

364-- | time

367instance FromField TimeOfDay where

365instance FromField TimeOfDay where

368− fromField = ff TypeInfo.time "TimeOfDay" parseTimeOfDay

366+ fromField = ff TI.time "TimeOfDay" parseTimeOfDay

369

367

370-- | timestamptz

368-- | timestamptz

371instance FromField UTCTimestamp where

369instance FromField UTCTimestamp where

372− fromField = ff TypeInfo.timestamptz "UTCTimestamp" parseUTCTimestamp

370+ fromField = ff TI.timestamptz "UTCTimestamp" parseUTCTimestamp

373

371

374-- | timestamptz

372-- | timestamptz

375instance FromField ZonedTimestamp where

373instance FromField ZonedTimestamp where

376− fromField = ff TypeInfo.timestamptz "ZonedTimestamp" parseZonedTimestamp

374+ fromField = ff TI.timestamptz "ZonedTimestamp" parseZonedTimestamp

377

375

378-- | timestamp

376-- | timestamp

379instance FromField LocalTimestamp where

377instance FromField LocalTimestamp where

380− fromField = ff TypeInfo.timestamp "LocalTimestamp" parseLocalTimestamp

378+ fromField = ff TI.timestamp "LocalTimestamp" parseLocalTimestamp

381

379

382-- | date

380-- | date

383instance FromField Date where

381instance FromField Date where

384− fromField = ff TypeInfo.date "Date" parseDate

382+ fromField = ff TI.date "Date" parseDate

385

383

386ff :: TypeInfo -> String -> (B8.ByteString -> Either String a)

384ff :: TypeInfo -> String -> (B8.ByteString -> Either String a)

387 -> Field -> Maybe B8.ByteString -> Conversion a

385 -> Field -> Maybe B8.ByteString -> Conversion a

@@ -415,7 +413,7 @@ instance (FromField a, Typeable a) => FromField (Vector a) where

415 fromField f mdat = do

413 fromField f mdat = do

416 info <- typeInfo f

414 info <- typeInfo f

417 case info of

415 case info of

418− TypeInfo.Array{} ->

416+ TI.Array{} ->

419 case mdat of

417 case mdat of

420 Nothing -> returnError UnexpectedNull f ""

418 Nothing -> returnError UnexpectedNull f ""

421 Just dat -> do

419 Just dat -> do

@@ -434,8 +432,9 @@ fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim

434 where f' | Arrays.Array _ <- item = f

432 where f' | Arrays.Array _ <- item = f

435 | otherwise = fElem

433 | otherwise = fElem

436

434

437−newtype Compat = Compat Word64

435+type Compat = PQ.Oid -> Bool

438

436

437+{-

439mkCompats :: [BuiltinType] -> Compat

438mkCompats :: [BuiltinType] -> Compat

440mkCompats = foldl' f (Compat 0) . map mkCompat

439mkCompats = foldl' f (Compat 0) . map mkCompat

441 where f (Compat a) (Compat b) = Compat (a .|. b)

440 where f (Compat a) (Compat b) = Compat (a .|. b)

@@ -445,14 +444,17 @@ mkCompat = Compat . shiftL 1 . fromEnum

445

444

446compat :: Compat -> Compat -> Bool

445compat :: Compat -> Compat -> Bool

447compat (Compat a) (Compat b) = a .&. b /= 0

446compat (Compat a) (Compat b) = a .&. b /= 0

447+-}

448

449okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat

450−okText = mkCompats [Name,Text,Char,BpChar,VarChar]

450+okText = $( mkCompats [ TI.name, TI.text, TI.char,

451−okText' = mkCompats [Name,Text,Char,BpChar,VarChar,Unknown]

451+ TI.bpchar, TI.varchar ] )

452−okBinary = mkCompats [ByteA]

452+okText' = $( mkCompats [ TI.name, TI.text, TI.char,

453−ok16 = mkCompats [Int2]

453+ TI.bpchar, TI.varchar, TI.unknown ] )

454+okBinary = $( mkCompat TI.bytea )

455+ok16 = $( mkCompat TI.int2 )

454−ok32 = mkCompats [Int2,Int4]

456+ok32 = $( mkCompats [TI.int2,TI.int4] )

455−ok64 = mkCompats [Int2,Int4,Int8]

457+ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )

456#if WORD_SIZE_IN_BITS < 64

458#if WORD_SIZE_IN_BITS < 64

457okInt = ok32

459okInt = ok32

458#else

460#else

@@ -462,9 +464,8 @@ okInt = ok64

462doFromField :: forall a . (Typeable a)

464doFromField :: forall a . (Typeable a)

463 => Field -> Compat -> (ByteString -> Conversion a)

465 => Field -> Compat -> (ByteString -> Conversion a)

464 -> Maybe ByteString -> Conversion a

466 -> Maybe ByteString -> Conversion a

465−doFromField f types cvt (Just bs)

467+doFromField f isCompat cvt (Just bs)

466− | Just typ <- oid2builtin (typeOid f)

468+ | isCompat (typeOid f) = cvt bs

467− , mkCompat typ `compat` types = cvt bs

468 | otherwise = returnError Incompatible f "types incompatible"

469 | otherwise = returnError Incompatible f "types incompatible"

469doFromField f _ _ _ = returnError UnexpectedNull f ""

470doFromField f _ _ _ = returnError UnexpectedNull f ""

470

471

src/Database/PostgreSQL/Simple/TypeInfo/Macro.hsnew file+38

@@ -0,0 +1,38 @@

1+{-# LANGUAGE TemplateHaskell #-}

3+------------------------------------------------------------------------------

4+-- |

5+-- Module: Database.PostgreSQL.Simple.TypeInfo.Macro

7+-- License: BSD3

8+-- Maintainer: Leon P Smith <leon@melding-monads.com>

9+-- Stability: experimental

10+--

11+-- A Template Haskell macro for efficiently checking membership in

12+-- a set of type oids.

13+--

14+------------------------------------------------------------------------------

15+

16+module Database.PostgreSQL.Simple.TypeInfo.Macro

17+ ( mkCompat

18+ , mkCompats

19+ ) where

20+

21+import Database.PostgreSQL.Simple.TypeInfo.Static

22+import Database.PostgreSQL.Simple.Types (Oid(..))

23+import Language.Haskell.TH

24+

25+mkCompat :: TypeInfo -> ExpQ

26+mkCompat ty = [| \(Oid x) -> x == $(litE (getTypoid ty)) |]

27+

28+mkCompats :: [TypeInfo] -> ExpQ

29+mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]

30+ where

31+ alt :: TypeInfo -> MatchQ

32+ alt ty = match (litP (getTypoid ty)) (normalB [| True |]) []

33+

34+ catchAll :: MatchQ

35+ catchAll = match wildP (normalB [| False |]) []

36+

37+getTypoid :: TypeInfo -> Lit

38+getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x)