@@ -1,9 +1,12 @@
1+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
12{-# LANGUAGE
23 DataKinds
34 , FlexibleContexts
45 , FlexibleInstances
6+ , FunctionalDependencies
57 , GADTs
68 , LambdaCase
9+ , MagicHash
710 , MultiParamTypeClasses
811 , OverloadedStrings
912 , PolyKinds
@@ -12,6 +15,7 @@
1215 , TypeApplications
1316 , TypeFamilies
1417 , TypeOperators
18+ , UndecidableInstances
1519#-}
1620
1721module Squeel.PostgreSQL.Query where
@@ -19,106 +23,94 @@ module Squeel.PostgreSQL.Query where
1923import Data.Boolean
2024import Data.ByteString (ByteString)
2125import Data.Monoid
22−import Data.Proxy
2326import Data.String
2427import Data.Vinyl
2528import Data.Vinyl.Functor
29+import GHC.Exts
2630import GHC.OverloadedLabels
2731import GHC.TypeLits
2832
2933import 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
34+
35+import Squeel.PostgreSQL.Schema
9936
10037newtype 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
38+ (params :: [PGType])
39+ (tables :: [(Symbol,[(Symbol,PGType)])])
40+ (ty :: PGType)
41+ = UnsafeExpression { renderExpression :: ByteString }
42+
43+class KnownNat n => HasParameter (n :: Nat) params ty | n params -> ty where
44+ param :: Proxy# n -> Expression params tables ty
45+ param p = UnsafeExpression $ ("$" <>) $ fromString $ show $ natVal' p
46+instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
47+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
48+ => HasParameter n (ty' : params) ty
49+
50+param1 :: Expression (ty1:tys) tables ty1
51+param1 = param (proxy# :: Proxy# 1)
52+param2 :: Expression (ty1:ty2:tys) tables ty2
53+param2 = param (proxy# :: Proxy# 2)
54+param3 :: Expression (ty1:ty2:ty3:tys) tables ty3
55+param3 = param (proxy# :: Proxy# 3)
56+param4 :: Expression (ty1:ty2:ty3:ty4:tys) tables ty4
57+param4 = param (proxy# :: Proxy# 4)
58+param5 :: Expression (ty1:ty2:ty3:ty4:ty5:tys) tables ty5
59+param5 = param (proxy# :: Proxy# 5)
60+
61+class KnownSymbol column => HasColumn column columns ty
62+ | column columns -> ty where
63+ getColumn :: Proxy# column -> Expression params '[table ::: columns] ty
64+ getColumn column = UnsafeExpression $ fromString $ symbolVal' column
65+instance {-# OVERLAPPING #-} KnownSymbol column
66+ => HasColumn column ((column ::: ty) ': tys) ty
67+instance {-# OVERLAPPABLE #-} (KnownSymbol column, HasColumn column table ty)
68+ => HasColumn column (ty' ': table) ty
69+
70+instance HasColumn column columns ty
71+ => IsLabel column (Expression params '[table ::: columns] ty) where
72+ fromLabel = getColumn
73+
74+(.&.)
75+ :: forall columns column params tables table ty
76+ . (HasTable table tables columns, HasColumn column columns ty)
77+ => Alias table -> Alias column -> Expression params tables ty
78+Alias table .&. Alias column = UnsafeExpression $
79+ fromString (symbolVal' table)
80+ <> "." <>
81+ fromString (symbolVal' column)
82+
83+unsafeBinaryOp
84+ :: ByteString
85+ -> Expression params tables ty0
86+ -> Expression params tables ty1
87+ -> Expression params tables ty2
88+unsafeBinaryOp op x y = UnsafeExpression $ mconcat
89+ ["(", renderExpression x, " ", op, " ", renderExpression y, ")"]
90+
91+unsafeUnaryOp
92+ :: ByteString
93+ -> Expression params tables ty0
94+ -> Expression params tables ty1
95+unsafeUnaryOp op x = UnsafeExpression $ mconcat
96+ ["(", op, " ", renderExpression x, ")"]
97+
98+unsafeFunction
99+ :: ByteString
100+ -> Expression params tables xty
101+ -> Expression params tables yty
102+unsafeFunction fn x = UnsafeExpression $ mconcat
103+ [fn, "(", renderExpression x, ")"]
104+
105+instance PGNum ty => Num (Expression params tables ty) where
106+ (+) = unsafeBinaryOp "+"
107+ (-) = unsafeBinaryOp "-"
108+ (*) = unsafeBinaryOp "*"
109+ abs = unsafeUnaryOp "@"
110+ signum = unsafeFunction "sign"
111+ fromInteger = UnsafeExpression . fromString . show
112+
113+instance IsString (Expression params tables 'PGText) where
122114 fromString str = UnsafeExpression $
123115 "E\'" <> fromString (escape =<< str) <> "\'"
124116 where
@@ -133,169 +125,201 @@ instance IsString (Expression ps xs 'PGText) where
133125 '\\' -> "\\\\"
134126 c -> [c]
135127
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
128+instance Boolean (Expression params tables 'PGBool) where
161129 true = UnsafeExpression "TRUE"
162130 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
131+ notB = unsafeUnaryOp "NOT"
132+ (&&*) = unsafeBinaryOp "AND"
133+ (||*) = unsafeBinaryOp "OR"
168134
169−type instance BooleanOf (Expression ps xs y) = Expression ps xs 'PGBool
135+type instance BooleanOf (Expression params tables ty) =
136+ Expression params tables 'PGBool
170137
171−instance IfB (Expression ps xs y) where
172− ifB predicate then_ else_ = UnsafeExpression $ mconcat
173− [ "CASE WHEN ",renderExpression predicate
138+instance IfB (Expression params tables ty) where
139+ ifB if_ then_ else_ = UnsafeExpression $ mconcat
140+ [ "CASE WHEN ",renderExpression if_
174141 , " THEN ",renderExpression then_
175142 , " ELSE ",renderExpression else_
176143 , " END"
177144 ]
178145
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
146+instance EqB (Expression params tables ty) where
147+ (==*) = unsafeBinaryOp "="
148+ (/=*) = unsafeBinaryOp "<>"
149+
150+instance OrdB (Expression params tables ty) where
151+ (>*) = unsafeBinaryOp ">"
152+ (>=*) = unsafeBinaryOp ">="
153+ (<*) = unsafeBinaryOp "<"
154+ (<=*) = unsafeBinaryOp "<="
155+
156+newtype TableRef
157+ (params :: [PGType])
158+ (schema :: [(Symbol,[(Symbol,PGType)])])
159+ (tables :: [(Symbol,[(Symbol,PGType)])])
160+ = UnsafeTableRef { renderTableRef :: ByteString }
161+
162+class KnownSymbol table => HasTable table tables columns
163+ | table tables -> columns where
164+ getTable :: Proxy# table -> TableRef params tables '[table ::: columns]
165+ getTable table = UnsafeTableRef $ fromString $ symbolVal' table
166+instance {-# OVERLAPPING #-} KnownSymbol table
167+ => HasTable table ((table ::: columns) ': tables) columns
168+instance {-# OVERLAPPABLE #-}
169+ (KnownSymbol table, HasTable table schema columns)
170+ => HasTable table (table' ': schema) columns
171+
172+crossJoin
173+ :: TableRef params schema '[table]
174+ -> TableRef params schema tables
175+ -> TableRef params schema (table ': tables)
176+crossJoin table tables = UnsafeTableRef $
177+ "(" <> renderTableRef tables <> " CROSS JOIN " <> renderTableRef table <> ")"
178+
179+innerJoin
180+ :: TableRef params tables '[left]
181+ -> Expression params '[left,right] 'PGBool
182+ -> TableRef params tables (right ': rest)
183+ -> TableRef params tables (left ': right ': rest)
184+innerJoin table on tables = UnsafeTableRef $
185+ renderTableRef tables
186+ <> " INNER JOIN " <>
187+ renderTableRef table
188+ <> " ON " <>
189+ renderExpression on
188190
189191newtype Projection
190− (ps :: [PGType])
191− (xs :: [(Symbol,PGType)])
192− (ys :: [(Symbol,PGType)]) =
192+ (params :: [PGType])
193+ (tables :: [(Symbol,[(Symbol,PGType)])])
194+ (columns :: [(Symbol,PGType)]) =
193195 UnsafeProjection { renderProjection :: ByteString }
194196
195−star :: Projection ps xs xs
197+star :: Projection params '[table ::: columns] columns
196198star = UnsafeProjection "*"
197199
200+tableStar
201+ :: HasTable table tables columns
202+ => Alias table -> Projection params tables columns
203+tableStar (Alias table) = UnsafeProjection $
204+ fromString (symbolVal' table) <> ".*"
205+
198206project
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)
207+ :: Rec (Aliased (Expression params tables)) columns
208+ -> Projection params tables columns
209+project
210+ = UnsafeProjection
211+ . ByteString.intercalate ", "
212+ . recordToList
213+ . rmap (Const . renderAliased renderExpression)
214+
215+data Tabulation
216+ (params :: [PGType])
217+ (schema :: [(Symbol,[(Symbol,PGType)])])
218+ (tables :: [(Symbol,[(Symbol,PGType)])])
219+ = Tabulation
220+ { fromClause :: TableRef params schema tables
221+ , whereClause :: Maybe (Expression params tables 'PGBool)
222+ , limitClause :: Maybe (Expression params '[] 'PGInt8)
223+ , offsetClause :: Maybe (Expression params '[] 'PGInt8)
209224 }
210225
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
226+tabulation :: TableRef params schema tables -> Tabulation params schema tables
227+tabulation tab = Tabulation tab Nothing Nothing Nothing
228+
229+renderTabulation :: Tabulation params schema tables -> ByteString
230+renderTabulation (Tabulation fr wh lim off)= mconcat
231+ [ renderTableRef fr
232+ , maybe "" ((" WHERE " <>) . renderExpression) wh
233+ , maybe "" ((" LIMIT " <>) . renderExpression) lim
234+ , maybe "" ((" OFFSET " <>) . renderExpression) off
235+ ]
236+
237+instance HasTable table schema columns
238+ => IsLabel table (TableRef params schema '[table ::: columns]) where
239+ fromLabel = getTable
240+
241+instance HasTable table schema columns
242+ => IsLabel table (Tabulation params schema '[table ::: columns]) where
243+ fromLabel p = Tabulation (getTable p) Nothing Nothing Nothing
216244
217−-- | where_ is a morphism of monoids `PGBool -> End Relation` under (&&*), true
218245where_
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
246+ :: Expression params tables 'PGBool
247+ -> Tabulation params schema tables
248+ -> Tabulation params schema tables
249+where_ condition tables = tables
250+ { whereClause = case whereClause tables of
224251 Nothing -> Just condition
225252 Just conditions -> Just (conditions &&* condition)
226253 }
227254
228−-- | limit is a morphism of semigroups `PGInt8 -> End Relation` under minB
229255limit
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
256+ :: Expression params '[] 'PGInt8
257+ -> Tabulation params schema tables
258+ -> Tabulation params schema tables
259+limit n tables = tables
260+ { limitClause = case limitClause tables of
235261 Nothing -> Just n
236262 Just n' -> Just (n' `minB` n)
237263 }
238264
239−-- | offset is a morphism of monoids `PGInt8 -> End Relation` under (+), 0
240265offset
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
266+ :: Expression params '[] 'PGInt8
267+ -> Tabulation params schema tables
268+ -> Tabulation params schema tables
269+offset n tables = tables
270+ { offsetClause = case offsetClause tables of
246271 Nothing -> Just n
247272 Just n' -> Just (n' + n)
248273 }
249274
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
275+newtype Selection params schema columns = UnsafeSelection
260276 { renderSelection :: ByteString }
261277
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
278+from
279+ :: Projection params tables columns
280+ -> Tabulation params schema tables
281+ -> Selection params schema columns
282+from projection tables = UnsafeSelection $
283+ renderProjection projection <> " FROM " <> renderTabulation tables
284+
285+newtype Query params schema0 schema1 columns = UnsafeQuery
286+ { renderQuery :: ByteString }
287+
288+newtype PreparedQuery params schema0 schema1 columns = UnsafePreparedQuery
289+ { renderPreparedQuery :: ByteString }
290+
291+select
292+ :: Selection params schema columns
293+ -> Query params schema schema columns
294+select = UnsafeQuery . ("SELECT " <>) . (<> ";") . renderSelection
295+
296+subselect
297+ :: Aliased (Selection params schema) table
298+ -> Tabulation params schema '[table]
299+subselect selection = Tabulation
300+ { fromClause = UnsafeTableRef . ("SELECT " <>) $
301+ renderAliased renderSelection selection
302+ , whereClause = Nothing
303+ , limitClause = Nothing
304+ , offsetClause = Nothing
272305 }
273306
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−
287307insertInto
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
308+ :: forall schema columns table params
309+ . HasTable table schema columns
310+ => Alias table
311+ -> Rec (Aliased (Expression params '[])) columns
312+ -> Query params schema schema '[]
313+insertInto (Alias table) expressions = UnsafeQuery $ "INSERT INTO "
314+ <> fromString (symbolVal' table)
315+ <> " (" <> ByteString.intercalate ", " aliases
296316 <> ") VALUES ("
297− <> ByteString.intercalate ", "
298− (recordToList (rmap (Const . renderExpression) exprs))
317+ <> ByteString.intercalate ", " values
299318 <> ");"
300319 where
301− (names,exprs) = unzipAliased values
320+ aliases = recordToList $ rmap
321+ (\ (_ `As` Alias name) -> Const (fromString (symbolVal' name)))
322+ expressions
323+ values = recordToList $ rmap
324+ (\ (expression `As` _) -> Const (renderExpression expression))
325+ expressions