squeal-postgresql/src/Squeal/PostgreSQL/Query.hs · squeal

git.iko.soy/squeal

on dfd6885 help sign in

squeal/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs

393 lines 13 kB history raw

1{-# LANGUAGE

2 DataKinds

3 , DeriveDataTypeable

4 , DeriveGeneric

5 , FlexibleInstances

6 , GADTs

7 , GeneralizedNewtypeDeriving

8 , KindSignatures

9 , LambdaCase

10 , MultiParamTypeClasses

11 , OverloadedStrings

12 , ScopedTypeVariables

13 , StandaloneDeriving

14 , TypeApplications

15 , TypeInType

16 , TypeOperators

17 , UndecidableInstances

18#-}

20module Squeal.PostgreSQL.Query

21 ( -- * Queries

22 Query (UnsafeQuery, renderQuery)

23 , union

24 , unionAll

25 , intersect

26 , intersectAll

27 , except

28 , exceptAll

29 -- * SELECT queries

30 , select

31 , selectDistinct

32 , selectStar

33 , selectDistinctStar

34 , selectDotStar

35 , selectDistinctDotStar

36 -- * FROM clauses

37 , FromClause (..)

38 , renderFromClause

39 -- * Table Expressions

40 , TableExpression (..)

41 , renderTableExpression

42 , from

43 , where_

44 , group

45 , having

46 , orderBy

47 , limit

48 , offset

49 -- * Grouping

50 , By (By, By2)

51 , renderBy

52 , GroupByClause (NoGroups, Group)

53 , renderGroupByClause

54 , HavingClause (NoHaving, Having)

55 , renderHavingClause

56 , GroupedBy (getGroup1, getGroup2)

57 -- * Sorting

58 , SortExpression (..)

59 , renderSortExpression

60 ) where

62import Control.DeepSeq

63import Data.ByteString (ByteString)

64import Data.Monoid

65import Data.String

66import Data.Word

67import Generics.SOP hiding (from)

68import GHC.TypeLits

70import qualified GHC.Generics as GHC

72import Squeal.PostgreSQL.Expression

73import Squeal.PostgreSQL.Prettyprint

74import Squeal.PostgreSQL.Schema

76newtype Query

77 (schema :: TablesType)

78 (params :: [ColumnType])

79 (columns :: ColumnsType)

80 = UnsafeQuery { renderQuery :: ByteString }

81 deriving (GHC.Generic,Show,Eq,Ord,NFData)

83union, unionAll, intersect, intersectAll, except, exceptAll

84 :: Query schema params columns

85 -> Query schema params columns

86 -> Query schema params columns

87q1 `union` q2 = UnsafeQuery $

88 parenthesized (renderQuery q1)

89 <+> "UNION"

90 <+> parenthesized (renderQuery q2)

91q1 `unionAll` q2 = UnsafeQuery $

92 parenthesized (renderQuery q1)

93 <+> "UNION" <+> "ALL"

94 <+> parenthesized (renderQuery q2)

95q1 `intersect` q2 = UnsafeQuery $

96 parenthesized (renderQuery q1)

97 <+> "INTERSECT"

98 <+> parenthesized (renderQuery q2)

99q1 `intersectAll` q2 = UnsafeQuery $

100 parenthesized (renderQuery q1)

101 <+> "INTERSECT" <+> "ALL"

102 <+> parenthesized (renderQuery q2)

103q1 `except` q2 = UnsafeQuery $

104 parenthesized (renderQuery q1)

105 <+> "EXCEPT"

106 <+> parenthesized (renderQuery q2)

107q1 `exceptAll` q2 = UnsafeQuery $

108 parenthesized (renderQuery q1)

109 <+> "EXCEPT" <+> "ALL"

110 <+> parenthesized (renderQuery q2)

111

112{-----------------------------------------

113SELECT queries

114-----------------------------------------}

115

116select

117 :: SListI columns

118 => NP (Aliased (Expression tables grouping params)) (column ': columns)

119 -> TableExpression schema params tables grouping

120 -> Query schema params (column ': columns)

121select list tabs = UnsafeQuery $

122 "SELECT"

123 <+> renderCommaSeparated (renderAliased renderExpression) list

124 <+> renderTableExpression tabs

125

126selectDistinct

127 :: SListI columns

128 => NP (Aliased (Expression tables 'Ungrouped params)) (column ': columns)

129 -> TableExpression schema params tables 'Ungrouped

130 -> Query schema params (column ': columns)

131selectDistinct list tabs = UnsafeQuery $

132 "SELECT DISTINCT"

133 <+> renderCommaSeparated (renderAliased renderExpression) list

134 <+> renderTableExpression tabs

135

136selectStar, selectDistinctStar

137 :: HasUnique table tables columns

138 => TableExpression schema params tables 'Ungrouped

139 -> Query schema params columns

140selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs

141selectDistinctStar tabs = UnsafeQuery $

142 "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs

143

144selectDotStar, selectDistinctDotStar

145 :: HasTable table tables columns

146 => Alias table

147 -> TableExpression schema params tables 'Ungrouped

148 -> Query schema params columns

149selectDotStar table tables = UnsafeQuery $

150 "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables

151selectDistinctDotStar table tables = UnsafeQuery $

152 "SELECT DISTINCT" <+> renderAlias table <> ".*"

153 <+> renderTableExpression tables

154

155{-----------------------------------------

156FROM clauses

157-----------------------------------------}

158

159data FromClause schema params tables where

160 Table

161 :: Aliased (Table schema) table

162 -> FromClause schema params '[table]

163 Subquery

164 :: Aliased (Query schema params) table

165 -> FromClause schema params '[table]

166 CrossJoin

167 :: FromClause schema params right

168 -> FromClause schema params left

169 -> FromClause schema params (Join left right)

170 InnerJoin

171 :: FromClause schema params right

172 -> Condition (Join left right) 'Ungrouped params

173 -> FromClause schema params left

174 -> FromClause schema params (Join left right)

175 LeftOuterJoin

176 :: FromClause schema params right

177 -> Condition (Join left right) 'Ungrouped params

178 -> FromClause schema params left

179 -> FromClause schema params (Join left (NullifyTables right))

180 RightOuterJoin

181 :: FromClause schema params right

182 -> Condition (Join left right) 'Ungrouped params

183 -> FromClause schema params left

184 -> FromClause schema params (Join (NullifyTables left) right)

185 FullOuterJoin

186 :: FromClause schema params right

187 -> Condition (Join left right) 'Ungrouped params

188 -> FromClause schema params left

189 -> FromClause schema params

190 (Join (NullifyTables left) (NullifyTables right))

191

192renderFromClause :: FromClause schema params tables -> ByteString

193renderFromClause = \case

194 Table table -> renderAliased renderTable table

195 Subquery selection -> renderAliased (parenthesized . renderQuery) selection

196 CrossJoin right left ->

197 renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right

198 InnerJoin right on left -> renderJoin "INNER JOIN" right on left

199 LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left

200 RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left

201 FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left

202 where

203 renderJoin op right on left =

204 renderFromClause left <+> op <+> renderFromClause right

205 <+> "ON" <+> renderExpression on

206

207{-----------------------------------------

208Table Expressions

209-----------------------------------------}

210

211data TableExpression

212 (schema :: TablesType)

213 (params :: [ColumnType])

214 (tables :: TablesType)

215 (grouping :: Grouping)

216 = TableExpression

217 { fromClause :: FromClause schema params tables

218 , whereClause :: [Condition tables 'Ungrouped params]

219 , groupByClause :: GroupByClause tables grouping

220 , havingClause :: HavingClause tables grouping params

221 , orderByClause :: [SortExpression tables grouping params]

222 , limitClause :: [Word64]

223 , offsetClause :: [Word64]

224 }

225

226renderTableExpression

227 :: TableExpression schema params tables grouping

228 -> ByteString

229renderTableExpression

230 (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat

231 [ "FROM ", renderFromClause tables

232 , renderWheres whs'

233 , renderGroupByClause grps'

234 , renderHavingClause hvs'

235 , renderSorts srts'

236 , renderLimits lims'

237 , renderOffsets offs'

238 ]

239 where

240 renderWheres = \case

241 [] -> ""

242 wh:[] -> " WHERE" <+> renderExpression wh

243 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

244 renderSorts = \case

245 [] -> ""

246 srts -> " SORT BY"

247 <+> commaSeparated (renderSortExpression <$> srts)

248 renderLimits = \case

249 [] -> ""

250 lims -> " LIMIT" <+> fromString (show (minimum lims))

251 renderOffsets = \case

252 [] -> ""

253 offs -> " OFFSET" <+> fromString (show (sum offs))

254

255from

256 :: FromClause schema params tables

257 -> TableExpression schema params tables 'Ungrouped

258from tables = TableExpression tables [] NoGroups NoHaving [] [] []

259

260where_

261 :: Condition tables 'Ungrouped params

262 -> TableExpression schema params tables grouping

263 -> TableExpression schema params tables grouping

264where_ wh tables = tables {whereClause = wh : whereClause tables}

265

266group

267 :: SListI bys

268 => NP (By tables) bys

269 -> TableExpression schema params tables 'Ungrouped

270 -> TableExpression schema params tables ('Grouped bys)

271group bys tables = TableExpression

272 { fromClause = fromClause tables

273 , whereClause = whereClause tables

274 , groupByClause = Group bys

275 , havingClause = Having []

276 , orderByClause = []

277 , limitClause = limitClause tables

278 , offsetClause = offsetClause tables

279 }

280

281having

282 :: Condition tables ('Grouped bys) params

283 -> TableExpression schema params tables ('Grouped bys)

284 -> TableExpression schema params tables ('Grouped bys)

285having hv tables = tables

286 { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }

287

288orderBy

289 :: [SortExpression tables grouping params]

290 -> TableExpression schema params tables grouping

291 -> TableExpression schema params tables grouping

292orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}

293

294limit

295 :: Word64

296 -> TableExpression schema params tables grouping

297 -> TableExpression schema params tables grouping

298limit lim tables = tables {limitClause = lim : limitClause tables}

299

300offset

301 :: Word64

302 -> TableExpression schema params tables grouping

303 -> TableExpression schema params tables grouping

304offset off tables = tables {offsetClause = off : offsetClause tables}

305

306{-----------------------------------------

307Grouping

308-----------------------------------------}

309

310data By

311 (tables :: TablesType)

312 (by :: (Symbol,Symbol)) where

313 By

314 :: (HasUnique table tables columns, HasColumn column columns ty)

315 => Alias column

316 -> By tables '(table, column)

317 By2

318 :: (HasTable table tables columns, HasColumn column columns ty)

319 => (Alias table, Alias column)

320 -> By tables '(table, column)

321deriving instance Show (By tables by)

322deriving instance Eq (By tables by)

323deriving instance Ord (By tables by)

324

325renderBy :: By tables tabcolty -> ByteString

326renderBy = \case

327 By column -> renderAlias column

328 By2 (table, column) -> renderAlias table <> "." <> renderAlias column

329

330data GroupByClause tables grouping where

331 NoGroups :: GroupByClause tables 'Ungrouped

332 Group

333 :: SListI bys

334 => NP (By tables) bys

335 -> GroupByClause tables ('Grouped bys)

336

337renderGroupByClause :: GroupByClause tables grouping -> ByteString

338renderGroupByClause = \case

339 NoGroups -> ""

340 Group Nil -> ""

341 Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys

342

343data HavingClause tables grouping params where

344 NoHaving :: HavingClause tables 'Ungrouped params

345 Having

346 :: [Condition tables ('Grouped bys) params]

347 -> HavingClause tables ('Grouped bys) params

348deriving instance Show (HavingClause tables grouping params)

349deriving instance Eq (HavingClause tables grouping params)

350deriving instance Ord (HavingClause tables grouping params)

351

352renderHavingClause :: HavingClause tables grouping params -> ByteString

353renderHavingClause = \case

354 NoHaving -> ""

355 Having [] -> ""

356 Having conditions ->

357 " HAVING" <+> commaSeparated (renderExpression <$> conditions)

358

359{-----------------------------------------

360Sorting

361-----------------------------------------}

362

363data SortExpression tables grouping params where

364 Asc

365 :: Expression tables grouping params ('Required ('NotNull ty))

366 -> SortExpression tables grouping params

367 Desc

368 :: Expression tables grouping params ('Required ('NotNull ty))

369 -> SortExpression tables grouping params

370 AscNullsFirst

371 :: Expression tables grouping params ('Required ('Null ty))

372 -> SortExpression tables grouping params

373 AscNullsLast

374 :: Expression tables grouping params ('Required ('Null ty))

375 -> SortExpression tables grouping params

376 DescNullsFirst

377 :: Expression tables grouping params ('Required ('Null ty))

378 -> SortExpression tables grouping params

379 DescNullsLast

380 :: Expression tables grouping params ('Required ('Null ty))

381 -> SortExpression tables grouping params

382deriving instance Show (SortExpression tables grouping params)

383

384renderSortExpression :: SortExpression tables grouping params -> ByteString

385renderSortExpression = \case

386 Asc expression -> renderExpression expression <+> "ASC"

387 Desc expression -> renderExpression expression <+> "DESC"

388 AscNullsFirst expression -> renderExpression expression

389 <+> "ASC NULLS FIRST"

390 DescNullsFirst expression -> renderExpression expression

391 <+> "DESC NULLS FIRST"

392 AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"

393 DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"