@@ -0,0 +1,256 @@
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+------------------------------------------------------------------------------
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
207+-- Copyright: (c) 2011-2012 Leon P Smith
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])