tools/GenTypeInfo.hs · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on f221c1f help sign in

typeable/postgresql-simple/tools/GenTypeInfo.hs

250 lines 7.6 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------------------------------------------------------------------------------

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 -> Ok (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

131|]

132

133instance IsString Blaze.Builder where

134 fromString = Blaze.fromByteString . fromString

135

136connectionString = "dbname=postgres"

137

138withPostgreSQL = bracket (connectPostgreSQL connectionString) close

139

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

141getTypeInfos 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

168main = do

169 (oidmap, namemap) <- getTypeInfos typeNames

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

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

172

173

174showOid (Oid n) = show n

175

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

177renderOid 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

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

184renderElem 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.

193getNames :: NameMap -> TypeNames -> TypeNames

194getNames _ x = x

195

196bs = Blaze.fromByteString

197

198pg = fst

199

200hs = snd

201

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

203renderFile 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-- Note that this module is semi-internal, and you probably want to use

213-- Database.PostgreSQL.Simple.TypeInfo instead.

214--

215------------------------------------------------------------------------------

216

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

218-- not be edited directly

219

220module Database.PostgreSQL.Simple.TypeInfo.Static

221 ( TypeInfo(..)

222 , staticTypeInfo

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

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

225 ) where

226

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

228import Database.PostgreSQL.Simple.TypeInfo.Types

229

230staticTypeInfo :: Oid -> Maybe TypeInfo

231staticTypeInfo (Oid x) = case x of

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

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

234 ]

235 | name <- names ]

236 ++ [longstring|

237 _ -> Nothing

238|]

239 ++ concat [concat

240 [ "\n"

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

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

243 , " typoid = ", fromString (show typoid), ",\n"

244 , " typcategory = '", Blaze.fromChar typcategory, "',\n"

245 , " typdelim = '", Blaze.fromChar typdelim, "',\n"

246 , " typname = \"", bs typname, "\"\n"

247 , " }\n"

248 ]

249 | name <- getNames byName names

250 , let (Just (TypeInfo{..})) = Map.lookup (pg name) byName])