@@ -5,7 +5,7 @@ Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
8−Embedding of PostgreSQL type and alias system
8+A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.
99-}
1010
1111{-# LANGUAGE
@@ -33,9 +33,9 @@ Embedding of PostgreSQL type and alias system
3333#-}
3434
3535module Squeal.PostgreSQL.Schema
36− ( -- * Kinds
36+ ( -- * Types
3737 PGType (..)
38− , Oid (..)
38+ , HasOid (..)
3939 , NullityType (..)
4040 , ColumnType
4141 , ColumnsType
@@ -44,14 +44,14 @@ module Squeal.PostgreSQL.Schema
4444 , TableType
4545 , TablesType
4646 , Grouping (..)
47− -- * PostgreSQL Constraints
47+ -- * Constraints
4848 , (:=>)
4949 , ColumnsToRelation
5050 , TableToColumns
5151 , TablesToRelations
5252 , ColumnConstraint (..)
5353 , TableConstraint (..)
54− -- * AliasesOf
54+ -- * Aliases
5555 , (:::)
5656 , Alias (Alias)
5757 , renderAlias
@@ -100,6 +100,10 @@ import GHC.TypeLits
100100import qualified Generics.SOP.Type.Metadata as Type
101101
102102-- | `PGType` is the promoted datakind of PostgreSQL types.
103+--
104+-- >>> import Squeal.PostgreSQL.Schema
105+-- >>> :kind 'PGbool
106+-- 'PGbool :: PGType
103107data PGType
104108 = PGbool -- ^ logical Boolean (true/false)
105109 | PGint2 -- ^ signed two-byte integer
@@ -127,42 +131,54 @@ data PGType
127131 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
128132
129133-- | The object identifier of a `PGType`.
130−class Oid (ty :: PGType) where oid :: proxy ty -> Word32
131−instance Oid 'PGbool where oid _ = 16
132−instance Oid 'PGint2 where oid _ = 21
133−instance Oid 'PGint4 where oid _ = 23
134−instance Oid 'PGint8 where oid _ = 20
135−instance Oid 'PGnumeric where oid _ = 1700
136−instance Oid 'PGfloat4 where oid _ = 700
137−instance Oid 'PGfloat8 where oid _ = 701
138−instance Oid ('PGchar n) where oid _ = 18
139−instance Oid ('PGvarchar n) where oid _ = 1043
140−instance Oid 'PGtext where oid _ = 25
141−instance Oid 'PGbytea where oid _ = 17
142−instance Oid 'PGtimestamp where oid _ = 1114
143−instance Oid 'PGtimestamptz where oid _ = 1184
144−instance Oid 'PGdate where oid _ = 1082
145−instance Oid 'PGtime where oid _ = 1083
146−instance Oid 'PGtimetz where oid _ = 1266
147−instance Oid 'PGinterval where oid _ = 1186
148−instance Oid 'PGuuid where oid _ = 2950
149−instance Oid 'PGinet where oid _ = 869
150−instance Oid 'PGjson where oid _ = 114
151−instance Oid 'PGjsonb where oid _ = 3802
134+--
135+-- >>> :set -XTypeApplications
136+-- >>> import Data.Proxy
137+-- >>> oid (Proxy @'PGbool)
138+-- 16
139+class HasOid (ty :: PGType) where oid :: proxy ty -> Word32
140+instance HasOid 'PGbool where oid _ = 16
141+instance HasOid 'PGint2 where oid _ = 21
142+instance HasOid 'PGint4 where oid _ = 23
143+instance HasOid 'PGint8 where oid _ = 20
144+instance HasOid 'PGnumeric where oid _ = 1700
145+instance HasOid 'PGfloat4 where oid _ = 700
146+instance HasOid 'PGfloat8 where oid _ = 701
147+instance HasOid ('PGchar n) where oid _ = 18
148+instance HasOid ('PGvarchar n) where oid _ = 1043
149+instance HasOid 'PGtext where oid _ = 25
150+instance HasOid 'PGbytea where oid _ = 17
151+instance HasOid 'PGtimestamp where oid _ = 1114
152+instance HasOid 'PGtimestamptz where oid _ = 1184
153+instance HasOid 'PGdate where oid _ = 1082
154+instance HasOid 'PGtime where oid _ = 1083
155+instance HasOid 'PGtimetz where oid _ = 1266
156+instance HasOid 'PGinterval where oid _ = 1186
157+instance HasOid 'PGuuid where oid _ = 2950
158+instance HasOid 'PGinet where oid _ = 869
159+instance HasOid 'PGjson where oid _ = 114
160+instance HasOid 'PGjsonb where oid _ = 3802
152161
153162-- | `NullityType` encodes the potential presence or definite absence of a
154163-- @NULL@ allowing operations which are sensitive to such to be well typed.
164+--
165+-- >>> :kind 'Null 'PGint4
166+-- 'Null 'PGint4 :: NullityType
167+-- >>> :kind 'NotNull ('PGvarchar 50)
168+-- 'NotNull ('PGvarchar 50) :: NullityType
155169data NullityType
156170 = Null PGType -- ^ @NULL@ may be present
157171 | NotNull PGType -- ^ @NULL@ is absent
158172
159−-- | `:=>` is a type level pair between an "constraint" and some type,
173+-- | The constraint operator, `:=>` is a type level pair
174+-- between an "constraint" and some type,
160175-- either a `ColumnConstraint` and a `NullityType` or a row of
161176-- `TableConstraint`s and a `TableType`.
162177type (:=>) constraint ty = '(constraint,ty)
163178infixr 7 :=>
164179
165−-- | `:::` is like a promoted version of `As`, a type level pair between
180+-- | The alias operator `:::` is like a promoted version of `As`,
181+-- a type level pair between
166182-- an alias and some type, like a column alias and either a `ColumnType` or
167183-- `NullityType` or a table alias and either a `TableType` or a `RelationType`
168184-- or a constraint alias and a `TableConstraint`.
@@ -176,9 +192,31 @@ data ColumnConstraint
176192
177193-- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the
178194-- base `PGType` for a column.
195+--
196+-- >>> :kind 'NoDef :=> 'NotNull 'PGint4
197+-- 'NoDef :=> 'NotNull 'PGint4 :: (ColumnConstraint, NullityType)
198+-- >>> :kind 'NoDef :=> 'NotNull 'PGtext
199+-- 'NoDef :=> 'NotNull 'PGtext :: (ColumnConstraint, NullityType)
200+-- >>> import Data.Type.Equality
201+-- >>> Refl :: ColumnType :~: (ColumnConstraint, NullityType)
202+-- Refl
179203type ColumnType = (ColumnConstraint,NullityType)
180204
181205-- | `ColumnsType` is a row of `ColumnType`s.
206+--
207+-- >>> import GHC.TypeLits
208+-- >>> :{
209+-- type Columns =
210+-- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
211+-- , "id" ::: 'Def :=> 'NotNull 'PGint4
212+-- ]
213+-- :}
214+--
215+-- >>> :kind Columns
216+-- Columns :: [(Symbol, (ColumnConstraint, NullityType))]
217+-- >>> import Data.Type.Equality
218+-- >>> Refl :: ColumnsType :~: [(Symbol, (ColumnConstraint, NullityType))]
219+-- Refl
182220type ColumnsType = [(Symbol,ColumnType)]
183221
184222-- | `TableConstraint` encodes various forms of data constraints
@@ -191,18 +229,64 @@ data TableConstraint
191229
192230-- | `TableType` encodes a row of constraints on a table as well as the types
193231-- of its columns.
232+--
233+-- >>> :{
234+-- type UsersTable =
235+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
236+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
237+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
238+-- ]
239+-- :}
240+--
241+-- >>> :kind UsersTable
242+-- UsersTable :: ([(Symbol, TableConstraint)],
243+-- [(Symbol, (ColumnConstraint, NullityType))])
194244type TableType = ([(Symbol,TableConstraint)],ColumnsType)
195245
196246-- | `TablesType` is a row of `TableType`s, thought of as a union.
247+--
248+-- >>> :set -XTypeFamilies -XTypeInType
249+-- >>> :{
250+-- type family Schema :: TablesType where
251+-- Schema =
252+-- '[ "users" :::
253+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
254+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
255+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
256+-- , "vec" ::: 'NoDef :=> 'NotNull ('PGarray 'PGint2)
257+-- ]
258+-- , "emails" :::
259+-- '[ "pk_emails" ::: 'PrimaryKey '["id"]
260+-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
261+-- ] :=>
262+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
263+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
264+-- , "email" ::: 'NoDef :=> 'Null 'PGtext
265+-- ]
266+-- ]
267+-- :}
268+--
197269type TablesType = [(Symbol,TableType)]
198270
199271-- | `RelationType` is a row of `NullityType`
272+--
273+-- >>> :{
274+-- type Relation =
275+-- '[ "name" ::: 'NotNull 'PGtext
276+-- , "age" ::: 'NotNull 'PGint4
277+-- , "dateOfBirth" ::: 'Null 'PGdate
278+-- ]
279+-- :}
280+--
281+-- >>> :kind Relation
282+-- Relation :: [(Symbol, NullityType)]
200283type RelationType = [(Symbol,NullityType)]
201284
202285-- | `RelationsType` is a row of `RelationType`s, thought of as a product.
203286type RelationsType = [(Symbol,RelationType)]
204287
205288-- | `ColumnsToRelation` removes column constraints.
289+--
206290type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where
207291 ColumnsToRelation '[] = '[]
208292 ColumnsToRelation (column ::: constraint :=> ty ': columns) =