git.iko.soy/typeable/postgresql-simple
on dfbf5d9 help sign in
typeable/postgresql-simple/tools/GenTypeInfo.hs
367 lines 12 kB history raw
1------------------------------------------------------------------------------
2-- |
3-- Module: GenTypeInfo
4-- Copyright: (c) 2011-2012 Leon P Smith
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------------------------------------------------------------------------------
26{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}
28module GenBuiltinTypes where
30import Prelude hiding ((++), concat)
32import StringsQQ
33import Control.Arrow((&&&))
34import Control.Applicative
35import Control.Exception(bracket)
36import Database.PostgreSQL.Simple
37import Database.PostgreSQL.Simple.FromRow
38import Database.PostgreSQL.Simple.Ok
39import Database.PostgreSQL.Simple.Types(Oid(..))
40import Database.PostgreSQL.Simple.SqlQQ
41import qualified Data.ByteString.Char8 as B
42import Data.ByteString(ByteString)
43import qualified Data.ByteString.Lazy as L
44import qualified Blaze.ByteString.Builder as Blaze
45import qualified Blaze.ByteString.Builder.ByteString as Blaze
46import qualified Blaze.ByteString.Builder.Char8 as Blaze
47import Data.String
48import Data.List ( sort, intersperse )
49import qualified Data.Map as Map
51import Data.Monoid
53(++) :: Monoid a => a -> a -> a
54(++) = mappend
55infixr 5 ++
57concat :: Monoid a => [a] -> a
58concat = mconcat
60data TypeInfo = TypeInfo
61 { typoid :: Oid
62 , typcategory :: Char
63 , typdelim :: Char
64 , typname :: ByteString
65 , typelem :: Oid
66 , rngsubtype :: Maybe Oid
67 }
69instance FromRow TypeInfo where
70 fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field
72type NameMap = Map.Map B.ByteString TypeInfo
74type OidMap = Map.Map Oid TypeInfo
76type TypeName = (B.ByteString, B.ByteString)
78type TypeNames = [TypeName]
80-- Note that the following syntax is "pgName <whitespace> hsName", though
81-- they default to the same thing if there is only one identifier
82typeNames :: TypeNames
83typeNames = [typenames|
84bool
85bytea
86char
87name
88int8
89int2
90int4
91regproc
92text
93oid
94tid
95xid
96cid
97xml
98point
99lseg
100path
101box
102polygon
103line
104cidr
105float4
106float8
107unknown
108circle
109money
110macaddr
111inet
112bpchar
113varchar
114date
115time
116timestamp
117timestamptz
118interval
119timetz
120bit
121varbit
122numeric
123refcursor
124record
125void
126_record array_record
127regprocedure
128regoper
129regoperator
130regclass
131regtype
132uuid
133json
134jsonb
135int2vector
136oidvector
137_xml array_xml
138_json array_json
139_line array_line
140_cidr array_cidr
141_circle array_circle
142_money array_money
143_bool array_bool
144_bytea array_bytea
145_char array_char
146_name array_name
147_int2 array_int2
148_int2vector array_int2vector
149_int4 array_int4
150_regproc array_regproc
151_text array_text
152_tid array_tid
153_xid array_xid
154_cid array_cid
155_oidvector array_oidvector
156_bpchar array_bpchar
157_varchar array_varchar
158_int8 array_int8
159_point array_point
160_lseg array_lseg
161_path array_path
162_box array_box
163_float4 array_float4
164_float8 array_float8
165_polygon array_polygon
166_oid array_oid
167_macaddr array_macaddr
168_inet array_inet
169_timestamp array_timestamp
170_date array_date
171_time array_time
172_timestamptz array_timestamptz
173_interval array_interval
174_numeric array_numeric
175_timetz array_timetz
176_bit array_bit
177_varbit array_varbit
178_refcursor array_refcursor
179_regprocedure array_regprocedure
180_regoper array_regoper
181_regoperator array_regoperator
182_regclass array_regclass
183_regtype array_regtype
184_uuid array_uuid
185_jsonb array_jsonb
186int4range
187_int4range
188numrange
189_numrange
190tsrange
191_tsrange
192tstzrange
193_tstzrange
194daterange
195_daterange
196int8range
197_int8range
198|]
200instance IsString Blaze.Builder where
201 fromString = Blaze.fromByteString . fromString
203connectionString = "dbname=postgres"
205withPostgreSQL = bracket (connectPostgreSQL connectionString) close
207getTypeInfos :: TypeNames -> IO (OidMap, NameMap)
208getTypeInfos typnames = withPostgreSQL $ \conn -> do
209 infos <- query conn [sql|
210 WITH types AS
211 (SELECT oid, typcategory, typdelim, typname, typelem
212 FROM pg_type WHERE typname IN ?)
213 SELECT types.*, rngsubtype FROM types LEFT JOIN pg_range ON oid = rngtypid
214 |] (Only (In (sort (map pg typnames))))
215 loop conn (oidMap infos) (nameMap infos) infos
216 where
217 oidMap = Map.fromList . map (typoid &&& id)
218 nameMap = Map.fromList . map (typname &&& id)
219 loop conn oids names infos = do
220 let unknowns = [ x | x <- map typelem infos ++
221 [ x | Just x <- map rngsubtype infos ],
222 x /= Oid 0,
223 not (Map.member x oids) ]
224 case unknowns of
225 [] -> return (oids, names)
226 (_:_) -> do
227 infos' <- query conn [sql|
228 WITH types AS
229 (SELECT oid, typcategory, typdelim, typname, typelem
230 FROM pg_type WHERE oid IN ?)
231 SELECT types.*, rngsubtype
232 FROM types LEFT JOIN pg_range ON oid = rngtypid
233 |] (Only (In (sort unknowns)))
234 let oids' = oids `Map.union` oidMap infos'
235 names' = names `Map.union` nameMap infos'
236 loop conn oids' names' infos'
238main = do
239 (oidmap, namemap) <- getTypeInfos typeNames
240 L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
241 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))
244showOid (Oid n) = show n
246renderOid :: NameMap -> TypeName -> Blaze.Builder
247renderOid byName name
248 = case Map.lookup (pg name) byName of
249 Nothing -> error (B.unpack (pg name))
250 Just (showOid . typoid -> n) -> fromString n
251 ++ fromString (replicate (4 - length n) ' ')
253renderElem :: OidMap -> Oid -> Blaze.Builder
254renderElem byOid elemOid
255 | elemOid == Oid 0 = "Nothing"
256 | otherwise = case Map.lookup elemOid byOid of
257 Nothing -> error ("oid not found: " ++ show elemOid)
258 Just x -> "Just " ++ bs (typname x)
260renderTypeInfo :: OidMap -> TypeInfo -> TypeName -> Blaze.Builder
261renderTypeInfo byOid info name
262 | typcategory info == 'A' || typname info == "_record" =
263 let (Just typelem_info) = Map.lookup (typelem info) byOid
264 typelem_hs_name =
265 case lookup (typname typelem_info) typeNames of
266 Nothing -> error ( "type not found: "
267 ++ B.unpack( typname typelem_info)
268 ++ " (typelem of " ++ B.unpack (typname info)
269 ++ ")")
270 Just x -> x
271 in concat
272 [ "\n"
273 , bs (hs name), " :: TypeInfo\n"
274 , bs (hs name), " = Array {\n"
275 , " typoid = ", fromString (show (typoid info)), ",\n"
276 , " typcategory = '", Blaze.fromChar (typcategory info), "',\n"
277 , " typdelim = '", Blaze.fromChar (typdelim info), "',\n"
278 , " typname = \"", bs (typname info), "\",\n"
279 , " typelem = ", bs typelem_hs_name, "\n"
280 , " }\n"
281 ]
282 | typcategory info == 'R' =
283 let (Just rngsubtype_oid) = rngsubtype info
284 (Just rngsubtype_info) = Map.lookup rngsubtype_oid byOid
285 rngsubtype_hs_name =
286 case lookup (typname rngsubtype_info) typeNames of
287 Nothing -> error ( "type not found: "
288 ++ B.unpack (typname rngsubtype_info)
289 ++ " (rngsubtype of "
290 ++ B.unpack (typname info) ++ ")")
291 Just x -> x
292 in concat
293 [ "\n"
294 , bs (hs name), " :: TypeInfo\n"
295 , bs (hs name), " = Range {\n"
296 , " typoid = ", fromString (show (typoid info)), ",\n"
297 , " typcategory = '", Blaze.fromChar (typcategory info), "',\n"
298 , " typdelim = '", Blaze.fromChar (typdelim info), "',\n"
299 , " typname = \"", bs (typname info), "\",\n"
300 , " rngsubtype = ", bs rngsubtype_hs_name, "\n"
301 , " }\n"
302 ]
303 | otherwise =
304 concat
305 [ "\n"
306 , bs (hs name), " :: TypeInfo\n"
307 , bs (hs name), " = Basic {\n"
308 , " typoid = ", fromString (show (typoid info)), ",\n"
309 , " typcategory = '", Blaze.fromChar (typcategory info), "',\n"
310 , " typdelim = '", Blaze.fromChar (typdelim info), "',\n"
311 , " typname = \"", bs (typname info), "\"\n"
312 , " }\n"
313 ]
315-- FIXME: add in any names that we need that we didn't specify, (i.e.
316-- the "unknowns" in getTypeInfos
317-- and munge them into a valid haskell identifier if needed.
318getNames :: NameMap -> TypeNames -> TypeNames
319getNames _ x = x
321bs = Blaze.fromByteString
323pg = fst
325hs = snd
327renderFile :: OidMap -> NameMap -> TypeNames -> Blaze.Builder
328renderFile byOid byName names = ([longstring|
329------------------------------------------------------------------------------
330-- |
331-- Module: Database.PostgreSQL.Simple.TypeInfo
332-- Copyright: (c) 2011-2012 Leon P Smith
333-- License: BSD3
334-- Maintainer: Leon P Smith <leon@melding-monads.com>
335-- Stability: experimental
336--
337-- This module contains portions of the @pg_type@ table that are relevant
338-- to postgresql-simple and are believed to not change between PostgreSQL
339-- versions.
340--
341------------------------------------------------------------------------------
343-- Note that this file is generated by tools/GenTypeInfo.hs, and should
344-- not be edited directly
346module Database.PostgreSQL.Simple.TypeInfo.Static
347 ( TypeInfo(..)
348 , staticTypeInfo
349|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
350 | name <- names ] ++ [longstring|
351 ) where
353import Database.PostgreSQL.LibPQ (Oid(..))
354import Database.PostgreSQL.Simple.TypeInfo.Types
356staticTypeInfo :: Oid -> Maybe TypeInfo
357staticTypeInfo (Oid x) = case x of
358|] ++ concat [concat [ " ", renderOid byName name,
359 " -> Just ", bs (hs name), "\n"
360 ]
361 | name <- names ]
362 ++ [longstring|
363 _ -> Nothing
364|]
365 ++ concat [ renderTypeInfo byOid typeInfo name
366 | name <- getNames byName names
367 , let (Just typeInfo) = Map.lookup (pg name) byName])