tools/GenTypeInfo.hs · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on master help sign in

typeable/postgresql-simple/tools/GenTypeInfo.hs

381 lines 12 kB history raw

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-- runghc -itools tools/GenTypeInfo.hs

26-- @

27------------------------------------------------------------------------------

29{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}

31module GenBuiltinTypes where

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

35import StringsQQ

36import Control.Arrow((&&&))

37import Control.Applicative

38import Control.Exception(bracket)

39import Database.PostgreSQL.Simple

40import Database.PostgreSQL.Simple.FromRow

41import Database.PostgreSQL.Simple.Ok

42import Database.PostgreSQL.Simple.Types(Oid(..))

43import Database.PostgreSQL.Simple.SqlQQ

44import qualified Data.ByteString.Char8 as B8

45import Data.ByteString(ByteString)

46import qualified Data.ByteString.Lazy as L

47import qualified Data.ByteString.Builder as Blaze

48import Data.String

49import Data.List ( sort, intersperse )

50import qualified Data.Map as Map

52import Data.Monoid

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

55(++) = mappend

56infixr 5 ++

58concat :: Monoid a => [a] -> a

59concat = mconcat

61data TypeInfo = TypeInfo

62 { typoid :: Oid

63 , typcategory :: Char

64 , typdelim :: Char

65 , typname :: ByteString

66 , typelem :: Oid

67 , rngsubtype :: Maybe Oid

68 }

70instance FromRow TypeInfo where

71 fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field

73type NameMap = Map.Map B8.ByteString TypeInfo

75type OidMap = Map.Map Oid TypeInfo

77type TypeName = (B8.ByteString, B8.ByteString)

79type TypeNames = [TypeName]

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

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

83typeNames :: TypeNames

84typeNames = [typenames|

85bool

86bytea

87char

88name

89int8

90int2

91int4

92regproc

93text

94oid

95tid

96xid

97cid

98xml

99point

100lseg

101path

102box

103polygon

104line

105cidr

106float4

107float8

108unknown

109circle

110money

111macaddr

112inet

113bpchar

114varchar

115date

116time

117timestamp

118timestamptz

119interval

120timetz

121bit

122varbit

123numeric

124refcursor

125record

126void

127_record array_record

128regprocedure

129regoper

130regoperator

131regclass

132regtype

133uuid

134json

135jsonb

136int2vector

137oidvector

138_xml array_xml

139_json array_json

140_line array_line

141_cidr array_cidr

142_circle array_circle

143_money array_money

144_bool array_bool

145_bytea array_bytea

146_char array_char

147_name array_name

148_int2 array_int2

149_int2vector array_int2vector

150_int4 array_int4

151_regproc array_regproc

152_text array_text

153_tid array_tid

154_xid array_xid

155_cid array_cid

156_oidvector array_oidvector

157_bpchar array_bpchar

158_varchar array_varchar

159_int8 array_int8

160_point array_point

161_lseg array_lseg

162_path array_path

163_box array_box

164_float4 array_float4

165_float8 array_float8

166_polygon array_polygon

167_oid array_oid

168_macaddr array_macaddr

169_inet array_inet

170_timestamp array_timestamp

171_date array_date

172_time array_time

173_timestamptz array_timestamptz

174_interval array_interval

175_numeric array_numeric

176_timetz array_timetz

177_bit array_bit

178_varbit array_varbit

179_refcursor array_refcursor

180_regprocedure array_regprocedure

181_regoper array_regoper

182_regoperator array_regoperator

183_regclass array_regclass

184_regtype array_regtype

185_uuid array_uuid

186_jsonb array_jsonb

187int4range

188_int4range

189numrange

190_numrange

191tsrange

192_tsrange

193tstzrange

194_tstzrange

195daterange

196_daterange

197int8range

198_int8range

199|]

200

201connectionString = "dbname=postgres"

202

203withPostgreSQL = bracket (connectPostgreSQL connectionString) close

204

205getTypeInfos :: TypeNames -> IO (OidMap, NameMap)

206getTypeInfos typnames = withPostgreSQL $ \conn -> do

207 infos <- query conn [sql|

208 WITH types AS

209 (SELECT oid, typcategory, typdelim, typname, typelem

210 FROM pg_type WHERE typname IN ?)

211 SELECT types.*, rngsubtype FROM types LEFT JOIN pg_range ON oid = rngtypid

212 |] (Only (In (sort (map pg typnames))))

213 loop conn (oidMap infos) (nameMap infos) infos

214 where

215 oidMap = Map.fromList . map (typoid &&& id)

216 nameMap = Map.fromList . map (typname &&& id)

217 loop conn oids names infos = do

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

219 [ x | Just x <- map rngsubtype infos ],

220 x /= Oid 0,

221 not (Map.member x oids) ]

222 case unknowns of

223 [] -> return (oids, names)

224 (_:_) -> do

225 infos' <- query conn [sql|

226 WITH types AS

227 (SELECT oid, typcategory, typdelim, typname, typelem

228 FROM pg_type WHERE oid IN ?)

229 SELECT types.*, rngsubtype

230 FROM types LEFT JOIN pg_range ON oid = rngtypid

231 |] (Only (In (sort unknowns)))

232 let oids' = oids `Map.union` oidMap infos'

233 names' = names `Map.union` nameMap infos'

234 loop conn oids' names' infos'

235

236main = do

237 (oidmap, namemap) <- getTypeInfos typeNames

238 L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"

239 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))

240

241

242showOid (Oid n) = show n

243

244renderOid :: NameMap -> TypeName -> Blaze.Builder

245renderOid byName name

246 = case Map.lookup (pg name) byName of

247 Nothing -> error (B8.unpack (pg name))

248 Just (showOid . typoid -> n) -> fromString n

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

250

251renderElem :: OidMap -> Oid -> Blaze.Builder

252renderElem byOid elemOid

253 | elemOid == Oid 0 = "Nothing"

254 | otherwise = case Map.lookup elemOid byOid of

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

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

257

258renderTypeInfo :: OidMap -> TypeInfo -> TypeName -> Blaze.Builder

259renderTypeInfo byOid info name

260 | typcategory info == 'A' || typname info == "_record" =

261 let (Just typelem_info) = Map.lookup (typelem info) byOid

262 typelem_hs_name =

263 case lookup (typname typelem_info) typeNames of

264 Nothing -> error ( "type not found: "

265 ++ B8.unpack( typname typelem_info)

266 ++ " (typelem of " ++ B8.unpack (typname info)

267 ++ ")")

268 Just x -> x

269 in concat

270 [ "\n"

271 , bs (hs name), " :: TypeInfo\n"

272 , bs (hs name), " = Array {\n"

273 , " typoid = ", bs (hs name), "Oid,\n"

274 , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"

275 , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"

276 , " typname = \"", bs (typname info), "\",\n"

277 , " typelem = ", bs typelem_hs_name, "\n"

278 , " }\n"

279 , "\n"

280 , bs (hs name), "Oid :: Oid\n"

281 , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"

282 , "{-# INLINE ", bs (hs name), "Oid #-}"

283 , "\n"

284 ]

285 | typcategory info == 'R' =

286 let (Just rngsubtype_oid) = rngsubtype info

287 (Just rngsubtype_info) = Map.lookup rngsubtype_oid byOid

288 rngsubtype_hs_name =

289 case lookup (typname rngsubtype_info) typeNames of

290 Nothing -> error ( "type not found: "

291 ++ B8.unpack (typname rngsubtype_info)

292 ++ " (rngsubtype of "

293 ++ B8.unpack (typname info) ++ ")")

294 Just x -> x

295 in concat

296 [ "\n"

297 , bs (hs name), " :: TypeInfo\n"

298 , bs (hs name), " = Range {\n"

299 , " typoid = ", bs (hs name), "Oid,\n"

300 , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"

301 , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"

302 , " typname = \"", bs (typname info), "\",\n"

303 , " rngsubtype = ", bs rngsubtype_hs_name, "\n"

304 , " }\n"

305 , "\n"

306 , bs (hs name), "Oid :: Oid\n"

307 , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"

308 , "{-# INLINE ", bs (hs name), "Oid #-}"

309 , "\n"

310 ]

311 | otherwise =

312 concat

313 [ "\n"

314 , bs (hs name), " :: TypeInfo\n"

315 , bs (hs name), " = Basic {\n"

316 , " typoid = ", bs (hs name), "Oid,\n"

317 , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"

318 , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"

319 , " typname = \"", bs (typname info), "\"\n"

320 , " }\n"

321 , "\n"

322 , bs (hs name), "Oid :: Oid\n"

323 , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"

324 , "{-# INLINE ", bs (hs name), "Oid #-}"

325 , "\n"

326 ]

327

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

329-- the "unknowns" in getTypeInfos

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

331getNames :: NameMap -> TypeNames -> TypeNames

332getNames _ x = x

333

334bs = Blaze.byteString

335

336pg = fst

337

338hs = snd

339

340renderFile :: OidMap -> NameMap -> TypeNames -> Blaze.Builder

341renderFile byOid byName names = ([longstring|

342------------------------------------------------------------------------------

343-- |

344-- Module: Database.PostgreSQL.Simple.TypeInfo

346-- License: BSD3

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

348-- Stability: experimental

349--

350-- This module contains portions of the @pg_type@ table that are relevant

351-- to postgresql-simple and are believed to not change between PostgreSQL

352-- versions.

353--

354------------------------------------------------------------------------------

355

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

357-- not be edited directly

358

359module Database.PostgreSQL.Simple.TypeInfo.Static

360 ( TypeInfo(..)

361 , staticTypeInfo

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

363 ++ " , " ++ bs (hs name) ++ "Oid\n"

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

365 ) where

366

367import Database.PostgreSQL.LibPQ (Oid(..))

368import Database.PostgreSQL.Simple.TypeInfo.Types

369

370staticTypeInfo :: Oid -> Maybe TypeInfo

371staticTypeInfo (Oid x) = case x of

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

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

374 ]

375 | name <- names ]

376 ++ [longstring|

377 _ -> Nothing

378|]

379 ++ concat [ renderTypeInfo byOid typeInfo name

380 | name <- getNames byName names

381 , let (Just typeInfo) = Map.lookup (pg name) byName])