git.iko.soy/typeable/postgresql-simple
on bebf49e help sign in
typeable/postgresql-simple/tools/GenTypeInfo.hs
252 lines 7.6 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 }
68instance FromRow TypeInfo where
69 fromRow = TypeInfo <$> field <*> charF <*> charF <*> field <*> field
70 where charF = fieldWith (\_f dat -> return (B.head (unJust dat)))
71 unJust (Just x) = x
73type NameMap = Map.Map B.ByteString TypeInfo
75type OidMap = Map.Map Oid TypeInfo
77type TypeName = (B.ByteString, B.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
108abstime
109reltime
110tinterval
111unknown
112circle
113money
114macaddr
115inet
116bpchar
117varchar
118date
119time
120timestamp
121timestamptz
122interval
123timetz
124bit
125varbit
126numeric
127refcursor
128record
129void
130uuid
131json
132|]
134instance IsString Blaze.Builder where
135 fromString = Blaze.fromByteString . fromString
137connectionString = "dbname=postgres"
139withPostgreSQL = bracket (connectPostgreSQL connectionString) close
141getTypeInfos :: TypeNames -> IO (OidMap, NameMap)
142getTypeInfos typnames = withPostgreSQL $ \conn -> do
143 infos <- query conn [sql|
144 SELECT oid, typcategory, typdelim, typname, typelem
145 FROM pg_type
146 WHERE typname IN ?
147 |]
148 (Only (In (sort (map pg typnames))))
149 loop conn (oidMap infos) (nameMap infos) infos
150 where
151 oidMap = Map.fromList . map (typoid &&& id)
152 nameMap = Map.fromList . map (typname &&& id)
153 loop conn oids names infos = do
154 let unknowns = [ x | x <- map typelem infos,
155 x /= Oid 0,
156 not (Map.member x oids) ]
157 case unknowns of
158 [] -> return (oids, names)
159 (_:_) -> do
160 infos' <- query conn [sql|
161 SELECT oid, typcategory, typdelim, typname, typelem
162 FROM pg_type
163 WHERE oid IN ?
164 |] (Only (In (sort unknowns)))
165 let oids' = oids `Map.union` oidMap infos'
166 names' = names `Map.union` nameMap infos'
167 loop conn oids' names' infos'
169main = do
170 (oidmap, namemap) <- getTypeInfos typeNames
171 L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
172 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))
175showOid (Oid n) = show n
177renderOid :: NameMap -> TypeName -> Blaze.Builder
178renderOid byName name
179 = case Map.lookup (pg name) byName of
180 Nothing -> error (B.unpack (pg name))
181 Just (showOid . typoid -> n) -> fromString n
182 ++ fromString (replicate (4 - length n) ' ')
184renderElem :: OidMap -> Oid -> Blaze.Builder
185renderElem byOid elemOid
186 | elemOid == Oid 0 = "Nothing"
187 | otherwise = case Map.lookup elemOid byOid of
188 Nothing -> error ("oid not found: " ++ show elemOid)
189 Just x -> "Just " ++ bs (typname x)
191-- FIXME: add in any names that we need that we didn't specify, (i.e.
192-- the "unknowns" in getTypeInfos
193-- and munge them into a valid haskell identifier if needed.
194getNames :: NameMap -> TypeNames -> TypeNames
195getNames _ x = x
197bs = Blaze.fromByteString
199pg = fst
201hs = snd
203renderFile :: OidMap -> NameMap -> TypeNames -> Blaze.Builder
204renderFile byOid byName names = ([longstring|
205------------------------------------------------------------------------------
206-- |
207-- Module: Database.PostgreSQL.Simple.TypeInfo
208-- Copyright: (c) 2011-2012 Leon P Smith
209-- License: BSD3
210-- Maintainer: Leon P Smith <leon@melding-monads.com>
211-- Stability: experimental
212--
213-- This module contains portions of the @pg_type@ table that are relevant
214-- to postgresql-simple and are believed to not change between PostgreSQL
215-- versions.
216--
217------------------------------------------------------------------------------
219-- Note that this file is generated by tools/GenTypeInfo.hs, and should
220-- not be edited directly
222module Database.PostgreSQL.Simple.TypeInfo.Static
223 ( TypeInfo(..)
224 , staticTypeInfo
225|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
226 | name <- names ] ++ [longstring|
227 ) where
229import Database.PostgreSQL.LibPQ (Oid(..))
230import Database.PostgreSQL.Simple.TypeInfo.Types
232staticTypeInfo :: Oid -> Maybe TypeInfo
233staticTypeInfo (Oid x) = case x of
234|] ++ concat [concat [ " ", renderOid byName name,
235 " -> Just ", bs (hs name), "\n"
236 ]
237 | name <- names ]
238 ++ [longstring|
239 _ -> Nothing
240|]
241 ++ concat [concat
242 [ "\n"
243 , bs (hs name), " :: TypeInfo\n"
244 , bs (hs name), " = Basic {\n"
245 , " typoid = ", fromString (show typoid), ",\n"
246 , " typcategory = '", Blaze.fromChar typcategory, "',\n"
247 , " typdelim = '", Blaze.fromChar typdelim, "',\n"
248 , " typname = \"", bs typname, "\"\n"
249 , " }\n"
250 ]
251 | name <- getNames byName names
252 , let (Just (TypeInfo{..})) = Map.lookup (pg name) byName])