cc10a76 · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on master help sign in

Merge branch 'arrays' into 0.3

cc10a76Leon P Smith14 years ago

postgresql-simple.cabal+3

compare with master

unifiedsplit

@@ -21,6 +21,7 @@ Library

21 hs-source-dirs: src

22 Exposed-modules:

23 Database.PostgreSQL.Simple

24+ Database.PostgreSQL.Simple.Arrays

24 Database.PostgreSQL.Simple.BuiltinTypes

25 Database.PostgreSQL.Simple.BuiltinTypes

25 Database.PostgreSQL.Simple.FromField

26 Database.PostgreSQL.Simple.FromField

26 Database.PostgreSQL.Simple.FromRow

27 Database.PostgreSQL.Simple.FromRow

@@ -32,6 +33,7 @@ Library

32 Database.PostgreSQL.Simple.Time.Internal

33 Database.PostgreSQL.Simple.Time.Internal

33 Database.PostgreSQL.Simple.ToField

34 Database.PostgreSQL.Simple.ToField

34 Database.PostgreSQL.Simple.ToRow

35 Database.PostgreSQL.Simple.ToRow

36+ Database.PostgreSQL.Simple.TypeInfo

35 Database.PostgreSQL.Simple.Types

37 Database.PostgreSQL.Simple.Types

36-- Other-modules:

38-- Other-modules:

37 Database.PostgreSQL.Simple.Internal

39 Database.PostgreSQL.Simple.Internal

@@ -87,6 +89,7 @@ test-suite test

87 , OverloadedStrings

89 , OverloadedStrings

88 , Rank2Types

90 , Rank2Types

89 , RecordWildCards

91 , RecordWildCards

92+ , PatternGuards

91 build-depends: base

94 build-depends: base

92 , base16-bytestring

95 , base16-bytestring

src/Database/PostgreSQL/Simple.hs+35−21

@@ -4,6 +4,7 @@

4{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE ViewPatterns #-}

7+{-# LANGUAGE QuasiQuotes #-}

8------------------------------------------------------------------------------

9------------------------------------------------------------------------------

9-- |

10-- |

@@ -143,6 +144,7 @@ import Database.PostgreSQL.Simple.ToRow (ToRow(..))

143import Database.PostgreSQL.Simple.Types

144import Database.PostgreSQL.Simple.Types

144 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )

145 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )

145import Database.PostgreSQL.Simple.Internal as Base

146import Database.PostgreSQL.Simple.Internal as Base

147+import Database.PostgreSQL.Simple.SqlQQ (sql)

146import qualified Database.PostgreSQL.LibPQ as PQ

148import qualified Database.PostgreSQL.LibPQ as PQ

147import qualified Data.ByteString.Char8 as B

149import qualified Data.ByteString.Char8 as B

148import qualified Data.Text as T

150import qualified Data.Text as T

@@ -552,19 +554,19 @@ finishQuery conn q result = do

552 PQ.TuplesOk -> do

554 PQ.TuplesOk -> do

553 ncols <- PQ.nfields result

555 ncols <- PQ.nfields result

554 let unCol (PQ.Col x) = fromIntegral x :: Int

556 let unCol (PQ.Col x) = fromIntegral x :: Int

555− typenames <- V.generateM (unCol ncols)

557+ typeinfos <- V.generateM (unCol ncols)

556 (\(PQ.Col . fromIntegral -> col) -> do

558 (\(PQ.Col . fromIntegral -> col) -> do

557− getTypename conn =<< PQ.ftype result col)

559+ getTypeInfo conn =<< PQ.ftype result col)

558 nrows <- PQ.ntuples result

560 nrows <- PQ.ntuples result

559 ncols <- PQ.nfields result

561 ncols <- PQ.nfields result

560 forM' 0 (nrows-1) $ \row -> do

562 forM' 0 (nrows-1) $ \row -> do

561− let rw = Row row typenames result

563+ let rw = Row row typeinfos result

562 case runStateT (runReaderT (unRP fromRow) rw) 0 of

564 case runStateT (runReaderT (unRP fromRow) rw) 0 of

563 Ok (val,col) | col == ncols -> return val

565 Ok (val,col) | col == ncols -> return val

564 | otherwise -> do

566 | otherwise -> do

565 vals <- forM' 0 (ncols-1) $ \c -> do

567 vals <- forM' 0 (ncols-1) $ \c -> do

566 v <- PQ.getvalue result row c

568 v <- PQ.getvalue result row c

567− return ( typenames V.! unCol c

569+ return ( typeinfos V.! unCol c

568 , fmap ellipsis v )

570 , fmap ellipsis v )

569 throw (ConversionFailed

571 throw (ConversionFailed

570 (show (unCol ncols) ++ " values: " ++ show vals)

572 (show (unCol ncols) ++ " values: " ++ show vals)

@@ -1015,24 +1017,36 @@ fmtError msg q xs = throw FormatError {

1015-- wrong results. In such cases, write a @newtype@ wrapper and a

1017-- wrong results. In such cases, write a @newtype@ wrapper and a

1016-- custom 'Result' instance to handle your encoding.

1018-- custom 'Result' instance to handle your encoding.

1017

1019

1018−getTypename :: Connection -> PQ.Oid -> IO ByteString

1020+getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo

1019−getTypename conn@Connection{..} oid =

1021+getTypeInfo conn@Connection{..} oid =

1020 case oid2typname oid of

1022 case oid2typname oid of

1021− Just name -> return name

1023+ Just name -> return $! TypeInfo { typ = NamedOid oid name

1024+ , typelem = Nothing

1025+ }

1022 Nothing -> modifyMVar connectionObjects $ \oidmap -> do

1026 Nothing -> modifyMVar connectionObjects $ \oidmap -> do

1023 case IntMap.lookup (oid2int oid) oidmap of

1027 case IntMap.lookup (oid2int oid) oidmap of

1024− Just name -> return (oidmap, name)

1028+ Just typeinfo -> return (oidmap, typeinfo)

1025 Nothing -> do

1029 Nothing -> do

1026− names <- query conn "SELECT typname FROM pg_type WHERE oid=?"

1030+ names <- query conn

1031+ [sql| SELECT p.oid, p.typname, c.oid, c.typname

1032+ FROM pg_type AS p LEFT OUTER JOIN pg_type AS c

1033+ ON c.oid = p.typelem

1034+ WHERE p.oid = ?

1027− (Only oid)

1035+ |] (Only oid)

1028− name <- case names of

1036+ typinf <- case names of

1029− [] -> return $ throw SqlError {

1037+ [] -> return $ throw SqlError {

1030− sqlNativeError = -1,

1038+ sqlNativeError = -1,

1031− sqlErrorMsg = "invalid type oid",

1039+ sqlErrorMsg = "invalid type oid",

1032− sqlState = ""

1040+ sqlState = ""

1033− }

1041+ }

1034− [Only x] -> return x

1042+ [(pOid, pTypName, mbCOid, mbCTypName)] ->

1043+ return $! TypeInfo { typ = NamedOid pOid pTypName

1044+ , typelem = do

1045+ cOid <- mbCOid

1046+ cTypName <- mbCTypName

1047+ return $ NamedOid cOid cTypName

1048+ }

1035− _ -> fail "typename query returned more than one result"

1049+ _ -> fail "typename query returned more than one result"

1036− -- oid is a primary key, so the query should

1050+ -- oid is a primary key, so the query should

1037− -- never return more than one result

1051+ -- never return more than one result

1038− return (IntMap.insert (oid2int oid) name oidmap, name)

1052+ return (IntMap.insert (oid2int oid) typinf oidmap, typinf)

src/Database/PostgreSQL/Simple/Arrays.hsnew file+94

@@ -0,0 +1,94 @@

1+{-# LANGUAGE PatternGuards #-}

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

4+-- |

5+-- Module: Database.PostgreSQL.Simple.Arrays

7+-- License: BSD3

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

9+-- Stability: experimental

10+-- Portability: portable

11+--

12+-- A Postgres array parser and pretty-printer.

13+------------------------------------------------------------------------------

14+

15+module Database.PostgreSQL.Simple.Arrays where

16+

17+import Control.Applicative (Applicative(..), Alternative(..), (<$>))

18+import Data.ByteString.Char8 (ByteString)

19+import qualified Data.ByteString.Char8 as B

20+import Data.Monoid

21+import Data.Attoparsec.Char8

22+

23+

24+-- | Parse one of three primitive field formats: array, quoted and plain.

25+arrayFormat :: Char -> Parser ArrayFormat

26+arrayFormat delim = Array <$> array delim

27+ <|> Plain <$> plain delim

28+ <|> Quoted <$> quoted

29+

30+data ArrayFormat = Array [ArrayFormat]

31+ | Plain ByteString

32+ | Quoted ByteString

33+ deriving (Eq, Show, Ord)

34+

35+array :: Char -> Parser [ArrayFormat]

36+array delim = char '{' *> option [] (arrays <|> strings) <* char '}'

37+ where

38+ strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim)

39+ arrays = sepBy1 (Array <$> array delim) (char ',')

40+ -- NB: Arrays seem to always be delimited by commas.

41+

42+-- | Recognizes a quoted string.

43+quoted :: Parser ByteString

44+quoted = char '"' *> option "" contents <* char '"'

45+ where

46+ esc = char '\\' *> (char '\\' <|> char '"')

47+ unQ = takeWhile1 (notInClass "\"\\")

48+ contents = mconcat <$> many (unQ <|> B.singleton <$> esc)

49+

50+-- | Recognizes a plain string literal, not containing quotes or brackets and

51+-- not containing the delimiter character.

52+plain :: Char -> Parser ByteString

53+plain delim = takeWhile1 (notInClass (delim:"\"{}"))

54+

55+-- Mutually recursive 'fmt' and 'delimit' separate out value formatting

56+-- from the subtleties of delimiting.

57+

58+-- | Format an array format item, using the delimiter character if the item is

59+-- itself an array.

60+fmt :: Char -> ArrayFormat -> ByteString

61+fmt = fmt' False

62+

63+-- | Format a list of array format items, inserting the appropriate delimiter

64+-- between them. When the items are arrays, they will be delimited with

65+-- commas; otherwise, they are delimited with the passed-in-delimiter.

66+delimit :: Char -> [ArrayFormat] -> ByteString

67+delimit _ [] = ""

68+delimit c [x] = fmt' True c x

69+delimit c (x:y:z) = fmt' True c x `B.snoc` c' `mappend` delimit c (y:z)

70+ where

71+ c' | Array _ <- x = ','

72+ | otherwise = c

73+

74+-- | Format an array format item, using the delimiter character if the item is

75+-- itself an array, optionally applying quoting rules. Creates copies for

76+-- safety when used in 'FromField' instances.

77+fmt' :: Bool -> Char -> ArrayFormat -> ByteString

78+fmt' quoting c x =

79+ case x of

80+ Array items -> '{' `B.cons` delimit c items `B.snoc` '}'

81+ Plain bytes -> B.copy bytes

82+ Quoted q | quoting -> '"' `B.cons` esc q `B.snoc` '"'

83+ | otherwise -> B.copy q

84+ -- NB: The 'snoc' and 'cons' functions always copy.

85+

86+-- | Escape a string according to Postgres double-quoted string format.

87+esc :: ByteString -> ByteString

88+esc = B.concatMap f

89+ where

90+ f '"' = "\\\""

91+ f '\\' = "\\\\"

92+ f c = B.singleton c

93+ -- TODO: Implement easy performance improvements with unfoldr.

94+

src/Database/PostgreSQL/Simple/FromField.hs+20−1

@@ -53,15 +53,19 @@ import Data.ByteString (ByteString)

53import qualified Data.ByteString.Char8 as B

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

55import Data.List (foldl')

56+import Data.Maybe (fromMaybe)

56import Data.Ratio (Ratio)

57import Data.Ratio (Ratio)

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

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

58import Data.Typeable (Typeable, typeOf)

59import Data.Typeable (Typeable, typeOf)

60+import Data.Vector (Vector)

61+import qualified Data.Vector as V

59import Data.Word (Word64)

62import Data.Word (Word64)

60import Database.PostgreSQL.Simple.Internal

63import Database.PostgreSQL.Simple.Internal

61import Database.PostgreSQL.Simple.BuiltinTypes

64import Database.PostgreSQL.Simple.BuiltinTypes

62import Database.PostgreSQL.Simple.Ok

65import Database.PostgreSQL.Simple.Ok

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

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

64import Database.PostgreSQL.Simple.Time

67import Database.PostgreSQL.Simple.Time

68+import Database.PostgreSQL.Simple.Arrays

65import qualified Database.PostgreSQL.LibPQ as PQ

69import qualified Database.PostgreSQL.LibPQ as PQ

66import System.IO.Unsafe (unsafePerformIO)

70import System.IO.Unsafe (unsafePerformIO)

67import qualified Data.ByteString as SB

71import qualified Data.ByteString as SB

@@ -241,6 +245,21 @@ instance (FromField a, FromField b) => FromField (Either a b) where

241 fromField f dat = (Right <$> fromField f dat)

245 fromField f dat = (Right <$> fromField f dat)

242 <|> (Left <$> fromField f dat)

246 <|> (Left <$> fromField f dat)

243

247

248+instance (FromField a, Typeable a) => FromField (Vector a) where

249+ fromField f dat = either (returnError ConversionFailed f)

250+ (V.fromList <$>)

251+ (parseOnly (fromArray ',' f) (maybe "" id dat))

252+

253+fromArray :: (FromField a) => Char -> Field -> Parser (Ok [a])

254+fromArray delim f = sequence . (parseIt <$>) <$> array delim

255+ where

256+ fElem = f{ typeinfo = TypeInfo tElem Nothing }

257+ tInfo = typeinfo f

258+ tElem = fromMaybe (typ tInfo) (typelem tInfo)

259+ parseIt item = (fromField f' . Just . fmt delim) item

260+ where f' | Array _ <- item = f

261+ | otherwise = fElem

262+

244newtype Compat = Compat Word64

263newtype Compat = Compat Word64

245

264

246mkCompats :: [BuiltinType] -> Compat

265mkCompats :: [BuiltinType] -> Compat

@@ -270,7 +289,7 @@ doFromField :: forall a . (Typeable a)

270 => Field -> Compat -> (ByteString -> Ok a)

289 => Field -> Compat -> (ByteString -> Ok a)

271 -> Maybe ByteString -> Ok a

290 -> Maybe ByteString -> Ok a

272doFromField f types cvt (Just bs)

291doFromField f types cvt (Just bs)

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

292+ | Just typ <- oid2builtin (typoid $ typ $ typeinfo f)

274 , mkCompat typ `compat` types = cvt bs

293 , mkCompat typ `compat` types = cvt bs

275 | otherwise = returnError Incompatible f "types incompatible"

294 | otherwise = returnError Incompatible f "types incompatible"

276doFromField f _ _ _ = returnError UnexpectedNull f ""

295doFromField f _ _ _ = returnError UnexpectedNull f ""

src/Database/PostgreSQL/Simple/FromRow.hs+3−3

@@ -68,13 +68,13 @@ class FromRow a where

68fieldWith :: FieldParser a -> RowParser a

69fieldWith fieldP = RP $ do

70 let unCol (PQ.Col x) = fromIntegral x :: Int

71− Row{..} <- ask

71+ r@Row{..} <- ask

72 column <- lift get

73 lift (put (column + 1))

74 let ncols = nfields rowresult

75 if (column >= ncols)

76 then do

77− let vals = map (\c -> ( typenames ! (unCol c)

77+ let vals = map (\c -> ( typenames r ! (unCol c)

78 , fmap ellipsis (getvalue rowresult row c) ))

79 [0..ncols-1]

80 convertError = ConversionFailed

@@ -85,7 +85,7 @@ fieldWith fieldP = RP $ do

85 \convert and number in target type"

86 lift (lift (Errors [SomeException convertError]))

87 else do

88− let typename = typenames ! unCol column

88+ let typeinfo = typeinfos ! unCol column

89 result = rowresult

90 field = Field{..}

91 lift (lift (fieldP field (getvalue result row column)))

src/Database/PostgreSQL/Simple/Internal.hs+18−5

@@ -52,9 +52,20 @@ import System.IO.Unsafe (unsafePerformIO)

52data Field = Field {

53 result :: !PQ.Result

54 , column :: {-# UNPACK #-} !PQ.Column

55− , typename :: !ByteString

55+ , typeinfo :: !TypeInfo

56 }

58+data NamedOid = NamedOid { typoid :: !PQ.Oid

59+ , typname :: !ByteString

60+ } deriving Show

61+

62+data TypeInfo = TypeInfo { typ :: !NamedOid

63+ , typelem :: !(Maybe NamedOid)

64+ } deriving Show

65+

66+typename :: Field -> ByteString

67+typename = typname . typ . typeinfo

68+

58name :: Field -> Maybe ByteString

69name :: Field -> Maybe ByteString

59name Field{..} = unsafePerformIO (PQ.fname result column)

70name Field{..} = unsafePerformIO (PQ.fname result column)

@@ -71,12 +82,11 @@ format :: Field -> PQ.Format

71format Field{..} = unsafePerformIO (PQ.fformat result column)

82format Field{..} = unsafePerformIO (PQ.fformat result column)

73typeOid :: Field -> PQ.Oid

84typeOid :: Field -> PQ.Oid

74−typeOid Field{..} = unsafePerformIO (PQ.ftype result column)

85+typeOid = typoid . typ . typeinfo

75−

77data Connection = Connection {

87data Connection = Connection {

78 connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)

88 connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)

79− , connectionObjects :: {-# UNPACK #-} !(MVar (IntMap.IntMap ByteString))

89+ , connectionObjects :: {-# UNPACK #-} !(MVar (IntMap.IntMap TypeInfo))

80 }

90 }

82data SqlType

92data SqlType

@@ -301,10 +311,13 @@ newNullConnection = do

301

311

302data Row = Row {

312data Row = Row {

303 row :: {-# UNPACK #-} !PQ.Row

313 row :: {-# UNPACK #-} !PQ.Row

304− , typenames :: !(V.Vector ByteString)

314+ , typeinfos :: !(V.Vector TypeInfo)

305 , rowresult :: !PQ.Result

315 , rowresult :: !PQ.Result

306 }

316 }

307

317

318+typenames :: Row -> V.Vector ByteString

319+typenames = V.map (typname . typ) . typeinfos

320+

308newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a }

321newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a }

309 deriving ( Functor, Applicative, Alternative, Monad )

322 deriving ( Functor, Applicative, Alternative, Monad )

310

323

src/Database/PostgreSQL/Simple/ToField.hs+10

@@ -39,6 +39,8 @@ import qualified Data.ByteString.Lazy as LB

39import qualified Data.Text as ST

40import qualified Data.Text.Encoding as ST

41import qualified Data.Text.Lazy as LT

42+import Data.Vector (Vector)

43+import qualified Data.Vector as V

42import qualified Database.PostgreSQL.LibPQ as PQ

44import qualified Database.PostgreSQL.LibPQ as PQ

43import Database.PostgreSQL.Simple.Time

45import Database.PostgreSQL.Simple.Time

@@ -221,6 +223,14 @@ instance ToField Date where

221 toField = Plain . inQuotes . dateToBuilder

223 toField = Plain . inQuotes . dateToBuilder

222 {-# INLINE toField #-}

224 {-# INLINE toField #-}

223

225

226+instance (ToField a) => ToField (Vector a) where

227+ toField xs = Many $

228+ Plain (fromByteString "ARRAY[") :

229+ (intersperse (Plain (fromChar ',')) . map toField $ V.toList xs) ++

230+ [Plain (fromChar ']')]

231+ -- Because the ARRAY[...] input syntax is being used, it is possible

232+ -- that the use of type-specific separator characters is unnecessary.

233+

224-- | Surround a string with single-quote characters: \"@'@\"

234-- | Surround a string with single-quote characters: \"@'@\"

225--

235--

226-- This function /does not/ perform any other escaping.

236-- This function /does not/ perform any other escaping.

src/Database/PostgreSQL/Simple/TypeInfo.hsnew file+538

@@ -0,0 +1,538 @@

1+------------------------------------------------------------------------------

2+-- |

3+-- Module: Database.PostgreSQL.Simple.TypeInfo

5+-- License: BSD3

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

7+-- Stability: experimental

8+--

9+------------------------------------------------------------------------------

10+

11+-- Note that this file is generated by tools/GenTypeInfo.hs, and should

12+-- not be edited directly

13+

14+module Database.PostgreSQL.Simple.TypeInfo

15+ ( TypeInfo(..)

16+ , staticTypeInfo

17+ , bool

18+ , bytea

19+ , char

20+ , name

21+ , int8

22+ , int2

23+ , int4

24+ , regproc

25+ , text

26+ , oid

27+ , tid

28+ , xid

29+ , cid

30+ , xml

31+ , point

32+ , lseg

33+ , path

34+ , box

35+ , polygon

36+ , line

37+ , cidr

38+ , float4

39+ , float8

40+ , abstime

41+ , reltime

42+ , tinterval

43+ , unknown

44+ , circle

45+ , money

46+ , macaddr

47+ , inet

48+ , bpchar

49+ , varchar

50+ , date

51+ , time

52+ , timestamp

53+ , timestamptz

54+ , interval

55+ , timetz

56+ , bit

57+ , varbit

58+ , numeric

59+ , refcursor

60+ , record

61+ , void

62+ , uuid

63+ ) where

64+

65+import Data.ByteString (ByteString)

66+import Database.PostgreSQL.LibPQ (Oid(..))

67+

68+data TypeInfo = TypeInfo

69+ { typoid :: {-# UNPACK #-} !Oid

70+ , typcategory :: {-# UNPACK #-} !Char

71+ , typdelim :: {-# UNPACK #-} !Char

72+ , typelem :: !(Maybe TypeInfo)

73+ , typname :: !ByteString

74+ }

75+

76+staticTypeInfo :: Oid -> Maybe TypeInfo

77+staticTypeInfo (Oid x) = case x of

78+ 16 -> Just bool

79+ 17 -> Just bytea

80+ 18 -> Just char

81+ 19 -> Just name

82+ 20 -> Just int8

83+ 21 -> Just int2

84+ 23 -> Just int4

85+ 24 -> Just regproc

86+ 25 -> Just text

87+ 26 -> Just oid

88+ 27 -> Just tid

89+ 28 -> Just xid

90+ 29 -> Just cid

91+ 142 -> Just xml

92+ 600 -> Just point

93+ 601 -> Just lseg

94+ 602 -> Just path

95+ 603 -> Just box

96+ 604 -> Just polygon

97+ 628 -> Just line

98+ 650 -> Just cidr

99+ 700 -> Just float4

100+ 701 -> Just float8

101+ 702 -> Just abstime

102+ 703 -> Just reltime

103+ 704 -> Just tinterval

104+ 705 -> Just unknown

105+ 718 -> Just circle

106+ 790 -> Just money

107+ 829 -> Just macaddr

108+ 869 -> Just inet

109+ 1042 -> Just bpchar

110+ 1043 -> Just varchar

111+ 1082 -> Just date

112+ 1083 -> Just time

113+ 1114 -> Just timestamp

114+ 1184 -> Just timestamptz

115+ 1186 -> Just interval

116+ 1266 -> Just timetz

117+ 1560 -> Just bit

118+ 1562 -> Just varbit

119+ 1700 -> Just numeric

120+ 1790 -> Just refcursor

121+ 2249 -> Just record

122+ 2278 -> Just void

123+ 2950 -> Just uuid

124+ _ -> Nothing

125+

126+bool :: TypeInfo

127+bool = TypeInfo {

128+ typoid = Oid 16,

129+ typcategory = 'B',

130+ typdelim = ',',

131+ typelem = Nothing,

132+ typname = "bool"

133+ }

134+

135+bytea :: TypeInfo

136+bytea = TypeInfo {

137+ typoid = Oid 17,

138+ typcategory = 'U',

139+ typdelim = ',',

140+ typelem = Nothing,

141+ typname = "bytea"

142+ }

143+

144+char :: TypeInfo

145+char = TypeInfo {

146+ typoid = Oid 18,

147+ typcategory = 'S',

148+ typdelim = ',',

149+ typelem = Nothing,

150+ typname = "char"

151+ }

152+

153+name :: TypeInfo

154+name = TypeInfo {

155+ typoid = Oid 19,

156+ typcategory = 'S',

157+ typdelim = ',',

158+ typelem = Just char,

159+ typname = "name"

160+ }

161+

162+int8 :: TypeInfo

163+int8 = TypeInfo {

164+ typoid = Oid 20,

165+ typcategory = 'N',

166+ typdelim = ',',

167+ typelem = Nothing,

168+ typname = "int8"

169+ }

170+

171+int2 :: TypeInfo

172+int2 = TypeInfo {

173+ typoid = Oid 21,

174+ typcategory = 'N',

175+ typdelim = ',',

176+ typelem = Nothing,

177+ typname = "int2"

178+ }

179+

180+int4 :: TypeInfo

181+int4 = TypeInfo {

182+ typoid = Oid 23,

183+ typcategory = 'N',

184+ typdelim = ',',

185+ typelem = Nothing,

186+ typname = "int4"

187+ }

188+

189+regproc :: TypeInfo

190+regproc = TypeInfo {

191+ typoid = Oid 24,

192+ typcategory = 'N',

193+ typdelim = ',',

194+ typelem = Nothing,

195+ typname = "regproc"

196+ }

197+

198+text :: TypeInfo

199+text = TypeInfo {

200+ typoid = Oid 25,

201+ typcategory = 'S',

202+ typdelim = ',',

203+ typelem = Nothing,

204+ typname = "text"

205+ }

206+

207+oid :: TypeInfo

208+oid = TypeInfo {

209+ typoid = Oid 26,

210+ typcategory = 'N',

211+ typdelim = ',',

212+ typelem = Nothing,

213+ typname = "oid"

214+ }

215+

216+tid :: TypeInfo

217+tid = TypeInfo {

218+ typoid = Oid 27,

219+ typcategory = 'U',

220+ typdelim = ',',

221+ typelem = Nothing,

222+ typname = "tid"

223+ }

224+

225+xid :: TypeInfo

226+xid = TypeInfo {

227+ typoid = Oid 28,

228+ typcategory = 'U',

229+ typdelim = ',',

230+ typelem = Nothing,

231+ typname = "xid"

232+ }

233+

234+cid :: TypeInfo

235+cid = TypeInfo {

236+ typoid = Oid 29,

237+ typcategory = 'U',

238+ typdelim = ',',

239+ typelem = Nothing,

240+ typname = "cid"

241+ }

242+

243+xml :: TypeInfo

244+xml = TypeInfo {

245+ typoid = Oid 142,

246+ typcategory = 'U',

247+ typdelim = ',',

248+ typelem = Nothing,

249+ typname = "xml"

250+ }

251+

252+point :: TypeInfo

253+point = TypeInfo {

254+ typoid = Oid 600,

255+ typcategory = 'G',

256+ typdelim = ',',

257+ typelem = Just float8,

258+ typname = "point"

259+ }

260+

261+lseg :: TypeInfo

262+lseg = TypeInfo {

263+ typoid = Oid 601,

264+ typcategory = 'G',

265+ typdelim = ',',

266+ typelem = Just point,

267+ typname = "lseg"

268+ }

269+

270+path :: TypeInfo

271+path = TypeInfo {

272+ typoid = Oid 602,

273+ typcategory = 'G',

274+ typdelim = ',',

275+ typelem = Nothing,

276+ typname = "path"

277+ }

278+

279+box :: TypeInfo

280+box = TypeInfo {

281+ typoid = Oid 603,

282+ typcategory = 'G',

283+ typdelim = ';',

284+ typelem = Just point,

285+ typname = "box"

286+ }

287+

288+polygon :: TypeInfo

289+polygon = TypeInfo {

290+ typoid = Oid 604,

291+ typcategory = 'G',

292+ typdelim = ',',

293+ typelem = Nothing,

294+ typname = "polygon"

295+ }

296+

297+line :: TypeInfo

298+line = TypeInfo {

299+ typoid = Oid 628,

300+ typcategory = 'G',

301+ typdelim = ',',

302+ typelem = Just float8,

303+ typname = "line"

304+ }

305+

306+cidr :: TypeInfo

307+cidr = TypeInfo {

308+ typoid = Oid 650,

309+ typcategory = 'I',

310+ typdelim = ',',

311+ typelem = Nothing,

312+ typname = "cidr"

313+ }

314+

315+float4 :: TypeInfo

316+float4 = TypeInfo {

317+ typoid = Oid 700,

318+ typcategory = 'N',

319+ typdelim = ',',

320+ typelem = Nothing,

321+ typname = "float4"

322+ }

323+

324+float8 :: TypeInfo

325+float8 = TypeInfo {

326+ typoid = Oid 701,

327+ typcategory = 'N',

328+ typdelim = ',',

329+ typelem = Nothing,

330+ typname = "float8"

331+ }

332+

333+abstime :: TypeInfo

334+abstime = TypeInfo {

335+ typoid = Oid 702,

336+ typcategory = 'D',

337+ typdelim = ',',

338+ typelem = Nothing,

339+ typname = "abstime"

340+ }

341+

342+reltime :: TypeInfo

343+reltime = TypeInfo {

344+ typoid = Oid 703,

345+ typcategory = 'T',

346+ typdelim = ',',

347+ typelem = Nothing,

348+ typname = "reltime"

349+ }

350+

351+tinterval :: TypeInfo

352+tinterval = TypeInfo {

353+ typoid = Oid 704,

354+ typcategory = 'T',

355+ typdelim = ',',

356+ typelem = Nothing,

357+ typname = "tinterval"

358+ }

359+

360+unknown :: TypeInfo

361+unknown = TypeInfo {

362+ typoid = Oid 705,

363+ typcategory = 'X',

364+ typdelim = ',',

365+ typelem = Nothing,

366+ typname = "unknown"

367+ }

368+

369+circle :: TypeInfo

370+circle = TypeInfo {

371+ typoid = Oid 718,

372+ typcategory = 'G',

373+ typdelim = ',',

374+ typelem = Nothing,

375+ typname = "circle"

376+ }

377+

378+money :: TypeInfo

379+money = TypeInfo {

380+ typoid = Oid 790,

381+ typcategory = 'N',

382+ typdelim = ',',

383+ typelem = Nothing,

384+ typname = "money"

385+ }

386+

387+macaddr :: TypeInfo

388+macaddr = TypeInfo {

389+ typoid = Oid 829,

390+ typcategory = 'U',

391+ typdelim = ',',

392+ typelem = Nothing,

393+ typname = "macaddr"

394+ }

395+

396+inet :: TypeInfo

397+inet = TypeInfo {

398+ typoid = Oid 869,

399+ typcategory = 'I',

400+ typdelim = ',',

401+ typelem = Nothing,

402+ typname = "inet"

403+ }

404+

405+bpchar :: TypeInfo

406+bpchar = TypeInfo {

407+ typoid = Oid 1042,

408+ typcategory = 'S',

409+ typdelim = ',',

410+ typelem = Nothing,

411+ typname = "bpchar"

412+ }

413+

414+varchar :: TypeInfo

415+varchar = TypeInfo {

416+ typoid = Oid 1043,

417+ typcategory = 'S',

418+ typdelim = ',',

419+ typelem = Nothing,

420+ typname = "varchar"

421+ }

422+

423+date :: TypeInfo

424+date = TypeInfo {

425+ typoid = Oid 1082,

426+ typcategory = 'D',

427+ typdelim = ',',

428+ typelem = Nothing,

429+ typname = "date"

430+ }

431+

432+time :: TypeInfo

433+time = TypeInfo {

434+ typoid = Oid 1083,

435+ typcategory = 'D',

436+ typdelim = ',',

437+ typelem = Nothing,

438+ typname = "time"

439+ }

440+

441+timestamp :: TypeInfo

442+timestamp = TypeInfo {

443+ typoid = Oid 1114,

444+ typcategory = 'D',

445+ typdelim = ',',

446+ typelem = Nothing,

447+ typname = "timestamp"

448+ }

449+

450+timestamptz :: TypeInfo

451+timestamptz = TypeInfo {

452+ typoid = Oid 1184,

453+ typcategory = 'D',

454+ typdelim = ',',

455+ typelem = Nothing,

456+ typname = "timestamptz"

457+ }

458+

459+interval :: TypeInfo

460+interval = TypeInfo {

461+ typoid = Oid 1186,

462+ typcategory = 'T',

463+ typdelim = ',',

464+ typelem = Nothing,

465+ typname = "interval"

466+ }

467+

468+timetz :: TypeInfo

469+timetz = TypeInfo {

470+ typoid = Oid 1266,

471+ typcategory = 'D',

472+ typdelim = ',',

473+ typelem = Nothing,

474+ typname = "timetz"

475+ }

476+

477+bit :: TypeInfo

478+bit = TypeInfo {

479+ typoid = Oid 1560,

480+ typcategory = 'V',

481+ typdelim = ',',

482+ typelem = Nothing,

483+ typname = "bit"

484+ }

485+

486+varbit :: TypeInfo

487+varbit = TypeInfo {

488+ typoid = Oid 1562,

489+ typcategory = 'V',

490+ typdelim = ',',

491+ typelem = Nothing,

492+ typname = "varbit"

493+ }

494+

495+numeric :: TypeInfo

496+numeric = TypeInfo {

497+ typoid = Oid 1700,

498+ typcategory = 'N',

499+ typdelim = ',',

500+ typelem = Nothing,

501+ typname = "numeric"

502+ }

503+

504+refcursor :: TypeInfo

505+refcursor = TypeInfo {

506+ typoid = Oid 1790,

507+ typcategory = 'U',

508+ typdelim = ',',

509+ typelem = Nothing,

510+ typname = "refcursor"

511+ }

512+

513+record :: TypeInfo

514+record = TypeInfo {

515+ typoid = Oid 2249,

516+ typcategory = 'P',

517+ typdelim = ',',

518+ typelem = Nothing,

519+ typname = "record"

520+ }

521+

522+void :: TypeInfo

523+void = TypeInfo {

524+ typoid = Oid 2278,

525+ typcategory = 'P',

526+ typdelim = ',',

527+ typelem = Nothing,

528+ typname = "void"

529+ }

530+

531+uuid :: TypeInfo

532+uuid = TypeInfo {

533+ typoid = Oid 2950,

534+ typcategory = 'U',

535+ typdelim = ',',

536+ typelem = Nothing,

537+ typname = "uuid"

538+ }

tools/GenTypeInfo.hsnew file+256

@@ -0,0 +1,256 @@

1+------------------------------------------------------------------------------

2+-- |

3+-- Module: GenTypeInfo

5+-- License: BSD3

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

7+-- Stability: experimental

8+--

9+-- Queries a PostgreSQL database for the Object IDs and other type

10+-- information associated with typenames, and generates a module with

11+-- data constants representing part of the pg_type table.

12+--

13+-- Note that only some of the built-in types have stable type OIDs, and

14+-- thus a TypeInfo module that contains user-defined types is liable to

15+-- not work across different database instances. For these types, it is

16+-- better for `FromField` to use the `typeinfo` operator that works for

17+-- any type, whether or not it is in this module.

18+--

19+-- `typeinfo` works because postgresql-simple will dynamically query

20+-- the pg_types table the first time it receives a type OID it doesn't

21+-- know about. It then constructs a TypeInfo record and stores it in

22+-- a per-connection cache for later use.

23+--

24+------------------------------------------------------------------------------

25+

26+{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}

27+

28+module GenBuiltinTypes where

29+

30+import Prelude hiding ((++), concat)

31+

32+import StringsQQ

33+import Control.Arrow((&&&))

34+import Control.Applicative

35+import Control.Exception(bracket)

36+import Database.PostgreSQL.Simple

37+import Database.PostgreSQL.Simple.FromRow

38+import Database.PostgreSQL.Simple.Ok

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

40+import Database.PostgreSQL.Simple.SqlQQ

41+import qualified Data.ByteString.Char8 as B

42+import Data.ByteString(ByteString)

43+import qualified Data.ByteString.Lazy as L

44+import qualified Blaze.ByteString.Builder as Blaze

45+import qualified Blaze.ByteString.Builder.ByteString as Blaze

46+import qualified Blaze.ByteString.Builder.Char8 as Blaze

47+import Data.String

48+import Data.List ( sort, intersperse )

49+import qualified Data.Map as Map

50+

51+import Data.Monoid

52+

53+(++) :: Monoid a => a -> a -> a

54+(++) = mappend

55+infixr 5 ++

56+

57+concat :: Monoid a => [a] -> a

58+concat = mconcat

59+

60+data TypeInfo = TypeInfo

61+ { typoid :: Oid

62+ , typcategory :: Char

63+ , typdelim :: Char

64+ , typname :: ByteString

65+ , typelem :: Oid

66+ }

67+

68+instance FromRow TypeInfo where

69+ fromRow = TypeInfo <$> field <*> charF <*> charF <*> field <*> field

70+ where charF = fieldWith (\_f dat -> Ok (B.head (unJust dat)))

71+ unJust (Just x) = x

72+

73+type NameMap = Map.Map B.ByteString TypeInfo

74+

75+type OidMap = Map.Map Oid TypeInfo

76+

77+type TypeName = (B.ByteString, B.ByteString)

78+

79+type TypeNames = [TypeName]

80+

81+-- Note that the following syntax is "pgName <whitespace> hsName", though

82+-- they default to the same thing if there is only one identifier

83+typeNames :: TypeNames

84+typeNames = [typenames|

85+bool

86+bytea

87+char

88+name

89+int8

90+int2

91+int4

92+regproc

93+text

94+oid

95+tid

96+xid

97+cid

98+xml

99+point

100+lseg

101+path

102+box

103+polygon

104+line

105+cidr

106+float4

107+float8

108+abstime

109+reltime

110+tinterval

111+unknown

112+circle

113+money

114+macaddr

115+inet

116+bpchar

117+varchar

118+date

119+time

120+timestamp

121+timestamptz

122+interval

123+timetz

124+bit

125+varbit

126+numeric

127+refcursor

128+record

129+void

130+uuid

131+|]

132+

133+instance IsString Blaze.Builder where

134+ fromString = Blaze.fromByteString . fromString

135+

136+connectionString = "dbname=postgres"

137+

138+withPostgreSQL = bracket (connectPostgreSQL connectionString) close

139+

140+getTypeInfos :: TypeNames -> IO (OidMap, NameMap)

141+getTypeInfos typnames = withPostgreSQL $ \conn -> do

142+ infos <- query conn [sql|

143+ SELECT oid, typcategory, typdelim, typname, typelem

144+ FROM pg_type

145+ WHERE typname IN ?

146+ |]

147+ (Only (In (sort (map pg typnames))))

148+ loop conn (oidMap infos) (nameMap infos) infos

149+ where

150+ oidMap = Map.fromList . map (typoid &&& id)

151+ nameMap = Map.fromList . map (typname &&& id)

152+ loop conn oids names infos = do

153+ let unknowns = [ x | x <- map typelem infos,

154+ x /= Oid 0,

155+ not (Map.member x oids) ]

156+ case unknowns of

157+ [] -> return (oids, names)

158+ (_:_) -> do

159+ infos' <- query conn [sql|

160+ SELECT oid, typcategory, typdelim, typname, typelem

161+ FROM pg_type

162+ WHERE oid IN ?

163+ |] (Only (In (sort unknowns)))

164+ let oids' = oids `Map.union` oidMap infos'

165+ names' = names `Map.union` nameMap infos'

166+ loop conn oids' names' infos'

167+

168+main = do

169+ (oidmap, namemap) <- getTypeInfos typeNames

170+ L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo.hs"

171+ (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))

172+

173+

174+showOid (Oid n) = show n

175+

176+renderOid :: NameMap -> TypeName -> Blaze.Builder

177+renderOid byName name

178+ = case Map.lookup (pg name) byName of

179+ Nothing -> error (B.unpack (pg name))

180+ Just (showOid . typoid -> n) -> fromString n

181+ ++ fromString (replicate (4 - length n) ' ')

182+

183+renderElem :: OidMap -> Oid -> Blaze.Builder

184+renderElem byOid elemOid

185+ | elemOid == Oid 0 = "Nothing"

186+ | otherwise = case Map.lookup elemOid byOid of

187+ Nothing -> error ("oid not found: " ++ show elemOid)

188+ Just x -> "Just " ++ bs (typname x)

189+

190+-- FIXME: add in any names that we need that we didn't specify, (i.e.

191+-- the "unknowns" in getTypeInfos

192+-- and munge them into a valid haskell identifier if needed.

193+getNames :: NameMap -> TypeNames -> TypeNames

194+getNames _ x = x

195+

196+bs = Blaze.fromByteString

197+

198+pg = fst

199+

200+hs = snd

201+

202+renderFile :: OidMap -> NameMap -> TypeNames -> Blaze.Builder

203+renderFile byOid byName names = ([longstring|

204+------------------------------------------------------------------------------

205+-- |

206+-- Module: Database.PostgreSQL.Simple.TypeInfo

208+-- License: BSD3

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

210+-- Stability: experimental

211+--

212+------------------------------------------------------------------------------

213+

214+-- Note that this file is generated by tools/GenTypeInfo.hs, and should

215+-- not be edited directly

216+

217+module Database.PostgreSQL.Simple.TypeInfo

218+ ( TypeInfo(..)

219+ , staticTypeInfo

220+|] ++ concat [ " , " ++ bs (hs name) ++ "\n"

221+ | name <- names ] ++ [longstring|

222+ ) where

223+

224+import Data.ByteString (ByteString)

225+import Database.PostgreSQL.LibPQ (Oid(..))

226+

227+data TypeInfo = TypeInfo

228+ { typoid :: {-# UNPACK #-} !Oid

229+ , typcategory :: {-# UNPACK #-} !Char

230+ , typdelim :: {-# UNPACK #-} !Char

231+ , typelem :: !(Maybe TypeInfo)

232+ , typname :: !ByteString

233+ }

234+

235+staticTypeInfo :: Oid -> Maybe TypeInfo

236+staticTypeInfo (Oid x) = case x of

237+|] ++ concat [concat [ " ", renderOid byName name,

238+ " -> Just ", bs (hs name), "\n"

239+ ]

240+ | name <- names ]

241+ ++ [longstring|

242+ _ -> Nothing

243+|]

244+ ++ concat [concat

245+ [ "\n"

246+ , bs (hs name), " :: TypeInfo\n"

247+ , bs (hs name), " = TypeInfo {\n"

248+ , " typoid = ", fromString (show typoid), ",\n"

249+ , " typcategory = '", Blaze.fromChar typcategory, "',\n"

250+ , " typdelim = '", Blaze.fromChar typdelim, "',\n"

251+ , " typelem = ", renderElem byOid typelem, ",\n"

252+ , " typname = \"", bs typname, "\"\n"

253+ , " }\n"

254+ ]

255+ | name <- getNames byName names

256+ , let (Just (TypeInfo{..})) = Map.lookup (pg name) byName])

tools/StringsQQ.hs+12−1

@@ -1,6 +1,6 @@

1{-# LANGUAGE TemplateHaskell #-}

3−module StringsQQ (strings, longstring) where

3+module StringsQQ (strings, longstring, typenames) where

5import Language.Haskell.TH

6import Language.Haskell.TH.Quote

@@ -28,3 +28,14 @@ longstring = QuasiQuoter { quotePat = undefined,

29longstringExp ('\n':xs) = stringE xs

30longstringExp xs = stringE xs

31+

32+typenames = QuasiQuoter { quotePat = undefined,

33+ quoteType = undefined,

34+ quoteExp = typenamesExp,

35+ quoteDec = undefined }

36+

37+typenamesExp :: String -> Q Exp

38+typenamesExp = foldr (\x xs -> [e| $(x) : $(xs) |]) [e| [] |]

39+ . map delta . filter (not . null) . map words . lines

40+ where delta [xs] = delta [xs,xs]

41+ delta [xs,ys] = [e| ( $(stringE xs) , $(stringE ys) ) |]