@@ -1,17 +1,16 @@
1+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
12{-# LANGUAGE
23 DataKinds
3− , FlexibleContexts
44 , FlexibleInstances
5− , GADTs
5+ , FunctionalDependencies
66 , LambdaCase
7− , MultiParamTypeClasses
7+ , MagicHash
88 , OverloadedStrings
99 , PolyKinds
10− , RankNTypes
1110 , ScopedTypeVariables
12− , TypeApplications
1311 , TypeFamilies
1412 , TypeOperators
13+ , UndecidableInstances
1514#-}
1615
1716module Squeel.PostgreSQL.Query where
@@ -19,106 +18,93 @@ module Squeel.PostgreSQL.Query where
1918import Data.Boolean
2019import Data.ByteString (ByteString)
2120import Data.Monoid
22−import Data.Proxy
2321import Data.String
2422import Data.Vinyl
2523import Data.Vinyl.Functor
24+import GHC.Exts
2625import GHC.OverloadedLabels
2726import GHC.TypeLits
2827
2928import qualified Data.ByteString as ByteString
30−import qualified Data.ByteString.Char8 as Char8
31−
32−import Squeel.PostgreSQL.Type
33−
34−class HasField label xs x where
35− fieldName :: Proxy label -> Proxy xs -> Proxy x -> ByteString
36−instance {-# OVERLAPPING #-} KnownSymbol label
37− => HasField label ('(label, x) ': xs) x where
38− fieldName _ _ _ = Char8.pack (symbolVal (Proxy @label))
39−instance {-# OVERLAPPABLE #-} HasField label xs y
40− => HasField label (x ': xs) y where
41− fieldName _ _ _ = fieldName (Proxy @label) (Proxy @xs) (Proxy @y)
42−
43−data Alias label = Alias
44−data Aliased obj labeled where
45− As :: obj x -> Alias label -> Aliased obj '(label, x)
46−instance IsLabel label (Alias label) where fromLabel _ = Alias
47−instance IsLabel label (obj x)
48− => IsLabel label (Aliased obj '(label, x)) where
49− fromLabel p = fromLabel p `As` fromLabel p
50−
51−aliasName :: forall label. KnownSymbol label => Alias label -> ByteString
52−aliasName _ = Char8.pack (symbolVal (Proxy @label))
53−
54−alias :: Aliased obj '(label, x) -> Alias label
55−alias _ = Alias
56−
57−unalias :: Aliased obj '(label, x) -> obj x
58−unalias (obj `As` _) = obj
59−
60−renderAliased
61− :: KnownSymbol label
62− => (obj x -> ByteString)
63− -> Aliased obj '(label, x)
64− -> ByteString
65−renderAliased render (obj `As` label) =
66− render obj <> " AS " <> Char8.pack (symbolVal label)
67−
68−class UnzipAliased (xs :: [(Symbol,k)]) where
69− type Unaliased xs :: [k]
70− unzipAliased
71− :: Rec (Aliased obj) xs
72− -> ([ByteString], Rec obj (Unaliased xs))
73−instance UnzipAliased '[] where
74− type Unaliased '[] = '[]
75− unzipAliased _ = ([], RNil)
76−instance (KnownSymbol label, UnzipAliased xs)
77− => UnzipAliased ( '(label, x) ': xs) where
78− type Unaliased ( '(label, x) ': xs) = x ': Unaliased xs
79− unzipAliased (x :& xs) =
80− let
81− (labels,values) = unzipAliased xs
82− in
83− (aliasName (alias x) : labels, unalias x :& values)
84−
85−class AllAliased xs where
86− renderAllAliased
87− :: (forall x. obj x -> ByteString)
88− -> Rec (Aliased obj) xs
89− -> ByteString
90−instance KnownSymbol label => AllAliased '[ '(label, x)] where
91− renderAllAliased render
92− (aliased :& RNil :: Rec (Aliased obj) '[ '(label, x)]) =
93− renderAliased render aliased
94−instance (KnownSymbol label, AllAliased (x' ': xs))
95− => AllAliased ('(label, x) ': (x' ': xs)) where
96− renderAllAliased render
97− (x :& xs :: Rec (Aliased obj) ('(label, x) ': x' : xs)) =
98− renderAliased render x <> ", " <> renderAllAliased render xs
29+
30+import Squeel.PostgreSQL.Schema
9931
10032newtype Expression
101− (ps :: [PGType])
102− (xs :: [(Symbol,PGType)])
103− (y :: PGType) =
104− UnsafeExpression { renderExpression :: ByteString }
105−
106−param1 :: Expression (p1:ps) cols p1
107−param1 = UnsafeExpression "$1"
108−param2 :: Expression (p1:p2:ps) cols p2
109−param2 = UnsafeExpression "$2"
110−param3 :: Expression (p1:p2:p3:ps) cols p3
111−param3 = UnsafeExpression "$3"
112−param4 :: Expression (p1:p2:p3:p4:ps) cols p4
113−param4 = UnsafeExpression "$4"
114−param5 :: Expression (p1:p2:p3:p4:p5:ps) cols p5
115−param5 = UnsafeExpression "$5"
116−
117−instance HasField label xs x => IsLabel label (Expression ps xs x) where
118− fromLabel _ = UnsafeExpression $
119− fieldName (Proxy @label) (Proxy @xs) (Proxy @x)
120−
121−instance IsString (Expression ps xs 'PGText) where
33+ (params :: [PGType])
34+ (tables :: [(Symbol,[(Symbol,PGType)])])
35+ (ty :: PGType)
36+ = UnsafeExpression { renderExpression :: ByteString }
37+
38+class KnownNat n => HasParameter (n :: Nat) params ty | n params -> ty where
39+ param :: Proxy# n -> Expression params tables ty
40+ param p = UnsafeExpression $ ("$" <>) $ fromString $ show $ natVal' p
41+instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
42+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
43+ => HasParameter n (ty' : params) ty
44+
45+param1 :: Expression (ty1:tys) tables ty1
46+param1 = param (proxy# :: Proxy# 1)
47+param2 :: Expression (ty1:ty2:tys) tables ty2
48+param2 = param (proxy# :: Proxy# 2)
49+param3 :: Expression (ty1:ty2:ty3:tys) tables ty3
50+param3 = param (proxy# :: Proxy# 3)
51+param4 :: Expression (ty1:ty2:ty3:ty4:tys) tables ty4
52+param4 = param (proxy# :: Proxy# 4)
53+param5 :: Expression (ty1:ty2:ty3:ty4:ty5:tys) tables ty5
54+param5 = param (proxy# :: Proxy# 5)
55+
56+class KnownSymbol column => HasColumn column columns ty
57+ | column columns -> ty where
58+ getColumn :: Proxy# column -> Expression params '[table ::: columns] ty
59+ getColumn column = UnsafeExpression $ fromString $ symbolVal' column
60+instance {-# OVERLAPPING #-} KnownSymbol column
61+ => HasColumn column ((column ::: ty) ': tys) ty
62+instance {-# OVERLAPPABLE #-} (KnownSymbol column, HasColumn column table ty)
63+ => HasColumn column (ty' ': table) ty
64+
65+instance HasColumn column columns ty
66+ => IsLabel column (Expression params '[table ::: columns] ty) where
67+ fromLabel = getColumn
68+
69+(.&.)
70+ :: (HasTable table tables columns, HasColumn column columns ty)
71+ => Alias table -> Alias column -> Expression params tables ty
72+Alias table .&. Alias column = UnsafeExpression $
73+ fromString (symbolVal' table)
74+ <> "." <>
75+ fromString (symbolVal' column)
76+
77+unsafeBinaryOp
78+ :: ByteString
79+ -> Expression params tables ty0
80+ -> Expression params tables ty1
81+ -> Expression params tables ty2
82+unsafeBinaryOp op x y = UnsafeExpression $ mconcat
83+ ["(", renderExpression x, " ", op, " ", renderExpression y, ")"]
84+
85+unsafeUnaryOp
86+ :: ByteString
87+ -> Expression params tables ty0
88+ -> Expression params tables ty1
89+unsafeUnaryOp op x = UnsafeExpression $ mconcat
90+ ["(", op, " ", renderExpression x, ")"]
91+
92+unsafeFunction
93+ :: ByteString
94+ -> Expression params tables xty
95+ -> Expression params tables yty
96+unsafeFunction fn x = UnsafeExpression $ mconcat
97+ [fn, "(", renderExpression x, ")"]
98+
99+instance PGNum ty => Num (Expression params tables ty) where
100+ (+) = unsafeBinaryOp "+"
101+ (-) = unsafeBinaryOp "-"
102+ (*) = unsafeBinaryOp "*"
103+ abs = unsafeUnaryOp "@"
104+ signum = unsafeFunction "sign"
105+ fromInteger = UnsafeExpression . fromString . show
106+
107+instance IsString (Expression params tables 'PGText) where
122108 fromString str = UnsafeExpression $
123109 "E\'" <> fromString (escape =<< str) <> "\'"
124110 where
@@ -133,169 +119,201 @@ instance IsString (Expression ps xs 'PGText) where
133119 '\\' -> "\\\\"
134120 c -> [c]
135121
136−instance Num (Expression ps xs 'PGInt2) where
137− fromInteger n = UnsafeExpression . fromString $ show n
138− x + y = UnsafeExpression $ renderExpression x <> "+" <> renderExpression y
139− x * y = UnsafeExpression $ renderExpression x <> "*" <> renderExpression y
140− UnsafeExpression x - UnsafeExpression y = UnsafeExpression $ x <> "+" <> y
141− abs (UnsafeExpression x) = UnsafeExpression $ "@" <> x
142− signum (UnsafeExpression x) = UnsafeExpression $ "sign(" <> x <> ")"
143−
144−instance Num (Expression ps xs 'PGInt4) where
145− fromInteger n = UnsafeExpression . fromString $ show n
146− x + y = UnsafeExpression $ renderExpression x <> "+" <> renderExpression y
147− x * y = UnsafeExpression $ renderExpression x <> "*" <> renderExpression y
148− UnsafeExpression x - UnsafeExpression y = UnsafeExpression $ x <> "+" <> y
149− abs (UnsafeExpression x) = UnsafeExpression $ "@" <> x
150− signum (UnsafeExpression x) = UnsafeExpression $ "sign(" <> x <> ")"
151−
152−instance Num (Expression ps xs 'PGInt8) where
153− fromInteger n = UnsafeExpression . fromString $ show n
154− x + y = UnsafeExpression $ renderExpression x <> "+" <> renderExpression y
155− x * y = UnsafeExpression $ renderExpression x <> "*" <> renderExpression y
156− UnsafeExpression x - UnsafeExpression y = UnsafeExpression $ x <> "+" <> y
157− abs (UnsafeExpression x) = UnsafeExpression $ "@" <> x
158− signum (UnsafeExpression x) = UnsafeExpression $ "sign(" <> x <> ")"
159−
160−instance Boolean (Expression ps xs 'PGBool) where
122+instance Boolean (Expression params tables 'PGBool) where
161123 true = UnsafeExpression "TRUE"
162124 false = UnsafeExpression "FALSE"
163− notB x = UnsafeExpression $ "NOT " <> renderExpression x
164− x &&* y = UnsafeExpression $
165− renderExpression x <> " AND " <> renderExpression y
166− x ||* y = UnsafeExpression $
167− renderExpression x <> " OR " <> renderExpression y
125+ notB = unsafeUnaryOp "NOT"
126+ (&&*) = unsafeBinaryOp "AND"
127+ (||*) = unsafeBinaryOp "OR"
168128
169−type instance BooleanOf (Expression ps xs y) = Expression ps xs 'PGBool
129+type instance BooleanOf (Expression params tables ty) =
130+ Expression params tables 'PGBool
170131
171−instance IfB (Expression ps xs y) where
172− ifB predicate then_ else_ = UnsafeExpression $ mconcat
173− [ "CASE WHEN ",renderExpression predicate
132+instance IfB (Expression params tables ty) where
133+ ifB if_ then_ else_ = UnsafeExpression $ mconcat
134+ [ "CASE WHEN ",renderExpression if_
174135 , " THEN ",renderExpression then_
175136 , " ELSE ",renderExpression else_
176137 , " END"
177138 ]
178139
179−instance EqB (Expression ps xs y) where
180− x ==* y = UnsafeExpression $ renderExpression x <> "=" <> renderExpression y
181− x /=* y = UnsafeExpression $ renderExpression x <> "<>" <> renderExpression y
182−
183−instance OrdB (Expression ps xs y) where
184− x >* y = UnsafeExpression $ renderExpression x <> ">" <> renderExpression y
185− x >=* y = UnsafeExpression $ renderExpression x <> ">=" <> renderExpression y
186− x <* y = UnsafeExpression $ renderExpression x <> "<" <> renderExpression y
187− x <=* y = UnsafeExpression $ renderExpression x <> "<=" <> renderExpression y
140+instance EqB (Expression params tables ty) where
141+ (==*) = unsafeBinaryOp "="
142+ (/=*) = unsafeBinaryOp "<>"
143+
144+instance OrdB (Expression params tables ty) where
145+ (>*) = unsafeBinaryOp ">"
146+ (>=*) = unsafeBinaryOp ">="
147+ (<*) = unsafeBinaryOp "<"
148+ (<=*) = unsafeBinaryOp "<="
149+
150+newtype TableRef
151+ (params :: [PGType])
152+ (schema :: [(Symbol,[(Symbol,PGType)])])
153+ (tables :: [(Symbol,[(Symbol,PGType)])])
154+ = UnsafeTableRef { renderTableRef :: ByteString }
155+
156+class KnownSymbol table => HasTable table tables columns
157+ | table tables -> columns where
158+ getTable :: Proxy# table -> TableRef params tables '[table ::: columns]
159+ getTable table = UnsafeTableRef $ fromString $ symbolVal' table
160+instance {-# OVERLAPPING #-} KnownSymbol table
161+ => HasTable table ((table ::: columns) ': tables) columns
162+instance {-# OVERLAPPABLE #-}
163+ (KnownSymbol table, HasTable table schema columns)
164+ => HasTable table (table' ': schema) columns
165+
166+crossJoin
167+ :: TableRef params schema '[table]
168+ -> TableRef params schema tables
169+ -> TableRef params schema (table ': tables)
170+crossJoin table tables = UnsafeTableRef $
171+ renderTableRef tables <> " CROSS JOIN " <> renderTableRef table
172+
173+innerJoin
174+ :: TableRef params schema '[table]
175+ -> Expression params (table ': tables) 'PGBool
176+ -> TableRef params schema tables
177+ -> TableRef params schema (table ': tables)
178+innerJoin table on tables = UnsafeTableRef $
179+ renderTableRef tables
180+ <> " INNER JOIN " <>
181+ renderTableRef table
182+ <> " ON " <>
183+ renderExpression on
188184
189185newtype Projection
190− (ps :: [PGType])
191− (xs :: [(Symbol,PGType)])
192− (ys :: [(Symbol,PGType)]) =
186+ (params :: [PGType])
187+ (tables :: [(Symbol,[(Symbol,PGType)])])
188+ (columns :: [(Symbol,PGType)]) =
193189 UnsafeProjection { renderProjection :: ByteString }
194190
195−star :: Projection ps xs xs
191+star :: Projection params '[table ::: columns] columns
196192star = UnsafeProjection "*"
197193
194+tableStar
195+ :: HasTable table tables columns
196+ => Alias table -> Projection params tables columns
197+tableStar (Alias table) = UnsafeProjection $
198+ fromString (symbolVal' table) <> ".*"
199+
198200project
199− :: AllAliased ys
200− => Rec (Aliased (Expression ps xs)) ys
201− -> Projection ps xs ys
202−project = UnsafeProjection . renderAllAliased renderExpression
203−
204−data Relation ps xss xs = UnsafeRelation
205− { relation :: ByteString
206− , restriction :: Maybe (Expression ps xs 'PGBool)
207− , limitation :: Maybe (Expression ps '[] 'PGInt8)
208− , offsetting :: Maybe (Expression ps '[] 'PGInt8)
201+ :: Rec (Aliased (Expression params tables)) columns
202+ -> Projection params tables columns
203+project
204+ = UnsafeProjection
205+ . ByteString.intercalate ", "
206+ . recordToList
207+ . rmap (Const . renderAliased renderExpression)
208+
209+data Tabulation
210+ (params :: [PGType])
211+ (schema :: [(Symbol,[(Symbol,PGType)])])
212+ (tables :: [(Symbol,[(Symbol,PGType)])])
213+ = Tabulation
214+ { fromClause :: TableRef params schema tables
215+ , whereClause :: Maybe (Expression params tables 'PGBool)
216+ , limitClause :: Maybe (Expression params '[] 'PGInt8)
217+ , offsetClause :: Maybe (Expression params '[] 'PGInt8)
209218 }
210219
211−renderRelation :: Relation ps xss xs -> ByteString
212−renderRelation (UnsafeRelation rel wh lim off) = rel
213− <> maybe "" ((" WHERE " <>) . renderExpression) wh
214− <> maybe "" ((" LIMIT " <>) . renderExpression) lim
215− <> maybe "" ((" OFFSET " <>) . renderExpression) off
220+tabulation :: TableRef params schema tables -> Tabulation params schema tables
221+tabulation tab = Tabulation tab Nothing Nothing Nothing
222+
223+renderTabulation :: Tabulation params schema tables -> ByteString
224+renderTabulation (Tabulation fr wh lim off)= mconcat
225+ [ renderTableRef fr
226+ , maybe "" ((" WHERE " <>) . renderExpression) wh
227+ , maybe "" ((" LIMIT " <>) . renderExpression) lim
228+ , maybe "" ((" OFFSET " <>) . renderExpression) off
229+ ]
230+
231+instance HasTable table schema columns
232+ => IsLabel table (TableRef params schema '[table ::: columns]) where
233+ fromLabel = getTable
234+
235+instance HasTable table schema columns
236+ => IsLabel table (Tabulation params schema '[table ::: columns]) where
237+ fromLabel p = Tabulation (getTable p) Nothing Nothing Nothing
216238
217−-- | where_ is a morphism of monoids `PGBool -> End Relation` under (&&*), true
218239where_
219− :: Expression ps xs 'PGBool
220− -> Relation ps xss xs
221− -> Relation ps xss xs
222−where_ condition ys = ys
223− { restriction = case restriction ys of
240+ :: Expression params tables 'PGBool
241+ -> Tabulation params schema tables
242+ -> Tabulation params schema tables
243+where_ condition tables = tables
244+ { whereClause = case whereClause tables of
224245 Nothing -> Just condition
225246 Just conditions -> Just (conditions &&* condition)
226247 }
227248
228−-- | limit is a morphism of semigroups `PGInt8 -> End Relation` under minB
229249limit
230− :: Expression ps '[] 'PGInt8
231− -> Relation ps xss xs
232− -> Relation ps xss xs
233−limit n ys = ys
234− { limitation = case limitation ys of
250+ :: Expression params '[] 'PGInt8
251+ -> Tabulation params schema tables
252+ -> Tabulation params schema tables
253+limit n tables = tables
254+ { limitClause = case limitClause tables of
235255 Nothing -> Just n
236256 Just n' -> Just (n' `minB` n)
237257 }
238258
239−-- | offset is a morphism of monoids `PGInt8 -> End Relation` under (+), 0
240259offset
241− :: Expression ps '[] 'PGInt8
242− -> Relation ps xss xs
243− -> Relation ps xss xs
244−offset n ys = ys
245− { offsetting = case offsetting ys of
260+ :: Expression params '[] 'PGInt8
261+ -> Tabulation params schema tables
262+ -> Tabulation params schema tables
263+offset n tables = tables
264+ { offsetClause = case offsetClause tables of
246265 Nothing -> Just n
247266 Just n' -> Just (n' + n)
248267 }
249268
250−instance HasField label xss xs
251− => IsLabel label (Relation ps xss xs) where
252− fromLabel _ = UnsafeRelation
253− { relation = fieldName (Proxy @label) (Proxy @xss) (Proxy @xs)
254− , restriction = Nothing
255− , limitation = Nothing
256− , offsetting = Nothing
257− }
258−
259−newtype Selection ps xss ys = UnsafeSelection
269+newtype Selection params schema columns = UnsafeSelection
260270 { renderSelection :: ByteString }
261271
262−from :: Projection ps xs ys -> Relation ps xss xs -> Selection ps xss ys
263−ys `from` xs = UnsafeSelection $
264− renderProjection ys <> " FROM " <> renderRelation xs
265−
266−subselect :: Selection ps xss ys -> Relation ps xss ys
267−subselect selection = UnsafeRelation
268− { relation = "SELECT " <> renderSelection selection
269− , restriction = Nothing
270− , limitation = Nothing
271− , offsetting = Nothing
272+from
273+ :: Projection params tables columns
274+ -> Tabulation params schema tables
275+ -> Selection params schema columns
276+from projection tables = UnsafeSelection $
277+ renderProjection projection <> " FROM " <> renderTabulation tables
278+
279+newtype Query params schema0 schema1 columns = UnsafeQuery
280+ { renderQuery :: ByteString }
281+
282+newtype PreparedQuery params schema0 schema1 columns = UnsafePreparedQuery
283+ { renderPreparedQuery :: ByteString }
284+
285+select
286+ :: Selection params schema columns
287+ -> Query params schema schema columns
288+select = UnsafeQuery . ("SELECT " <>) . (<> ";") . renderSelection
289+
290+subselect
291+ :: Aliased (Selection params schema) table
292+ -> Tabulation params schema '[table]
293+subselect selection = Tabulation
294+ { fromClause = UnsafeTableRef . ("SELECT " <>) $
295+ renderAliased renderSelection selection
296+ , whereClause = Nothing
297+ , limitClause = Nothing
298+ , offsetClause = Nothing
272299 }
273300
274−newtype Query
275− (ps :: [PGType])
276− (xss :: [(Symbol,[(Symbol,PGType)])])
277− (yss :: [(Symbol,[(Symbol,PGType)])])
278− (zs :: [(Symbol,PGType)]) =
279− UnsafeQuery { renderQuery :: ByteString }
280−newtype PreparedQuery ps xss yss zs =
281− UnsafePreparedQuery { renderPreparedQuery :: ByteString }
282−
283−select :: Selection ps xss ys -> Query ps xss xss ys
284−select selection = UnsafeQuery $
285− "SELECT " <> renderSelection selection <> ";"
286−
287301insertInto
288− :: forall xss xs label ps
289− . (HasField label xss xs, UnzipAliased xs)
290− => Proxy label
291− -> Rec (Aliased (Expression ps '[])) xs
292− -> Query ps xss xss '[]
293−insertInto table values = UnsafeQuery $ "INSERT INTO "
294− <> fieldName table (Proxy @xss) (Proxy @xs)
295− <> " (" <> ByteString.intercalate ", " names
302+ :: forall schema columns table params
303+ . HasTable table schema columns
304+ => Alias table
305+ -> Rec (Aliased (Expression params '[])) columns
306+ -> Query params schema schema '[]
307+insertInto (Alias table) expressions = UnsafeQuery $ "INSERT INTO "
308+ <> fromString (symbolVal' table)
309+ <> " (" <> ByteString.intercalate ", " aliases
296310 <> ") VALUES ("
297− <> ByteString.intercalate ", "
298− (recordToList (rmap (Const . renderExpression) exprs))
311+ <> ByteString.intercalate ", " values
299312 <> ");"
300313 where
301− (names,exprs) = unzipAliased values
314+ aliases = recordToList $ rmap
315+ (\ (_ `As` Alias name) -> Const (fromString (symbolVal' name)))
316+ expressions
317+ values = recordToList $ rmap
318+ (\ (expression `As` _) -> Const (renderExpression expression))
319+ expressions