cc10a76 · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

Merge branch 'arrays' into 0.3

commitcc10a7670c4c8355231d6ec89c9c54c6f58532ab authorLeon P Smith <leon@melding-monads.com> dateMon 8 Oct 2012, 13:31 (14 years ago) parent9ac2ee0 e794d39

10 files changed+989−31

compare with master

unifiedsplit

postgresql-simple.cabal+3 src/Database/PostgreSQL/Simple.hs+35−21 src/Database/PostgreSQL/Simple/Arrays.hs+94 src/Database/PostgreSQL/Simple/FromField.hs+20−1 src/Database/PostgreSQL/Simple/FromRow.hs+3−3 src/Database/PostgreSQL/Simple/Internal.hs+18−5 src/Database/PostgreSQL/Simple/ToField.hs+10 src/Database/PostgreSQL/Simple/TypeInfo.hs+538 tools/GenTypeInfo.hs+256 tools/StringsQQ.hs+12−1

postgresql-simple.cabal+3

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

2121 hs-source-dirs: src

2222 Exposed-modules:

2323 Database.PostgreSQL.Simple

24+ Database.PostgreSQL.Simple.Arrays

2425 Database.PostgreSQL.Simple.BuiltinTypes

2526 Database.PostgreSQL.Simple.FromField

2627 Database.PostgreSQL.Simple.FromRow

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

3233 Database.PostgreSQL.Simple.Time.Internal

3334 Database.PostgreSQL.Simple.ToField

3435 Database.PostgreSQL.Simple.ToRow

36+ Database.PostgreSQL.Simple.TypeInfo

3537 Database.PostgreSQL.Simple.Types

3638-- Other-modules:

3739 Database.PostgreSQL.Simple.Internal

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

8789 , OverloadedStrings

8890 , Rank2Types

8991 , RecordWildCards

92+ , PatternGuards

9093

9194 build-depends: base

9295 , base16-bytestring

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

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

44{-# LANGUAGE PatternGuards #-}

55{-# LANGUAGE RecordWildCards #-}

66{-# LANGUAGE ViewPatterns #-}

7+{-# LANGUAGE QuasiQuotes #-}

89------------------------------------------------------------------------------

910-- |

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

143144import Database.PostgreSQL.Simple.Types

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

145146import Database.PostgreSQL.Simple.Internal as Base

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

146148import qualified Database.PostgreSQL.LibPQ as PQ

147149import qualified Data.ByteString.Char8 as B

148150import qualified Data.Text as T

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

552554 PQ.TuplesOk -> do

553555 ncols <- PQ.nfields result

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

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

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

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

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

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

558560 nrows <- PQ.ntuples result

559561 ncols <- PQ.nfields result

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

561− let rw = Row row typenames result

563+ let rw = Row row typeinfos result

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

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

564566 | otherwise -> do

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

566568 v <- PQ.getvalue result row c

567− return ( typenames V.! unCol c

569+ return ( typeinfos V.! unCol c

568570 , fmap ellipsis v )

569571 throw (ConversionFailed

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

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

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

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

10171019

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

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

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

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

10201022 case oid2typname oid of

1021− Just name -> return name

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

1024+ , typelem = Nothing

1025+ }

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

10231027 case IntMap.lookup (oid2int oid) oidmap of

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

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

10251029 Nothing -> do

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

1027− (Only oid)

1028− name <- case names of

1029− [] -> return $ throw SqlError {

1030− sqlNativeError = -1,

1031− sqlErrorMsg = "invalid type oid",

1032− sqlState = ""

1033− }

1034− [Only x] -> return x

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

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

1037− -- never return more than one result

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

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 = ?

1035+ |] (Only oid)

1036+ typinf <- case names of

1037+ [] -> return $ throw SqlError {

1038+ sqlNativeError = -1,

1039+ sqlErrorMsg = "invalid type oid",

1040+ sqlState = ""

1041+ }

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+ }

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

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

1051+ -- never return more than one result

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)

5353import qualified Data.ByteString.Char8 as B

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

5555import Data.List (foldl')

56+import Data.Maybe (fromMaybe)

5657import Data.Ratio (Ratio)

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

5859import Data.Typeable (Typeable, typeOf)

60+import Data.Vector (Vector)

61+import qualified Data.Vector as V

5962import Data.Word (Word64)

6063import Database.PostgreSQL.Simple.Internal

6164import Database.PostgreSQL.Simple.BuiltinTypes

6265import Database.PostgreSQL.Simple.Ok

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

6467import Database.PostgreSQL.Simple.Time

68+import Database.PostgreSQL.Simple.Arrays

6569import qualified Database.PostgreSQL.LibPQ as PQ

6670import System.IO.Unsafe (unsafePerformIO)

6771import qualified Data.ByteString as SB

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

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

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

243247

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+

244263newtype Compat = Compat Word64

245264

246265mkCompats :: [BuiltinType] -> Compat

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

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

271290 -> Maybe ByteString -> Ok a

272291doFromField f types cvt (Just bs)

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

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

274293 , mkCompat typ `compat` types = cvt bs

275294 | otherwise = returnError Incompatible f "types incompatible"

276295doFromField f _ _ _ = returnError UnexpectedNull f ""

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

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

6868fieldWith :: FieldParser a -> RowParser a

6969fieldWith fieldP = RP $ do

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

71− Row{..} <- ask

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

7272 column <- lift get

7373 lift (put (column + 1))

7474 let ncols = nfields rowresult

7575 if (column >= ncols)

7676 then do

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

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

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

7979 [0..ncols-1]

8080 convertError = ConversionFailed

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

8585 \convert and number in target type"

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

8787 else do

88− let typename = typenames ! unCol column

88+ let typeinfo = typeinfos ! unCol column

8989 result = rowresult

9090 field = Field{..}

9191 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)

5252data Field = Field {

5353 result :: !PQ.Result

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

55− , typename :: !ByteString

55+ , typeinfo :: !TypeInfo

5656 }

5757

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+

5869name :: Field -> Maybe ByteString

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

6071

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

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

7283

7384typeOid :: Field -> PQ.Oid

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

75−

85+typeOid = typoid . typ . typeinfo

7686

7787data Connection = Connection {

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

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

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

8090 }

8191

8292data SqlType

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

301311

302312data Row = Row {

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

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

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

305315 , rowresult :: !PQ.Result

306316 }

307317

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

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

320+

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

309322 deriving ( Functor, Applicative, Alternative, Monad )

310323

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

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

3939import qualified Data.Text as ST

4040import qualified Data.Text.Encoding as ST

4141import qualified Data.Text.Lazy as LT

42+import Data.Vector (Vector)

43+import qualified Data.Vector as V

4244import qualified Database.PostgreSQL.LibPQ as PQ

4345import Database.PostgreSQL.Simple.Time

4446

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

221223 toField = Plain . inQuotes . dateToBuilder

222224 {-# INLINE toField #-}

223225

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+

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

225235--

226236-- 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 @@

11{-# LANGUAGE TemplateHaskell #-}

3−module StringsQQ (strings, longstring) where

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

55import Language.Haskell.TH

66import Language.Haskell.TH.Quote

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

2828

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

3030longstringExp 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) ) |]